Archive for the 'Minimal surfaces' Category

25
Feb
09

Chen-Gackstatter Minimal Surface

The Chen-Gackstatter Minimal Surface is a modified Enneper surface with holes in it. The following Mathematica code uses some functions that were adapted from Matthias Weber’sMathematica notebook:
(* runtime: 0.4 second *)
<< Graphics`Shapes`; k = 5; n = (k - 1)/k; rho = 1.0/Sqrt[4^n Gamma[(3 - n)/2] Gamma[1 + n/2]/(Gamma[(3 +n)/2]Gamma[1 - n/2])];
phi[n_, z_] := z^(1 + n)Hypergeometric2F1[(1 + n)/2, n, (3 + n)/2, z^2]/(1 + n); f[z_] := {0.5(phi[n, z]/rho - rho phi[-n, z]), 0.5I(rho phi[-n, z] + phi[n, z]/rho), z};
surface = ParametricPlot3D[Re[f[r Exp[I theta]]], {r, 0, 2}, {theta, 1*^-6, 2Pi}, PlotPoints -> {9, 33}, Compiled -> False, DisplayFunction -> Identity][[1]];
Show[Graphics3D[Table[RotateShape[surface, 0, 0, 2Pi i/k], {i, 0, k - 1}]]]

10
Feb
09

Scherk-Collins Surface

This surface can be formed by twisting and warping a singly-periodic Scherk’s minimal surface. This idea was originally attributed to Brent Collins. Technically, the surface is no longer considered exactly “minimal” after twisting but it still looks minimal (it is actually very difficult to find the exact shape for most minimal surfaces). Click here to download some POV-Ray code.

Here is some Mathematica code:
(* runtime: 0.3 second *)
<< Graphics`Master`; n = 5; r = 0.75n;
Twist[{x_, y_, z_}, theta_] := {x Cos[theta] - y Sin[theta], x Sin[theta] + y Cos[theta], z};
Warp[{x_, y_, z_}, theta_] := {(x + r) Cos[theta], (x + r) Sin[theta], y};
f[z_] := Module[{t1 = Sqrt[2Cot[z]], t2 = Cot[z] + 1}, Warp[Twist[Re[{0.5xsign(Log[t1 - t2] - Log[t1 + t2])/Sqrt[2], ysign I(ArcTan[1 - t1] - ArcTan[1 + t1])/Sqrt[2], z}], 2Re[z]/n], 2Re[z]/n]];
DisplayTogether[Table[ParametricPlot3D[f[x + I y], {x, 0, n Pi}, {y, 0.001, 0.75}, PlotPoints -> {8n + 1, 5}, Compiled -> False], {xsign, -1, 1, 2}, {ysign, -1, 1, 2}]]

The following Mathematica code can be used to increase the number of edges (or “branches”). This code uses some complicated functions that were adapted from Matthias Weber’s Mathematica notebook:
(* runtime: 1.2 seconds *)
<< Graphics`Shapes`; k = 4; phi = Pi(0.6/k - 0.5)/(1 - k);
f[z_] := Re[NIntegrate[Evaluate[{0.5 (w^(1 - k) - w^(k - 1)), 0.5 I (w^(1 - k) + w^(k - 1)), 1}/(w^(k + 1) + w^(1 - k) - 2w Cos[k phi])], {w, 0, z}]];
alpha = Pi/k; zbeta = Exp[I Pi(phi/alpha - 0.5)];
surface = ParametricPlot3D[Re[f[Exp[I alpha/2]((1 + I zbeta Exp[r + I theta])/(I Exp[r + I theta] -zbeta))^(alpha/Pi)]], {r, 0, 4}, {theta, 0, Pi}, PlotPoints -> 10, Compiled -> False, DisplayFunction -> Identity][[1]];
z0 = f[1][[3]]; surface = {surface, AffineShape[TranslateShape[surface, {0, 0, -2z0}], {1, 1, -1}]};
surface = {surface, AffineShape[surface, {1, -1, 1}]}; surface = Table[RotateShape[surface, 2Pi i/k, 0, 0], {i, 1, k}];
dz = Pi Csc[k phi]/k; Show[Graphics3D[Table[TranslateShape[surface, {0, 0, i dz}], {i, 0, 1}]]]

