Multivariable Calculus Computer Algebra Project 2016

Math  21a,Fall 2016

In this Mathematica 11 project (use 11.0.1.0 if possible), we try to be creative.  I will  provide you with some examples. The actual problems at the very end. The project is due on Saturday December 3th (23:59:59 midnight) electronically by email. There is a Mathematica workshop on Wednesday, November 16, 2016, from 5:30-6:30 PM in Hall A. 

Content in a Mathematica  file is organized as cells. To evaluate a cell, grab the bracket to the right, holding down the shift key and hit return.

General  objects

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->White];
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->{Thickness[0.1],Red}];
S4=ParametricPlot3D[{x,Cos[x*y],y},{x,-2,2},{y,-2,2},
Mesh->False,PlotStyle->{Thickness[0.1],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}]

Here is an example using basic graphics objects called “Kung-Fu”

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]],Boxed->False,ViewPoint->{0.51,3.30,0.494}]

And here, we use some polyhedra to build a scary face candy:

A1={Yellow,Translate[Scale[PolyhedronData["Icosahedron","Faces"],0.4],{2,1,1.8}]};
A2={Green,Translate[Scale[PolyhedronData["Dodecahedron","Faces"],0.3],{1,2,1.8}]};
A3={Orange,Sphere[{0,0,1},2.3]};
A4={Blue,Cone[{{1.3,1.5,.5},{1,1,1}}]};
S=Show[Graphics3D[{A1,A2,A3,A4}],Boxed->False,ViewPoint->{0.5278978285483763`,3.2368363852086115`,0.8331951140060536`},ViewVertical->{0.01520449713987866`,0.37705565858746815`,0.9447318888167381`}]

Polytopes

S1={Yellow,Opacity[0.4],PolyhedronData["Dodecahedron","Faces"]};
S2={Green,Opacity[0.4],PolyhedronData["Icosahedron","Faces"]};
S3={Blue,Opacity[0.4],PolyhedronData["Octahedron","Faces"]};
S4={Orange,Opacity[0.4],PolyhedronData["Tetrahedron","Faces"]};
S5={Pink,Opacity[0.4],PolyhedronData["Hexahedron","Faces"]};
HarmonicesMundi=Graphics3D[{S1,S2,S3,S4,S5},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]

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[Yellow,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]

Making a surface printable

S1=ParametricPlot3D[{u v,2u,v^2},{u,-2,2},{v,-2,2},PlotStyle->{Thickness[0.2],Orange},Mesh->False,Boxed->False,Axes->False]

A printable Mesh

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]

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]

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

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]

Sierpinski pyramid

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

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]

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]

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

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]

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,ViewPoint->{0.16892023495048958`,3.155836044400346`,-1.209200072398217`},ViewVertical->{-0.06887844009643537`,0.2939207902815811`,-0.9617649676093725`}]

Area  computation

Area[ImplicitRegion[ x^2+y^2<1,{x,y}]]

Volume  computation

Note that the following might be different in Mathematica 10 (as well as in Mathematica documentation, where DiscretizeRegion is not used). In Mathematica 11, the folllwing works:

R=ImplicitRegion[x^4+y^2+z^2/3<1,{x,y,z}];
Volume[DiscretizeRegion[R]]

V=PolyhedronData["Octahedron"];
W=ConvexHullMesh[V[[1,1]]];
Integrate[1,{x,y,z} ∈W]

Center of Mass of the Bunny

u=ExampleData[{"Geometry3D","StanfordBunny"}];
s=DiscretizeGraphics[u];
NIntegrate[{x,y,z},{x,y,z}∈ s]

Moment of Inertia

V=PolyhedronData["Octahedron"];
W=ConvexHullMesh[V[[1,1]]];
NIntegrate[x^2+y^2,{x,y,z} ∈W]

Assignment

Be creative. If you use inspiration beyond these templates, give credit. Use the above templates to do the following: 

1) (1 points) Find the volume of the region x^8+y^8+z^6<1.
2) (1 point)  Integrate the function  Exp[-x^2-y^2-z^2]  over the Icosahedron.
3) (1 point)   A region plot of a new solid of your choice  (math candy!) 
4) (1 point)  A new parametrized surface of your choice, make it printable. 
5) (1 point)  A new knot of your choice.
6) (5 points) An object of your choice using various parts using Graphics3D

The objects in 3-6 have to be original. In 6) be creative. Experiment to make it look good. The best objects will be selected for an exhibit. 
Submit your notebook after removing all the graphics in the above menu Cell -> Delete All Output. If you should use additional resources like textures 
or scanned objects, send them too or provide a link to a download page.

Oliver Knill, November 13 , 2016, email: knill@math.harvard.edu