Code for Electronic Supplement

FactorForm Code

FactorForm::"usage"="FactorForm[f] puts the list f, which should be a list of the form returned by FactorInteger, into traditional mathematical notation.";

Ifix[s_String]:=StringReplace[s,"I"->"I"];

FactorForm[l_]:=SequenceForm@@(DisplayForm[RowBox[{#," "}]]&)/@
   MapThread[If[#2==1,If[Head[#1]===Complex,Ifix[StringJoin["(",ToString[#1],")"]],ToString[#1]],If[Re[#1]≠0&&Im[#1]≠0,SuperscriptBox[StringJoin["(",Ifix[ToString[#1]],")"],#2],SuperscriptBox[Ifix[ToString[#1]],#2]]]&,Transpose[l]]

Dynamic Manipulations

Code for Chapter Opening Art

.  Basic Manipulations

Manipulate[Factor[(x^n)-1],{n,1,100,1}]

Manipulate[Factor[(x^n)-1],{{n,10},1,100,1}]

Manipulate[Factor[(x^n)-1],{{n,10,"degree of (x^n) - 1"},1,100,1, Appearance->"Open"}]

Manipulate[StringForm["(x^(``)) - 1 = ``",n,Factor[(x^n)-1]],{{n,15,"degree"},1,100,1,Appearance->"Labeled"}]

Manipulate[Plot[Evaluate[{(b^x),D[(b^x),x]}],{x,-2,2},PlotStyle->{{GrayLevel[0.8],Thickness[0.025]},{Black,Thick}},PlotRange->{{-2,2},{0,4}}],{{b,2},1,10,Appearance->"Labeled"}]

Manipulate[GraphicsRow[
{Plot[Evaluate[{(b^x),D[(b^x),x]}],{x,-2,2},PlotStyle->{{Green,Thickness[0.04]},Thick},PlotRange->{{-2,2},{0,4}}],
LogPlot[Evaluate[Abs[(b^x)-D[(b^x),x]]],{x,-2,2},Frame->True,Axes->False,PlotStyle->Thick,FrameTicks->{Automatic,Automatic,None, None},PlotRange->{(10^(-7)),2}]}],{b,2,4,Appearance->"Labeled"}]

.  Control Variations

Manipulate[a=ToString[Expand[Sum[(i^p), {i,0,n}]], StandardForm];
Pane[Style[If[eqnQ,StringForm[ "(Underoverscript[Σ, (i=0), n]) (i^(``)) = ``",p /. 1->"",a],a], FontFamily->"Times",12],{370,50},
Alignment->{Automatic, Center}], {{eqnQ, True, "show equality"}, {True, False}}, {{p,6,"power"},1,12,1}]

Manipulate[a=ToString[Expand[Sum[(i^power), {i,0,n}]], StandardForm];
Pane[Style[If[eqnQ,StringForm[ "(Underoverscript[Σ, (i=0), n]) (i^(``))  =  ``",power /. 1->"",a],a], FontFamily->"Times",12],{370,35},
Alignment->{Automatic, Center}], {{eqnQ, True, "show equality"}, {True, False}, Setter}, {{power,6},Range[12],Setter}]

sinPlot=Plot[(x^2) Sin[(1/x)],{x,-1,1},PlotPoints->500,MaxRecursion->4,PlotRange->All, Frame->True, Axes->False, PlotStyle->Thick];
Manipulate[Show[sinPlot,FrameTicks->{{0,{ xmax/2,NumberForm[xmax/2.,{4,3}]},{-xmax/2,NumberForm[-xmax/2.,{4,3}]}}, {0,{ymax,NumberForm[ymax,{4,3}]},{-ymax,NumberForm[-ymax,{4,3}]}}, None, None},PlotRange->{{-xmax,xmax},{-ymax,ymax}}],{{xmax,1},0.01,1},{{ymax,0.1},0.001,1,VerticalSlider,ControlPlacement->Left}]

Manipulate[Show[sinPlot,
FrameTicks->{{0,{ xmax/2,NumberForm[xmax/2.,{4,3}]},{-xmax/2,NumberForm[-xmax/2.,{4,3}]}}, {0,{ ymax,NumberForm[ymax,{4,3}]},{-ymax,NumberForm[-ymax,{4,3}]}}, None, None},PlotRange->{{-xmax,xmax},{-ymax,ymax}}],{{xmax,1},0.01,1,None},{{ymax,0.1},0.001,1,None},
Row[{"xMax",Manipulator[Dynamic[xmax],{0.01,1},Appearance->"Labeled",ImageSize->Small],
Spacer[20],"yMax",Manipulator[Dynamic[ymax],{0.001,1},Appearance->"Labeled",ImageSize->Small]}]]

Manipulate[∫f\[DifferentialD]x,{f,Sin[x] Tan[x]}]

.  Locators

Manipulate[Graphics[{EdgeForm[Thick],FaceForm[GrayLevel[0.4]],Polygon[{p,q,r,s}],FaceForm[GrayLevel[0.8]],Polygon[Mean/@Partition[{p,q,r,s,p},2,1]]},PlotRange->1.2],{{p,{0,1}},Locator},{{q,{1,1}},Locator},{{r,{1,0.5}},Locator},{{s,{-1,-0.7}},Locator}]

Manipulate[Graphics[{EdgeForm[Thick],FaceForm[GrayLevel[0.2]],Polygon[p],FaceForm[GrayLevel[0.8]],Polygon[Mean/@Partition[Append[p,p[[1]]],2,1]]},PlotRange->1.2],{{p,{{0,1},{1,1},{1,0.5},{-1,-0.7}}},Locator}]

pCos=Plot[Cos[x],{x,-3π,12 π}, Frame->True, Axes->False,PlotRange-> 1.2,FrameTicks->{Range[-2π, 12π, 2π],{-1,0,1},None, None},PlotStyle->Thick,PlotLabel->"y-coordinate: Cosine",AspectRatio->1/3];
pSin=Plot[Sin[x],{x,-3π,12 π}, Frame->True, Axes->False,PlotRange-> 1.2, FrameTicks->{Range[-2π, 12π, 2π],{-1,0,1},None, None},AspectRatio->1/3,PlotStyle->Thick,PlotLabel->"x-coordinate: Sine"];
Module[{tnew=.01,told=0.01,count1=0, count2,q},
Manipulate[q=Normalize[p];
Grid[{{
Graphics[{Thick,Circle[],
{Locator[q], Line[{q/6, q}]}, Text[Style[count1,30],{0,0}]}, PlotRange->1.1],
Grid[{{Show[pCos,
Graphics[{PointSize[Large],Red,tnew=ArcTan@@q;
If[0<tnew<π/2&&-π/2<told<0, count1++];
If[0<told<π/2&&-π/2<tnew<0, count1--];
count2 =count1+If[Mod[tnew, 2π]<π,  0,1];
told=tnew;
Point[{tnew+count2 2π, Cos[tnew]}]}]]},
{Show[pSin,Graphics[{PointSize[Large],Red,
Point[{tnew+count2 2π, Sin[tnew]}]}]]}}]}}],{{p,{Cos[0.01],Sin[0.01]}},Locator,Appearance->None}, Paneled->False, AppearanceElements->None]]

n=3;
r=Range[0,n-1];
Binomial[n-1,r] (t^r) (((1-t))^(n-1-r))

Bezier[pts_]:=With[{n=Length[pts],r=Range[0,Length[pts]-1]},(Binomial[n-1,r] (t^r) (((1-t))^(n-1-r))) . pts]
bezCurve[pts_,opts___Rule]:=ParametricPlot[Bezier[pts],{t,0,1},opts, PlotStyle->Thick,Frame->True,FrameTicks->False,Axes->False];

Manipulate[bezCurve[pts, PlotRange->2],{{pts,{ {-1,-1},{1,1}, {-0.2, 1.2}} }, Locator, LocatorAutoCreate->True}, Paneled->False, AppearanceElements->None]

Manipulate[Graphics[{Thick,BezierCurve[pts,SplineDegree->100]},PlotRange->2,Frame->True,FrameTicks->False,Axes->False],{{pts,{{-1,-1},{1,1},{-0.2,1.2}}},Locator,LocatorAutoCreate->True},Paneled->False,AppearanceElements->None]

Manipulate[Show[bezCurve[pts, PlotRange->2],Graphics[{Blue, PointSize[.08], Point[pts], Yellow, MapIndexed[Text[Style[#2[[1]],16], #]&, pts]}]], 
{{pts, {{-1,-1},{1,-1},{1.3,1},{-1.3,1}} }, Locator, Appearance->None,LocatorAutoCreate->True}, AppearanceElements->None, Paneled->False]

.  Fine Control

Options

Manipulate[Row[{n,If[PrimeQ[n],Pause[6]; " is prime"," is not prime" ]}], {n, 2,17,1}]

Manipulate[If[PrimeQ[n],Pause[6];"Prime","Not prime"],{n,2,17,1},SynchronousUpdating->False]

a=10;
Manipulate[n+a,{n,1,100,1}]

a=20;

b=100;
Manipulate[n+b,{n,1,100,1},TrackedSymbols:>{n}]

z=5; (* a normal cell *)

z

ManipulateLocal[z__]:=CellPrint[ExpressionCell[Manipulate[z],"Output",CellContext->Cell]];
Attributes[ManipulateLocal]=HoldAll;

Pane

Manipulate[Pane[FactorForm[FactorInteger[n!]],BaseStyle->{FontFamily->"Times",10},Alignment->{Left,Bottom},ImageSize->{370,14}],{{n,100},2,100,1}]

Dynamic

F[x_,y_]:=((x^2)+3 (y^2)) (E^(1-(x^2)-(y^2)));
Manipulate[Plot3D[F[x,y],{x,-2,2},{y,-2.5,2.5},MeshFunctions->(#3&),Ticks->None,BoxRatios->Automatic,SphericalRegion->True,
ViewPoint -> Dynamic[r{ Cos[θ], Sin[θ],z}],PlotLabel->Dynamic[StringForm["ViewPoint = ``",NumberForm[Chop[{r Cos[θ],r Sin[θ],z}],3]]]],
{θ,0,2π},{{r,2.5},-2,6},{{z,0.6},-1,4}]

im=Plot3D[F[x,y],{x,-2,2},{y,-2.5,2.5},MeshFunctions->(#3&),Ticks->None, BoxRatios->Automatic];
Manipulate[Show[im,SphericalRegion->True,ViewPoint->Dynamic[vp]],{{vp,{1,-2,2}},ControlType->InputField}]

ColorData["Gradients" ]

Manipulate[ContourPlot[F[x,y],{x,-2,2},{y,-2.5,2.5},PlotPoints->100,PlotLabel->Dynamic[ColorData["Gradients"][[i]]],ColorFunction->(Dynamic[ColorData[ColorData["Gradients"][[i]]]])],{{i,49},1,Length[ColorData["Gradients"]],1}]

.  Three Case Studies

A Virtual Planimeter

FElbow[{x_,y_}][L_]:=(1/L)((1/2){y,-x}+{x,y} (Sqrt[  ((L^2)/((x^2)+(y^2)))-(1/4)]));
(∂_x)FElbow[{x,y}][L][[2]]-(∂_y)FElbow[{x,y}][L][[1]]//Simplify

Clear[θ];L=1.3;
FElbow[{x_,y_}][L_]:=((1/2){y,-x}+{x,y} (Sqrt[  ((L^2)/((x^2)+(y^2)))-(1/4)]));
F[{x_,y_}][L_]:=({-y,x}+FElbow[{x,y}][L])/L;
pathCircle[θ_]:=0.6 {Cos[θ],Sin[θ]}+{1,1};
pathBlob[θ_]:=pathCircle[θ]+{(0.2+ Cos[θ Sin[θ]]/3) -0.5,0.1 Cos[θ] (1+ Cos[θ]/2)}-{1/30,3/20};
pathSquare[θ_]:=With[{t=θ/(2 π)},Which[0≤t≤(1/8),{1.6,1+8t 0.6},
(1/8)<t≤(3/8),{1.6-4(t-(1/8)) 1.2,1.6},(3/8)<t≤(5/8),{0.4,1.6-4(t-(3/8))1.2},
(5/8)<t≤(7/8),{0.4+4(t-(5/8))1.2,0.4},(7/8)<t≤1,{1.6,0.4+8(t-(7/8))0.6}]];
pathCircleDer[θ_] := Evaluate[D[pathCircle[θ],θ]];
pathBlobDer[θ_] := Evaluate[D[pathBlob[θ],θ]];
pathSquareDer[θ_] := (1/(2π))With[{t=θ/(2 π)},Which[
0≤t≤(1/8)||(7/8)<t≤1,{0,4.8},(1/8)<t≤(3/8),{-4.8,0},(3/8)<t≤(5/8),{0, -4.8},(5/8)<t≤(7/8),{4.8,0}]];
distFuncCircle= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathCircle[θ]][L] . pathCircleDer[θ]},d[θ],{θ,0,2π}]];
distFuncBlob= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathBlob[θ]][L] . pathBlobDer[θ]},d[θ],{θ,0,2π}]];
distFuncSquare= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathSquare[θ]][L] . pathSquareDer[θ]},d[θ],{θ,0,2π}]];

Manipulate[nspokes=4; rad=0.2;circumference=2π rad;
spokecolor=Black;needleColor=startPostColor=Red;wheelColor1=Lighter@Orange;
wheelColor2=Cyan;areaColor=Nest[Lighter,Yellow,1];tableColor=Nest[Lighter,Blue,4];
tpath=tpath1 2π;
pathFcn = region/. {"circle" -> pathCircle, "blob"->pathBlob, "square"->pathSquare};
pder[tt_] := Evaluate[D[pathFcn[tt],tt]];
distExpr= region /.{"circle" -> distFuncCircle,"blob"->distFuncBlob,  "square"->distFuncSquare};
p=pathFcn[tpath];
distance = distExpr/. θ-> tpath;
p3D=Append[p,0];
p3Dup=p3D+{0,0,0.2};
 q=Append[0.1 ({-1,1}Reverse[(p-{a,b})]),0]; 
{a,b} = Reverse[FElbow[p][L]]{-1,1};
elbow={a,b,0.2};cen=0.03elbow+0.97 p3Dup;
region2D = ParametricPlot[pathFcn[t],{t,0,2π}];
spokelines=Table[{cen,cen+0.22 Cos[ρ] q/Norm[q]+0.22 Sin[ρ] {0,0,1}},{ρ,0,2π-(π/nspokes),(π/nspokes)}];
spokes = {spokecolor,Thickness[0.004],Line[spokelines]};
rot2= RotationTransform[-5 distance,p3D-{a,b,0},elbow];
rot = RotationTransform[π/2+ArcTan@@({a,b} - Most[cen]),{0,0,1}, cen];
pr={{-1.8, 2}, {-.2, 1.9},{-0.1,0.5}};
Pane[Column[{
Row[{"winding number (number of turns): ",NumberForm[distance/circumference,{4,3}]}],
Row[{"roller radius = (1/5); circumference = 2 π (1/5) = 1.2566"}],
Which[region ==="circle", "circle area: π × (0.6^2) = 1.131",
region ==="square", "square area: (1.2^2) = 1.44", 
region ==="blob", "blob area = 1.156"],
 Row[{"area = winding number × circumference × L (= 1.3) = ",NumberForm[distance L,{4,3}]}],
Graphics3D[{
{tableColor, Polygon[{{pr[[1,1]],pr[[2,1]],-0.01},{pr[[1,2]],pr[[2,1]],-0.01},{pr[[1,2]],pr[[2,2]],-0.01},{pr[[1,1]],pr[[2,2]],-0.01}}]},
{FaceForm[areaColor,areaColor],EdgeForm[Thick],Cases[region2D,Line[z_]:>Polygon[z /. {x1_,x2_}:>{x1,x2,0}],∞]},
 {PointSize[Large], Point[{{0,0,0},{a,b,0}}]},
{RGBColor[0.634, 0.896, 0.992],Cylinder[{{0,0,0.2}, elbow},0.02],Cylinder[{elbow,p3Dup},0.02]},{Black,Cylinder[{{0,0,0},{0,0,0.2}},0.02],Cylinder[{{a,b,0},elbow},0.02],needleColor,Line[{p3D,p3Dup}]},
{FaceForm[wheelColor1], 
Polygon[Table[cen+{rad Cos[θ],0,rad Sin[θ]},{θ,0,π,2π/30}]],
wheelColor2,Polygon[Table[cen+{rad Cos[θ],0,rad Sin[θ]},{θ,π,2π, 2π/30}]]}/. {x_?NumericQ,y_,z_} :>rot[{x,y,z}]/.{x_?NumericQ,y_,z_} :>rot2[{x,y,z}],
spokes/. {x_?NumericQ, y_, z_} :>rot2[{x,y,z}],
{tableColor, Cylinder[{{ pr[[1,1]], pr[[2,1]],0.3},{pr[[1,1]], pr[[2,1]],-0.2}}, 0.01],
Cylinder[{{pr[[1,2]],pr[[2,1]],0.3},{pr[[1,2]], pr[[2,1]],-0.2}},0.01],Cylinder[{{ pr[[1,1]],pr[[2,2]],0.3},{pr[[1,1]], pr[[2,2]],-0.2}},0.01],
Cylinder[{{ pr[[1,2]], pr[[2,2]],0.3},{ pr[[1,2]], pr[[2,2]],-0.2}},0.01]},
{startPostColor, Thickness[0.01],Line[{{1.6,1,0.1},{1.6,1,-0.2}}]},
{PointSize[0.01],Blue, Point[p3D]}},
 Lighting->"Neutral",
PlotRange->(#+{-0.2,0.2}& /@ pr),ImageSize->320,Axes->False,Boxed->False,ViewPoint->{8,0,2},SphericalRegion->True,
PlotRegion->{{0.1,0.9},{0,1.3}},ViewAngle->π/50]}],
BaseStyle->{FontFamily->"Times"}, ImageSize->{360,290}, Alignment->{Center,Bottom}],
{{tpath1, 0,"trace region"},0,1},
{{region,"circle"}, {"circle","square","blob"}},TrackedSymbols->{tpath1,region}]

A Virtual PlanimeterOLD

FElbow[{x_,y_}][L_]:=(1/2){y,-x}+{x,y} (Sqrt[  ((L^2)/((x^2)+(y^2)))-(1/4)]);
(∂_x)FElbow[{x,y}][L][[2]]-(∂_y)FElbow[{x,y}][L][[1]]

Clear[θ];L=1.3;
FElbow[{x_,y_}][L_]:=(1/2){y,-x}+{x,y} (Sqrt[  ((L^2)/((x^2)+(y^2)))-(1/4)]);
F[{x_,y_}][L_]:={-y,x}+FElbow[{x,y}][L];  
pathCircle[θ_]:=0.6 {Cos[θ],Sin[θ]}+{1,1};
pathBlob[θ_]:=pathCircle[θ]+{(0.2+ Cos[θ Sin[θ]]/3) -0.5,0.1 Cos[θ] (1+ Cos[θ]/2)}-{1/30,3/20};
pathSquare[θ_]:=With[{t=θ/(2 π)},Which[0≤t≤(1/8),{1.6,1+8t 0.6},
(1/8)<t≤(3/8),{1.6-4(t-(1/8)) 1.2,1.6},(3/8)<t≤(5/8),{0.4,1.6-4(t-(3/8))1.2},
(5/8)<t≤(7/8),{0.4+4(t-(5/8))1.2,0.4},(7/8)<t≤1,{1.6,0.4+8(t-(7/8))0.6}]];
pathCircleDer[θ_] := Evaluate[D[pathCircle[θ],θ]];
pathBlobDer[θ_] := Evaluate[D[pathBlob[θ],θ]];
pathSquareDer[θ_] := (1/(2π))With[{t=θ/(2 π)},Which[
0≤t≤(1/8)||(7/8)<t≤1,{0,4.8},(1/8)<t≤(3/8),{-4.8,0},(3/8)<t≤(5/8),{0, -4.8},(5/8)<t≤(7/8),{4.8,0}]];
distFuncCircle= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathCircle[θ]][L] . pathCircleDer[θ]},d[θ],{θ,0,2π}]];
distFuncBlob= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathBlob[θ]][L] . pathBlobDer[θ]},d[θ],{θ,0,2π}]];
distFuncSquare= d[θ]/.First[NDSolve[
{d[0]==0,d'[θ]==F[pathSquare[θ]][L] . pathSquareDer[θ]},d[θ],{θ,0,2π}]];

Manipulate[nspokes=4; rad=0.2;turnfactor=1/(2π rad);
spokecolor=Black;needleColor=startPostColor=Red;wheelColor1=Lighter@Orange;
wheelColor2=Cyan;areaColor=Nest[Lighter,Yellow,1];tableColor=Nest[Lighter,Blue,4];
tpath=tpath1 2π;
pathFcn = region/. {"circle" -> pathCircle, "blob"->pathBlob, "square"->pathSquare};
pder[tt_] := Evaluate[D[pathFcn[tt],tt]];
distExpr= region /.{"circle" -> distFuncCircle,"blob"->distFuncBlob,  "square"->distFuncSquare};
p=pathFcn[tpath];
distance = distExpr/. θ-> tpath;
p3D=Append[p,0];
p3Dup=p3D+{0,0,0.2};
 q=Append[0.1 ({-1,1}Reverse[(p-{a,b})]),0]; 
{a,b} = Reverse[FElbow[p][L]]{-1,1};
elbow={a,b,0.2};cen=0.07elbow+0.93 p3Dup;
region2D = ParametricPlot[pathFcn[t],{t,0,2π}];
spokelines=Table[{cen,cen+0.22 Cos[ρ] q/Norm[q]+0.22 Sin[ρ] {0,0,1}},{ρ,0,2π-(π/nspokes),(π/nspokes)}];
spokes = {spokecolor,Thickness[0.004],Line[spokelines]};
rot2= RotationTransform[-5 distance,p3D-{a,b,0},elbow];
rot = RotationTransform[π/2+ArcTan@@({a,b} - Most[cen]),{0,0,1}, cen];
pr={{-1.8, 2}, {-.2, 1.9},{-0.1,0.5}};
Pane[Column[{
Row[{"winding number (number of turns): ",NumberForm[turnfactor distance,{4,3}]}],
Row[{"roller radius = (1/5), so calibration factor = 2 π radius = 2 π (1/5) = 1.2566"}],
Which[region ==="circle", "circle area: π × (0.6^2) = 1.131",
region ==="square", "square area: (1.2^2) = 1.44", 
region ==="blob", "blob area = 1.156"],
 Row[{"area = winding number × calibration = ", 2 π/5," × ",NumberForm[turnfactor distance,{4,3}]," = ",NumberForm[distance,{4,3}]}],
Graphics3D[{
{tableColor, Polygon[{{pr[[1,1]],pr[[2,1]],-0.01},{pr[[1,2]],pr[[2,1]],-0.01},{pr[[1,2]],pr[[2,2]],-0.01},{pr[[1,1]],pr[[2,2]],-0.01}}]},
{FaceForm[areaColor,areaColor],EdgeForm[Thick],Cases[region2D,Line[z_]:>Polygon[z /. {x1_,x2_}:>{x1,x2,0}],∞]},
 {PointSize[Large], Point[{{0,0,0},{a,b,0}}]},
{RGBColor[0.634, 0.896, 0.992],Cylinder[{{0,0,0.2}, elbow},0.02],Cylinder[{elbow,p3Dup},0.02]},{Black,Cylinder[{{0,0,0},{0,0,0.2}},0.02],Cylinder[{{a,b,0},elbow},0.02],needleColor,Line[{p3D,p3Dup}]},
{FaceForm[wheelColor1], 
Polygon[Table[cen+{rad Cos[θ],0,rad Sin[θ]},{θ,0,π,2π/30}]],
wheelColor2,Polygon[Table[cen+{rad Cos[θ],0,rad Sin[θ]},{θ,π,2π, 2π/30}]]}/. {x_?NumericQ,y_,z_} :>rot[{x,y,z}]/.{x_?NumericQ,y_,z_} :>rot2[{x,y,z}],
spokes/. {x_?NumericQ, y_, z_} :>rot2[{x,y,z}],
{tableColor, Cylinder[{{ pr[[1,1]], pr[[2,1]],0.3},{pr[[1,1]], pr[[2,1]],-0.2}}, 0.01],
Cylinder[{{pr[[1,2]],pr[[2,1]],0.3},{pr[[1,2]], pr[[2,1]],-0.2}},0.01],Cylinder[{{ pr[[1,1]],pr[[2,2]],0.3},{pr[[1,1]], pr[[2,2]],-0.2}},0.01],
Cylinder[{{ pr[[1,2]], pr[[2,2]],0.3},{ pr[[1,2]], pr[[2,2]],-0.2}},0.01]},
{startPostColor, Thickness[0.01],Line[{{1.6,1,0.1},{1.6,1,-0.2}}]},
{PointSize[0.01],Blue, Point[p3D]}},
 Lighting->"Neutral",
PlotRange->(#+{-0.2,0.2}& /@ pr),ImageSize->320,Axes->False,Boxed->False,ViewPoint->{8,0,2},SphericalRegion->True,
PlotRegion->{{0.1,0.9},{0,1.3}},ViewAngle->π/50]}],
BaseStyle->{FontFamily->"Times"}, ImageSize->{360,290}, Alignment->{Center,Bottom}],
{{tpath1, 0,"trace region"},0,1},
{{region,"circle"}, {"circle","square","blob"}},TrackedSymbols->{tpath1,region}]

The Icing-on-the-Cake Puzzle

Clear[rot];
 Manipulate[
θ=x /.Degree -> π/180;k=Ceiling[2π/θ];rr=Round[2π/θ];
If[n>2 k(k-1),n=2k(k-1)];
z=θ-((2 π)/k);small=k z;
large=θ-k z;ends=π/2-Prepend[Accumulate[Riffle[Table[large,{k}],Table[small,{k-1}]]], 0];
pieces = Reverse/@ Partition[ends,2,1];
Acolor[j_,i_]:=If[EvenQ[Quotient[i-j,k]],1,0];
Bcolor[j_,i_]:=If[EvenQ[Quotient[i-j,k-1]],1,0];
rot[i_]:=z_Disk | z_Line| z_Circle:>GeometricTransformation[z,RotationTransform[i θ ]];
Apieces=pieces[[Range[1,2 k-1,2]]];
Bpieces=pieces[[Range[2,2 k-2,2]]];
time =If[Abs[2π/θ - rr]<10^-5, 2 rr, 2 k (k-1)];
Column[{Style[StringForm["number of steps to return to start: ``",time], FontFamily->"Times"],
Graphics[{
Table[{EdgeForm[{Thickness[0.017]}],FaceForm[Acolor[j,n]/.{0->Brown,1->White}],Disk[{0,0},1,Apieces[[j]]]},{j,k}],

Table[{EdgeForm[{Thickness[0.017]}],FaceForm[Bcolor[j,n]/.{0->Brown,1->White}],Disk[{0,0},1,Bpieces[[j]]]},{j,k-1}], 
If[n< If[Abs[2π/θ - rr]<10^-5,2 rr,2 k(k-1)],{Thickness[0.005],Line[{1.1 {Cos[(π/2)+θ],Sin[(π/2)+θ]},{0,0},{0,1.1}}],
EdgeForm[{Red, Thickness[0.005]}],FaceForm[{White,Opacity[0.2]}],Disk[{0,0}, 1.1,{π/2,(π/2)+θ} ]},{}]}/.
rot[n],PlotRange->1.2,ImageSize->300]}],
{{x,π/4, "slice angle, radians"}, 0.1, 2π},
{{x,Pi/4,"slice angle, radians"},{Pi/4->"π / 4",Pi/2->"π / 2",3Pi/2->"3 π / 2",π->"π",185 Degree->"185°",6,1}, SetterBar},


{{n,0, "number of slices"},0,
If[Abs[2π/x - Round[2π/x] /. Degree -> π/180]<10^-5,2 Round[2π/x/. Degree-> π/180],2 Ceiling[((2 π)/x)/. Degree->π/180](Ceiling[((2 π)/x)/. Degree->π/180]-1)],1,Appearance->"Open"}, TrackedSymbols:>{n,x}]

Shadowing

NN[x_] := SetPrecision[x,80];
makeTimes[z_]:=Style[z,FontFamily->"Times"];
f[r_][x_]:=r x(1-x);
trajectory[r_,seed_]:=NestList[f[r],seed,100];
base[s_]:=base[s]=trajectory[s,0.1];
olddiff=0;
Manipulate[If[update,olddiff+=NN[δ (10^scale)];δ=0;update=False];
new=trajectory[r,NN[1/10+olddiff]+NN[δ (10^scale)]];
Pane[Column[{Row[{
makeTimes[StringForm["Difference from (1/10):  ``\n",Style[ToString[SetPrecision[olddiff+δ (10^scale),30],TraditionalForm]]]],
makeTimes[StringForm["Total error as (Sqrt["sum of squares"]):  ``\n",Style[ToString[NumberForm[Norm[base[r]-new],8],TraditionalForm]]]]}],Show[ListLinePlot[{base[r],new},PlotStyle->{{Thickness[0.016],
Lighter[Orange]},{Thickness[0.005],Blue}}],
Frame->True,Axes->False,AspectRatio->0.4,ImageSize->350,PlotLabel->None,FrameTicks->{Automatic,{0,0.5,1},None,None},PlotRange->{{start,Min[start+len,100]},{0,1}}]}],ImageSize->{350,220}],{{scale,-16,"power of 10 scale for change"},Range[-8,-30,-2]},{{δ,0.,"change (without power of 10)"},-1,1},{{start,40,"display start"},1,99,1},{{len,40,"display length"},1,100,1},{update,{False,True}},{r,{4,38/10->3.8}},TrackedSymbols:>{scale,r,update,start,len,δ}]