Whirl

Author

Eric W. Weisstein
September 6, 2007

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Graphics/Whirl.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Whirl.html.

©2007 Wolfram Research, Inc. except for portions noted otherwise

Code

Pursuit[l_List,{t_,t1_},v_:1]:=Module[
{s,a,vars,pairs,n=Length[l],soln,eqns},
vars=Map[#[t]&,Array[a,{n,2}],{2}];
pairs=Partition[vars,2,1,1];
eqns=Join[
Thread[D[Last[#],t]==v (s=Subtract@@#)/Norm[s]]&/@pairs,
(Equal@@@Transpose[Flatten/@({Map[#[0]&,Array[a,{n,2}],{2}],l})])
];
soln=NDSolve[Evaluate[eqns],Flatten[vars],{t,0,t1}];
Partition[Map[Last,soln,{2}][[1]],2]
]

Vertices[n_]:=Through[{Cos,Sin}[2π#/n]]&/@Range[0,n-1]

MiceProblem[n_,t1_,v_:1]:=Module[{t},Pursuit[Vertices[n],{t,t1},v]/.t->t1]

Whirl[n_,{t0_,t1_,dt_},opts___?OptionQ]:=Module[
{
t,
cf=ColorFunction/.{opts}/.ColorFunction->White,
ef=EdgeStyle/.{opts}/.EdgeStyle->Black,
ac=AlternatingColor/.{opts}/.AlternatingColor->False,
i=0
},
Graphics[{EdgeForm[ef],Table[{If[ac&&Mod[i++,2]==0,Black,If[cf===White,White,cf[t]]],Polygon[MiceProblem[n,t]]},{t,t0,t1,dt}]}]
]

Interactive

Manipulate[Whirl[n,{0,θ,dθ},ColorFunction->color,EdgeStyle->edgestyle,AlternatingColor->altcolor],
{{n,3},3,8,1},{{θ,1},0,2},
{{dθ,.04},.01,.5},
{{color,ColorData["DarkRainbow"]},Join[{White->"White",Delimiter},Thread[ColorData[#]->#]&/@ColorData["Gradients"]]},
{{altcolor,False},{True,False}},
{{edgestyle,Black},
{None,Delimiter,Black->"Black",White->"White"},ControlType->PopupMenu}]

Graphics

Black and White

GraphicsArray[Whirl[#,{0,#/3,.1}]&/@Range[3,6],ImageSize->500]

GraphicsArray[Whirl[#,{0,#/3,.1},AlternatingColor->True,EdgeStyle->None]&/@Range[3,6],ImageSize->500]

GraphicsArray[Graphics[Whirl[#,{0,#/3,.05}]]&/@Range[3,6],ImageSize->500]

GraphicsArray[Whirl[#,{0,#/3,.05},AlternatingColor->True,EdgeStyle->None]&/@Range[3,6],ImageSize->500]

Color

GraphicsArray[Whirl[#,{0,#/3,.1},ColorFunction->ColorData["Rainbow"]]&/@Range[3,6],ImageSize->500]

GraphicsArray[Whirl[#,{0,#/3,.1},EdgeStyle->None,ColorFunction->ColorData["Rainbow"]]&/@Range[3,6],ImageSize->500]

GraphicsArray[Whirl[#,{0,#/3,.1},AlternatingColor->True,EdgeStyle->None,ColorFunction->ColorData["Rainbow"]]&/@Range[3,6],ImageSize->500]