Mathematica Project, Math 21a, Fall, 2012

The project

This creative project asks you to produce an art object in Mathematica which can be printed on a 3D printer.
The project is due Sunday December 9, 2012 but you can submit anytime unitl then. Submit the project electronically to knill@math.harvard.edu after deleting all output (Choose Cell->DeleteAllOutput in the menu to the top of this window. You will get a confirmation that the project has been accepted.). We will print the printable submissions using a 5000 dollar grant from the Elson Family Arts initiative. We try to print as many of your projects to print (hopefully all) until the money is gone.

Example: A bumpy sphere

Grab the bracket to the right of the following yellow cell with the cursor. Click on it, then hold the Shift key and hit Return to evaluate the cell. A graphic showing the parametrized surface should appear below.

S=ParametricPlot3D[5 (3+Sin[11 s]-Sin[7t]) {Cos[t] Sin[s],Sin[t] Sin[s],Cos[s]},{t,0,2 Pi},{s,0,Pi},Boxed->False,Axes->False,PlotPoints->30,ColorFunction->Function[{x,y,z,u,v},Hue[(Sin[11u])^2]]]

The simplest export is in STL format, but this does not use the color:

Export["s.stl",S];

It will look as follows:

Import["s.stl"]

If we want to print in color, we have to export in WRL format as follows:

Export["s.wrl",S]

When this object is uploaded to http://www.shapeways.com using millimeters as unit  and printed in Full Color Sandstone, it costs 17 dollars. The cost of the printing very much depends on the material as well as the size. You get full credit if you submit an original object which can be printed for less than 20 dollars. Original means that it should be something new. Submitting a bare sphere for example is not original. Here is how the above project looks on Shapeways:

Import["http://www.math.harvard.edu/~knill/project2012/project1.jpg"]

In the rest of this notebook, we give you more examples and ideas to get started.

Tips

Watch the size. 
Minimal wall thickness: 1mm. 
Surfaces need to be closed. 
Not too many polygons (1 Million). 
 Increase the resolution like PlotPoints0->100 to make the object smoother. 
 Watch the size. Not more than 64 meg. 
 Submit the WRL or STL file to Shapeways to see whether it prints.

Example: A Sculpture

leaf=ParametricPlot3D[20 {Cos[t] Sin[s],0.2 Sin[t] Sin[s],0.1 Cos[s]},{t,0,2 Pi},{s,0,Pi},Mesh->False][[1]];
leafs=Table[{RGBColor[{(1+Random[])/2,Random[],0}],Rotate[leaf,2 Pi k/7,{0,0,1},{0,0,0}]},{k,1,7}];
stem={Green,Cylinder[{{0,0,0},{0,0,-20}},1]};
base={Yellow,Cylinder[{{0,0,-20},{0,0,-23}},10]};
flower={leafs,stem,base};
S=Show[Graphics3D[flower]]
Export["flower.stl",S];

Example: The perfect Euler brick

a=30;b=25;c=16;r0=1;r1=1;r2=2;r3=1;r4=2;l=0.2;
A1={0,0,0};A2={a,0,0};A3={a,b,0};A4={0,b,0};A={A1,A2,A3,A4};
B1={0,0,c};B2={a,0,c};B3={a,b,c};B4={0,b,c};B={B1,B2,B3,B4};
S1={Yellow,Cylinder[{A1,A2},r0]};S2={Yellow,Cylinder[{A2,A3},r0]};
S3={Yellow,Cylinder[{A3,A4},r0]};S4={Yellow,Cylinder[{A4,A1},r0]};
S5={Yellow,Cylinder[{B1,B2},r0]};S6={Yellow,Cylinder[{B2,B3},r0]};
S7={Yellow,Cylinder[{B3,B4},r0]};S8={Yellow,Cylinder[{B4,B1},r0]};
S11={Yellow,Cylinder[{A1,B1},r0]};S12={Yellow,Cylinder[{A2,B2},r0]};
S13={Yellow,Cylinder[{A3,B3},r0]};S14={Yellow,Cylinder[{A4,B4},r0]};
S20=Table[{Blue,Sphere[A[[i]],r2]},{i,Length[A]}];
S21=Table[{Blue,Sphere[B[[i]],r2]},{i,Length[B]}];
S31={Green,Cylinder[{A1+l (A3-A1),A3-l(A3-A1)},r3],Cone[{A1+l (A3-A1),A1},r4],Cone[{A3-l(A3-A1),A3},r4]};
S32={Green,Cylinder[{A1+l (B4-A1),B4-l(B4-A1)},r3],Cone[{A1+l (B4-A1),A1},r4],Cone[{B4-l(B4-A1),B4},r4]};
S33={Green,Cylinder[{A3+l (B4-A3),B4-l(B4-A3)},r3],Cone[{A3+l (B4-A3),A3},r4],Cone[{B4-l(B4-A3),B4},r4]};
S41={Red,Cylinder[{B2+l (A4-B2),A4-l(A4-B2)},r3],Cone[{B2+l (A4-B2),B2},r4],Cone[{A4-l(A4-B2),A4},r4]};

