## Posts Tagged ‘POV-Ray

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}]]] ```

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}]];```

21
Oct
08

### Dodecaplex (120 Cell)

Polychorons are the 4D version of polyhedrons. One way to visualize a polychoron is to apply a 4D to 3D stereographic projection to it. A dodecaplex is a uniform 4D polychoron composed 120 dodecahedral cells. These cells can be divided into 12 rings (Hopf fibrations) of 10 cells each. This picture shows a stereographic projection of 6 rings of the dodecaplex. Each ring is shown in a different color, but only 5 rings are open to direct view because they are wrapped around the 6th ring. I first saw this concept on Matthias Weber’s book page. Click here to download some POV-Ray code.

10
Oct
08

### Stereographic Projection of a Dodecahedron

Here is a stereographic projection of a dodecahedron. This is the 3D counterpart to the 4D dodecaplex. Here is some Mathematica code:
```(* runtime: 0.4 second *) z1 = (Sqrt[5] - 3)/Sqrt[30.0 - 6 Sqrt[5]]; z2 = Sqrt[(1 + 2/Sqrt[5])/3.0]; r1 = Sqrt[2(1 + 1/Sqrt[5])/3.0]; r2 = Sqrt[2(1 - 1/Sqrt[5])/3.0]; vertices = Join[Table[{r2 Cos[theta], r2 Sin[theta], z2}, {theta, 0, 2Pi - 0.4Pi, 0.4Pi}], Table[z1 = -z1; {r1 Cos[theta], r1 Sin[theta], z1}, {theta, 0, 1.8Pi, 0.2Pi}], Table[{r2 Cos[theta], r2 Sin[theta], -z2}, {theta, 0.2Pi, 1.8Pi, 0.4Pi}]]; edges = {{1, 2}, {2, 3}, {3, 4}, {4, 5}, {5, 1}, {1, 6}, {2, 8}, {3, 10}, {4, 12}, {5, 14}, {6, 7}, {7, 8}, {8, 9}, {9, 10}, {10, 11}, {11, 12}, {12, 13}, {13, 14}, {14, 15}, {15, 6}, {7, 16}, {9, 17}, {11, 18}, {13, 19}, {15, 20}, {16,17}, {17, 18}, {18, 19}, {19, 20}, {20, 16}}; Show[Graphics3D[Map[Line[vertices[[#]]] &, edges]]] Norm[x_] := x.x; Normalize[x_] := x/Sqrt[x.x]; Rx[theta_] := {{1, 0, 0}, {0, Cos[theta], -Sin[theta]}, {0,Sin[theta], Cos[theta]}}; ProjectPoint[{x_, y_, z_}] := 2{x, y}/(1 - z); ProjectSegment[{v1_, v2_}] := Module[{p1 = ProjectPoint[v1], p2 = ProjectPoint[v2]}, {nx, ny, nz} = Normalize[Cross[v1, v2]]; If[nz != 0, p0 = -2{nx, ny}/nz; r = 2/Abs[nz]; theta = Sign[nz]Re[ArcCos[(p1 - p0).(p2 - p0)/Sqrt[Norm[p1 - p0]Norm[p2 - p0]]]], theta = 0]; If[Abs[theta] > 0.001, theta1 = ArcTan[p1[[1]] - p0[[1]], p1[[2]] - p0[[2]]]; theta2 = theta1 + theta; If[theta1 > theta2, t = theta1; theta1 = theta2; theta2 = t]; Circle[p0, r, {theta1, theta2}], Line[{p1, p2}]]]; Do[Show[Graphics[Map[ProjectSegment[Map[Rx[phi].# &, vertices[[#]]]] &, edges], PlotRange -> 6{{-1, 1}, {-1, 1}}, AspectRatio -> Automatic]], {phi, 0, 2Pi, Pi/18}];```

01
Oct
08

### Double Spiral

One way to create a Double Spiralis by applying a light projection from the top of a Riemann sphere (loxodrome) onto a plane.

This type of projection is called a stereographic projection.

