Multivariable Calculus Computer Algebra Project Summer 2017

Maths  21a, Summer 2017

Also this years Mathematica  project is  creative.  The assignment is very simple: use Mathematica to 
1) (5 points) produce your own Pasta type (there are more than thousand pasta types)  documented. Make your own and also give it an original name)
2) (5 points) create your own desert (can be fruit, cheese, ice cream, drink etc) and give your creation an original name.
I will  provide you with some examples.The project is due on Saturday July 29 electronically by email.  Your submission does not have to be a master piece.
But I want it to be original. It can be simple but grabbing a known implementation of an apple for example would not qualify. You certainly could create your own. If you use code template different from what is provided here or in the workshop, you have to acknowledge its source. 
We will have a short  project launch workshop on Tuesday, July 25.

Content in a mathematica file is organized as cells. To evaluate, grab the bracket to the right, holding down the shift key and hit return. We will give a few tips during the workshop.

Objects using parametric and implicit surfaces

Here is an example of an object using parametric and implicit surfaces

S1=ContourPlot3D[x^2+y^2+z^2==1,{x,-3,3},{y,-3,3},{z,-3,3},
Mesh->False,ContourStyle->RGBColor[1,1,1]];
S2=ParametricPlot3D[{0,2 s-2,t},{t,-0.5,0.5},{s,-1.5,1},
Mesh->False,PlotStyle->Green];
S3=ParametricPlot3D[2.3*{s Cos[t],-s,s Sin[t]}+{0,-1.0,0},{t,0,2 Pi},{s,0,1},
Mesh->False,PlotStyle->Red];
S4=ParametricPlot3D[{x,Cos[x*y],y},{x,-2,2},{y,-2,2},
Mesh->False,PlotStyle->Yellow];
S=Show[{S1,S2,S3,S4},Boxed->False,Axes->False,PlotRange->All,
ViewPoint->{3.24,0.071,-0.97},ViewVertical->{0.54,0.81,-0.17}]

General  objects

A1={Yellow,Polygon[{{0,0,0},{0,3,0},{3,3,0},{3,0,0}}]};
A2={Blue,Cylinder[{{2,1,0},{0,3,3}},0.1]};
A3={Red,Sphere[{2,2,2.5},0.6]};
A4={Orange,Cuboid[{1,1,1},{2,2,2}]};
A5={Yellow,Sphere[{0,3,3},0.2]};
A6={Yellow,Sphere[{2,1,0},0.2]};
S=Show[Graphics3D[Scale[{A1,A2,A3,A4,A5,A6},0.2]],ViewPoint->{0.51,3.30,0.494}]

And here is the Monkey riding the saddle:

S1=ParametricPlot3D[{u,v,v u^2-v^3-0.4},{u,-1,1},{v,-1,1},PlotStyle->Blue,Mesh->False];
S2=ParametricPlot3D[0.5 {Cos[u] Sin[v],Sin[u] Sin[v],2 Cos[v]}+{0,0,0.6},{u,0,2 Pi},{v,0,Pi},Mesh->False,PlotStyle->Red];
S3=ParametricPlot3D[0.4 {Cos[u] Sin[v],Sin[u] Sin[v],Cos[v]}+{0,0,2},{u,0,2 Pi},{v,0,Pi},Mesh->False];
S4=Graphics3D[{Green,Tube[{{0,0,0},{1,-0.5,-0.2}},0.2]}];
S5=Graphics3D[{Green,Tube[{{0,0,0},{-1,-0.5,-0.2}},0.2]}];
S6=Graphics3D[{Green,Tube[{{0,0,0},{0,1,-0.2}},0.2]}];
S7=Graphics3D[{Blue,Cuboid[{{-0.4,-0.4,2.4},{0.4,0.4,2.5}}]}];
S=Show[{S1,S2,S3,S4,S5,S6,S7},ViewPoint->{-3.13927,-0.431189,1.18703},ViewVertical->{-0.420105,-0.098456,0.962471},PlotRange->All,Axes->False,Boxed->False]

Region Plot

To print things, we have to use closed surfaces or to make a region plot:

S=RegionPlot3D[x^2 y^2+z^2 y^2+x^2 z^2≤1&&x^2≤8.5&&y^2≤8.5&&z^2≤8.5,{x,-3,3},{y,-3,3},{z,-3,3},PlotPoints->50,Mesh->False,ColorFunction->Function[{x,y,z},Hue[z]],Axes->False,Boxed->False]

Polytopes

