Code for Electronic Supplement

SpinAndSlide

Abe Lincoln's data

Lincoln=Module[{eye={{0.2415099,0.371989},{0.1738699,0.3043549},{0.22122,0.304354}},eye1={{0.21269,0.305227},{0.2198399,0.326157},{0.21269,0.341855}},shoulder={{-0.32662,-0.304354},{-0.279279,-0.311118},{-0.198119,-0.344934},{-0.13725,-0.399042},{-0.0898998,-0.453150},{-0.0560899,-0.541075},{-0.00197999,-0.764268}},linc1={{-0.218409,0.0405809},{-0.218409,0},{-0.2387,-0.027054},{-0.2387,-0.054108},{-0.29957,-0.142031},{-0.353679,-0.223193},{-0.38073,-0.290827},{-0.42808,-0.385516},{-0.522759,-0.554602}},linc2={{-0.522759,-0.554602},{-0.488949,-0.622237},{-0.434839,-0.676343},{-0.34691,-0.730452},{-0.24546,-0.764269},{-0.13725,-0.784558},{-0.0358,-0.777796},{0.09271,-0.757505},{0.200919,-0.723688},{0.30914,-0.676343},{0.40383,-0.629},{0.471459,-0.568128}},linc3={{0.471459,-0.568128},{0.20769,-0.223193},{0.20769,-0.189375},{0.173869,-0.142031},{0.20769,-0.101452}},linc5={{0.27532,0.541075},{0.28885,0.486967},{0.302379,0.405806},{0.32267,0.324645},{0.349719,0.263773},{0.36325,0.182613},{0.3159,0.175849},{0.268559,0.175849}},linc6={{-0.09667,0.0608709},{-0.00198,0},{0.13329,-0.060871},{0.22122,-0.101452},{0.2618,-0.101452},{0.30238,-0.094688},{0.32267,-0.067634},{0.32943,-0.02705},{0.2618,-0.006763},{0.15358,0.02029},{0.03184,0.060871},{-0.04256,0.094688},{-0.08314,0.121742},{-0.11019,0.094688},{-0.096670,0.060871}},linc7={{0.32437,0.175257},{0.30606,0.114287},{0.29507,0.058859},{0.3024,0.025602},{0.30972,-0.018739}},linc4={{-0.2387,-0.040581},{0.20092,-0.223194}},linc8={{-0.21164,0.040581},{-0.30633,0.243484},{-0.34015,0.371989},{-0.34015,0.486968},{-0.3131,0.561365},{-0.24546,0.629},{-0.1643,0.669581},{-0.0899,0.710161},{-0.00198,0.730451},{0.10624,0.723688},{0.20092,0.703398},{0.24827,0.67634},{0.28209,0.64929},{0.30238,0.581656},{0.28209,0.534312},{0.21445,0.541075},{0.13329,0.554602},{0.06566,0.574892},{0.01831,0.574892},{-0.02227,0.541075},{-0.04932,0.486968},{-0.06285,0.419333},{-0.10343,0.378753},{-0.11696,0.331409},{-0.11019,0.270538},{-0.10343,0.209667},{-0.10343,0.155559},{-0.13048,0.094688},{-0.1643,0.060871},{-0.21841,0.054108},{-0.21164,0.040581}},mouth={{0.22798,0.121742},{0.30914,0.121742}}},beard=Polygon[Rest[linc6]];hair=Polygon[Rest[linc8]];{{GrayLevel[0.5],beard,hair},Line/@{linc1,linc2,linc3,linc4,linc5,eye,eye1,linc6,shoulder,linc7,linc8,mouth}}];

SpinAndSlide::usage = "SpinAndSlide[] generates a movie that shows where the cycloid equations come from.";
Options[SpinAndSlide] := {Movie -> True, BaseStyle-> 12, Transpose->False}; 