```(* runtime: 3 seconds *) << Graphics`Shapes`; a = 0.25; Rx[phi_] := {{1, 0, 0}, {0, Cos[phi], -Sin[phi]}, {0, Sin[phi], Cos[phi]}}; Do[loxodrome = Table[Rx[phi].{Sin[t], -a t, -Cos[t]}/Sqrt[1 + (a t)^2], {t, -100, 100, 0.1}]; projection = Map[Module[{r = 2/(1 - #[[3]])}, {r #[[1]],r #[[2]], -1}] &, loxodrome]; Show[Graphics3D[{EdgeForm[], Sphere[0.99, 37, 19], Polygon[{{4, 4, -1}, {-4, 4, -1}, {-4, -4, -1}, {4, -4, -1}}],Line[loxodrome], Line[projection]},PlotRange -> {{-4, 4}, {-4, 4}, {-1, 1}}]], {phi, 0, Pi -Pi/12, Pi/12}] ```
Another kind of double spiral can be made by applying a special homography to a single logarithmic spiral:
```(* runtime: 0.05 second *) Show[Graphics[Table[Line[Table[z = Exp[r + (2 r + theta)I]; z = (1 + z)/(1 - z); {Re[z], Im[z]}, {r, -10, 10, 0.1}]], {theta, -Pi, Pi, Pi/3}], PlotRange -> {{-2, 2}, {-2, 2}}, AspectRatio -> Automatic]]```

Here is some Mathematica code that uses the inverse method:
```(* runtime: 17 seconds *) Show[Graphics[RasterArray[Table[r1 = (x - 1)^2 + y^2; r2 = (x + 1)^2 + y^2; Hue[(Sign[y]ArcCos[(x^2 + y^2 - 1)/Sqrt[r1 r2]] -Log[r1/r2])/(2Pi)], {x, -2, 2, 4/274}, {y, -2, 2, 4/274}]], AspectRatio -> 1]]```
and here is some POV-Ray code:
```// runtime: 2 seconds camera{orthographic location <0,0,-2> look_at 0 angle 90} #declare r1=function(x,y) {(x-1)*(x-1)+y*y}; #declare r2=function(x,y) {(x+1)*(x+1)+y*y}; #declare f=function{(y/abs(y)*acos((x*x+y*y-1)/sqrt(r1(x,y)*r2(x,y)))-ln(r1(x,y)/r2(x,y)))/(2*pi)}; plane{z,0 pigment{function{f(x,y,0)}} finish{ambient 1}}```

25
Aug
08

### Cross Section of the Quintic Calabi-Yau Manifold

The left picture shows a 3D cross section of the quintic 6D Calabi-Yau Manifold proposed for String Theory. The right picture shows various degrees of complexity.

Here is some Mathematica code:
```(* runtime: 54 seconds, change n for other degrees of complexity *) n = 5; CalabiYau[z_, k1_, k2_] := Module[{z1 = Exp[2Pi I k1/n]Cosh[z]^(2/n), z2 = Exp[2Pi I k2/n]Sinh[z]^(2/n)}, {Re[z1], Re[z2], Cos[alpha]Im[z1] + Sin[alpha]Im[z2]}]; Do[alpha = (0.25 + t)Pi; Show[Graphics3D[Table[ParametricPlot3D[CalabiYau[x + I y, k1, k2], {x, -1, 1}, {y, 0, Pi/2}, DisplayFunction -> Identity, Compiled ->False][[1]], {k1, 0, n - 1}, {k2, 0, n - 1}], PlotRange -> 1.5{{-1, 1}, {-1, 1}, {-1, 1}}, ViewPoint -> {1, 1, 0}]], {t, 0, 1, 0.1}];```

12
Aug
08

### Clifford Torus

The Hopf map is a special transformation invented by Heinz Hopf that maps to each point on the ordinary 3D sphere from a unique circle of points on the 4D sphere. Taken together, these circles form a fiber bundle called a Hopf Fibration. If you apply a 4D to 3D stereographic projection to the Hopf Fibration, you get a beautiful 3D torus called a Clifford Torus composed of interlinked Villarceau circles.

By applying 4D rotations to the Hopf Fibration, you can transform the Clifford Torus into a Dupin cyclide or you can turn it inside-out.