S=Show[Graphics3D[{S1,S2,S3,S4,S5,S6,S7,S8,S11,S12,S13,S14,S20,S21,S31,S32,S33,S41}]]
Export["Eulerbrick.wrl",S]

Example: A form

S=ParametricPlot3D[10 {Cos[t] Sin[s],Sin[t] Sin[s],Cos[t]+Cos[s]+Sin[s]},{t,0,2 Pi},{s,0,Pi},
MeshShading->{{Green,Blue},{Yellow,Red}},Mesh->8,PlotPoints->50,Axes->False,Boxed->False,Mesh->False,AspectRatio->1];
Export["s.wrl",S]

Example: A ring

Start with a ring with 21 millimeter center radius. It is flatt with 5 millimeter.

S0=ParametricPlot3D[ {(21+ Cos[s])Cos[t],(21+Cos[s])Sin[t],5 Sin[s]},{t,0,2Pi},{s,0,2Pi},Mesh->False];

Lets add something on top:

S1=ParametricPlot3D[ {-10,0,20}+{(2+Sin[s])(4+ Cos[s])Cos[t],(2+Cos[s])(4+Cos[s])Sin[t],3 Sin[s]},{t,0,2Pi},{s,0,2Pi},Mesh->False];

The translation and rotation and scaling things do not work unfortunately:

S=Show[Graphics3D[{S0[[1]],Rotate[S1[[1]],90,{0,1,0}]}]]
Export["s.stl",S,"STL"]

Example: A Curve

tubeplot[R_,a_,b_]:=Module[{M=20,r0=2,eps=0.0001,v=D[R,t]},
TT=v/Sqrt[0.01+v.v];VV=D[TT,t];NN=VV/Sqrt[eps+VV.VV];BB=Cross[TT,NN];U=Re[N[R+r0 Cos[s] NN+r0 Sin[s] BB]];
ParametricPlot3D[U,{t,a,b},{s,0,2Pi},PlotPoints->{100,20},PlotStyle->Blue]];
R1=N[{20(2+Cos[12t])Cos[t],15(2+Cos[12t])Sin[t],30 Sin[12t]}];
S=tubeplot[R1,0,2Pi]
Export["tube.stl",S,"STL"]

Example: A polyhedron

