(******************************************************************* This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialization Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) QuadraticCurve::usage= "QuadraticCurve[{{a,b},{c,d},{e,f}}] creates a list of graphics objects \ for the quadratic curve beginning at {a,b}, passing through {c,d} and ending \ at {e,f}. If Arrows->True, it then draws an arrow pointing towards {e,f} if \ Up->True and towards {a,b} if Up->False. CurveThickness is the absolute \ thickness of the curve (this probably only affects things if Ribbon->False). \ The arrow is controlled by the following options: ArrowLength is the length \ of the two line segments that make up the arrow (currently this is a \ coordinate length, not an absolute length); ArrowAngle is the angle these \ lines make with the tangent to the curve; ArrowLocation is the value of the \ parameter t where the arrow is to be drawn (t=0 at {a,b}, .5 at {c,d} and 1 \ at {e,f}); ArrowThickness is the absolute point size of the arrow. If \ Ribbon->True, the edges are drawn as ribbons, and the arrows as triangles. \ RibbonWidth is the coordinate width of the ribbon; RibbonPointCount is the \ number of edges used on each side of the polygon that is drawn to produce the \ ribbon; RibbonColor is the ribbon color. A box is drawn around the ribbon, \ but there are options Front and Back which control whether the front of the \ box (the end at {e,f}) and the back of the box (the end at {a,b}) are drawn."; Options[QuadraticCurve]={Arrows->False,ArrowThickness->.25,ArrowLength->.11, ArrowAngle->Pi/6,ArrowLocation->.6,Ribbon->False,RibbonWidth->.03, RibbonPointCount->100,RibbonColor->GrayLevel[.85],Up->True, CurveThickness->.25,Front\[Rule]True, Back\[Rule]True}; QuadraticCurve[{{a_,b_},{c_,d_},{e_,f_}},opts___?OptionQ]:= Module[{coefs,fx,fy,unittangent,unitnormal,arrowvector,loc,arrows, arrowlength,arrowthickness,arrowangle,arrowlocation,ribbon,ribbonwidth, ribbonpointcount,ribboncolor,up,curvethickness,front, back},{arrows,arrowlength,arrowthickness,arrowangle,arrowlocation, ribbon,ribbonwidth,ribbonpointcount,ribboncolor,up,curvethickness, front,back}={Arrows,ArrowLength,ArrowThickness,ArrowAngle, ArrowLocation,Ribbon,RibbonWidth,RibbonPointCount,RibbonColor,Up, CurveThickness,Front,Back}/.{opts}/.Options[QuadraticCurve]; If[ribbon,arrowlength+=ribbonwidth/(2Sin[arrowangle])]; coefs={2#\[LeftDoubleBracket]3\[RightDoubleBracket]-4#\[LeftDoubleBracket]2\ \[RightDoubleBracket]+2#\[LeftDoubleBracket]1\[RightDoubleBracket],-#\ \[LeftDoubleBracket]3\[RightDoubleBracket]+4#\[LeftDoubleBracket]2\ \[RightDoubleBracket]-3#\[LeftDoubleBracket]1\[RightDoubleBracket],#\ \[LeftDoubleBracket]1\[RightDoubleBracket]}&/@{{a,c,e},{b,d,f}}; {fx,fy}=Function[t,{t^2,t,1}.#]&/@coefs; loc=If[up,arrowlocation,1-arrowlocation]; unittangent[ t_]:=(#/Sqrt[#.#])&[(2t #\[LeftDoubleBracket]1\[RightDoubleBracket]+#\ \[LeftDoubleBracket]2\[RightDoubleBracket])&/@coefs]; unitnormal[ t_]:={-#\[LeftDoubleBracket]2\[RightDoubleBracket],#\ \[LeftDoubleBracket]1\[RightDoubleBracket]}&@unittangent[t]; arrowvector=-arrowlength(unittangent[loc]); {AbsoluteThickness[curvethickness], If[ribbon, With[{L1= Table[{fx[t],fy[t]}+ribbonwidth*unitnormal[t],{t,0,1, 1/ribbonpointcount}], L2=Table[{fx[t],fy[t]}-ribbonwidth*unitnormal[t],{t,1, 0,-1/ribbonpointcount}]},{ribboncolor,Polygon[Join[L1,L2]], Sequence@@GrayStyle,Line[L1],Line[L2], If[back,Line[{{fx[0],fy[0]}- ribbonwidth*unitnormal[0],{fx[0],fy[0]}+ ribbonwidth*unitnormal[0]}],{}], If[front, Line[{{fx[1],fy[1]}-ribbonwidth*unitnormal[1],{fx[1],fy[1]}+ ribbonwidth*unitnormal[1]}],{}]}], Cases[ ParametricPlot[{fx[t],fy[t]},{t,0,1}, DisplayFunction->Identity],_Line,Infinity]], If[arrows,{AbsoluteThickness[arrowthickness], If[ribbon, EdgedPolygon[ Flatten[{{{fx[loc],fy[loc]}},#,{{fx[loc],fy[loc]}}},1], ribboncolor,GrayStyle], Line[{{fx[loc],fy[loc]},#}]&/@#]&@({fx[ loc]+{Cos[#],-Sin[#]}.arrowvector, fy[loc]+{Sin[#],Cos[#]}.arrowvector}&/@ If[up,{arrowangle,-arrowangle},{Pi+arrowangle, Pi-arrowangle}])},{}]}] graph1[w_,h_,psize_,whisk_,off_,step1_,step2_,thickness_,angle_,len_]:= With[{},points=Flatten[Table[{x,y},{y,-h,0},{x,Mod[y,2],2w-Mod[y,2],2}],1]; ArrowLine[{a_,b_},opts___?OptionQ]:= Module[{mid,dir},mid=(a+b)/2; dir=(b-a)/Sqrt[(b-a).(b-a)]; {Line[{a,b},opts], Line[{mid- len*{{Cos[angle],Sin[angle]},{-Sin[angle],Cos[angle]}}.dir, mid,mid-len*{{Cos[angle],-Sin[angle]},{Sin[angle], Cos[angle]}}.dir},opts]}]; SetOptions[QuadraticCurve,Arrows\[Rule]True, ArrowThickness\[Rule]thickness,ArrowLength\[Rule]len, ArrowAngle\[Rule]angle,ArrowLocation->.6,Ribbon->False,RibbonWidth->.03, RibbonPointCount->100,RibbonColor->GrayLevel[.85],Up->True, CurveThickness\[Rule]thickness,Front\[Rule]True, Back\[Rule]True]; Show[Graphics[{GrayLevel[0],AbsoluteThickness[.25], AbsoluteDashing[{0.25,2}],AbsolutePointSize[psize], Map[Line,Table[{{n,0+whisk},{n,-2h-whisk}},{n,0,2 w}]],GrayLevel[0], Dashing[{0}],AbsoluteThickness[thickness],Point/@points, Map[(x=#[[1]]; y=#[[2]];{If[x==0||y==-h,Line[{{x,y},{x,y}-whisk*{1,1}}], ArrowLine[{{x,y},{x-1,y-1}}]], If[x\[Equal]2w||y==-h,Line[{{x,y},{x,y}+whisk*{1,-1}}], ArrowLine[{{x,y},{x+1,y-1}}]], If[y\[Equal]0,{Line[{{x,y},{x,y}+whisk*{1,1}}], Line[{{x,y},{x,y}+whisk*{-1,1}}]},{}], If[x\[Equal]0,Line[{{x,y},{x,y}+whisk*{-1,1}}], If[x\[Equal]2w,Line[{{x,y},{x,y}+whisk*{1,1}}],{}]]})&, points],Map[(x=#[[1]]; y=#[[2]];{QuadraticCurve[{{x,y},{x+.5,y+off},{x+1,y}}], QuadraticCurve[{{x+1,y},{x+.5,y-off},{x,y}}],Point[{x,y}], Point[{x,y-step2}],Line[{{x,y-step2},{x+1,y-step2}}]})&, Table[{n,-h-step1},{n,-1,2w}]]}], PlotRange\[Rule]{{-whisk,2w+whisk},{whisk,-h-step1-step2-whisk}}, AspectRatio\[Rule]Automatic]] particle[t_,h_,w_,off_]:= Module[{tab},tab=Table[{{x,-h},{x+1,-h}},{x,0,2w-1}]; tab[[t+1]]={{t,-h},{1+t,-h-off}}; tab[[t+2]]={{1+t,-h-off},{2+t,-h}}; AppendTo[tab,{{t,-h},{1+t,-h+off}}]; AppendTo[tab,{{1+t,-h+off},{2+t,-h}}]; AppendTo[tab,{{1+t,-h-off},{1+t,-h+off}}];{Point/@Union[Flatten[tab,1]], Line/@tab}] graph2[w_,h_,psize_,whisk_,off_,step1_,step2_,d_,thickness_,angle_,len_]:= Module[{x,y}, points=Flatten[Table[{x,y},{y,-h,0},{x,Mod[y,2],2w-Mod[y,2],2}],1]; ArrowLine[{a_,b_},opts___?OptionQ]:= Module[{mid,dir},mid=(a+b)/2; dir=(b-a)/Sqrt[(b-a).(b-a)]; {Line[{a,b},opts], Line[{mid- len*{{Cos[angle],Sin[angle]},{-Sin[angle],Cos[angle]}}.dir, mid,mid-len*{{Cos[angle],-Sin[angle]},{Sin[angle], Cos[angle]}}.dir},opts]}]; SetOptions[QuadraticCurve,Arrows\[Rule]True, ArrowThickness\[Rule]thickness,ArrowLength\[Rule]len, ArrowAngle\[Rule]angle,ArrowLocation->.6,Ribbon->False,RibbonWidth->.03, RibbonPointCount->100,RibbonColor->GrayLevel[.85],Up->True, CurveThickness\[Rule]thickness,Front\[Rule]True, Back\[Rule]True]; Show[Graphics[{GrayLevel[0],AbsoluteThickness[.25], AbsoluteDashing[{0.25,2}],AbsolutePointSize[psize], Map[Line, Table[{{n,0+whisk},{n,-h-step1-step2(h+1)-whisk}},{n,0,2 w}]], GrayLevel[0],Dashing[{0}],AbsoluteThickness[thickness], Point/@points, Map[(x=#[[1]]; y=#[[2]];{If[x==0||y==-h,Line[{{x,y},{x,y}-whisk*{1,1}}], ArrowLine[{{x,y},{x-1,y-1}}]], If[x\[Equal]2w||y==-h,Line[{{x,y},{x,y}+whisk*{1,-1}}], ArrowLine[{{x,y},{x+1,y-1}}]], If[y\[Equal]0,{Line[{{x,y},{x,y}+whisk*{1,1}}], Line[{{x,y},{x,y}+whisk*{-1,1}}]},{}], If[x\[Equal]0,Line[{{x,y},{x,y}+whisk*{-1,1}}], If[x\[Equal]2w,Line[{{x,y},{x,y}+whisk*{1,1}}],{}]]})&, points], Point/@Table[{2-y,y-d},{y,0,-h,-1}], ArrowLine/@ Flatten[Table[{{{2-y,y-d},{2-y+i,y-1-d*(i+1)/2}},{{2-y+i, y+1-d(1-i)/2},{2-y,y-d}}},{y,0,-h+1,-1},{i,-1,1,2}],2], ArrowLine[{{3+h,-h+1},{2+h,-h-d}}], Line[{{2+h,-h-d}+(whisk-d)*{-1,-1},{2+h,-h- d},{2+h,-h-d}+(whisk-d)*{1,-1}}], particle[#,h+step1+step2#,w,.4]&/@ Range[h+1],{Line[{{-whisk,#},{0,#}}], Line[{{2w,#},{2w+whisk,#}}]}&/@ Range[-h-step1-step2,-h-step1-step2*(h+1),-step2], Table[Text[n,{-2whisk,-n+1}],{n,1,h+1}], Table[Text[n,{-2whisk,-n*step2-h-step1}],{n,1,h+1}] }],PlotRange\[Rule]{{-1,2w+whisk},{whisk,-3h-whisk}}, AspectRatio\[Rule]Automatic, DefaultFont\[Rule]{"UniverseCondensedLight-Italic",4.5}]] Graph3D[w_,h_,psize_,whisk_,step1_,angle_,len_,viewpoint_]:= Module[{c,s,rot1,rot2,points,makelines,n1,n2},n1=viewpoint[[1]]; n2=viewpoint[[2]];c=n2/Sqrt[n1^2+n2^2];s=n1/Sqrt[n1^2+n2^2]; rot1={{c,s,0},{-s,c,0},{0,0,1}}.{{Cos[angle],0,Sin[angle]},{0,1, 0},{-Sin[angle],0,Cos[angle]}}.{{c,-s,0},{s,c,0},{0,0,1}}; rot2={{c,s,0},{-s,c,0},{0,0,1}}.{{Cos[angle],0,-Sin[angle]},{0,1, 0},{Sin[angle],0,Cos[angle]}}.{{c,-s,0},{s,c,0},{0,0,1}}; ALine[{a_,b_},opts___?OptionQ]:= Module[{mid,dir},mid=(a+b)/2; dir=(b-a)/Sqrt[(b-a).(b-a)];{Line[{a,b},opts], Line[{mid-len*rot1.dir,mid,mid-len*rot2.dir}]}]; points= Flatten[Table[{x,y,z},{z,0,-h,-1},{x,-w,w},{y,-w+Mod[z+x+w,2], w-Mod[z+x+w,2],2}],2]; dir={{1,0,-1},{-1,0,-1},{0,1,-1},{0,-1,-1}}; makelines[p_]:= Table[If[Max[Take[Abs[p+dir[[i]]],2]]>w||p[[3]]==-h, Line[{p,p+whisk*dir[[i]]}],ALine[{p,p+dir[[i]]}]],{i,1, Length[dir]}]; maketopwhisk[p_]:= Table[If[Max[Take[Abs[p-dir[[i]]],2]]>w||p[[3]]==0, Line[{p,p-whisk*dir[[i]]}],{}],{i,1,Length[dir]}]; Show[Graphics3D[{GrayLevel[0],AbsoluteThickness[.25], AbsoluteDashing[{0.25,2}],AbsolutePointSize[psize], Map[Line, Flatten[Table[{{n,m,whisk},{n,m,-h-step1-whisk}},{n,-w,w},{m,-w, w}],1]],GrayLevel[0],Dashing[{0}],AbsoluteThickness[.25], makelines/@points,maketopwhisk/@points,Point/@points, points=Flatten[Table[{x,y,-h-step1},{x,-w,w},{y,-w,w}],1]; makelines[p_]:= Table[If[Max[Take[Abs[p+dir[[i]]],2]]>w||p[[3]]==-h, Line[{p,p+whisk*dir[[i]]}],Line[{p,p+dir[[i]]}]],{i,1, Length[dir]}];dir={{1,0,0},{-1,0,0},{0,1,0},{0,-1,0}}; makelines/@points,Point/@points}], ViewPoint->viewpoint,AspectRatio\[Rule]Automatic,Boxed\[Rule]False]]