SpinAndSlide[opts___] := Module[{cycloid, tmax, frames, pts,i},
		cycloid[t_] := {t-Sin[t], 1-Cos[t]};
	{bs,movQ, trQ} ={BaseStyle, Movie, Transpose} /. {opts} /. Options[SpinAndSlide];
  tmax = 2;frames =10;images=Table[Null,{100}];pts = {};j = 0;
		
Do[j++;images[[j]] = Graphics[
	{Line[{{-1.3,0}, {5,0}}],Circle[{0,1}, 1],
	PointSize[0.03],
	AppendTo[pts,Point[{0.,1.} + {-Sin[t], - Cos[t]}]];
	pts,{PointSize[.02], Last[pts]},
	Text["Spin to (-sin t, 1 - cos t)", {-1, 2.4}, {-1,-1}],
			Lincoln /. {x_, y_?NumericQ} :>
		{{Cos[t], +Sin[t]}, {-Sin[t], Cos[t]}}. {x, y}+{0,1}}, 
		PlotRange -> {{-1.3, 4}, {-.3, 3.1}},Frame->True,
		FrameTicks -> None,BaseStyle ->bs], {t, 0, tmax, tmax/frames}];
i = 0;
Do[i++;highPts = {PointSize[0.03],
			 Table[Point [{dt- Sin[t], 1-Cos[t]}],
				  {t, dt+tmax/frames, tmax, tmax/frames}]};
		lowPts = {AbsolutePointSize[4],
			Table[Point[cycloid[t]],{t,0,dt, tmax/frames}]};
j++;images[[j]]=Graphics[
		{Line[{{-1.3,0}, {5,0}}],Circle[{dt,1}, 1],highPts, lowPts,
		{PointSize[.02],
			Point[{dt-Sin[tmax], 1-Cos[tmax]}]},
		Text["Slide to (t - sin t, 1 - cos t)", {-1, 2.4}, {-1,-1}],
					Lincoln /. {x_, y_?NumericQ} :>
		{{Cos[tmax], Sin[tmax]}, {-Sin[tmax], Cos[tmax]}}. {x, y}+{dt,1} },
		PlotRange -> {{-1.3, 4}, {-.3, 3.1}},
		Frame->True,FrameTicks -> None,
		BaseStyle ->bs], {dt, 0, tmax, tmax/frames}];
images = DeleteCases[images, Null];
If[!movQ, GraphicsGrid[Map[images[[#]]& , If[trQ, {{1,4}, {7, 10}, {13, 16}, {19,22}},{{1,13}, {4, 16}, {7, 19}, {10,22}}],{2}]],
Manipulate[Show[images[[i]]], {{i,1, "i"}, 1, Length[images],1}]
				]];

CameraSimulation

CameraSimulation::"usage"="CameraSimulation simulates a photograph of a rolling wheel taken with a stationary camera.";
CameraSimulation:=Module[{norm,f,places,a},norm[v_]:=(Sqrt[v.v]);f[pt_]:=Module[{del=0.02},Table[norm[pt] {Cos[t],Sin[t]},{t,a=ArcTan@@pt-del,a+2 del,(del/10)}]];Show[Graphics[{AbsolutePointSize[5],Circle[{0,1},1],places={{-0.007241,0.1},{-0.304,0.27},{0.319,0.3},{0.616,0.747},{-0.434,0.739},{0.0434,0.986},{0.514,1.43},{-0.507,1.45},{-0.268,1.64},{0.145,1.76}};(Text["Focus On This!",#1]&)/@Flatten[f/@places,1]}],PlotRange->All,BaseStyle->{FontFamily->"Times",FontSize->9}]];

RollingSquare

RollingSquare::usage = "RollingSquare[(opts)] generates a list animation of a rolling square.";
Movie::usage= "Movie is an option to RollingSquare and similar functions that specifies whether a movie, or just the final image, should be shown.";
Frames::usage= "Frames is an option to RollingSquare and similar functions that specifies the number of frames that define the output, whether movie or single image.";
LastWheelOnly::usage = "LastWheelOnly is an option to RollingSquare that controls, when a still image is shown, whether all wheels are shown, or only the last one.";
TracePoints::usage = "TracePoints is an option to RollingSquare that controls whether the locus of a vertex is shown.";
WheelColor::usage = "WheelColor is an option to RollingSquare that sets the color of the square wheel.";CenterPointSize::usage = "CenterPointSize is an option to RollingSquare that sets the size of the central point on the wheel.";
CornerPointSize::usage = "CornerPointSize is an option to RollingSquare that sets the size of the corner point on the wheel.";
TracePointSize::usage = "TracePointSize is an option to RollingSquare that sets the size of the points on the locus.";BorderStyle::usage = "BorderStyle is an option to RollingSquare that sets the style of the border of the wheel.";

Options[RollingSquare] = {Movie->True, Frames->30, BorderStyle->Thickness[0.003], WheelColor->Gray, CenterPointSize->PointSize[0.015], LastWheelOnly->True,TracePoints->True,TracePointSize->PointSize[0.015],CornerPointSize->PointSize[0.015]};

RollingSquare[opts___]:= Module[
{mov, rotate, cr, ir, npts=30,dots = {tracesize},a, plot,startpolygon, polygon, n = 4},
{movQ, npts, bsty, wcol, centersize, cornersize, tracesize, trQ,lastonlyQ} = {Movie, Frames, BorderStyle, WheelColor,CenterPointSize,CornerPointSize, TracePointSize, TracePoints,LastWheelOnly} /. {opts} /. Options[RollingSquare];
cr = Csc[π/n];	(* circumradius of polygon *)  
ir = Cot[π/n];	(* inradius of polygon *)   
a = ir*ArcSinh[1/ir];

rotate[p_, t_, center_] :=RotationTransform[-t, center][p];

plot = Show[Table[Plot[cr - ir Cosh[(x - 2 a i)/ir], 
      {x, -a + 2 a i, a + 2 a i},
    Evaluate[Sequence@@FilterRules[{opts}, (First /@ Options[Plot])]],PlotRange->All,PlotPoints->50,  PlotStyle->{Black,Thickness[0.004]}], {i, 0, 6}]];

startpolygon = N@Map[# + {0, cr} &, Map[{Re[#], Im[#]} &,cr N[Exp[I Range[-π/2 + π/n, 3 π/2 + π/n, 2 π/n]]]]];
polygons={};
polygon[tVal_] := Module[{loop=N[Floor[(t + a)/(2a)]]},(* loop tells which loop the square is on *) 
Map[{tVal,0} + rotate[#,loop 2π/n + ArcTan[Sinh[(tVal-loop 2 a)/ir]], {0,cr}]&,startpolygon]];


images = Table[newpolygon = polygon[t]; 
AppendTo[polygons, {EdgeForm[bsty], FaceForm[wcol],Polygon[newpolygon],
			Line[{newpolygon[[{1,3}]],newpolygon[[{2,4}]]}],
centersize,Point[{t, cr}],
        {cornersize,Point[newpolygon[[n]]]}}];
	AppendTo[dots, Point[newpolygon[[n]]]];
		Show[Graphics[{ Thickness[.0005], If[lastonlyQ,polygons[[-1]] , polygons],
        If[trQ,dots,{}],
Line[{{-cr, cr}, {13 a,cr}}]}, Sequence@@FilterRules[{opts}, (First /@ Options[Graphics])]], plot,
    PlotRange->{{-cr, 13.2 a }, {-.2, 2 cr + .15}}], {t, If[npts==1, 11 a, 0.],11a, 11 a/If[npts==1,1,(npts-1)]}];
If[!movQ, Show[images[[-1]]],ListAnimate[images]]];

SpokedBicyclePhotograph

SpokedBicyclePhotograph::usage = "SpokedBicyclePhotograph generates a simulated photograph of a rolling bicycle wheel.";

th = Thickness[0.001];
SpokedBicyclePhotograph := Module[{step,spokes,rims,wheel,g,b},
	step = 0.05;spokes = 20;rims = {};
g = Compile[{x,y}, (Abs[(Sqrt[(x^2) + (((y-1))^2)]) - Cos[3 π/2 - ArcTan[x, y-1]]])/2];
wheel[time_] := Module[{mat={{Cos[time],Sin[time]},{-Sin[time], Cos[time]}}},
     N[{
AppendTo[rims,{th, Table[Circle[{0.,1.},rad],{rad,1,1.1,0.1/2}]}/. 
		  {x_?NumericQ,y_?NumericQ} :>  mat.({x,y}-{0.,1.})+{time,1}];
   {th,Red,Table[
     {b=g[(r+step/2) Cos[s],1+(r+step/2) Sin[s]];
     GrayLevel[Which[ b<0.085, 0, b<0.2,0.5, 
             b<0.5,0.65, b<0.6,0.75,b<0.8,0.8,
            True, 0.85]],Black,Thickness[0.001],
     Line[{{0.,1.}+ r {Cos[s],Sin[s]}, {0,1}+(r+step){Cos[s],Sin[s]}}]},
            {r,0.,1-step,step},{s,0.,2 π,2. π/spokes}]} /. 
            {x_?NumericQ,y_?NumericQ} :>    mat.({x,y}-{0,1})+{time,1}}]  ];
 Show[Graphics[{
{ Thickness[.0013 2],Red, Circle[{0, 1/2}, 1/2-.02],Circle[{0, 1/2}, 1/2+.02]},
 Map[wheel,Range[0.,0.06,0.06/10]],
        rims}], ImageSize->300,PlotRange -> {{-1.3, 1.3}, {-0.3, 2.3}}]]

SquareHoleWatts

SquareHole::"usage"="SquareHole[frames] generates an image of loci related to a Reuleaux triangle rolling inside a square.";

Rotate2DLegacy[vec_, θ_, pt_:{0,0}] := RotationTransform[-θ,pt][vec]

 SquareHole[frames_,opts___]:=Module[{movQ,centroid={1-((2 (Sqrt[3.]))/3),0},choose,arc,verts={{1-(Sqrt[3.]),-1},{1,0},{1-(Sqrt[3.]),1}},angles={(π/6),((5 π)/6),((9 π)/6)},dots={}},
choose[t_]:=Floor[0.5 (Floor[(t/(π/6))]+3)];arc[{center_,startangle_}]:=Table[center+2 {Cos[t],Sin[t]},{t,startangle,N[startangle+(π/3)],0.08}];reuleaux0=Flatten[arc/@Transpose[{verts,angles}],1];Do[tempverts=(Rotate2DLegacy[#1,-t,centroid]&)/@verts;translate=2 Mod[{choose[t],choose[t-(π/2)]},2]-1-{tempverts[[Mod[choose[t],3]+1,1]],tempverts[[Mod[choose[t-(π/2)],3]+1,2]]};newverts=(#1+translate&)/@tempverts;reuleaux=Flatten[arc/@Transpose[{newverts,t+angles}],1];
AppendTo[reuleaux,First[reuleaux]];
dots=Join[dots,{newverts[[3]],centroid+translate,Rotate2DLegacy[{0,0},-t,centroid]+translate}];If[t==2 π-((2 π)/frames),Return[Graphics[{
{GrayLevel[0.75],Polygon[reuleaux0]},
Line[reuleaux0],
Line[Append[verts,First[verts]]],
{Thickness[0.006],Line[{{1,1},{1,-1},{-1,-1},{-1,1},{1,1}}]},
(Line[{centroid,#1}]&)/@verts,
PointSize[0.025],Point/@verts,
Point[centroid],Point[{0,0}],
dots=Transpose[Partition[dots,3,3]];
 PointSize[0.02],Point/@dots[[1]],PointSize[0.01],Point/@dots[[2]], {PointSize[0.01],Point/@dots[[3]]};{}},opts,PlotRange->{{-1.05,1.05},{-1.05,1.05}}], Module]],{t,0,1.9999 π,((2 π)/frames)}]]

Square Holes

PerfectSquareHole:= Module[{θ, spokes},
Manipulate[
Module[
{tval,end,rot, translate,line,w,a,b,c,f,rotor,auxcircle, tracepts, circle},
w=2;tval=π/4;r2=w-w/(2 Sin[tval]);
{a,b,c}={{-1,0}, {1,0}, {0, 1 }}; s=2((Sqrt[2])-1);
end=a+(Sqrt[2]);
rot=RotationTransform[θ, {0, 1}];
translate= TranslationTransform[Which[
0≤θ≤π/4, -{Cos[θ]+Sin[θ]-1,0},π/4≤θ≤π/2, -{(Sqrt[2])-1,- Cos[θ] - Sin[θ]+(Sqrt[2])},
π/2≤θ≤3π/4, -{(Sqrt[2])-1,- Cos[θ] + Sin[θ]-2+(Sqrt[2])},
3π/4≤θ≤π, -{- Cos[θ] +Sin[θ]-1,-2+2(Sqrt[2])},π≤θ≤5π/4, -{ Cos[θ] +Sin[θ]+1,-2+2(Sqrt[2])},
5π/4≤θ≤3π/2, -{-(Sqrt[2])+1, -Cos[θ] -Sin[θ]+(Sqrt[2])-2},3π/2≤θ≤7π/4, -{ -(Sqrt[2])+1,-Cos[θ] +Sin[θ]+(Sqrt[2])},

7π/4≤θ≤2π, -{-Cos[θ]+Sin[θ]+1,0}]];
f[z_] := translate[rot[z]];
f1[z_]:=GeometricTransformation[GeometricTransformation[z, rot],translate];
Graphics[{
{RGBColor[0.79,1,0.56],
EdgeForm[{Gray,Thickness[0.002]}],Rectangle[{-1, -(Sqrt[2]-1)},{1, -(Sqrt[2]-1)+2}]},
{White,Rectangle [ (c-{s/2,s}), c+{s/2, 0}]}, 
Red,Thickness[0.002], 
rotor = N[{Circle[c, (Sqrt[2]), {-3 π/4,- π/4}],Circle[a, 2, {0, π/4}],
Circle[b, 2, {3π/4,π}],Circle[c, r2, {π/4,3π/4}]}];
auxcircle = Circle[c, r2, {0,2π}];
f1[{Polygon[ {c, c-{0.08,0.2} 0.8, c-0.8 {-0.08, 0.2}}],
 rotor,{Blue,auxcircle},
{Black,Line[{a,c}], Line[ {b,c}],Line[{b,a}],
{Line[ {c,end}],Line[{c,end {-1,1}}],
Line[Table[{c, c+r2 {Cos[tt], Sin[tt]}}, {tt, 0, 15/16  2π , 2π/16}]] }[[If[spokes,3,{1,2}]]]}}],
tracepts=Take[
{c,{1-(Sqrt[2]),1},{1-(Sqrt[2]),3-2(Sqrt[2])},{(Sqrt[2])-1,3-2(Sqrt[2])},{(Sqrt[2])-1,1}}, 2+Quotient[θ-π/4, π/2]]; {Thick, Line[tracepts], Line[{tracepts[[-1]], f[c]}]}},ImageSize->300,PlotRange->{{-1.02,1.02}, {-.5,1.72}}]], {{θ,0, "θ"},0,2π},{{spokes,False, "spokes"}, {False,True}},TrackedSymbols->Manipulate, SaveDefinitions->True]]

Square Hole Drill in Three Dimensions

translateFcn[θθ_]:= TranslationTransform[Which[0≤θθ≤π/4, -{Cos[θθ]+Sin[θθ]-1,0,0},
π/4≤θθ≤π/2, -{(Sqrt[2])-1,0,- Cos[θθ] - Sin[θθ]+(Sqrt[2])},π/2≤θθ≤3π/4, -{(Sqrt[2])-1,0,- Cos[θθ] + Sin[θθ]-2+(Sqrt[2])},
3π/4≤θθ≤π, -{- Cos[θθ] +Sin[θθ]-1,0,-2+2(Sqrt[2])},π≤θθ≤5π/4, -{ Cos[θθ] +Sin[θθ]+1,0,-2+2(Sqrt[2])},
5π/4≤θθ≤3π/2, -{-(Sqrt[2])+1, 0,-Cos[θθ] -Sin[θθ]+(Sqrt[2])-2},3π/2≤θθ≤7π/4, -{ -(Sqrt[2])+1,0,-Cos[θθ] +Sin[θθ]+(Sqrt[2])},
7π/4≤θθ≤2π, -{-Cos[θθ]+Sin[θθ]+1,0,0}]];

oldhamCenter[θθ_] :=({Sin[θθ] (-τy Cos[θθ]+τx Sin[θθ]),oldhamLoc,(1/2) (2+τy+τy Cos[2 θθ]-τx Sin[2 θθ])}/. Thread[{τx,τy} ->translateFcn[θθ][c][[{1,3}]]-{0,1}]); 

circleSector3D[cen_,rad_, yval_,{θ1_,θ2_}, res_:20] := Table[cen+rad{Cos[θθ], Sin[θθ]}, {θθ, θ1, θ2, (θ2-θ1)/(res-1)}]/. {x_?NumericQ, z_} :> {x, yval,z};
circle3D[a_,r_,p_,res_:50]:=Table[N[a+r {Cos[θθ],0,Sin[θθ]}],{θθ,p[[1]],p[[2]],((p[[2]]-p[[1]])/res)}];
extrude[shape_,tVal_]:=Table[{shape[[i]],shape[[i+1]],shape[[i+1]]+{0,tVal,0},shape[[i]]+{0,tVal,0}},{i,Length[shape]-1}];

cube0=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{0.2 x,0.3 y+.15,0.2 z},PolyhedronData["Cube","Faces"][[2]]];
cube1=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{0.2 x,0.5 y+0.55,3. z},PolyhedronData["Cube","Faces"][[2]]];
cube2=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{3 x,0.4 y-0.2,0.2 z},PolyhedronData["Cube","Faces"][[2]]];

SquareHoleThreeDimensionalDrill[opts___] := Module[{rot,rotor,rotorcolor, f, a,b,s, cylrad, end, r2,cc, oldhamcolor, drivecolor, oldhamcylindercolor,knifecolor, oldhamCenterPoint, oldhamtranslate,rotorcirclecolor, tracepts, cuttingcirclecolor },Manipulate[
{a,b,c}=N[{{-1,0,0}, {1,0,0}, {0,0, 1 }}]; r2=N[2-(Sqrt[2])];
end=a+{(Sqrt[2]),0,(Sqrt[2])};cc=c+{0,2.6,0};s=2((Sqrt[2])-1);cylrad=0.1;  oldhamLoc=1.4;
oldhamcolor=Magenta;cuttingcirclecolor=Lighter[Lighter[Green]];
drivecolor=Lighter[Yellow];rotorcolor=Lighter[Yellow];rotorcirclecolor=Yellow;
oldhamcylindercolor=Brown;knifecolor=Red;

oldhamCenterPoint = oldhamCenter[θ];
oldhamtranslate[p_]:=p+(oldhamCenterPoint-(c+{0,oldhamLoc,0}));
rot=RotationTransform[θ, {0,-1,0},{0, 0,1}];

f[z_,θθ_] := translateFcn[θθ][rot[z]];
 Graphics3D[{
{RGBColor[.79,1,.56],EdgeForm[{Gray,Orange,Thickness[0.002]}],FaceForm[Opacity[opac]],
Cuboid[{-1, 0,-(Sqrt[2]-1)},{1,1, -(Sqrt[2]-1)+2}]},

{White,Cuboid [ (c-{s/2,0,s}), c+{s/2, 0,0}]};

rotorcolor,Thickness[0.002], 
rotor=N@{extrude[circle3D[c, (Sqrt[2]), {-3 π/4,- π/4},10],1],
extrude[circle3D[a, 2, {0, π/4},10],1],
extrude[circle3D[b, 2, {3π/4,π},10],1],extrude[circle3D[c, r2, {π/4,3π/4},10],1]};
 auxcircle =extrude[ circle3D[c, r2, {0,2π}],1];

{EdgeForm[];Polygon/@ (Map[f[#,θ]&,  rotor, {2}])},
{cuttingcirclecolor,
Polygon[f[#,θ]&/@circle3D[c, r2, {0, 2π}]],Polygon[f[#,θ]&/@circle3D[c+{0,1,0}, r2, {0, 2π}]] },

(* leftmost driving circle with crank *) 
{drivecolor,Polygon[circle3D[cc, r2, {0, 2π}]],Polygon[circle3D[cc+{0,-.2,0}, r2, {0, 2π}]];
{Blue,Polygon[extrude[circleSector3D[cc[[{1,3}]], r2,cc[[2]]-.2, θ+{-1.4, 1.4},00021],-0.7]],
 Polygon[extrude[circleSector3D[cc[[{1,3}]], r2,cc[[2]]-.2, θ+{π-1.4,π+ 1.4},00021],-0.7]]},
Polygon[extrude[circle3D[cc, r2, {0, 2π}],-.2]], Thick, Black, Line[{cc,cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]}}],
Thickness[0.01],
Line[{cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]},cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]}+ {0,.3,0}}],
{Thickness[0.001],Line[Table[{cc, cc+{r2 Cos[ρ+θ], 0, r2 Sin[ρ+θ]}}, {ρ, 0, 2π-π/4, π/4}]]}},
 
 {rotorcirclecolor,EdgeForm[Blue],Polygon[f[#,θ]&/@ auxcircle]},

(* the three Oldham drive boxes in the center *) 
 
{oldhamcolor, {cube0, cube1, cube2} /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} :> rot[{x,y,z+1}]-{0,0,1}+oldhamCenterPoint},  
 

{Blue,Polygon[extrude[f[#,θ]&/@ circleSector3D[{0,1}, r2,1.4, π/2+{-1.4, 1.4}],-.4]],
            Polygon[extrude[f[#,θ]& /@ circleSector3D[{0,1}, r2,1.4, π/2+{π-1.4,π+ 1.4}],-.4]]},

{{Black,Line[Table[f[#,θ]&/@ {c, c+r2 {Cos[tVal], 0,Sin[tVal]}}, {tVal, 0, 2π - 2π/8 , π/4}]] },
 tracepts=Take[
{c,{1-(Sqrt[2]),0,1},{1-(Sqrt[2]),0,3-2(Sqrt[2])},{(Sqrt[2])-1,0,3-2(Sqrt[2])},{(Sqrt[2])-1,0,1}}, 2+Quotient[(θ-π/4),( π/2)]];{Thick,White,Opacity[opac],Polygon[extrude[tracepts,-.3 ]], Polygon[extrude[{tracepts[[-1]], f[c,θ]},-.3]]},

{FaceForm[knifecolor],Polygon[f[#,θ]&/@ {c, c-{.08,0, r2} , c-{-.08,0, r2}}];
Polygon[f[#,θ]&/@ extrude[{c, c-{0.08,0, r2} , c-{-.08,0, r2},c}, -.3]];
Polygon[f[#,θ]&/@ extrude[circle3D[{-((Sqrt[2])-1)(Sqrt[3])/2,0,1-((Sqrt[2])-1)/2},(Sqrt[2])-1,{ -π /6  ,π/6 },5],-0.3  ]],
Polygon[f[#,θ]&/@ extrude[circle3D[{-((Sqrt[2])-1)(Sqrt[3])/2- .75,0,1-((Sqrt[2])-1)/2},((Sqrt[2])-1)2.7,.34{ -π /6  ,π/6 },5],-0.3 ]]}}},
Sequence@@ FilterRules[{opts}, Options[Graphics3D]],ViewPoint->Dynamic[vp],ViewAngle->Pi/12,ImageSize->400, SphericalRegion->True,Lighting->Automatic, Boxed->False,
AxesLabel->{"x","y",""},PlotRange->{{-2.3,2.3},{-0.6 ,3.1}, {-1.4,2.75}}], 
{{θ,0, "crank angle"}, 0, 2π},
{{opac,0.2, "opacity of box around rotor"}, 0,1, ImageSize->Small},{{vp,{-0.7, -3, -.3}, "viewpoint"},{{-2, 3, 0.3}->"crank view",{-0.7, -3, -.3}->"cutting tool view", {-3,-0.4,0.4}->"Oldham coupling view"}, SetterBar},  
Evaluate[Sequence@@ FilterRules[{opts}, Options[Manipulate]]],
TrackedSymbols->Manipulate, SaveDefinitions->True,AutorunSequencing->{{1,20},3}]];

Options[SquareHoleDrillImage] = {OpacityOfBoxAroundRotor->0.2,  ViewPoint->{-2, 3, 0.3}};

SquareHoleDrillImage[θ_, opts___]:=Module[{vp,f,a,b,c,cc,s,cylrad, oldhamLog, oldhamcolor, cuttingcirclecolor,drivecolor,rotorcolor,rotorcirclecolor,oldhamcylindercolor,knifecolor,r2,line,spokes,end,oldhamcenter, circleSector3D, circle, extrude, translateFcn, oldhamCenterPoint, rot, oldhamtranslate, rotor,auxcircle, tracepts},

oldhamCenter[θθ_] :=({Sin[θθ] (-τy Cos[θθ]+τx Sin[θθ]),oldhamLoc,(1/2) (2+τy+τy Cos[2 θθ]-τx Sin[2 θθ])}/. Thread[{τx,τy} ->translateFcn[θθ][c][[{1,3}]]-{0,1}]); 

circleSector3D[cen_,rad_, yval_,{θ1_,θ2_}, res_:20] := Table[cen+rad{Cos[θθ], Sin[θθ]}, {θθ, θ1, θ2, (θ2-θ1)/(res-1)}]/. {x_?NumericQ, z_} :> {x, yval,z};
circle3D[a_,r_,p_,res_:50]:=Table[N[a+r {Cos[θθ],0,Sin[θθ]}],{θθ,p[[1]],p[[2]],((p[[2]]-p[[1]])/res)}];
extrude[shape_,tVal_]:=Table[{shape[[i]],shape[[i+1]],shape[[i+1]]+{0,tVal,0},shape[[i]]+{0,tVal,0}},{i,Length[shape]-1}];
translateFcn[θθ_]:= TranslationTransform[Which[0≤θθ≤π/4, -{Cos[θθ]+Sin[θθ]-1,0,0},
π/4≤θθ≤π/2, -{(Sqrt[2])-1,0,- Cos[θθ] - Sin[θθ]+(Sqrt[2])},π/2≤θθ≤3π/4, -{(Sqrt[2])-1,0,- Cos[θθ] + Sin[θθ]-2+(Sqrt[2])},
3π/4≤θθ≤π, -{- Cos[θθ] +Sin[θθ]-1,0,-2+2(Sqrt[2])},π≤θθ≤5π/4, -{ Cos[θθ] +Sin[θθ]+1,0,-2+2(Sqrt[2])},
5π/4≤θθ≤3π/2, -{-(Sqrt[2])+1, 0,-Cos[θθ] -Sin[θθ]+(Sqrt[2])-2},3π/2≤θθ≤7π/4, -{ -(Sqrt[2])+1,0,-Cos[θθ] +Sin[θθ]+(Sqrt[2])},
7π/4≤θθ≤2π, -{-Cos[θθ]+Sin[θθ]+1,0,0}]];
cube0=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{0.2 x,0.3 y+.15,0.2 z},PolyhedronData["Cube","Faces"][[2]]];
cube1=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{0.2 x,0.5 y+0.55,3. z},PolyhedronData["Cube","Faces"][[2]]];
cube2=GraphicsComplex[PolyhedronData["Cube","Faces"][[1]]/.{x_,y_,z_}:>{3 x,0.4 y-0.2,0.2 z},PolyhedronData["Cube","Faces"][[2]]];



{opac,vp} = {OpacityOfBoxAroundRotor, ViewPoint}/. {opts}/. Options[SquareHoleDrillImage];
{a,b,c}=N[{{-1,0,0}, {1,0,0}, {0,0, 1 }}]; r2=N[2-(Sqrt[2])];
end=a+{(Sqrt[2]),0,(Sqrt[2])};cc=c+{0,2.6,0};s=2((Sqrt[2])-1);cylrad=0.1;  oldhamLoc=1.4;
oldhamcolor=Magenta;cuttingcirclecolor=Lighter[Lighter[Green]];
drivecolor=Lighter[Yellow];rotorcolor=Lighter[Yellow];rotorcirclecolor=Yellow;
oldhamcylindercolor=Brown;knifecolor=Red;

oldhamCenterPoint = oldhamCenter[θ];
oldhamtranslate[p_]:=p+(oldhamCenterPoint-(c+{0,oldhamLoc,0}));
rot=RotationTransform[θ, {0,-1,0},{0, 0,1}];

f[z_,θθ_] := translateFcn[θθ][rot[z]];
Graphics3D[{
{RGBColor[.79,1,.56],EdgeForm[{Gray,Orange,Thickness[0.002]}],FaceForm[Opacity[opac]],
Cuboid[{-1, 0,-(Sqrt[2]-1)},{1,1, -(Sqrt[2]-1)+2}]},

{White,Cuboid [ (c-{s/2,0,s}), c+{s/2, 0,0}]};

rotorcolor,Thickness[0.002], 
rotor=N@{extrude[circle3D[c, (Sqrt[2]), {-3 π/4,- π/4},10],1],
extrude[circle3D[a, 2, {0, π/4},10],1],
extrude[circle3D[b, 2, {3π/4,π},10],1],extrude[circle3D[c, r2, {π/4,3π/4},10],1]};
 auxcircle =extrude[ circle3D[c, r2, {0,2π}],1];

{EdgeForm[];Polygon/@ (Map[f[#,θ]&,  rotor, {2}])},
{cuttingcirclecolor,
Polygon[f[#,θ]&/@circle3D[c, r2, {0, 2π}]],Polygon[f[#,θ]&/@circle3D[c+{0,1,0}, r2, {0, 2π}]] },

(* leftmost driving circle with crank *) 
{drivecolor,Polygon[circle3D[cc, r2, {0, 2π}]],Polygon[circle3D[cc+{0,-.2,0}, r2, {0, 2π}]];
{Blue,Polygon[extrude[circleSector3D[cc[[{1,3}]], r2,cc[[2]]-.2, θ+{-1.4, 1.4},00021],-0.7]],
 Polygon[extrude[circleSector3D[cc[[{1,3}]], r2,cc[[2]]-.2, θ+{π-1.4,π+ 1.4},00021],-0.7]]},
Polygon[extrude[circle3D[cc, r2, {0, 2π}],-.2]], Thick, Black, Line[{cc,cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]}}],
Thickness[0.01],
Line[{cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]},cc+1.4 {r2 Cos[θ+π/2], 0.02,r2 Sin[θ+π/2]}+ {0,.3,0}}],
{Thickness[0.001],Line[Table[{cc, cc+{r2 Cos[ρ+θ], 0, r2 Sin[ρ+θ]}}, {ρ, 0, 2π-π/4, π/4}]]}},
 
 {rotorcirclecolor,EdgeForm[Blue],Polygon[f[#,θ]&/@ auxcircle]},

(* the three Oldham drive boxes in the center *) 
 

{oldhamcolor, {cube0, cube1, cube2} /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} :> rot[{x,y,z+1}]-{0,0,1}+oldhamCenterPoint},  
 

{Blue,Polygon[extrude[f[#,θ]&/@ circleSector3D[{0,1}, r2,1.4, π/2+{-1.4, 1.4}],-.4]],
            Polygon[extrude[f[#,θ]& /@ circleSector3D[{0,1}, r2,1.4, π/2+{π-1.4,π+ 1.4}],-.4]]},

{{Black,Line[Table[f[#,θ]&/@ {c, c+r2 {Cos[tVal], 0,Sin[tVal]}}, {tVal, 0, 2π - 2π/8 , π/4}]] },
 tracepts=Take[
{c,{1-(Sqrt[2]),0,1},{1-(Sqrt[2]),0,3-2(Sqrt[2])},{(Sqrt[2])-1,0,3-2(Sqrt[2])},{(Sqrt[2])-1,0,1}}, 2+Quotient[(θ-π/4),( π/2)]];{Thick,White,Opacity[opac;1],Polygon[extrude[tracepts,-.3 ]], Polygon[extrude[{tracepts[[-1]], f[c,θ]},-.3]]},

{FaceForm[knifecolor],Polygon[f[#,θ]&/@ {c, c-{.08,0, r2} , c-{-.08,0, r2}}];
Polygon[f[#,θ]&/@ extrude[{c, c-{.08,0, r2} , c-{-.08,0, r2},c}, -.3]];
Polygon[f[#,θ]&/@ extrude[circle3D[{-((Sqrt[2])-1)(Sqrt[3])/2,0,1-((Sqrt[2])-1)/2},(Sqrt[2])-1,{ -π /6  ,π/6 },5],-0.3  ]],
Polygon[f[#,θ]&/@ extrude[circle3D[{-((Sqrt[2])-1)(Sqrt[3])/2- .75,0,1-((Sqrt[2])-1)/2},((Sqrt[2])-1)2.7,.34{ -π /6  ,π/6 },5],-0.3 ]]}}},
Sequence @@ FilterRules[{opts}, Options[Graphics3D]],ViewAngle->Pi/12,ViewPoint->vp,ImageSize->400, SphericalRegion->True,Lighting->Automatic, Boxed->False,
AxesLabel->{"x","y",""},PlotRange->{{-2.3,2.3},{-0.6 ,3.1}, {-1.4,2.75}}]]

Rolling Circles

COA Code

.  Discovering the Cycloid

SpinAndSlide[Movie->False]

Animate[Graphics[{
{EdgeForm[{Black, Thick}],Gray,Disk[{t,1}]},Line[{{-1,0},{7,0}}]}],{t,0,2 π}]

cycloid[t_]:={t-Sin[t],1-Cos[t]}
Animate[Graphics[
{{EdgeForm[{Black, Thick}],Gray,Disk[{t,1}]},Line[{{-1,0},{7,0}}],{Thick,Line[{{t,1},cycloid[t]}]}}],{t,0,2 π}]

Module[{frames=30,locus,t},
locus=Table[cycloid[t],{t,0,2 π,((2 π)/(frames-1))}];Animate[t=((i 2 π)/(frames-1));Graphics[{{EdgeForm[{Black, Thick}],Gray,Disk[{t,1}]},Line[{{-1,0},{7,0}}],{Thick,Line[{{t,1},locus[[i+1]]}]},{PointSize[Large],Point[Take[locus,i+1]]}},PlotRange->{{-1.5,7.5},{-0.2,2.2}},Frame->True,FrameTicks->None],{i,0,frames-1,1}]]

Nest[(Sqrt[1+#])&,2,10]

Nest[(Sqrt[1.+#])&,2,10]

pts=Map[cycloid, Range[0,2 π,2 π/3.]]

Module[{cycloid,frames,locus,t},
cycloid[r_,t_]:={t-r Sin[t],1-r Cos[t]};
frames=30;
locus[r_]:=Table[cycloid[r,t],{t,0,3 π,3 π/(frames-1)}];

Manipulate[
t = i 3 π/(frames-1);
   Graphics[{{EdgeForm[{Black, Thick}],Gray,Disk[{t,1}]},
        Line[{{-1,0},{11,0}}],
       {Thick, Line[{{t,1},locus[r][[i+1]]}]},
       {PointSize[Medium], Point[Take[locus[r],i+1]]} },
  		PlotRange -> {{-1.5, 3 π+1.5},{-0.5, 2.6}},
		  Frame -> True,FrameTicks -> None], 
 {{i,0, "Time"},0,frames-1,1}, {{r,1,"Spoke length"},.7,1.3}]]

.  The Derivative of the Trochoid

trochoid[t_]:={t-1.3 Sin[t],1-1.3 Cos[t]};

f[t_]:=Nest[Sin,t,3]
Clear[t];fder[t_]:=Evaluate[f'[t]];

?fder

velocity[t_]:=Evaluate[trochoid'[t]]
ParametricPlot[velocity[t],{t,0,2 π}, PlotStyle->Thick]

vectors=Table[{trochoid[t],trochoid[t]+velocity[t]},{t,0,8,0.3}];
Graphics[{Thick,Line[vectors]}]

Graphics[{Circle[{1,0},1.3],Thick,Table[Arrow[{{0,0},velocity[t]}],{t,0.01,2 π,0.3}]}]

.  Abe Lincoln’s Somersaults

Graphics[Lincoln,Frame->True]

Shallow[Lincoln,5]

{2,3,{4,5},m[{6,7}]}/.{x_,y_}:>{(x^2),2 y}

{2,3,{{4,5},{1,2}},h[{6,7}]}/.{x_,y_}:>19

{2,3,{{4,5},{1,2}},h[{6,7}]}/.{x_Integer,y_}:>19

cycloid[t_]:={t-Sin[t],1-Cos[t]};
Module[{frames, locus,b,i,t},
frames=30;b=3 π/2;
locus=Table[cycloid[t],{t,0,b,(b/(frames-1))}];
Animate[t=((i b)/(frames-1));Graphics[{Circle[{t,1}],Line[{{-1,0},{7,0}}],Lincoln/.{x_?NumericQ,y_}:>RotationTransform[-t][{x,y}]+{t,1},{PointSize[Medium],Point[Take[locus,i+1]]}},PlotRange->All],{{i,0,"i"},frames-1,1}]]

Options[RoundRoad]={ShowLincoln->False,LocusPoints->30};

{lincQ,nloc}={ShowLincoln,LocusPoints}/.{opts}/.Options[RoundRoad];

RoundRoad::usage="RoundRoad[r, frames] creates an image of a round wheel rolling along a round road, with a locus of points corresponding to the positions of the initial touching point. The stationary wheel has radius 1 and the rolling wheel has radius r. If r < -1 the rolling wheel is on the inside of the stationary one.";
ShowLincoln::usage="ShowLincoln is an option to RoundRoad that, if the radius is set to +1, causes an image of Lincoln to appear on the wheels. This works only if the Lincoln data (at top of chapter) is loaded!";
LocusPoints::usage="LocusPoints is an option to ROundRoad that specifies the number of points in the locus.";

Options[RoundRoad]={ShowLincoln->False, LocusPoints->100};

RoundRoad[r_,opts___]:=Module[{lincQ,nloc,delt,centers,locus,p=r(1+Sign[r])},{lincQ, nloc}={ShowLincoln, LocusPoints}/.{opts}/.Options[RoundRoad];
delt=2π/(nloc-1);
centers=Table[(1+r){-Cos[t],Sin[t]},{t,0,2π,delt}];locus=centers+rTable[{Cos[-(1+1/r)t],Sin[-(1+1/r)t]},{t,0,2π,delt}];
Graphics[{{LightGray,EdgeForm[Black], Disk[{0,0}]},
PointSize[Small],{GrayLevel[0.5],EdgeForm[Thick],Disk[ {-1-r,0},Abs[r]]},Point[locus],If[lincQ&&r==1,{Lincoln,Lincoln/.{x_?NumericQ,y_}:>RotationTransform[(1+r)2π][{x,y}]+{-1-r,0}},{}]},Sequence@@FilterRules[{opts},Options[Graphics]],
PlotRange->{{-1.2-p,1.2+p},{-1.2-p,1.2+p}}]]

GraphicsGrid[{
{RoundRoad[1,ShowLincoln->True],RoundRoad[(1/4)]},
{RoundRoad[-(1/4)],RoundRoad[-(1/2)]}}]

Module[{Δt,centers,locus,θ},
Manipulate[
Δt=2.π/(nloc-1);θ=i Δt;
centers=Table[(1+r){-Cos[t],Sin[t]},{t,0,2π,Δt}];
locus=centers+rTable[{Cos[-(1+1/r)t],Sin[-(1+1/r)t]},{t,0,2π,Δt}];
Graphics[{Circle[{0,0}],If[ShowLincoln&&r==1,{Lincoln,Lincoln/.{x_?NumericQ,y_}:>RotationTransform[-(1+r)θ][{x,y}]+centers[[i+1]]},Line[{centers[[i+1]],locus[[i+1]]}]],PointSize[Small],Circle[centers[[i+1]],Abs[r]],Point[Take[locus,i+1]]},PlotRange->3.05],{{nloc,100,"Number points"},2,500,1},
{{i,nloc-1,"rotate"},0,nloc-1,1},
{{r,1, "Outer radius"},-1,1},{ShowLincoln, {True, False}}]]

.  The Cycloid’s Intimate Relationship with Gravity

Clear[t];
f[t_]:={t-Sin[t],Cos[t]-1};
norm[v_]:=(Sqrt[v.v]);
distanceOverSpeed=Simplify[((norm[f'[t]])/(Sqrt[2 g (f[t0][[2]]-f[t][[2]])]))]

timeIndefinite  = ∫distanceOverSpeed \[DifferentialD]t//PowerExpand

trigRules={Csc[((x_)/2)]:>((Sqrt[2])/(Sqrt[1-Cos[x]])),Cos[((x_)/2)]:>(Sqrt[ ((1+Cos[x])/2)])};
trigRulesReverse={Cos[x_]:>2 ((Cos[x/2])^2)-1};
logRule=(Log[a_+I b_]:>Log[(Sqrt[(a^2)+(b^2)])]+I ArcTan[b/a]);arctanRule=ArcTan[a_ b_]:>(π/2)-ArcCos[(a/(Sqrt[(a^2)+((((1/b)))^2)]))];

timeRaw1 = timeIndefinite  /.trigRules/. logRule  //Simplify

timeRaw2=timeRaw1-((I Log[1+Cos[t0]]-π)/(Sqrt[g]))//Simplify

timeRaw3 = timeRaw2 /.arctanRule //Simplify

timeRaw4 = timeRaw3 /. trigRulesReverse //PowerExpand

GeneralDescentTime=timeRaw4/.Sec[x_]:>1/HoldForm[Cos[x]]

(2/(Sqrt[g]))ArcCos[((Cos[(t/2)])/(Cos[((Subscript[t, 0])/2)]))]            (*)

GeneralDescentTime/.t-> π

t/.Last[Solve[GeneralDescentTime==time,t]] //Quiet

Tautochrone[t0_,npts_]:=Module[{g=9.8,posns,f,cycloidPlot,tPar,t1,Δt},
t1=π/(Sqrt[g]);
Δt=(t1/(npts-1.));
f[t_]:={t-Sin[t],Cos[t]-1};
tPar[time_,tInit_]:=2 ArcCos[Cos[(tInit/2)] Cos[(((Sqrt[g]) time)/2)]];
posns={
Table[f[tPar[time,t0]],{time,0,t1,Δt}],Table[f[2 π-tPar[time,0]],{time,0,t1,Δt}]};

Show[Graphics[{PointSize[Medium],
Table[{{Gray,Point[posns[[1]]]},Point[posns[[2]]],Line[{{π,-2.1},{π,-1.8}}]}, {i,1,npts}]}],ParametricPlot[f[s],{s,0,2 π}],PlotRange->{{-0.2,2 π+0.2},{-2.2,0.2}},Frame->True,FrameTicks->None]]

GraphicsGrid[{{Tautochrone[0,15]},{Tautochrone[1,15]},{Tautochrone[2,15]},{Tautochrone[2.5,15]}}]

Needs["Units`"]

Convert[(Sqrt[32.])Foot/Second, Mile/Hour]

cycloid[t_]:={t-Sin[t],1-Cos[t]}
cycloidI[t_]:={t-Sin[t],Cos[t]-1}
cycPlots=ParametricPlot[{cycloid[t],cycloidI[t]},{t,0,π}];
pts=cycloid/@Range[0,π,(π/20.)];
lowPts=pts/.{x_?NumericQ,y_}:>{x,-y};
Show[Graphics[{Line[{{-0.4,0},{4.2,0}}],{GrayLevel[0.9],EdgeForm[Black],Table[Disk[{c,1}], {c, 0, π, π/20}]},

PointSize[Medium],Point[pts],Point[lowPts],Line[Transpose[{pts,lowPts}]]}],cycPlots]

y[t_,d_]:=-2 ((((t/π)))^(1/d))

Plot[Table[y[t,d],{d,1,8}],{t,0,π},Frame->True,PlotStyle->{Black, Thick}]

g = 9.8;
h[t_,d_]:=Evaluate[((Sqrt[1+((D[y[t,d],t])^2)])/(Sqrt[-2 g y[t,d]]))]

TableForm[data=Table[{d,NIntegrate[h[t,d],{t,0,π}]},{d,1,8}],TableHeadings->{None,{"Polynomial Degree","Descent Time"}}]

th = Thickness[1.4];
Grid[Prepend[data, {"Polynomial degree", "Descent time"}], Background->LightGray, Dividers->{{th,Thin,th},{th,th,Thin,Thin,Thin,Thin,Thin,Thin,Thin,th}}, BaseStyle->{FontFamily->"Times",10}, Spacings->{3,0.6}, Alignment->Center]

Plot[NIntegrate[h[t,d],{t,0,π}],{d,1,8},
	Frame->True,Axes->None,
	GridLines->{None,{π/(Sqrt[g])}},PlotRange->{0.95, 1.22},
	Epilog->{PointSize[Large],Point[data]}]

Show[%,PlotRange->{{2,3},{1.01,1.017}}, GridLines->{{2.274},{}}]

obj[d_Real] :=NIntegrate[h[t,d],{t,0,π}];
 FindMinimum[obj[d],{d,2}]

.  Bicycles, Square Wheels, and Square-Hole Drills

The Square Wheel

RollingSquare[Movie->False]

Drilling a Square Hole

SquareHole[100]

r2=2-(Sqrt[2]);{a,b,c}={{-1,0},{1,0},{0,1}};s=2((Sqrt[2])-1);end=a+(Sqrt[2]);
im[θ_]:=(rot=RotationTransform[θ,{0,1}];
translate=TranslationTransform[Which[
0≤θ≤π/4,-{Cos[θ]+Sin[θ]-1,0},π/4≤θ≤π/2,-{(Sqrt[2])-1,-Cos[θ]-Sin[θ]+(Sqrt[2])},π/2≤θ≤3π/4,-{(Sqrt[2])-1,-Cos[θ]+Sin[θ]-2+(Sqrt[2])},
3π/4≤θ≤π,-{-Cos[θ]+Sin[θ]-1,-2+2(Sqrt[2])},π≤θ≤5π/4,-{Cos[θ]+Sin[θ]+1,-2+2(Sqrt[2])},
5π/4≤θ≤3π/2,-{-(Sqrt[2])+1,-Cos[θ]-Sin[θ]+(Sqrt[2])-2},3π/2≤θ≤7π/4,-{-(Sqrt[2])+1,-Cos[θ]+Sin[θ]+(Sqrt[2])},7π/4≤θ≤2π,-{-Cos[θ]+Sin[θ]+1,0}]];
rotF[e_]:=GeometricTransformation[e,rot];
translateF[e_]:=GeometricTransformation[e,translate];
f[z_]:=translate[rot[z]];
Graphics[{{RGBColor[0.55,1,1],EdgeForm[{Thin,Black}],Rectangle[{-1,-((Sqrt[2])-1)},{-1,-((Sqrt[2])-1)}+2]},
{RGBColor[1,1,0.3],Rectangle[c-{s/2,s},c+{s/2,0}]},
Thickness[0.004],
rotor=N@{Circle[c,(Sqrt[2]),{-3π/4,-π/4}],Circle[a,2,{0,π/4}],Circle[b,2,{3π/4,π}],Circle[c,r2,{π/4,3π/4}]};
translateF[rotF[rotor]],
translateF[rotF[Circle[c,r2]]],
translateF[rotF[Line[{{end{-1,1},c,end},{a,c,b,a}}]]],
tracepts=Take[
{c,{1-(Sqrt[2]),1},{1-(Sqrt[2]),3-2(Sqrt[2])},{(Sqrt[2])-1,3-2(Sqrt[2])},{(Sqrt[2])-1,1}},2+Quotient[θ-π/4,π/2]];
{Thick,Red,Line[tracepts],Line[{tracepts[[-1]],f[c]}]},
{translateF[rotF[Polygon[{c,c-{0.08,0.2}0.8,c-0.8{-0.08,0.2}}]]]}},ImageSize->150,PlotRange->{{-1.12,1.12},{-0.53,1.7}}]);
GraphicsGrid[Partition[Table[im[t],{t,{0,π/4-0.3,π/4,π/4+0.3,3π/4,3.3}}],2]]

PerfectSquareHole

SquareHoleThreeDimensionalDrill[]

im1=SquareHoleDrillImage[1.4,ViewPoint->{-2,.2,0.3}, ViewAngle->0.4];
im2=SquareHoleDrillImage[1.4,ViewPoint->{-.3,-2,0.35}, ViewAngle->0.4];
GraphicsRow[{im1, im2}]

ParametricPlot[{Sin[θ] (-τy Cos[θ]+τx Sin[θ]),(1/2) (2+τy+τy Cos[2 θ]-τx Sin[2 θ])}/.Thread[{τx,τy}->translateFcn[θ][{0,0,1}][[{1,3}]]-{0,1}],{θ,0,2 π}]

Focus on a Solid Bicycle Wheel

CameraSimulation

Focus on a Spoked Bicycle Wheel

SpokedBicyclePhotograph

A Curious Bicycle Track

unitVec[v_]:=(v/(Sqrt[v.v]));

FrontTrack[rear_,t_]:=rear+unitVec[D[rear,t]];
rear={t,Sin[t]+(t/10)-Cos[(t/2)]};

ParametricPlot[Evaluate[{rear,FrontTrack[rear,t]}],{t,0,3 π},Frame->True,Axes->False,FrameTicks->None,PlotRange->{{1,9},{-1,3}}]

p1=Plot[Evaluate[Table[D[(E^(-(1/x))),{x,i}],{i,0,3}]],{x,0,0.5},Frame->True,PlotRange->{-0.1,1},Axes->False, PlotStyle->Thick]

f[x_]:=(E^(-(1/x)));
f[0] =Limit[f[x], x->0];
fder[0][x_]:=f[x];
fder[n_][0]:=Limit[((fder[n-1][h]-fder[n-1][0])/h),h->0];
fder[n_][x_]:=(fder[n-1])'[x];

fder[5][x]
fder[5][0]

Table[fder[n][0],{n,15}]

finn[1][t_]:={t,(E^(-(1/(t(1-t)))))};
finn[1][0|0.]={0,0};
finn[1][1|1.]={1,0};

ParametricPlot[finn[1][t],{t,0,1},PlotRange->{{0,1},{-.2,.2}},PlotStyle->Thick, Frame->True]

Do[finn[i][t_]:=Evaluate[FrontTrack[finn[i-1][t],t]];
finn[i][0|0.]={i-1,0};
finn[i][1|1.]={i,0},{i,2,4}];

finn[2][t]

Table[Count[finn[i][t],((_)^(_)),∞],{i,4}]

cols={Red,Green,Blue,Orange};
track=Quiet[ParametricPlot[Evaluate[Table[finn[i][t],{i,4}]],{t,0,1},PlotStyle->Table[{Thick,cols[[i]]},{i,4}]]];
Show[track,Graphics[{PointSize[0.015],Point[Table[{i,0},{i,4}]]}],Frame->True,Axes->None,PlotRange->{{-0.2,4.2},{-1.5,1.8}},FrameTicks->{Range[0,4],Range[-1,1],None,None}]

Show[track,Graphics[
{{Thickness[0.006],MapIndexed[Line[{finn[Min[#2[[1]],3]][#1],finn[Min[#2[[1]],3]+1][#1]}]&,{0.38,0.71,0.17, 0.85}]}}],PlotRange->{{-0.2,4.2},{-1.5,1.8}},Axes->False,Frame->True]

Manipulate[tt=Floor[t]+1;Show[track,Graphics[{Thickness[0.01],Line[{finn[tt][t-tt+1],finn[tt+1][t-tt+1]}]}],Frame->True,FrameTicks->None,Axes->False,PlotRange->{{-0.2,5},{-2,2}}],{t,0,2.99}]