Get["PolyhedronOperations`"];
Fullerene[solid_,level_]:=Module[{g,F0,F,E1,p1,e1,s},g=First[PolyhedronOperations`Geodesate[PolyhedronData[solid],level]];
F0=g[[2,1]];F1=Map[RotateRight,F0];F2=Map[RotateLeft,F0];
F=Union[F0,F1,F2];f=Length[F]/3;V=Union[Flatten[F]];v=Length[V];vertices=Table[k,{k,v}];
E1=Table[{F[[k,1]],F[[k,2]]},{k,Length[F]}];E2=Table[{F[[k,2]],F[[k,3]]},{k,Length[F]}];EE=Union[E1,E2];e=Length[EE]/2;
p1[k_]:=Position[V,F[[k,1]]][[1,1]];p2[k_]:=Position[V,F[[k,2]]][[1,1]];
e1=Table[p1[k]->p2[k],{k,Length[E1]}];e2=Table[p1[k]->p2[k],{k,Length[EE]}];s=Union[e1,e2];
s=UndirectedGraph[Graph[s]]];
MyGraphPlot[s_]:=Module[{A,u,Q,line,S2,S3,P},
line[{a_,b_}]:={Cylinder[{a,b},0.8]};P=7*GraphPlot3D[s][[1,1,1]];
u=Normal[GraphPlot3D[s][[1,1]]][[1,2]];Q=7*Table[u[[k,1]],{k,Length[u]}];
S2=Graphics3D[Table[{Red,Sphere[P[[k]],1.5]},{k,Length[P]}]];
S3=Graphics3D[{Blue,Table[line[Q[[k]]],{k,Length[Q]}]}];
Show[{S2,S3},Boxed->False,Axes->False,AspectRatio->1]]

S=MyGraphPlot[Fullerene["Dodecahedron",3]]
Export["p.stl",S,"STL"]

Example: A surface

S=ContourPlot3D[x^2+y^2+z^2+24Sin[x y z/20]==60,{x,-10,10},{y,-10,10},{z,-10,10}]
Export["shreck.stl",S,"STL"]

Example: A statue

a=30;b=22;c=10;d=25;e=6;
A1={Yellow,Cuboid[{{0,0,-2},{a,a,0}}]};
A2={Blue,Cylinder[{{b,c,0},{0,a,a}},1]};
A3={Red,Sphere[{b,b,d},e]};
A4={Orange,Cuboid[{c,c,c},{b,b,b}]};
A5={Yellow,Sphere[{0,a,a},2]};
A6={Yellow,Sphere[{b,c,0},2]};
S=Show[Graphics3D[{A1,A2,A3,A4,A5,A6}]]
Export["kungfu.stl",S,"STL"]

Example: The Penrose triangle

Evaluate this and turn it around with the mouse. (This appeared as a polygon in the Mathematica guide book by Trott.). This example was added November 26th (simplified November 27 because it would not print).

b=N[20/7];d=22.4;f=18.666;h=20;
P1={Yellow,Cuboid[{{0,0,0},{h+b,-b,b}}]};
P2={Yellow,Cuboid[{{0,0,0},{b,-h,b}}]};
P3={Yellow,Cuboid[{{0,-h,0},{b,b-h,f}}]};
P4={Yellow,Polygon[{{b,b-h,f},{b,-h,d},{0,-h,d},{0,b-h,f},{b,b-h,f}}]};
P5={Yellow,Polygon[{{b,-h,f},{b,-h,d},{0,-h,d},{0,-h,f},{b,-h,f}}]};
P6={Yellow,Polygon[{{0,b-h,f},{0,-h,f},{0,-h,d},{0,b-h,f}}]};
P7={Yellow,Polygon[{{b,b-h,f},{b,-h,f},{b,-h,d},{b,b-h,f}}]};
S=Show[Graphics3D[{P1,P2,P3,P4,P5,P6,P7}],PlotRange->All,ViewPoint->{-12.625,-10.9375,14.21},Boxed->False,Axes->False]
Export["triangle.stl",S,"STL"]

Example: Random stuff

This was added on December 3 for the workshop.

S=Graphics3D[Table[{Hue[Random[]],Sphere[20 {Random[],Random[],Random[]},2]},{600}]];

S=Graphics3D[Table[x=20{Random[],Random[],Random[]}; {Hue[Random[]],Rotate[Cuboid[{x,x+{8,8,8}}],2Pi Random[],{Random[]-0.5,Random[]-0.5,Random[]-0.5}]},{200}]]

Example: Drawing grid curves

This was added on December 3 for the workshop.

Clear[x,y];
MyParametricPlot3D[f_,xb_,yb_,n_,a_]:=Module[{b=xb[[4]]/n,c=yb[[4]]/n,t,s,A0,A1,A2},A0=Table[Sphere[f/.x->t+b/.y->s,a],{t,xb[[2]],xb[[3]],b},{s,yb[[2]],yb[[3]],yb[[4]]}];
A1=Table[Cylinder[{f/.x->t+b/.y->s,f/.x->t/.y->s},a],{t,xb[[2]],xb[[3]]-b,b},{s,yb[[2]],yb[[3]],yb[[4]]}];
A2=Table[Cylinder[{f/.x->t/.y->s+b,f/.x->t/.y->s},a],{t,xb[[2]],xb[[3]],xb[[4]]},{s,yb[[2]],yb[[3]]-c,c}];
Graphics3D[{A0,A1,A2}]];
S=MyParametricPlot3D[(10+3 Cos[2 x] Sin[3 y]) {Cos[x] Sin[y],Sin[x] Sin[y],Cos[y]},{x,0,2Pi,2Pi/8},{y,Pi/12,Pi-Pi/12,Pi/12},15,0.3]

Example: Flow lines of a differential equation

We see the Lorentz attractor, an icon for chaos. Added December 3 for the workshop. Unfortunately, this model prints only with much lower resolution at the moment.

Orb=NDSolve[{x'[t]==10.0(y[t]-x[t]),y'[t]==-x[t] z[t]+28x[t]-y[t],z'[t]==x[t]*y[t]-8z[t]/3,x[0]==z[0]==0.2,y[0]==.3},{x,y,z},{t,0,80},MaxSteps->500000];
f[t_]:=Evaluate[20 {x[t],y[t],z[t]}/.Orb][[1]];a=80/8000;r=6;
S=Graphics3D[Table[{Hue[t/80],Sphere[f[t],r],Cylinder[{f[t],f[t+a]},r]},{t,0,20-a,a}],Boxed->False]

Example: A bunny

Using built in models. Added December 3 for the workshop.

S1=ListSurfacePlot3D[ExampleData[{"Geometry3D","StanfordBunny"},"VertexData"],Lighting->"Neutral",MaxPlotPoints->100,Mesh->False,PlotStyle->{Specularity[White,20],Texture[ExampleData[{"ColorTexture","Vavona"}]]},TextureCoordinateFunction->(Normalize[{#1,#2,#3}]&),Axes->False,Boxed->False];
S2=Graphics3D[{Yellow,Sphere[{-0.055,-0.03,0.14},0.003]}];
S3=Graphics3D[{Yellow,Sphere[{-0.055-0.04,-0.03,0.14},0.003]}];
S4=Graphics3D[{Red,Sphere[{-0.055-0.02,-0.045,0.12},0.008]}];Show[{S1,S2,S3,S4}];
S=Show[{S1,S2,S3,S4},AspectRatio->1,ViewPoint->{-1.80793,-2.77419,0.696588},ViewVertical->{-0.262821,-0.439031,0.942257}]

Example: The earth

Using textures. Added December 3 for the workshop. Also textures unfortunately do not print with WRL export.

s=Import["http://www.math.harvard.edu/~knill/images/earthtexture.png"];
S=SphericalPlot3D[1.2+0.02 Sin[phi]^2 Cos[theta],{phi,0,Pi},{theta,0,2 Pi},Lighting->"Neutral",Mesh->None,PlotPoints->30,TextureCoordinateFunction->({-#5,#4}&),PlotStyle->{Specularity[White,20],Texture[s]},Axes->False,Boxed->False,AspectRatio->1]

Example: Chemical element

Added December 3 for the workshop. Type ChemicalData[] to see all molecules which are implemented. Also this model does not print as given since it is too large. The scaling command unfortunately also makes models unprintable.

S=ChemicalData["Caffein","MoleculePlot"];
Export["caffein.wrl",S]

Example: Using 3DS models

Added December 3 for the workshop. A violin. Also this model does not print because the walls are too thin. This example is also just added as a warning that it can be tricky to print models found in 3D warehouses.

S=Import["http://www.math.harvard.edu/~knill/images/violin.3ds"];
Export["violin.stl",S,"STL"];Import["violin.stl"]

Example: Menger Sponge

Menger[0,{i_,j_,k_}]:={Cuboid[{{i-0.01,j-0.01,k-0.01},{i+1.01,j+1.01,k+1.01}}]};
Menger[n_,{i_,j_,k_}]:=Module[{s={}},Do[If[Not[u==v==2||v==w==2||u==w==2],s=Union[s,Menger[n-1,3^(n-1)*{u,v,w}+{i,j,k}]]],{u,3},{v,3},{w,3}];s];
S=Show[Graphics3D[Menger[3,{0,0,0}]],Boxed->False]
Export["s.stl",S,"STL"]

Oliver Knill, November 22, 2012