S1=Graphics3D[{Yellow,Opacity[0.2],PolyhedronData["Dodecahedron","Faces"]},Boxed->False];
S2=Graphics3D[{Green,Opacity[0.2],PolyhedronData["Icosahedron","Faces"]},Boxed->False];
S3=Graphics3D[{Blue,Opacity[0.2],PolyhedronData["Octahedron","Faces"]},Boxed->False];
S4=Graphics3D[{Orange,Opacity[0.2],PolyhedronData["Tetrahedron","Faces"]},Boxed->False];
S5=Graphics3D[{Pink,Opacity[0.2],PolyhedronData["Hexahedron","Faces"]},Boxed->False];
HarmonicesMundi=Show[{S1,S2,S3,S4,S5}]

Contour plots

S=ContourPlot3D[ x^2+y^2+z^2+Sin[5 x y z]==0.14,{x,-0.4,0.4},{y,-0.4,0.4},{z,-0.4,0.4},
Mesh->{5,5},MeshStyle->{{Yellow,Thickness[0.001]},{Orange,Thickness[0.001]}},ContourStyle->Directive[Orange,Opacity[0.8],Specularity[White,30]],Boxed->False,Axes->False]

Parametrized surfaces

S=ParametricPlot3D[ (1.2+Cos[2t] Sin[3 s]) {Cos[t] Sin[s],Sin[t]Sin[s],Cos[s]}/2,{t,0,2Pi},{s,0,Pi},PlotStyle->Directive[Opacity[0.7],Blue,Specularity[White,10]],MeshStyle->{{Yellow,Thickness[0.001]},{Orange,Thickness[0.001]}},Axes->False,Boxed->False]

Using Textures