Here is some Mathematica code:
```(* runtime: 7 seconds *) HopfInverse[theta_, phi_, psi_] := {Cos[phi/2] Cos[psi], Cos[phi/2]Sin[psi], Cos[theta + psi]Sin[phi/2], Sin[theta + psi]Sin[phi/2]}; Ryw[theta_] := {{1, 0, 0, 0}, {0, Cos[theta], 0, Sin[theta]}, {0, 0, 1, 0}, {0, -Sin[theta], 0, Cos[theta]}}; StereographicProjection[{x_, y_, z_, w_}] := {x, y, z}/(1 - w); Table[Show[Graphics3D[Table[{Hue[(4 phi/Pi - 1)/3], Table[Line[Table[StereographicProjection[Ryw[alpha].HopfInverse[theta, phi, psi]], {psi, 0.0, 2Pi, Pi/18}]], {theta, 0.0, 2 Pi,Pi/9}]}, {phi, Pi/4, 3Pi/4, Pi/4}], PlotRange -> 3{{-1, 1}, {-1, 1}, {-1, 1}}]], {alpha, 0, Pi, Pi/18}];```

15
Apr
08

### Moiré Pattern

A Moiré pattern is the interference of two similar overlapping patterns. Here is the Moiré pattern on a twisted IKEA wastepaper basket. The mesh on the wastepaper basket was ray-traced from 100,000 tiny cylinders.

Here is some Mathematica code to plot Moiré contours around radiating lines:
```(* runtime: 1.7 seconds *) f[dx_] := Sin[200ArcTan[x - dx, y]]; DensityPlot[f[0.1] - f[-0.1], {x, -1, 1}, {y, -1, 1}, PlotRange -> {0, 1}, PlotPoints -> 275, Mesh -> False, Frame -> False]```

Here is some Mathematica code to plot a Moiré pattern from rapidly varying contours of a function:
```(* runtime: 0.8 second *) f[z_] := z^3; DensityPlot[Sin[20Pi Abs[f[x + I y]]], {x, -2.5, 2.5}, {y, -2.5, 2.5}, PlotPoints -> 275, Mesh -> False, Frame -> False]```

29
Oct
07

### Zoom Animation

Google Maps is lots of fun.

27
Oct
07

### Magnetic Pendulum Strange Attractor

This chaotic strange attractor represent the final resting positions for a magnetic pendulum suspended over some magnets (shown as black dots). It kind of looks like mixed paint. The 2D animation shows what happens as you decrease the damping factor. The 3D animation was shaded by path length.

Mathematica 4.2 version: 1/24/05; C++ version: 10/27/07; 3D rendered in POV-Ray 3.1

```(* runtime: 25 seconds, increase n for higher resolution *) n = 40; h = 0.25; g = 0.2; mu = 0.07; zlist = {Sqrt[3] + I, -Sqrt[3] + I, -2I}; image = Table[z2 = z[25] /. NDSolve[{z''[t] == Plus @@ ((zlist - z[t])/(h^2 + Abs[zlist - z[t]]^2)^1.5) - g z[t] - mu z'[t], z[0] == x + I y, z'[0] == 0}, z, {t, 0, 25}, MaxSteps -> 200000][[1]]; r = Abs[z2 - zlist]; i = Position[r, Min[r]][[1, 1]]; Hue[i/3], {y, -5.0, 5.0, 10.0/n}, {x, -5.0,5.0, 10.0/n}]; Show[Graphics[RasterArray[image]], AspectRatio -> 1];```

The picture on the left shows another version with five magnets. See also my physics pendulums.

Here is some Mathematica code to numerically solve this using the Beeman integration scheme with the predictor-corrector modification:
```(* runtime: 45 seconds, increase n for higher resolution *) n = 40; tmax = 25; dt = 0.1; h = 0.25; g = 0.2; mu = 0.07; zlist = {Sqrt[3] + I, -Sqrt[3] + I, -2I}; image = Table[z = x + I y; v = a = a1 = 0; Do[z += v dt + (4a - a1)dt^2/6; vpredict = v + (3a - a1)dt/2; a2 = Plus @@ ((zlist - z)/(h^2 + Abs[zlist - z]^2)^1.5) - g z - mu vpredict; v += (2a2 + 5a - a1)dt/6; a1 =a; a = a2, {t, 0, tmax, dt}]; r = Abs[z - zlist]; Hue[Position[r, Min[r]][[1, 1]]/3], {y, -5.0, 5.0, 10.0/n}, {x, -5.0, 5.0, 10.0/n}]; Show[Graphics[RasterArray[image]], AspectRatio -> 1];```

## 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