Links

21
Jan
09

Punctured Helicoid

Here is a helicoidwith holes in it. The following Mathematica code uses some complicated functions that were adapted from Matthias Weber’sMathematica notebook:
(* runtime: 4 seconds *)
<< Graphics`Shapes`;
tau0 = Exp[1.23409 I]; b0 = 0.629065; theta[z_] := EllipticTheta[1, Pi z, Exp[I Pi tau0]];
r1[z_] := theta[z + 0.5 (b0 - 2) (tau0 + 1)]/theta[z + 0.5 (b0 - 1) (tau0 + 1)]; r2[z_] := theta[z - 0.5 b0 (tau0 + 1)]/theta[z - 0.5 (b0 + 1) (tau0 + 1)];
omega3[z_] := r1[z] r2[z]/(0.386191 - 0.169839 I); G[z_] := (108.37 - 62.8417 I) Exp[I Pi (b0 - 2 z + 2 tau0 + b0 tau0)]r1[z]/r2[z];
f[z0_] := Re[NIntegrate[Evaluate[{-(G[z] omega3[z] - omega3[z]/G[z] )/2, I(G[z] omega3[z] + omega3[z]/G[z] )/2, omega3[z]}], {z, tau0/2, z0}]] + {0.434156, 0, -1};
a0 = -0.409956; r0 = 2.43051; g[z_] := (EllipticF[ArcSin[(a0 + r0 E^z)/(1 - a0 E^z)], 1/r0^2]/(2EllipticF[Pi/2, 1/r0^2]) + 0.5)(1 + tau0)/2;
surface = ParametricPlot3D[f[g[x + I y]], {x, -2.5, 2.5 - 0.8881}, {y, 0.001,0.999Pi}, PlotPoints -> {15, 10}, Compiled -> False, DisplayFunction -> Identity][[1]];
surface = {surface, RotateShape[surface, 0, 0, Pi]};
Show[Graphics3D[{surface, TranslateShape[surface, {0, 0, 2}]}, ViewPoint -> {1, 6, 3}]];

16
Jan
09

Jorge-Meeks K-Noids


The following Mathematica code uses some functions that were adapted from Matthias Weber’sMathematica notebook:
(* runtime: 0.4 second *)
<< Graphics`Shapes`;
k = 5; phi1[z_] := z^(k - 1) (k/(1 - z^k) - (k - 1) LerchPhi[z^k, 1, 1 - 1/k])/k^2; phi2[z_] := z(1/(1 - z^k) + (k - 1)LerchPhi[z^k, 1, 1/k]/k)/k;
f[z_] := {0.5 (phi2[z] - phi1[z]), 0.5 I (phi1[z] + phi2[z]), 1/(k - k z^k)};
surface = ParametricPlot3D[Re[f[(1 + 2/(I Exp[x + I y] - 1))^(2/k)]], {x,0, Pi/2}, {y, -Pi/2, Pi/2}, PlotPoints -> {8, 16}, Compiled -> False, DisplayFunction -> Identity][[1]];
surface = {surface, AffineShape[surface, {1, -1, 1}]};
Show[Graphics3D[Table[RotateShape[surface, 0, 0, 2Pi i/k], {i, 0, k - 1}]]];

Links

08
Jan
09

Catenoid/Helicoid

This minimal surface is a cross between acatenoid andhelicoid. It would be interesting to see what really happens when a spring is covered with a soap film. Click here to download some POV-Ray code. Here is some Mathematica code:
(* runtime: 0.6 second *)
x := Sin[alpha]Cosh[v]; y := Cos[alpha]Sinh[v];
Do[ParametricPlot3D[{x Cos[u] + y Sin[u], x Sin[u] - y Cos[u], u Cos[alpha] + v Sin[alpha]}, {u, 0, 2Pi}, {v, -2.25, 2.25}, PlotPoints -> {36, 10}], {alpha, -Pi/2, Pi/2, Pi/18}];

