3-D Printing

Rotating A Bounded Region Around the Y-Axis and "Printing" a Model of that Volume

Presenters:

Esther Rhodes		Matt Ragusa
	        Math Teacher				        Pre-Service Science Teacher	
Georgetown-Ridge Farm H.S.		University of Illinois

Joe Muskin			Adam Poetzel
    	 Nano-CEMMS  	 		 	Clinical Assistant Professor
University of Illinois				University of Illinois

Other Collaborators:
         Bryan Murawski		Igor Antonio		  Brett Champion
  Math Teacher			  Software Technology		    Kernel Developer
           Villa Grove High School	          Wolfram Research Inc.		  Wolfram Research Inc.

Initialization code

$HistoryLength=0;

Plotting Functions

DrawRegionPlot[lowerbound_, upperbound_]:=
RegionPlot[y≥lowerbound&&y≤upperbound,{x,0,10},{y,0,10},BoundaryStyle->Automatic,MaxRecursion->4,Mesh->None]

listRevolve[pts_,divs_,angle_:{0,2π}, gopts___]:=
Module[{nn,points,angles,heights,xbase,ybase,tmin,tmax,tstep,polygons},
nn=divs+1;
{tmin,tmax}=N[angle];
tstep=(tmax-tmin)/divs;
angles=Range[tmin,tmax,tstep];
heights=Table[1.,{nn}];
xbase=Cos[angles];
ybase=Sin[angles];
points=Flatten[Transpose[{#1xbase,#1ybase,#2heights}]&@@@pts,1];
polygons=Flatten[Table[{ii,ii+1,ii+nn+1,ii+nn}+jj nn,{jj,0,Length[pts]-1},{ii,nn-1}],1];
polygons=Mod[polygons,nn*Length[pts],1];
Graphics3D[GraphicsComplex[points,{EdgeForm[],Polygon[polygons]}], gopts]
]

DrawRevolutionPlot3D[lineplot_, gropts___]:=
If[lineplot =!= {},
listRevolve[First@lineplot, 30, {0,2Pi}, gropts],
Graphics3D[{}, gropts]
]

CalculateCountourLine[regionplot_Graphics]:=
If[MemberQ[regionplot, _Line, Infinity],
First@Cases[Normal[regionplot],_Line,Infinity],
{}
]

DrawMergedPlots[lowerbound_,upperbound_,line_, opts___]:=
Show[
RegionPlot[y≥lowerbound&&y≤upperbound,{x,0,10},{y,0,10},BoundaryStyle->Automatic,MaxRecursion->4],
Plot[{lowerbound,upperbound,line},{x,-10,10},PlotRange->{0,10},PlotStyle->{Red,Blue,Purple,Thick}, PlotLabel->{lowerbound, upperbound}]
,
opts
]

DrawSlicePlot[lowerbound_, upperbound_,line_, opts___]:=
Module[{j, k, l, m, n, o, p, q, qq, joinqs, qqq, r},
j=Flatten[x/.NSolve[lowerbound==line,x,WorkingPrecision->50]/.x->{}]//Quiet;
k=Flatten[x/.NSolve[upperbound==line,x,WorkingPrecision->50]/.x->{}]//Quiet;
l=Join[j,k];
m=Select[Cases[l,_Real],10≥ #>=0&];
n=Length[m];
o=Sort[Table[{m[[y]],line},{y,1,n}]];
p=If[o[[-1]]=!={10.,line}∨o=={},Insert[o,{10.,line},n+1],o]//Quiet;
q=Select[p,(Chop[Last[#]]≥Chop[lowerbound/.x->First[#]])&];
qq=Select[p,(Chop[Last[#]]≤ Chop[upperbound/.x->First[#]])&];
joinqs=Sort[Map[Drop[#,-1]&,Join[q,qq]]];
qqq=Flatten[Map[Drop[#,-Length[#]/2]&,DeleteCases[Split[joinqs],{something_}]]];
If[qqq=!={},
r=Length[qqq];
Show[
Table[Plot[{(Sqrt[qqq[[- s]]^2+.000001-x^2]),-(Sqrt[qqq[[- s]]^2+.000001-x^2])},{x,-10,10},PlotStyle->If[OddQ[s],White,Black],Filling->Axis,FillingStyle->If[OddQ[s],White,Black],PlotRange->{{-10,10},{-10,10}},AspectRatio->Automatic,Axes->False],{s,1,r}], 
Background->Black,opts],
(* else *)
$Failed
]
]

Examples of plotting function usage
These examples don't interfere with anything

EQN1=((x-3)^2(x-6)^2);
EQN2=((x-4.5)^2+6);
LINE = 5;

DrawRevolutionPlot3D[CalculateCountourLine[DrawRegionPlot[EQN1, EQN2]],Axes->True, AxesLabel->{"x","y","z"}]

DrawMergedPlots[EQN1, EQN2, LINE]

DrawSlicePlot[EQN1, EQN2, LINE]

Clear[EQN1, EQN2, LINE]

Slideshow generating functions

GenerateSlices[lowerbound_, upperbound_]:=
Table[DrawSlicePlot[lowerbound, upperbound, i],{i, 0., 10.,.1}]

GenerateNotebook[toolbar_, calibrateslide_, blankslide_,slides_]:=
Module[{nbexpr},
nbexpr = Notebook[
Join[
(***** FIRST SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["Revolution of two functions over the y-axis"],"Title", FontSize->45,FontColor->Red],
Cell[TextData["XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\nSlideshowCreatedByXXXXXXXXXXXXXXXXXXXXXXXXXXWolfram/Nano-CEMMSpartnershipXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Use the page up and page down buttons to advance through the presentation.  Please review the presentation before printing to make sure it is correct.  See if there are any slides you need to flash or if you need to stop the presentation early.  You can make notes on the black slides by converting the cell to text display and making the font red. XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"],"Text",FontColor->Red]},

(***** CALIBRATING SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["   "], "Title",FontSize->15],
Cell[BoxData[ToBoxes[calibrateslide]],"Output"]},

(***** BLANK SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[BoxData[ToBoxes[blankslide]],"Output"]},

(***** SLICES SLIDES *****)
Sequence@@@
Map[{
Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["   "], "Title"],
Cell[BoxData[ToBoxes[#]],"Output"],
Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData[""],"Text"]
}&,slides],

(***** LAST SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["LAST SLIDE"], "Title"],
Cell[TextData["The slide show is done.  Do not exit out of the slideshow until the beaker is blocked from the light."],FontSize->20,FontColor->Red]}


] (* end of join *)
,

(***** NOTEBOOK OPTIONS *****)

WindowFrame->Frameless,
WindowSize->Full,
ScreenStyleEnvironment->"SlideShow",
Background->Black,
WindowElements->{},
ShowCellBracket->False,

(* Inserts SlideShow toolbar at the top of every slide *)
DockedCells->toolbar,

(* Styles for notebook cells *)
StyleDefinitions->Notebook[{
Cell[StyleData[StyleDefinitions->"Default.nb"]],

Cell[StyleData["Title", "SlideShow"],
FontColor->textfontcolor,
TextAlignment->Center,
FontSize->30],

Cell[StyleData["Output", "SlideShow"],
TextAlignment->Center],


Cell[StyleData["Text", "SlideShow"],
FontColor->textfontcolor,
FontSize->20],

Cell[StyleData["DockedCell","SlideShow"],
Background->Red,
FontColor->textfontcolor,
CellFrame->False,
CellFrameMargins->5]
},StyleDefinitions->"PrivateStylesheetFormatting.nb"]
];
nbexpr
]

Slideshow variables

Colors

toolbarbackgroundcolor = Red;
textfontcolor = RGBColor[0.816464, 0.11751, 0.104494];
notebookbackgroundcolor = RGBColor[0,0,0];

Calibrating slide

calibrateslide =Plot[{Sqrt[100-x^2], -Sqrt[100-x^2]}, {x,-10,10}, 
PlotStyle->Red,
Filling->Axis,
FillingStyle->Red,
AspectRatio->1,
Axes->False,
ImageSize->450];

Blank Slide

blankslide =Plot[{Sqrt[100-x^2], -Sqrt[100-x^2]}, {x,-10,10}, 
PlotStyle->Black,
Filling->Axis,
FillingStyle->Black,
AspectRatio->1,
Axes->False,
ImageSize->450];

Toolbar

toolbar =Cell[BoxData[GridBox[{{

TooltipBox[ButtonBox[
StyleBox["Double Click to Escape",FontSize->10], ButtonFunction :> (FEPrivate`NotebookToggleFullScreen[]; {}),Alignment -> Center], DynamicBox[FEPrivate`FrontEndResource["SlideshowToolbarText","TooltipToggleFullScreen"]]],

RowBox[{DynamicBox[ToBoxes[CurrentValue[{"CounterValue","SlideShowNavigationBar"}],StandardForm]],"",DynamicBox[FEPrivate`FrontEndResource["SlideshowToolbarText","SlideshowToolbarCounterText"]],"",DynamicBox[ToBoxes[CurrentValue[{"MaxCounterValue","SlideShowNavigationBar"}],StandardForm]]}]

}},
GridBoxAlignment->{"Columns"->{Left, Center, Right}},
GridBoxItemSize->{"Columns"->{{Scaled[.33]}}},
ColumnsEqual->False,
RowsEqual->False

]],"DockedCell",

(* Options for SlideShow toolbar buttons *)
ButtonBoxOptions->{
Background->toolbarbackgroundcolor,
ButtonFrame->None,
Alignment->Bottom,
ImageSize->Large,
Evaluator->None,
ButtonFunction:>(FEPrivate`FrontEndExecute[FrontEnd`FrontEndToken[FrontEnd`ButtonNotebook[],#1]]&)}];

Panel interface

Panel@DynamicModule[
{(*ADAM: initial values for the equations go here *)
mylowerbound=((x-3)^2(x-6)^2),
myupperbound=((x-4.5)^2+6),
myline=2},

Grid[{

{Style["Rotating A Bounded Region Around The Y-Axis", FontSize->20], SpanFromLeft, SpanFromLeft},

{"Lower bound Eqn", "Upper bound Eqn", "Slicer"},

{InputField[Dynamic[mylowerbound]], InputField[Dynamic[myupperbound]], Row[{Slider[Dynamic[myline], {0,10,.5}]," ","y=", Dynamic[myline]}]},

{"","",""},

{Dynamic[DrawRevolutionPlot3D[CalculateCountourLine[DrawRegionPlot[mylowerbound, myupperbound]]], TrackedSymbols:> {mylowerbound, myupperbound}],
Dynamic[DrawMergedPlots[mylowerbound, myupperbound, myline], TrackedSymbols:> {myline}],
Dynamic[DrawSlicePlot[mylowerbound, myupperbound, myline], TrackedSymbols:> {mylowerbound, myupperbound, myline}]
}
,
{Button["Generate SlideShow! (This may take up to a minute)",NotebookPut@GenerateNotebook[toolbar, calibrateslide, blankslide,GenerateSlices[mylowerbound, myupperbound]], Method->"Queued"], SpanFromLeft, SpanFromLeft}

},
Spacings->{2,2}
]
]

Initialization code

$HistoryLength=0;

Plotting Functions

DrawRegionPlot[lowerbound_, upperbound_]:=
RegionPlot[y≥lowerbound&&y≤upperbound,{x,0,10},{y,0,10},BoundaryStyle->Automatic,MaxRecursion->4,Mesh->None]

listRevolve[pts_,divs_,angle_:{0,2π}, gopts___]:=
Module[{nn,points,angles,heights,xbase,ybase,tmin,tmax,tstep,polygons},
nn=divs+1;
{tmin,tmax}=N[angle];
tstep=(tmax-tmin)/divs;
angles=Range[tmin,tmax,tstep];
heights=Table[1.,{nn}];
xbase=Cos[angles];
ybase=Sin[angles];
points=Flatten[Transpose[{#1xbase,#1ybase,#2heights}]&@@@pts,1];
polygons=Flatten[Table[{ii,ii+1,ii+nn+1,ii+nn}+jj nn,{jj,0,Length[pts]-1},{ii,nn-1}],1];
polygons=Mod[polygons,nn*Length[pts],1];
Graphics3D[GraphicsComplex[points,{EdgeForm[],Polygon[polygons]}], gopts]
]

DrawRevolutionPlot3D[lineplot_, gropts___]:=
If[lineplot =!= {},
listRevolve[First@lineplot, 30, {0,2Pi}, gropts],
Graphics3D[{}, gropts]
]

CalculateCountourLine[regionplot_Graphics]:=
If[MemberQ[regionplot, _Line, Infinity],
First@Cases[Normal[regionplot],_Line,Infinity],
{}
]

DrawMergedPlots[lowerbound_,upperbound_,line_, opts___]:=
Show[
RegionPlot[y≥lowerbound&&y≤upperbound,{x,0,10},{y,0,10},BoundaryStyle->Automatic,MaxRecursion->4],
Plot[{lowerbound,upperbound,line},{x,-10,10},PlotRange->{0,10},PlotStyle->{Red,Blue,Purple,Thick}, PlotLabel->{lowerbound, upperbound}]
,
opts
]

DrawSlicePlot[lowerbound_, upperbound_,line_, opts___]:=
Module[{j, k, l, m, n, o, p, q, qq, joinqs, qqq, r},
j=Flatten[x/.NSolve[lowerbound==line,x,WorkingPrecision->50]/.x->{}]//Quiet;
k=Flatten[x/.NSolve[upperbound==line,x,WorkingPrecision->50]/.x->{}]//Quiet;
l=Join[j,k];
m=Select[Cases[l,_Real],10≥ #>=0&];
n=Length[m];
o=Sort[Table[{m[[y]],line},{y,1,n}]];
p=If[o[[-1]]=!={10.,line}∨o=={},Insert[o,{10.,line},n+1],o]//Quiet;
q=Select[p,(Chop[Last[#]]≥Chop[lowerbound/.x->First[#]])&];
qq=Select[p,(Chop[Last[#]]≤ Chop[upperbound/.x->First[#]])&];
joinqs=Sort[Map[Drop[#,-1]&,Join[q,qq]]];
qqq=Flatten[Map[Drop[#,-Length[#]/2]&,DeleteCases[Split[joinqs],{something_}]]];
If[qqq=!={},
r=Length[qqq];
Show[
Table[Plot[{(Sqrt[qqq[[- s]]^2+.000001-x^2]),-(Sqrt[qqq[[- s]]^2+.000001-x^2])},{x,-10,10},PlotStyle->If[OddQ[s],White,Black],Filling->Axis,FillingStyle->If[OddQ[s],White,Black],PlotRange->{{-10,10},{-10,10}},AspectRatio->Automatic,Axes->False],{s,1,r}], 
Background->Black,opts],
(* else *)
$Failed
]
]

Examples of plotting function usage
These examples don't interfere with anything

EQN1=((x-3)^2(x-6)^2);
EQN2=((x-4.5)^2+6);
LINE = 5;

DrawRevolutionPlot3D[CalculateCountourLine[DrawRegionPlot[EQN1, EQN2]],Axes->True, AxesLabel->{"x","y","z"}]

DrawMergedPlots[EQN1, EQN2, LINE]

DrawSlicePlot[EQN1, EQN2, LINE]

Clear[EQN1, EQN2, LINE]

Slideshow generating functions

GenerateSlices[lowerbound_, upperbound_]:=
Table[DrawSlicePlot[lowerbound, upperbound, i],{i, 0., 10.,.1}]

GenerateNotebook[toolbar_, calibrateslide_, blankslide_,slides_]:=
Module[{nbexpr},
nbexpr = Notebook[
Join[
(***** FIRST SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["Revolution of two functions over the y-axis"],"Title", FontSize->45,FontColor->Red],
Cell[TextData["XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX\nSlideshowCreatedByXXXXXXXXXXXXXXXXXXXXXXXXXXWolfram/Nano-CEMMSpartnershipXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX Use the page up and page down buttons to advance through the presentation.  Please review the presentation before printing to make sure it is correct.  See if there are any slides you need to flash or if you need to stop the presentation early.  You can make notes on the black slides by converting the cell to text display and making the font red. XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"],"Text",FontColor->Red]},

(***** CALIBRATING SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["   "], "Title",FontSize->15],
Cell[BoxData[ToBoxes[calibrateslide]],"Output"]},

(***** BLANK SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[BoxData[ToBoxes[blankslide]],"Output"]},

(***** SLICES SLIDES *****)
Sequence@@@
Map[{
Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["   "], "Title"],
Cell[BoxData[ToBoxes[#]],"Output"],
Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData[""],"Text"]
}&,slides],

(***** LAST SLIDE *****)
{Cell["","SlideShowNavigationBar",CellTags->"SlideShowHeader"],
Cell[TextData["LAST SLIDE"], "Title"],
Cell[TextData["The slide show is done.  Do not exit out of the slideshow until the beaker is blocked from the light."],FontSize->20,FontColor->Red]}


] (* end of join *)
,

(***** NOTEBOOK OPTIONS *****)

WindowFrame->Frameless,
WindowSize->Full,
ScreenStyleEnvironment->"SlideShow",
Background->Black,
WindowElements->{},
ShowCellBracket->False,

(* Inserts SlideShow toolbar at the top of every slide *)
DockedCells->toolbar,

(* Styles for notebook cells *)
StyleDefinitions->Notebook[{
Cell[StyleData[StyleDefinitions->"Default.nb"]],

Cell[StyleData["Title", "SlideShow"],
FontColor->textfontcolor,
TextAlignment->Center,
FontSize->30],

Cell[StyleData["Output", "SlideShow"],
TextAlignment->Center],


Cell[StyleData["Text", "SlideShow"],
FontColor->textfontcolor,
FontSize->20],

Cell[StyleData["DockedCell","SlideShow"],
Background->Red,
FontColor->textfontcolor,
CellFrame->False,
CellFrameMargins->5]
},StyleDefinitions->"PrivateStylesheetFormatting.nb"]
];
nbexpr
]

Slideshow variables

Colors

toolbarbackgroundcolor = Red;
textfontcolor = RGBColor[0.816464, 0.11751, 0.104494];
notebookbackgroundcolor = RGBColor[0,0,0];

Calibrating slide

calibrateslide =Plot[{Sqrt[100-x^2], -Sqrt[100-x^2]}, {x,-10,10}, 
PlotStyle->Red,
Filling->Axis,
FillingStyle->Red,
AspectRatio->1,
Axes->False,
ImageSize->450];

Blank Slide

blankslide =Plot[{Sqrt[100-x^2], -Sqrt[100-x^2]}, {x,-10,10}, 
PlotStyle->Black,
Filling->Axis,
FillingStyle->Black,
AspectRatio->1,
Axes->False,
ImageSize->450];

Toolbar

toolbar =Cell[BoxData[GridBox[{{

TooltipBox[ButtonBox[
StyleBox["Double Click to Escape",FontSize->10], ButtonFunction :> (FEPrivate`NotebookToggleFullScreen[]; {}),Alignment -> Center], DynamicBox[FEPrivate`FrontEndResource["SlideshowToolbarText","TooltipToggleFullScreen"]]],

RowBox[{DynamicBox[ToBoxes[CurrentValue[{"CounterValue","SlideShowNavigationBar"}],StandardForm]],"",DynamicBox[FEPrivate`FrontEndResource["SlideshowToolbarText","SlideshowToolbarCounterText"]],"",DynamicBox[ToBoxes[CurrentValue[{"MaxCounterValue","SlideShowNavigationBar"}],StandardForm]]}]

}},
GridBoxAlignment->{"Columns"->{Left, Center, Right}},
GridBoxItemSize->{"Columns"->{{Scaled[.33]}}},
ColumnsEqual->False,
RowsEqual->False

]],"DockedCell",

(* Options for SlideShow toolbar buttons *)
ButtonBoxOptions->{
Background->toolbarbackgroundcolor,
ButtonFrame->None,
Alignment->Bottom,
ImageSize->Large,
Evaluator->None,
ButtonFunction:>(FEPrivate`FrontEndExecute[FrontEnd`FrontEndToken[FrontEnd`ButtonNotebook[],#1]]&)}];

Panel interface

Panel@DynamicModule[
{(*ADAM: initial values for the equations go here *)
mylowerbound=((x-3)^2(x-6)^2),
myupperbound=((x-4.5)^2+6),
myline=2},

Grid[{

{Style["Rotating A Bounded Region Around The Y-Axis", FontSize->20], SpanFromLeft, SpanFromLeft},

{"Lower bound Eqn", "Upper bound Eqn", "Slicer"},

{InputField[Dynamic[mylowerbound]], InputField[Dynamic[myupperbound]], Row[{Slider[Dynamic[myline], {0,10,.5}]," ","y=", Dynamic[myline]}]},

{"","",""},

{Dynamic[DrawRevolutionPlot3D[CalculateCountourLine[DrawRegionPlot[mylowerbound, myupperbound]]], TrackedSymbols:> {mylowerbound, myupperbound}],
Dynamic[DrawMergedPlots[mylowerbound, myupperbound, myline], TrackedSymbols:> {myline}],
Dynamic[DrawSlicePlot[mylowerbound, myupperbound, myline], TrackedSymbols:> {mylowerbound, myupperbound, myline}]
}
,
{Button["Generate SlideShow! (This may take up to a minute)",NotebookPut@GenerateNotebook[toolbar, calibrateslide, blankslide,GenerateSlices[mylowerbound, myupperbound]], Method->"Queued"], SpanFromLeft, SpanFromLeft}

},
Spacings->{2,2}
]
]

Questions?

For More Information About Nano-CEMMS or the 3-D Printing Process

Contact Joe Muskin
jmuskin@illinois.edu