picture=Import["http://www.math.harvard.edu/archive/21a_fall_11/donald.jpg"];
ParametricPlot3D[(2+Sin[t]) {Cos[t] Sin[s],Sin[t] Sin[s],Cos[s]},{s,0,Pi},{t,0,2Pi},Lighting->"Neutral",Mesh->False,PlotPoints->40,TextureCoordinateFunction->({#5,#4}&),PlotStyle->{Texture[picture]},ViewPoint->{-3.25,-0.9,-0.2},ViewVertical->{-0.64,-0.05,-0.9},Axes->False,Boxed->False,PlotRange->All]

Knots

u=KnotData[{7,3},"SpaceCurve"];
s=Table[u[t],{t,0,2Pi,2Pi/400}];
S=Graphics3D[{Yellow,Tube[s,0.3]},Boxed->False]

s=Table[{Cos[4t-0.3],Cos[3t+0.3],Cos[5t+1]},{t,0,2Pi,2Pi/400}];
S=Graphics3D[{Green,Tube[s,0.04]},Boxed->False]

Spherical plots

Clear[s,t];S=SphericalPlot3D[0.1(1.4+Cos[4t]) (1+Sin[s]),{s,0,Pi},{t,0,2Pi},MeshStyle->Yellow,PlotStyle->Directive[Red],Axes->False,Boxed->False,PlotRange->All,PlotPoints->40]

Built in objects

ListSurfacePlot3D[ExampleData[{"Geometry3D","Horse"},"VertexData"],Lighting->"Neutral",MaxPlotPoints->50,Mesh->False,PlotStyle->{Specularity[White,20],Texture[ExampleData[{"ColorTexture","GiraffeFur"}]]},TextureCoordinateFunction->(Normalize[{#1,#2,#3}]&),Boxed->False,Axes->False]

From the web

A=Import["http://www.georgehart.com/rp/sierpinski5-george-hart.stl"];
B=Import["http://www.georgehart.com/rp/Goldberg-8-3-george-hart.stl"];Show[Graphics3D[{Scale[A[[1]],2],Translate[Scale[B[[1]],0.6],{1,1,3}]}],Boxed->False]

Scanned

If you want an object (or yourself to be scanned and include, see Oliver). Here is an example of a scan

A= Import["http://www.math.harvard.edu/~knill/providence/chimera.stl"]

Show[A]

Making a surface printable

XX={u v,2u,v^2};
NN=Cross[D[XX,u],D[XX,v]];NN=NN/(1+Sqrt[NN.NN]);
eps=0.4;
S1=ParametricPlot3D[XX,{u,-2,2},{v,-2,2},Mesh->False,PlotStyle->Green];
S2=ParametricPlot3D[XX+eps NN,{u,-2,2},{v,-2,2},Mesh->False,PlotStyle->Red];
S3=ParametricPlot3D[XX+eps*s NN/.v->-2,{u,-2,2},{s,0,1},Mesh->False,PlotStyle->Yellow];
S4=ParametricPlot3D[XX+eps*s NN/.v->2,{u,-2,2},{s,0,1},Mesh->False,PlotStyle->Yellow];
S5=ParametricPlot3D[XX+eps*s NN/.u->2,{v,-2,2},{s,0,1},Mesh->False,PlotStyle->Yellow];
S6=ParametricPlot3D[XX+eps*s NN/.u->-2,{v,-2,2},{s,0,1},Mesh->False,PlotStyle->Yellow];
SS=Show[{S1,S2,S3,S4,S5,S6},AspectRatio->1,Boxed->False,PlotRange->All,Axes->False]

An other possibility

XX={u v,2u,v^2};
S1=Graphics3D[Table[{Hue[Abs[v]/2],Tube[Table[XX,{u,-2,2,0.1}]]},{v,-2,2,0.1}]];
S2=Graphics3D[Table[{Hue[Abs[u]/2],Tube[Table[XX,{v,-2,2,0.1}]]},{u,-2,2,0.1}]];
SS=Show[{S1,S2},AspectRatio->1,Boxed->False,PlotRange->All,Axes->False]

The Kissing problem of spheres

s=Table[{0,n,m(Sqrt[5]+1)/2},{n,-1,1,2},{m,-1,1,2}];
s=Partition[Flatten[s],3];s=Append[s,{0,0,0}];
s=Union[s,Map[RotateRight,s],Map[RotateLeft,s]];
S=Graphics3D[Table[{Hue[Random[]],Sphere[s[[k]]]},{k,12}]]

Adding two knots

u=KnotData[{"PretzelKnot",{3,5,2}},"SpaceCurve"];
v=KnotData[{"TorusKnot",{5,11}},"SpaceCurve"];
s=Partition[Table[3u[t]-4v[t],{t,0,2 Pi,2Pi/10000}],100];
S=Graphics3D[Table[{Hue[k/100],Tube[s[[k]],0.6+0.3 Sin[2 Pi k/100]]},{k,100}],AspectRatio->1,Boxed->False,ViewPoint->{2.08924,0.374661,2.63528},ViewVertical->{0.352599,0.875238,1.54747}]

A torus with some decoration

M=130;a=10;n=13;
r[t_]:={(a+2Cos[n t])Cos[t],(a+2Cos[n t])Sin[t],3Sin[n t]};
S1={Red,Table[Sphere[r[t],0.5],{t,0,2Pi-2Pi/M,2Pi/M}]};
S2={Blue,Table[Cylinder[{r[t],r[t+2Pi/M]},0.2],{t,0,2Pi-2Pi/M,2Pi/M}]};
S3=ParametricPlot3D[{(a+2Cos[s])Cos[t],(a+2Cos[s])Sin[t],2Sin[s]},{t,0,2Pi},{s,0,2Pi},Mesh->False,PlotStyle->Yellow];
S=Graphics3D[{S1,S2,S3[[1]]},Boxed->False,AspectRatio->1]

Shierpinsky

s0=Scale[PolyhedronData["Tetrahedron"][[1]],Sqrt[3]];
P0=Sqrt[3] s0[[1,1]];E0=s0[[1,2,1]];
s0=Table[{Polygon[Table[P0[[E0[[k,l]]]],{l,Length[E0[[k]]]}]]},{k,Length[E0]}];
s1={Translate[s0,{0,0,Sqrt[2]}],Table[Translate[s0,{Cos[2 Pi k/3],Sin[2 Pi k/3],0}],{k,3}]};
s2={Translate[s1,{0,0,2 Sqrt[2]}],Table[Translate[s1,2 {Cos[2 Pi k/3],Sin[2 Pi k/3],0}],{k,3}]};
s3={Translate[s2,{0,0,4 Sqrt[2]}],Table[Translate[s2,4 {Cos[2 Pi k/3],Sin[2 Pi k/3],0}],{k,3}]};
s4={Translate[s3,{0,0,8 Sqrt[2]}],Table[Translate[s3,8 {Cos[2 Pi k/3],Sin[2 Pi k/3],0}],{k,3}]};
S=Show[Graphics3D[{Yellow,s4}],Boxed->False,ViewPoint->{-1.04044,-3.21418,0.191031},ViewVertical->{-0.166054,-0.647882,1.14683}]