Links

06
Jun
07

Richmond’s Minimal Surface

I learned about this minimal surface from Brian Johnston’s website. Here is some Mathematica code:

(* runtime: 2 seconds *)
Richmond[n_, z_] := {-1/(2z) - z^(2n + 1)/(4n + 2), -I/(2z) + I z^(2n + 1)/(4n + 2), z^n/n};
ParametricPlot3D[Re[Richmond[5, r Exp[I theta]]], {r, 0.53, 1.187}, {theta, 0, 2Pi}, PlotPoints -> {25, 180}, Compiled -> False]

04
Jun
05

Fourth Enneper Surface

Click here to download some POV-Ray code for this image.

Here is some Mathematica code for the Second Enneper Surface:
(* runtime: 0.5 second *)
n = 3; ParametricPlot3D[{r Cos[phi] - r^(2n - 1) Cos[(2n - 1) phi]/(2n - 1), r Sin[phi] + r^(2n - 1) Sin[(2n - 1) phi]/(2n - 1), 2 r^n Cos[n phi]/n, EdgeForm[]}, {phi, 0, 2Pi}, {r, 0, 1.3}, PlotPoints -> {181, 20}, ViewPoint -> {0, 0, 1}, PlotRange -> All]

Link : Enneper Mathematica

23
Mar
05

Costa’s Minimal Surface

Costa’s Minimal Surface is a classic example of a minimal surface with holes in it, also called “handles”. The number of holes is called the genus of the surface. This surface was discovered by a graduate student. I think it would be interesting to see someone create an actual soap film with this shape.


Here is some Mathematica code:
(* runtime: 5 seconds *)
c = 189.07272; e1 = 6.87519;
Costa[u_, v_] := Module[{z =u + I v}, zeta = WeierstrassZeta[z, {c, 0}]; zeta1 = WeierstrassZeta[z - 1/2, {c, 0}]; zeta2 = WeierstrassZeta[z - I/2, {c, 0}]; p = WeierstrassP[z, {c, 0}]; x = Re[Pi (u + Pi/(4 e1) ) - zeta + Pi(zeta1 - zeta2)/(2 e1)]/2; y = Re[Pi (v + Pi/(4 e1)) - I(zeta + Pi(zeta1 - zeta2)/(2 e1))]/2; z = (Sqrt[2 Pi]/4)Log[Abs[(p - e1)/(p + e1)]]; {x, y, z, EdgeForm[]}];
ParametricPlot3D[Costa[u, v], {u, 0.0001, 1}, {v, 0.0001, 1}, PlotPoints -> 40, PlotRange -> {{-3.5, 3.5}, {-3.5, 3.5}, {-2, 2}},Compiled -> False]

Here is another parametrization:
(* runtime: 5 seconds *)
Costa[z_] := Module[{phi1 = -2 Sqrt[z] Sqrt[1 - z^2] Hypergeometric2F1[1/4, 3/2, 5/4, z^2]/Sqrt[z^2 - 1], phi2 = -(2/3) z^(3/2) Sqrt[z^2 - 1] Hypergeometric2F1[3/4, 1/2, 7/4, z^2]/Sqrt[1 - z^2]}, Re[{phi2 - phi1, I(phi1 +phi2), Log[z - 1] - Log[z + 1]}]/2];
surface = ParametricPlot3D[Costa[Sqrt[Exp[r - I theta] + 1]], {r, -3.5, 6}, {theta, -Pi, Pi}, PlotPoints -> {20, 18}, Compiled -> False][[1]];
<< Graphics`Shapes`; surface = {surface, RotateShape[surface, Pi, 0, 0]}; Show[Graphics3D[{surface, RotateShape[surface, Pi/2, Pi, 0]}]]

Links




Welcome !

You will find here some of my favorite hobbies and interests, especially science and art.

I hope you enjoy it!

Subscribe to the RSS feed to stay informed when I publish something new here.

I would love to hear from you! Please feel free to send me an email : bugman123-at-gmail-dot-com

Archives

Blog Stats

  • 578,884 hits