Spirals of curvature

The direction of the Plane Curve (on the left) is determined at each point by the Curvature function (on the right)

- Marcus McGuff, Austin Community College

Manipulate[Refresh[If[var===Null,Clear[var];var["computePlotrange"]=plotrange;var["highrect"]={}];
If[kText===Null,
curvatureFunctions={{ToBoxes[s],{{-2,2},{-1.5,1.5}},{{-20,20}, {-20,20}}},
{ToBoxes[s Sin[s]],{{-2,2},{0,5}},{{-20,20}, {-20,20}}},
{ToBoxes[(E^s)+(E^(-s))],{{-2/3,2/3},{0,0.8}},{{-5,5},{0,150}}},
{ToBoxes[Abs[s Sin[Sin[s]]]],{{-3,3},{0,1.9}},{{-40,40},{0,40}}}
};
kText=curvatureFunctions[[1,1]]],None];

var["imagesize"]=300;

(* Use examples provided if it was chosen *)
Refresh[
If[MemberQ[curvatureFunctions[[All,1]],kText],plotrange=Part[curvatureFunctions[[Flatten@Position[curvatureFunctions[[All,1]],kText]]],1,2];
Thread[{minS,maxS}=Part[curvatureFunctions[[Flatten@Position[curvatureFunctions[[All,1]],kText]]],1,3,1]];
Thread[curvaturerange[[2]]=Part[curvatureFunctions[[Flatten@Position[curvatureFunctions[[All,1]],kText]]],1,3,2]]
],TrackedSymbols:>{kText}];

Thread[curvaturerange[[1]]={minS,maxS}];


(* Finds parameters in kEq and yEq, then writes the replacement rules for them; can specify exclusion cases here 

If you add additional equations (yEq, etc.), don't forget to include a yEq control at the bottom as well as a yText and add in yEq near kEq below *)

(* Convert input text boxes into expressions in TraditionalForm*)
kEq=ToExpression[kText,TraditionalForm];
params=SortBy[Thread[Rule[#,Replace[#,Join[params,{_->0.}],1]]],First]&[Cases[Level[{kEq},-1],sy_Symbol/;And[FreeQ[{s},sy],FreeQ[Attributes[sy],Locked|Constant]]]];



(* Main graphics stuff here 
Usable domains from user interaction:
Not refreshed DURING drag proces
{x,Part[var["computePlotrange"],1,1],Part[var["computePlotrange"],1,2]},{y,Part[var["computePlotrange"],2,1],Part[var["computePlotrange"],2,2]}

Can also reference plotrange directly for better look/worse performance during drag

Don't forget to apply /.params to kEq/yEq, etc. before using
*)


Row[{Dynamic@EventHandler[With[{sol=({x[s],y[s]}/.First[NDSolve[{x'[s]==Cos[t[s]],y'[s]==Sin[t[s]],t'[s]==(kEq/.params) ,x[0]==0,y[0]==0,t[0]==0},{x,y,t},{s,curvaturerange[[1,1]],curvaturerange[[1,2]]}]])},Tooltip[ParametricPlot[sol,{s,curvaturerange[[1,1]],currentPos},
Epilog->{Red,PointSize[Medium],Point[sol/.s->currentPos]},
ImageSize->parSize,PlotStyle->Red,PlotPoints->90,
Background->Yellow,PlotRange->If[MemberQ[curvatureFunctions[[All,1]],kText],plotrange,Full],PlotLabel->"Plane Curve",
ColorFunction->(ColorData["DarkRainbow"][(kEq/.params/.s->#3)]&)],MousePosition["Graphics"]]],

{"MouseClicked":>
Switch[mouseMode[],
"pan",None,
"zoomIn",None,
"zoomOut",None,
"special",None],
"MouseDown":>
(readMouse["start"];
Switch[mouseMode[],
"pan",None,
"zoomIn",None,
"zoomOut",None,
"special",None]
),
"MouseDragged":>
(readMouse["end"];
Switch[mouseMode[],
"pan",(plotrange=plotrange-Apply[Subtract,-plotrange,1](var["endScaled"]-var["startScaled"]);
readMouse["start"]),
"zoomIn",var["highrect"]={Opacity[0.2],Blue,Rectangle[var["start"],var["end"]]},
"zoomOut",var["highrect"]={Opacity[0.2],Red,Rectangle[var["start"],var["end"]]},
"special",None]
),
"MouseUp":>(Switch[mouseMode[],
"pan",None,
"zoomIn",If[var["highrect"]=!={},
plotrange=Sort/@Transpose[var/@{"start","end"}]],
"zoomOut",If[var["highrect"]=!={},
plotrange=1/Abs[(var["endScaled"]-var["startScaled"])]plotrange],
"special",None];
var["highrect"]={};
readMouse["start"];
var["computePlotrange"]=plotrange)}
]," ",

Dynamic@EventHandler[
Plot[Tooltip[Evaluate[kEq/.params],Text@Style[Row[{"κ = ",If[Length[MousePosition["Graphics"]]>1,kEq/.params/.s->MousePosition["Graphics"][[1]]]}]]],{s,curvaturerange[[1,1]],currentPos},
Epilog->{Red,PointSize[Medium],Point[Evaluate[{currentPos,(kEq/.params/.s->currentPos)}]]},ImageSize->Round[0.7*300],
AspectRatio->0.5,PlotStyle->Thickness[0.01],PlotPoints->30,Background->Green,PlotLabel->"Curvature", PlotRange-> If[MemberQ[curvatureFunctions[[All,1]],kText],curvaturerange,Automatic],ColorFunction->(ColorData["DarkRainbow"][(kEq/.params/.s->#1)]&)],

{"MouseClicked":>
Switch[mouseMode[],
"pan",None,
"zoomIn",None,
"zoomOut",None,
"special",None],
"MouseDown":>
(readMouse["start"];
Switch[mouseMode[],
"pan",None,
"zoomIn",None,
"zoomOut",None,
"special",None]
),
"MouseDragged":>
(readMouse["end"];
Switch[mouseMode[],
"pan",(plotrange=plotrange-Apply[Subtract,-plotrange,1](var["endScaled"]-var["startScaled"]);
readMouse["start"]),
"zoomIn",var["highrect"]={Opacity[0.2],Blue,Rectangle[var["start"],var["end"]]},
"zoomOut",var["highrect"]={Opacity[0.2],Red,Rectangle[var["start"],var["end"]]},
"special",None]
),
"MouseUp":>(Switch[mouseMode[],
"pan",None,
"zoomIn",If[var["highrect"]=!={},
plotrange=Sort/@Transpose[var/@{"start","end"}]],
"zoomOut",If[var["highrect"]=!={},
plotrange=1/Abs[(var["endScaled"]-var["startScaled"])]plotrange],
"special",None];
var["highrect"]={};
readMouse["start"];
var["computePlotrange"]=plotrange)}]}]
,

(* 2 ways to enter input - popup or text *)
OpenerView[{Control[{{kText,,"Curvature κ(s) = "},(#->ToExpression[#,StandardForm,TraditionalForm])&/@curvatureFunctions[[All,1]],ControlType->PopupMenu}],

Dynamic@If[StringCases[$InstallationDirectory,"Player"]=={},Grid[{{Control[{{kText,,"κ(s) = "},TraditionalForm[InputField[Dynamic[kText],Boxes]]&}],SpanFromLeft},
{Control[{{minS,-5,"Start: "},-50,0,Appearance->"Labeled",ImageSize->Small}],
Control[{{maxS,5,"End: "},0,50,Appearance->"Labeled",ImageSize->Small}]}}],
Text@Style[
"Extra input options not available in the free Mathematica Player; to enter your own equations, you must be using a full version of Mathematica",Italic]]}],

{kEq,ControlType->None},

Row[{Control@{{currentPos,Dynamic@minS,"Draw: "},Dynamic[Evaluate[minS+0.00001(maxS-minS)]],Dynamic@maxS,ControlType->Animator,AnimationRepetitions->1,DefaultDuration->20,AnimationDirection->Forward},Control@{{parSize,300,"Picture Size"},100,600,10}}],

(* Produces sliders dynamically for parameters *)
Item[Column[{"Parameters",Dynamic[Grid[MapIndexed[{params[[First@#2,1]],Manipulator[Dynamic[params[[First@#2,2]]],{-1,1},Appearance->"Labeled"]}&,params]]]}],ControlPlacement->Bottom],
{{params,{}},ControlType->None},

(* Used for built-in scrolling/zoom - can reference directly or use var["computePlotrange"] for better performance during drags *)
{{plotrange,{{-5,5},{-5,5}}},ControlType->None},

{{curvaturerange,{{Dynamic@minS,Dynamic@maxS},{-5,5}}},ControlType->None},

{curvatureFunctions,None},

(* temporary holding variable *)
{var,ControlType->None},

Initialization:>(mouseMode[]:=Switch[CurrentValue/@{"ShiftKey","CommandKey"},
{False,False},"special",
{True,False},"pan",
{False,True},"zoomIn",
{True,True},"zoomOut"];
readMouse[startOrEnd_]:=(var[startOrEnd]=MousePosition["Graphics"];
var[startOrEnd<>"Scaled"]=MousePosition["GraphicsScaled"])
)]