Math

Contents

	Home
	Physics Simulations
	Fractals
$Math Artwork$	Math Artwork
	Engineering
	Rendered Artwork
	Hand-made Artwork
	Bug Collection
	Programming
	High Voltage
	Physics Experiments
	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.

Dodecaplex (120 Cell) - Mathematica 4.2, POV-Ray 3.6.1, 10/21/08

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.

Links
Jenn 3D - polytope program, by Fritz Obermeyer
The HyperSphere, from an Artistic point of View - explanation by Rebecca Frankel
120 Cell Soap Bubbles - by John Sullivan
Regular Polytopes - Mathematica notebook by Russell Towle
4D Star Polytope Animations - data by Russell Towle
POV-Ray include files - by Russell Towle
Magic 120 Cell - OpenGL program by Roice Nelson, et al.

Clifford Torus - Mathematica 4.2, POV-Ray 3.6.1, 8/12/08

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. Click here to download some POV-Ray code. The right picture shows a complex cubic polynomial. 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}];

Links
Dimensions - interesting video animated by Jos Leys, see their fibration explantion and video
The Flat Torus in 3-Sphere - by Thomas Banchoff, explanation1, explanation2, animations
Stereographic Projection - by Davide Cervone
Visualization of the Hopf Bundle - Mathematica notebook by Srdjan Vukmirovic

Double Spiral - new version: C++, POV-Ray 3.6.1, 10/1/08; old version: Mathematica 4.2, 7/18/05

One way to create a double spiral is 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. Click here to download a Mathematica notebook. Here is some Mathematica code:
(* 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}}

Links
other double spiral formulas - Cornu spiral (clothoid), tanh spiral
Whirlpools - famous double spiral tessellation by M.C. Escher
Loxodrome animation - by Frank Jones

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 RP² a trilateral symmetry. The parameters (p,q) = (1,0) should give bilateral symmetry. Click here to download some POV-Ray code for this image. Here is some Mathematica code:
(* 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}}

Another way to obtain other symmetries is to use conformal mapping.

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

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. Here is some Mathematica code:
(* 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

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. Here is some Mathematica code:
(* 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[{face, 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

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

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

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]

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

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. Here is some Mathematica code:
(* 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]

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. Here is some Mathematica code:
(* 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

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. 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]

Link: Mandelbrot Set Moire Pattern - by Bernard Helmstetter

(11,3) Torus Knot - Mathematica 4.2, MathGL3d, POV-Ray 3.6.1, 10/31/04

This is one continuous torus knotted on itself. Click here to download an animated screensaver along with C++ source code. Click here to see a rotatable 3D version. The following Mathematica code was adapted from Maxim Rytin’s TubePlot code:
(* runtime: 2.6 seconds *)
Normalize[x_] := x/Sqrt[x.x]; p[t_] := {(1 + 0.3 Cos[11t/3])Cos[t], (1 + 0.3 Cos[11t/3]) Sin[t], 0.3 Sin[11t/3]};
f[t_, theta_] := Module[{dp = p'[t], ddp = p''[t], tangent, normal1, normal2},tangent = Normalize[dp]; normal1 = Normalize[ddp(dp.dp) - dp(dp.ddp)]; normal2 = Cross[tangent, normal1]; p[t] + 0.1 (normal1 Cos[theta] + normal2 Sin[theta])];
ParametricPlot3D[Append[f[t, theta], {EdgeForm[], SurfaceColor[Hue[t/(2Pi)]]}], {t,0, 6Pi}, {theta, 0, 2Pi}, PlotPoints -> {360, 15}, Compiled -> False]

POV-Ray has an internal function for torus knots:
// 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

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

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. 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]

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

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

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

Stereographic Projection of a Dodecahedron - POV-Ray, 10/10/08

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

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. Here is some Mathematica code:
(* 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]]

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. Here is some Mathematica code:
(* 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.2 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]

Here is another variation to make the image appear embossed:
(* runtime: 0.1 second *)
image = Import["C:/GrayPicture.jpg"][[1, 1]];
A = Table[1.0j E^-(j^2+i^2), {j, -1, 1}, {i, -1, 1}];
ListDensityPlot[ListConvolve[A, image] + ListConvolve[Transpose[A], image], Mesh -> False, Frame -> False]

Link: Sobel edge detection

Dithering - Mathematica 4.2, 9/22/08

Here is some Mathematica code demonstrating Floyd-Steinberg Dithering:
(* runtime: 14 seconds *)
image = Import["C:/GrayPicture.jpg"][[1, 1]]/255.0; ny = Length[image]; nx =Length[image[[1]]]; image2 = image;
Do[c0 = image2[[i, j]]; c = Round[c0]; image2[[i, j]] = c; e = (c0 - c)/16; image2[[i + 1, j]] += 7 e; image2[[i - 1, j + 1]] += 3 e; image2[[i, j + 1]] += 5 e; image2[[i + 1, j + 1]] += e, {i, 2, ny - 1}, {j, 2, nx - 1}];
ListDensityPlot[Round[image2], Mesh -> False, Frame -> False, ImageSize -> {nx, ny}, AspectRatio -> ny/nx]

Here is some Mathematica code demonstrating Ordered Dithering:
(* runtime: 0.2 second *)
image = Import["C:/GrayPicture.jpg"][[1, 1]]/255.0; ny = Length[image]; nx = Length[image[[1]]];
ThresholdMap = {{1, 9, 3, 11}, {13, 5, 15, 7}, {4, 12,2, 10}, {16, 8, 14, 6}}/17.0; n = Length[ThresholdMap];
ListDensityPlot[Table[Round[0.5(image[[i, j]] + ThresholdMap[[Mod[i - 1, n] + 1,Mod[j - 1, n] + 1]])], {i, 1, ny}, {j, 1, nx}], Mesh -> False, Frame -> False, ImageSize -> {nx, ny}, AspectRatio -> ny/nx]

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) = f^2q/p. The interlocking rings pattern in this image was adapted from M. C. Esher’s Snakes. Here is some Mathematica code:
(* 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) = e^{2 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. Here is some Mathematica code:
(* 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

Here is some Mathematica code:
(* 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 Mathematica 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
Srinivasa Ramanujan - amazing mathematician
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
echochrome - M.C. Escher video game