Contents Home Physics Simulations Engineering Fractals Math Artwork Rendered Artwork Hand-made Artwork Bug Collection Programming High Voltage Holography Physics Experiments Legos Claymation The Bible Links

Math On this page you will find some tessellations, surfaces, and other math stuff along with some basic Mathematica code. See also my Fractals and Physics pages and my page on the Virtual Art Museum. Kleinian Double Spiral - Mathematica 4.2, 7/18/05 This double spiral can be created by applying a stereographic projection to a loxodrome: (* runtime: 0.2 second *) << Graphics`Shapes`; a = 0.25; loxodrome = Table[(1 + (a t)^2)^-0.5{Sin[t], -a t, -Cos[t]}, {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}}]] This can also be done 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]] But the most beautiful approach is to use the inverse transformation: (* 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]] This is how you can make this in POV-Ray: // 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}} Click here to see a slightly different animation. See also my Double Cusp Group. Click here to download a Mathematica notebook for this image. Links Whirlpools - double spiral tessellation by M.C. Escher equation of a tanh spiral Hyperbolic Dodecahedron - POV-Ray 3.6.1, 2/15/07 A dodecahedron is a polyhedron with 12 pentagonal faces. This dodecahedron uses spheres for each face. Here is some POV-Ray code for the hyperbolic dodecahedron. See also my expanding dodecahedron. << Graphics`Polyhedra`; Show[Graphics3D[Polyhedron[Dodecahedron][[1]]]] Links Ideal Hyperbolic Polyhedra - POV-Ray renderings by Matthias Weber Spikey - Mathematica’s cover image dodecahedron Megaminx - dodecahedron-shaped Rubik's Cube Buckminsterfullerene (Buckyball) - truncated icosahedron arrangement of carbon atoms, assembly movie George Hart - polyhedra artist Inside the Hyperbolic Dodecahedron - POV-Ray 3.6.1, 2/15/07 This is what the dodecahedron would look like viewed from the inside with spherical mirrored walls. At certain dihedral angles, this resembles a Poincaré projection of 3D hyperbolic space tiled with ideal dodecahedrons. Notice that when the space becomes elliptic, a black “hole” opens up in the center. This is because the space loops around on itself causing objects beyond the “maximum distance” to appear larger because they are actually closer. Weird huh? Links Jenn 3D - multidimensional hyperbolic polytope program, by Fritz Obermeyer Curved Spaces 3 - program for tiling spherical and hyperbolic 3D space, by Jeff Weeks Hyperbolic Space Tiled by Dodecahedra - by Charlie Gunn Inside the Flat (Euclidean) Dodecahedron - POV-Ray 3.6.1, 2/12/07 Here is a dodecahedron viewed from the inside with flat mirrored walls. Links Mirrored Cube - this is what is might look like inside a 3-torus by Bernard Hatt, here is an older version Fun Topology - based on Bathsheba Grossman’s Quin Pendant Lamp, AutoCAD 2000, POV-Ray 3.6.1, 4/24/07 Here is my attempt to recreate a similar-looking structure to Bathsheba Grossman’s beautiful Quin Pendant Lamp. The topology is equivilent to a sphere with 30 holes. The boundary of each hole loops over itself twice with two Reidemeister-I twists and links with 6 others. I’m still not sure what the linking number of this 30-component knot is (let me know if you find out). In terms of symmetry, it can by described as: a dodecahedron with a hole over each edge an icosahedron with a hole over each edge an icosahedron with a hole over each vertex a rhombic triacontahedron with a hole over each face (the arms trace a graph isomorphic to the edge graph) Special thanks to Jonathan Schneider for pointing out these interesting observations to me. The animation shows a homotopy that continuously maps the structure to a sphere with 30 holes. (* runtime: 0.1 second *) << Graphics`Shapes` ; alpha = ArcCos[-Sqrt[5]/5]; surface = {{{0.11, 0.35, 1}, {0.16, 0.33, 1}, {0.23, 0.35, 0.99}, {0.3, 0.38, 0.96}, {0.35, 0.43, 0.9}, {0.29, 0.42, 0.8}, {0.22, 0.37,0.7}, {0.14, 0.34, 0.62}, {0.078, 0.296, 0.585}}, {{0, 0, 1}, {0.13, 0.09, 1}, {0.29, 0.22, 0.99}, {0.4, 0.33, 0.95}, {0.41, 0.45, 0.88}, {0.31, 0.47, 0.77}, {0.2, 0.43, 0.65}, {0.08, 0.4, 0.56}, {-0.019, 0.398, 0.526}}, {{0.36, 0, 1}, {0.39, 0.11, 1}, {0.45, 0.23,0.99}, {0.49, 0.35, 0.95}, {0.47, 0.45, 0.86}, {0.36, 0.52, 0.73}, {0.22, 0.5, 0.59}, {0.13, 0.48, 0.48}, {0.07, 0.489, 0.437}}}; arm = Map[Polygon[Flatten[#, 1][[{1, 2, 4, 3}]]] &, Partition[surface, {2, 2}, 1], {2}]; face = Table[RotateShape[Graphics3D[arm], 0, 0, psi][[1]], {psi, 0, 1.6Pi, 0.4Pi}]; Show[Graphics3D[{RotateShape[face, 0, 0, 0], RotateShape[face, 0, Pi, 0], Table[{RotateShape[face, 0, Pi - alpha, psi + Pi/5], RotateShape[face, Pi/5, alpha, psi]}, {psi, 0, 1.6Pi, 0.4Pi}]}]] Links Metal Printed Quintrino - by Bathsheba Grossman Quin Pendant Lamp - very beautiful, by Bathsheba Grossman Poincaré Hyperbolic Tiling - Mathematica 4.2, 3/17/05 The area inside this circle represents a hyperbolic plane filled with “ideal triangles”. Notice that all the angles inside these triangles go to zero at the edge of the circle. This image was generated using a series of reflections called anti-homographies. I learned about homographies while participating at the Experimental Geometry Lab at the University of Maryland. The right animation shows how a single homography can transform the upper half plane into the Poincaré disk. See also my POV-Ray code, Mathematica code, homography test, and circle inversion. Hyperbolic Links hyperbolic animations - by Jos Leys Hyperbolic Java applet - by Don Hatch HypEngine - 3D real-time hyperbolic maze by Bernie Freidin Hyperbolic surfaces in nature - leaf edges and torn plastic sheets Mathematica package - by Matthias Weber Mathematica code - for animated Poincaré grid, by Matthew Cook “Circle Limit III” and “Circle Limit IV” - M.C. Esher’s famous hyperbolic tessellations Reducing Lizards - upper half plane tessellation by M.C. Escher “Escher Fish” - Mathematica version by Silvio Levy Kangaroo Tiling - hyperbolic tessellation by Guy Cousineau, et. all Hyperbolic Texture Mapping - Mathematica 4.2 version: 6/22/05, C++ version: 8/9/05 This “hyperbolic beach ball” and hyperboloid were ray traced and textured using inverse transformations (the “pull back” method). Click here to download the complete Mathematica notebook for this image. Also, here is a C++ version for this image. Poincaré Hyperbolic Tiling - POV-Ray 3.6.1, 6/22/05 Click here to download some POV-Ray code for this image. Here is some Mathematica code: (* runtime: 0.02 second *) R = Sqrt[3]; Tiles = {Map[1.0 I{{#, R^2 - # Conjugate[#]}, {1, -Conjugate[#]}}/R &, {R + I, -R + I, -2I}]}; Tiles = Append[Tiles, Flatten[Table[Map[Tiles[[1, i]].Conjugate[Tiles[[1, #]]].Tiles[[1, i]] &, DeleteCases[{1, 2, 3}, i]], {i, 1, 3}], 1]]; Do[Tiles = Append[Tiles, Flatten[Table[Map[Tiles[[g, i]].Conjugate[#].Tiles[[g, i]] &, {Tiles[[g - 1, Ceiling[i/2]]], Tiles[[g, 2Ceiling[i/2] - Mod[i + 1,2]]]}], {i, 1, 3×2^(g - 1)}], 1]], {g, 2, 5}]; Tiles = Flatten[Tiles, 1]; n = Length[Tiles]; ToDisk[{{a_, b_}, {c_, d_}}] := Disk[{Re[a/c], Im[a/c]}, Abs[I/c]]; Show[Graphics[{Hue[0], Disk[{0, 0}, 1], Table[{Hue[Sqrt[i/n]], ToDisk[Tiles[[i]]]}, {i,1, n}]}, AspectRatio -> 1, PlotRange -> {{-1, 1}, {-1, 1}}]] Breather Pseudosphere - new version: POV-Ray 3.6.1, 6/21/06 old version: Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 9/30/04 A sphere is an elliptic surface with constant positive curvature. A pseudosphere is a hyperbolic surface with constant negative curvature. This pseudosphere is called a Breather. Click here to download some POV-Ray code for this image. You can also see this image described as an "Imploding Flower" on Chewxy's Math Art website. (* runtime: 6 seconds *) a = 0.498888; vmax = 47.1232; w = Sqrt[1 - a^2]; Breather[u_, v_] := Module[{d = a((w Cosh[a u])^2 + (a Sin[w v])^2)}, x = -u + 2w^2 Cosh[a u]Sinh[a u]/d; y = 2w Cosh[a u](-w Cos[v]Cos[w v] - Sin[v]Sin[w v])/d; z = 2w Cosh[a u](-w Sin[v]Cos[w v] +Cos[v]Sin[w v])/d; {x, y, z, {EdgeForm[], SurfaceColor[Hue[v/vmax]]}}]; ParametricPlot3D[Breather[u, v], {u, -10, 10}, {v, 0, vmax}, PlotPoints -> {49, 79}, Compiled -> False] Links Virtual Math Museum - beautiful rendition of this surface by Luc Benard, winning entry on cover of Science Magazine’s 2006 Visualization Challenge POV-Ray Code - by Mike Williams, param.inc Cooling Air Towers - also have a hyperbolic shape Rose-Shaped Parametric Surface - new version: POV-Ray 3.6.1, 6/21/06 old version: Mathematica 4.2, MathGL3d, 3/5/04 This rose is actually a plot of a single continuous math equation. Click here to see a larger animation. Click here to see a rotatable 3D version. Click here to download some POV-Ray code for this image. You can also see this on Abdessemed Ali’s web site. See also my Passion Flower. (* runtime: 16 seconds *) Rose[x_, theta_] := Module[{phi = (Pi/2)Exp[-theta/(8 Pi)], X = 1 - (1/2)((5/4)(1 - Mod[3.6 theta, 2 Pi]/Pi)^2 - 1/4)^2}, y = 1.95653 x^2 (1.27689 x - 1)^2 Sin[phi]; r = X(x Sin[phi] + y Cos[phi]); {r Sin[theta], r Cos[theta], X(x Cos[phi] - y Sin[phi]), EdgeForm[]}]; ParametricPlot3D[Rose[x, theta], {x, 0, 1}, {theta, -2 Pi, 15 Pi}, PlotPoints -> {25, 576}, LightSources -> {{{0, 0, 1}, RGBColor[1, 0, 0]}}, Compiled -> False] Boy’s Surface (Bryant-Kusner Parametrization) - new version: POV-Ray 3.6.1, 6/20/06 old version: Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 5/24/05 This one-sided surface was first parametrized correctly by Bernard Morin. The animation looks like it’s turning inside-out, although technically that’s impossible because it only has one side! Robert Bryant told me that the parameters (p,q) = (0,1) give this Willmore immersion of RP2 a trilateral symmetry. The parameters (p,q) = (1,0) should give bilateral symmetry. I’d like to know if it’s possible to make one with pentalateral symmetry. Click here to download some POV-Ray code for this image. (* runtime: 1 second *) ParametricPlot3D[Module[{z = r E^(I theta), a, m}, a = z^6 + Sqrt[5]z^3 - 1; m = {Im[z(z^4 - 1)/a], Re[z(z^4 + 1)/a], Im[(2/3) (z^6 + 1)/a] + 0.5}; Append[m/(m.m), SurfaceColor[Hue[r]]]], {r, 0, 1}, {theta, -Pi, Pi}, PlotPoints -> {20, 72}, ViewPoint -> {0, 0, 1}] POV-Ray also has an internal function for a different parametrization: // runtime: 50 seconds camera{location -1.5*z look_at 0} light_source{-z,1} #declare f=function{internal(8)} isosurface{function{-f(x,y,z,1e-4,1)} pigment{rgb 1}} Links Rotatable 3D Boy’s Surface Steiner Surfaces - POV-Ray animations by Adam Coffman Möebius Strip - a simple one-sided surface, see these twisting and 5 fold animated Möebius strips by Jos Leys Klein Bottle - an enclosed Möebius strip Möebius strip to Klein bottle transformation - Mathematica code by Ari Lehtonen Scherk-Collins Surface - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 7/19/06 This surface can be formed by twisting Scherk’s Minimal Surface. This one came out a little lumpy. Brent Collins has some nicer-looking surfaces. Click here to download some POV-Ray code for this image. (* runtime: 0.7 second *) n = 7; r = Pi; R = 2Pi; Twist[{x_, y_}, theta_] := {x Cos[theta] - y Sin[theta], x Sin[theta] + y Cos[theta]}; Warp[{x_, y_}, theta_] := {(x + R) Cos[theta], y, (x + R) Sin[theta]}; f[z_, i_] := Module[{x = Max[-r, Min[r, Re[2(Log[1 + z] - Log[1 - z])]]], y = Max[-r, Min[r, Re[4I ArcTan[z]]]],z1 = Re[2Pi i + (1 - 2Mod[i, 2]) 2I (Log[1 + z^2] - Log[1 - z^2])]}, Warp[Twist[{x, y}, z1/(n + 1)], z1/(n + 1)]]; Show[Table[ParametricPlot3D[f[r1 E^(I theta), i], {theta, 0, 2Pi}, {r1, 0, 1}, PlotPoints -> {25, 7}, Compiled -> False], {i, 0, n}]] Links “Whirled White Web” - a beautiful snow sculpture by Brent Collins Sculpture Generator - C++ program for Scherk-Collins surfaces by Carlo Séquin Bathsheba Grossman - metal printed math sculptures Annette Schwetje - math art “Dinosaur Tessellation” - AutoCAD 2000, AutoLisp, Adobe Photoshop 5.0, 12/9/02 A tessellation is a regular tiling of figures without any gaps or overlapping. If you have access to AutoCAD, you can use this AutoLisp routine to help you design your own tessellations. Tessellation Links Penrose Tiling Java Applet - by Craig Kaplan Maurits Cornelis Esher (M.C. Escher) - famous artist who used tessellations in his artwork Tessellation Java Applet - create your own tessellations “Free Spirit Tessellation” - AutoCAD 2000, AutoLisp, Adobe Photoshop 5.0, 5/12/03 I modelled this tessellation after “Spirit” from Disney’s “Spirit - Stallion of Cimarron” movie. I had to overlap the horse’s hind legs because there was not enough room. Still, I think the rest of it fits together remarkably well. Maelström Autostereogram - Mathematica 4.2, SISgen 1.58, 10/1/04 This 3D vortex image is hidden in the above picture. To see it, relax your eyes and focus behind the screen. This autostereogram was generated with William Steer’s free autostereogram generating program SISgen. Click here to see an animated version of this picture. I also have a Mathematica-only version of this picture, but it is not as accurate. See also Pascal Massimino’s “Maelstrom” autostereogram. (* Create Depth Map, runtime: 1 minute *) j1 = 615; i1 = 450; depth = Table[0, {i1}, {j1}]; r := Sqrt[x^2 + y^2]; z := 0.03Sin[7(2r - ArcTan[x, y])] - 0.1/r - 0.3; phi = Pi/6; ymax = 1.0/Cos[phi]; Do[flag = False; Do[i0 = ip; ip = Round[(i1 - 1 + (j1 - 1) (y Cos[phi] + z Sin[phi]))/2 + 0.2i1] + 1; z2 = z1; z1 = -y Sin[phi] + z Cos[phi]; If[flag, sign = If[i0 < ip, 1, -1]; j = Round[(j1 - 1)(x + 1)/2] + 1; Do[If[0 < i <= i1, depth[[i, j]] = ((i - i0)z1 + (ip - i)z2)/(ip - i0)], {i, i0 + sign, ip, sign}]]; flag = True, {y, ymax, -ymax, -2.0ymax/i1}], {x, -1, 1, 2.0/j1}]; ListDensityPlot[depth, Mesh -> False, Frame -> False, ImageSize -> {j1, i1}, AspectRatio -> Automatic] (* Create Shift Pattern, runtime: 10 seconds *) i2 = 450; j2 = 90; SeedRandom[0]; pattern = Map[Hue, -50Abs[InverseFourier[Fourier[Table[Random[], {i2}, {j2}]]Table[Exp[-((j/j2 - 0.5)^2 + (i/i2 - 0.5)^2)/0.025^2], {i, 1, i2}, {j, 1, j2}]]], {2}]; Show[Graphics[RasterArray[pattern],ImageSize -> {j2, i2}, AspectRatio -> Automatic]] (* Generate Autostereogram, Note: this code is not very accurate, you are better off using SISgen, runtime: 14 seconds *) f[z_] := 2(14 - 8.7z)/(28 - 8.7z); g[sign_] := Module[{x=0}, Table[x += sign/f[depth[[i, j]]]; pattern[[Mod[i - 1, i2] + 1, Mod[Round[x] - 1, j2] + 1]], {j, Floor[j1/2], If[sign != 1, 1, j1], sign}]]; Show[Graphics[RasterArray[Table[Join[Reverse[g[-1]], g[1]], {i, 1, i1}]], ImageSize -> {j1, i1}, AspectRatio -> Automatic]] Link: Animated Shark Autostereogram - by Fred Hsu Blended Pictures - AutoLisp, POV-Ray 3.6.1, C++, 12/5/07; Mathematica version: 9/29/04 The left image shows 12,629 pictures from my computer's hard drive. The right image shows what you get when you average them all together and increase the contrast (the result looks uniformly gray if you don't increase the contrast). Photographic Mosaic - AndreaMosaic: 12/6/07; C++ version: 12/6/07 This photographic mosaic was generated using Andrea Denzler's free software AndreaMosaic. I also tried to create my own version using C++, but it didn't look as nice. Links Photomosaic - free software for creating irregular photographic mosaics by Chris Lomont Mosaic Creator - free software by Olej Every Second of Star Wars - picture by Jason Salavon Motion After Affect - the most amazing optical illusion I’ve ever seen Motion Illusions - by Akiyoshi Kitaoka Fourth Enneper Surface - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 6/4/05 This is an example of a minimal surface. If you dipped this wire in a soap solution, the resulting soap film would be shaped like this (ideally). 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 *) ParametricPlot3D[{r Cos[phi] - r^5Cos[5phi]/5, r Sin[phi] + r^5Sin[5phi]/5, 2r^3Cos[3phi]/3, EdgeForm[]}, {phi, 0, 2Pi}, {r, 0, 1.3}, PlotPoints -> {181, 20}, ViewPoint -> {0, 0, 1}, PlotRange -> All] Links Enneper Mathematica Notebook Enneper Snow Sculpture Costa’s Minimal Surface - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 4/3/05 This minimal surface was discovered by a graduate student. I think it would be interesting to see someone create an actual soap film with this shape. The following Mathematica code uses the Weierstrass zeta and Weierstrass elliptic functions. (* 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] Links Mathematica code and minimal surface art - by Matthias Weber Alfred Gray - differential geometry gallery soap bubble light interference - by Kei Iwasaki Helaman Ferguson - math sculptor, see his Costa snow sculpture Richmond’s Minimal Surface - Mathematica 4.2, POV-Ray 3.6.1, 6/6/07 I learned about this minimal surface from Brian Johnston’s website. (* 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] 3,4,5 Quasi-Homogeneous Domain - C++ version: 8/24/06, Mathematica version: 8/22/06 This was adapted from Anton Lukyanenko’s C++ code. Here is some Mathematica code: (* runtime: 0.2 second *) p = 3; q = 4; r = 5; d = 1.0; s = Sin[Pi/p]; c = Cos[Pi/p]; s2 = Sin[2Pi/p];c2 = Cos[2Pi/p]; p = Inverse[{{-s, c - d, s d}, {s, 3 (c - d), -s d}, {(-3 + 4 c d) s,3 c - (1 + 2 c2) d, -s d}}].{1, 2Cos[2Pi/q], 2Cos[2Pi/r] + 1}; R1 = {{1, 0, 0}, {0, -1, 0}, {0, 0, 1}}; R2 = {{c2, s2, 0}, {s2, -c2, 0}, {0, 0, 1}}; T = {{d, c, p[[1]]}, {0, s, p[[2]]}, {1, 1, p[[3]]}}; R3 = T.{{1, 0, 0}, {0, 1,0}, {0, 0, -1}}.Inverse[T]; Reflect[tile_, R_] := R.# & /@ tile; Children[tile_] := Reflect[tile, #] & /@ {R1, R2, R3}; tiles = {{{0, 0, 1}, {d, 0, 1}, {c, s, 1}}}; Do[tiles = Flatten[Children /@ tiles, 1], {7}]; Show[Graphics[Table[Polygon[Map[{#[[1]], #[[2]]}/#[[3]] &, tiles[[i]]]], {i, 1, Length[tiles]}], AspectRatio -> 1]] Link: Anton Lukyanenko’s Animations - 3,3,4, 3,4,5, 3,5,4, 4,3,5, 4,5,3, 5,3,4, 5,4,3 Moiré Pattern - POV-Ray 3.6.1 version: 4/15/07, Mathematica 4.2 version: 1/29/05 A Moiré pattern is the interference of two similar overlapping patterns. The left picture shows the Moiré pattern on a twisted IKEA wastepaper basket. The mesh on the wastepaper basket was ray-traced from 109,400 tiny cylinders. (* runtime: 3 seconds *) f[dx_] := Mod[Floor[50 ArcTan[x - dx, y]], 2]; DensityPlot[f[0.1] - f[-0.1], {x, -1, 1}, {y, -1, 1}, PlotRange -> {0, 1}, PlotPoints -> 275, Mesh -> False, Frame -> False] Hyperboloid - POV-Ray 3.6.1, 6/22/05 Click here to download some POV-Ray code for this image. You can also make hyperboloids quickly in POV-Ray using the quadric command: camera{location <0,10,0> look_at <0,0,0>} light_source{<0,10,0>,1} quadric{<1,1,-1>,<0,0,0>,<0,0,0>,1 pigment{rgb 1}} Link: Gallery of Algebraic Surfaces - by Xiao Gang (11,3) Torus Knot - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 10/31/04 This is one continuous torus knotted on itself. The following code uses the tube plotting technique adapted from Maxim Rytin’s TubePlot code. See also my magnetic field of a torus. Click here to see a rotatable 3D version. Click here to download an animated screensaver along with C++ source code. (* runtime: 10 seconds *) Normalize[x_] := x/Sqrt[x.x]; p[theta_] := {(1 + 0.3 Cos[11theta/3]) Cos[theta], (1 + 0.3 Cos[11theta/3]) Sin[theta], 0.3 Sin[11theta/3]}; tangent[t_] := Normalize[p'[t]]; normal[t_] := Normalize[p''[t](p'[t].p'[t]) - p'[t](p'[t].p''[t])]; ParametricPlot3D[Append[p[t] + 0.1Transpose[{normal[t], Cross[tangent[t], normal[t]]}].{Cos[theta], Sin[theta]}, {EdgeForm[], SurfaceColor[Hue[t/(2Pi)]]}], {t, 0, 6Pi}, {theta, 0, 2Pi}, PlotPoints -> {360, 15}, Compiled -> False] POV-Ray has an internal function for this: // runtime: 8 seconds camera{location 16*y look_at 0} light_source{16*y,1} #declare f=function{internal(24)} isosurface{function{f(x,y,z,6,11,3,0.1,0.5,1,0.1,1,1,0)} max_gradient 2 contained_by{sphere{0,8}} pigment{rgb 1}} Knots Links Celtic knotwork tutorial - by Christian Mercat Knots3D - free Celtic knot program by Steve Abbott, see also KnotsBag by Geraud Bousquet KnotPlot - knot mathematics Gears Trefoil - by Michael Trott Tubes and Knots - Mathematica code by Mark McClure Kluchikov’s Favorite Isosurface - Mathematica 4.2, MathGL3d, 2/28/05 I found some beautiful POV-Ray renditions of this surface on Christoph Hormann’s web site so I decided to see if it could be plotted in Mathematica. The original equation for this implicit surface is attributed to Alex Kluchikov. Isosurfaces are commonly used for scientific visualizations. (* runtime: 25 seconds *) << MathGL3d`OpenGLViewer`; x1 = 0.125; y1 = 0.25Sin[2 Pi/3]; Kluchikov[x_, y_, z_, t1_,t2_] := Module[{r = Sqrt[x^2 + z^2] - 1.5, theta = ArcTan[z, x] + Pi/2,t, x2, y2}, t = 8theta/3 + t1; x2 = r Sin[t] + y Cos[t]; y2 = r Cos[t] - y Sin[t]; 0.33(((x2 + 0.25)^2 + y2^2)^(1/64) + ((x2 - x1)^2 + (y2 + y1)^2)^(1/64) + ((x2 - x1)^2 + (y2 - y1)^2)^(1/64)) + 0.01Sin[5theta + t2]]; Scan[MVContourPlot3D[Kluchikov[x, y, z, If[#, 0, Pi/3], If[#, 0, Pi]], {x, -2, 2}, {z, -2, 2}, {y, -0.5, 0.5}, Contours -> {0.945}, PlotPoints -> 100, ContourStyle -> {RGBColor @@ If[#, {0, 0, 1}, {1, 1, 1}]}, MVAlpha -> If[#, 0.5, 1], MVNewScene -> #, MVReturnValue -> None] &, {True, False}] MVPasteGraphics[]; If you do not have access to the free MathGL3d package, you can use ImplicitPlot3D or ContourPlot3D, but it doesn’t look as nice: (* runtime: 80 seconds *) << Graphics`ImplicitPlot3D`; ImplicitPlot3D[Kluchikov[x, y, z, 0, 0] == 0.945, {x, -2.1, 2.1}, {z, -2.1, 2.1}, {y, -0.55, 0.55}, PlotPoints -> 100] (* runtime: 80 seconds *) << Graphics`ContourPlot3D`; ContourPlot3D[Kluchikov[x, y, z, 0, 0], {x, -2.1, 2.1}, {z, -2.1, 2.1}, {y, -0.55, 0.55}, Contours -> {0.945}, PlotPoints -> 12, ContourStyle -> {EdgeForm[]}] This is how you can make this surface in POV-Ray: // runtime: 7 minutes camera{location 4*y look_at 0 up y right x} light_source{4*y,1} #declare x1=1/8; #declare y1=sin(2*pi/3)/4; #declare Sqr=function(X) {X*X}; #declare theta=function{atan2(x,z)+pi/2}; #declare r=function{sqrt(x*x+z*z)-1.5}; #declare T=function(x,y,z,t1) {8*theta(x,y,z)/3+t1}; #declare x2=function(x,y,z,t1) {r(x,y,z)*sin(T(x,y,z,t1))+y*cos(T(x,y,z,t1))}; #declare y2=function(x,y,z,t1) {r(x,y,z)*cos(T(x,y,z,t1))-y*sin(T(x,y,z,t1))}; #macro Kluchikov(t1,t2,c) isosurface{function{0.33*(pow(Sqr(x2(x,y,z,t1)+1/4)+Sqr(y2(x,y,z,t1)),1/64)+pow(Sqr(x2(x,y,z,t1)-x1)+Sqr(y2(x,y,z,t1)+y1),1/64)+pow(Sqr(x2(x,y,z,t1)-x1)+Sqr(y2(x,y,z,t1)-y1),1/64))+0.01*sin(5*theta(x,y,z)+t2)-0.945} threshold 0 accuracy 0.0002 max_gradient 0.75 contained_by{box{-<2.1,0.55,2.1>,<2.1,0.55,2.1>}} pigment{rgbt c}} #end Kluchikov(0,0,<1,1,1,0>) Kluchikov(pi/3,pi,<0,0,1,0.5>) Link: Polygonising a scalar field - how to make metaballs, by Paul Bourke Contour Plot - Mathematica 4.2, 6/27/07 Here is some code demonstrating how to make a simple 2D contour plot. Mathematica has a built-in function for this, but hopefully this might be a useful starting point for writing contour plot algorithms of your own. The image on the left is a contour plot of Perlin noise. (* runtime: 0.5 second *) x1 = y1 = -4; x2 = y2 = 4; n = 15; dx = (x2 - x1)/(n - 1); dy = (y2 - y1)/(n - 1); mesh = Table[x^2 + y^2 - x y, {x, x1, x2, dx}, {y, y1, y2, dy}]; interpolate[x1_, x2_, z1_, z2_] := If[Abs[2z - z1 - z2] < Abs[z2 - z1], (x2 -x1)(z - z1)/(z2 - z1) + x1]; Show[Graphics[Table[lines = {}; Do[x = x1 + i dx; y = y1 + j dy; plist = Select[{{interpolate[x - dx, x, mesh[[i, j]], mesh[[i + 1, j]]], y - dy}, {x - dx, interpolate[y - dy, y, mesh[[i, j]], mesh[[i, j + 1]]]}, {interpolate[x - dx, x, mesh[[i,j + 1]], mesh[[i + 1,j + 1]]], y}, {x,interpolate[y - dy, y, mesh[[i + 1,j]], mesh[[i + 1, j + 1]]]}}, ! MemberQ[#, Null] &]; If[Length[plist] == 2, lines = Append[lines, Line[plist]]], {i, 1, n - 1}, {j, 1, n - 1}]; lines, {z, 0, 48, 6}], AspectRatio -> Automatic]] Loxodrome - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 5/19/05 I made this animation in response to a special request from Donald Palermo. I am interested in finding more graphics work. Please let me know if you might have a job for me! (* runtime: 0.7 second *) a = 1; b = Sqrt[1 + (a t)^2]; ParametricPlot3D[{Sin[t + theta]/b, Cos[t + theta]/b, -a t/b, {EdgeForm[], SurfaceColor[Hue[t/5 - theta/Pi]]}}, {t, -10, 10}, {theta, 0, Pi}, PlotPoints -> {91, 19}] Link: Loxodrome animation - by Frank Jones Image Deconvolution - Mathematica 4.2, 3/10/06 Here is an amazing technique for focusing a blurry image. In order for this technique to work, the exact blurring function must be known. This technique can also be used for generating beautiful periodic textures. (* runtime: 50 seconds *) image = Import["C:/GrayPicture.jpg"][[1, 1]]; n = Length[image]; dx = 2.0/n; blurfunction = Fourier[Table[Exp[-(x^2 + y^2)/0.01^2], {y, -1, 1 - dx, dx}, {x, -1, 1 - dx, dx}]]^2; blurryimage = Re[InverseFourier[Fourier[image]blurfunction]]; ListDensityPlot[blurryimage, Mesh -> False, Frame -> False]; restoredimage = Re[InverseFourier[Fourier[blurryimage]/blurfunction]]; ListDensityPlot[restoredimage, Mesh -> False, Frame -> False] Link: Hubble telescope’s optical correction - M100 Galaxy before and after Canny Edge Detection - Mathematica 4.2, 7/7/05 Here is a beautiful technique for finding edges. I learned this technique from Mariusz Jankowski’s Mathematica code, which uses Mathematica’s ListConvolve function. (* runtime: 0.4 second *) image = Import["C:/GrayPicture.jpg"][[1, 1]]; A = Table[j Exp[-(j^2 + i^2)], {j, -1.0, 1.0}, {i, -1.0, 1.0}]; ListDensityPlot[Sqrt[ListConvolve[A, image]^2 + ListConvolve[Transpose[A],image]^2], Mesh -> False, Frame -> False] Link: Sobel edge detection Spherical Canvas versus Reflective Sphere - POV-Ray 3.6.1, 10/17/07 This image was inspired by Dick Termes' paintings of 3D worlds on a spherical “canvas” called Termespheres. These images have 6 vanishing points as opposed to linear perspective drawings which only have 3 vanishing points. The left picture shows my version of a spherical canvas for my factory scene. This was accomplished by rendering a spherical panorama of the scene in POV-Ray, and then mapping it to a sphere. Click here to download some sample POV-Ray code. The right picture shows a reflective sphere when viewed from the exact same position. As you can see, it looks quite different. Golden Ratio Logarithmic Spiral Transformation - Mathematica 4.2, 6/21/04 The Golden Ratio f = (1 + sqrt(5))/2 ≈ 1.61803 has an interesting relationship with Fibonacci Numbers. The basic equation for a Golden Spiral is given by r(q) = f2q/p. The interlocking rings pattern in this image was adapted from M. C. Esher’s Snakes. (* runtime: 48 seconds *) image = Import["C:/Picture.jpg"][[1, 1]]/255.0; imax = Length[image]; jmax = Length[image[[1]]]; n = 275; phi = 0.5 (1 + Sqrt[5]); Show[Graphics[RasterArray[Table[Module[{x = 2j/n - 1, y = 2i/n - 1, r, theta}, r = x^2 + y^2; theta = ArcTan[y, x]; RGBColor @@ If[r != 0, image[[Floor[imax Mod[2theta/Pi, 1]] + 1, Floor[jmax Mod[theta/Pi + 0.25Log[r]/Log[phi], 1]] + 1]], {0, 0, 0}]], {i, 1, n}, {j, 1, n}]], ImageSize -> n, PlotRange -> {{0, n}, {1, n}}, AspectRatio -> 1]] Links Droste Effect Gallery - recursive pictures by Josh Sommers Complex Map Polar Transformation: f(z) = e2 p z - Mathematica 4.2, 6/14/04 These images were generated by mapping a tessellation to the complex plane, similar to M. C. Esher’s Development II. (* runtime: 80 seconds *) image = Import["Picture.jpg"][[1, 1]]; n = Length[image]; m = Length[image[[1]]]; Show[Graphics[RasterArray[Table[RGBColor @@ Module[{z = Log[2j/275 - 1 + I (2i/275 - 1)]/(2Pi) + 1.0}, image[[Floor[n Mod[6 m Re[z]/n, 1]] + 1, Floor[m Mod[6 Im[z], 1]] + 1]]/255.0], {i, 1, 275}, {j, 1, 275}]], ImageSize -> 275, PlotRange -> {{0, 275}, {1, 275}}, AspectRatio -> 1]] Fisheye Transformation - Mathematica 4.2, 6/15/04 (* runtime: 26 seconds *) image = Import["C:/Picture.jpg"][[1, 1]]; n = Length[image]; m = Length[image[[1]]]; Show[Graphics[RasterArray[Table[RGBColor @@ Module[{x = 2j/275 - 1, y = 2i/275 - 1, r, h}, r = 1.0 - x^2 - y^2; h = 0.5(1 - 0.5If[r > 0, Sqrt[r], 0]); image[[Floor[n Mod[5 m h x/n, 1]] + 1, Floor[m Mod[5 h y, 1]] + 1]]/255.0], {i, 1, 275}, {j, 1, 275}]], ImageSize -> 275, PlotRange -> {{0, 275}, {1, 275}}, AspectRatio -> 1]] RSA Encryption (Rivest, Shamir and Adleman) - Mathematica 4.2, 11/15/06 Here is some code to encrypt messages using prime numbers. Anyone with the public key (and n) can encode messages, but only the person with the secret key can decode them: (* runtime: 0.05 second *) message = "This is a secret message containing 112 characters. This message will be divided into 4 blocks of 28 characters."; << NumberTheory`NumberTheoryFunctions`; SeedRandom[0]; PublicKey = NextPrime[Random[]256^28]; p = NextPrime[Random[]256^14]; q = NextPrime[256.0^28/p]; n = p q; SecretKey = PowerMod[PublicKey, -1, (p - 1)(q - 1)]; ToNumbers[str_] := Map[FromDigits[#, 256] &, Partition[ToCharacterCode[str], 28]]; ToText[nlist_] := StringJoin @@ Map[StringJoin @@ Map[FromCharacterCode, IntegerDigits[#, 256, 28]] &, nlist]; encryption = ToText[Map[PowerMod[#, PublicKey, n] &, ToNumbers[message]]] ToText[Map[PowerMod[#, SecretKey, n] &, ToNumbers[encryption]]] If you do not know p and q, you can try to break the code using this method (but it is very slow): (* runtime: 40 minutes *) SecretKey = PowerMod[PublicKey, -1, EulerPhi[n]]; Here’s a basic idea how these functions work: InverseMod[a0_, n0_] := Module[{n = n0, a = a0, x = 0, x1 = 0,x2 = 1, q1 = 0, q2 = 0, i = 1}, While[a != 0, If[i > 2, x = Mod[x1 - x2 q1 + n0^2, n0]; x1 = x2; x2 = x]; q1 = q2; q2 = Floor[n/a]; {n, a} = {a, Mod[n, a]}; i++]; Mod[x1 - x2 q1 + n0^2, n0]]; PowerMod[a_, b_, n_] := If[b == -1, InverseMod[a, n], Module[{c = 1}, digits =IntegerDigits[b, 2]; Scan[If[#[[1]] == 1, c = Mod[c #[[2]], n]] &, Transpose[{digits, Reverse[NestList[Mod[#^2, n] &,a, Length[digits] - 1]]}]]; c]]; GCD[a_, b_] := If[b == 0, a, GCD[b, Mod[a, b]]]; Link: RSA Encryption - Mathematica notebook by Kit Dodson Spirographs - MacDraw (vector art), 1992? I made these a very long time ago on my old Macintosh. I don’t remember how to make them anymore. Mathematica Typesetting Shortcuts Here is a Mathematica notebook that summarizes some convenient Mathematica typesetting shortcuts. You can type equations quite quickly in Mathematica once you know these shortcuts. I use these shortcuts to type my class notes in Mathematica. Other Math Links Mathematica - excellent technical computing software, easy to make beautiful plots and play equations as sounds MathWorld - mathematics dictionary MathGL3d - free Mathematica package for rendering with OpenGL and writing POV-Ray scripts LiveGraphics3D - software for displaying rotatable 3D Mathematica graphics on the internet JavaView - another program similar to LiveGraphics3D Mathematica Information Center - many sample notebooks & packages Mathematica Art - I especially like the animated GIFs Sphere Eversion - beautiful animation turning a sphere inside-out by Bill Thurston Hyperspheres - If a 2-sphere is a circle, and a 3-sphere is a regular sphere, then what is a 4-sphere? How about a 4.5-sphere? Did you know there is a formula to find the “volume” for any n-sphere? Amazing! Who thinks of this stuff? Penrose Tiling - amazing aperiodic tilings discovered by Roger Penrose, here is a Mathematica notebook by E. Arthur Robinson Sphere Packing - by Jos Leys Chatin’s Constant - the infamous “incalculable” constant, the probability that a random algorithm halts Who can name the Biggest Number? - Chained Arrow Notation, Busy Beavers Large Numbers Andrew Wiles - solver of Fermat’s Last Theorem John Nash - A Beautiful Mind, see also autobiography Fractional Calculus - fractional derivatives Discrete Cosine Transform - how JPEGs are made Hyperspheres - surface areas & volumes of n-dimensional spheres Strang’s Strange Figures - unexpected patterns in trig functions Wikipedia article on p Gödel's Incompleteness Theorem - famous proof that there are true statements which are unprovable. I can’t say I understand it, but it’s interesting Chinese Rings - a simple puzzle that can be solved in no less than 18446744073709551616 moves Number Spiral - interesting pattern of prime numbers