Discrete Whitney-Grauenstein.

Exit[]

Get[FileNameJoin[{$HomeDirectory,"CoBarSLink","CoBarSLink.m"}]];

The Whitney-Grauenstein theorem says that we can deform a curve to another planar curve with the same winding number by regular homotopy: a homotopy between regular parametrizations through regular parametrizations. If the two curves have the same arclength, we may do so through arclength-parametrized curves.

We now give an example of the discrete version proved in class: two polygons with the same edgelengths and winding number may be deformed to one another through polygon of the same edgelengths. We are going to want to go back and forth between polygon and edge angles.

$HomeDirectory

ClearAll[ToPolygon];ToPolygon[e_]:= Standardize[Prepend[Accumulate[e],{0.,0.}],Mean,1&]

ClearAll[ToEdges];ToEdges[p_]:= Rest[p - RotateRight[p]]

ClearAll[EdgeLengths]; EdgeLengths[p_]:= Norm /@ ToEdges[p];

Now we’re going to take the point of view that angles are always measured in the shorter direction.

ClearAll[SignedAngle];SignedAngle[{u_,v_}]:= Sign[Det[{u,v}]]VectorAngle[u,v]

Now we can construct the tangent indicatrix of the polygon and use it to define the winding number. To do so, we sum the angles between consecutive edges. We do include the angle between the last edge and the first one (even if the polygon isn’t closed). The tantrix includes weights (which give the edge lengths), so each element is in the form “{edgelength,angle}”.

ClearAll[ToLiftedTantrix];ToLiftedTantrix[p_] := Block[{e},e = ToEdges[p];Transpose[{EdgeLengths[p],Accumulate[Join[{ArcTan@@e[[1]]},SignedAngle /@Partition[e,2,1]]]}
]
]

We can go back from the lifted tantrix to the polygon by creating and summing edges.

ClearAll[FromLiftedTantrix];FromLiftedTantrix[t_]:=ToPolygon[{#[[1]] Cos[#[[2]]],#[[1]] Sin[#[[2]]]}& /@ t];

Here’s a test:

P = RotateRight[1.0CirclePoints[17],7]; P = Append[P,First@P]; P = Standardize[P,Mean,1&];Graphics[{Line[P],{Red,Line[FromLiftedTantrix[ToLiftedTantrix[P]]]}},ImageSize->Small]

Now we can generate isotopies. The plan is to linearly interpolate between lifted tangent indicatrices.

We’ll start with a picture of a horse from Picasso’s one-line drawing:

Araw = {#[[1]],-#[[2]]}&/@ToExpression[Import[NotebookDirectory[]<>"/horse_polygon_mathematica.txt"]];

AEdited = RandomVariate[NormalDistribution[0,1],{89,2}]+Join[Araw[[27;;55]],Araw[[123;;182]]];

A=Standardize[RotateRight[Most@ConformalClosures[EdgeLengths[AEdited],{AEdited}]["ClosedPolygonVertexPositions"][[1]],28],Mean,1&];
AppendTo[A,First@A];

Graphics[{Line[A]}]

To make a comparable drawing with the same edgelengths, we construct a new lifted tangent indicatrix:

Block[{Blt},Blt =FromLiftedTantrix[Transpose[{ToLiftedTantrix[A][[All,1]],Accumulate[Standardize[Table[0.1Cos[t],{t,1.0Subdivide[π,87]}],Mean,1&]]}]
];
B = (ConformalClosures[EdgeLengths[Blt],{Blt}]["ClosedPolygonVertexPositions"][[1]]);
]

Graphics[Line[B]]

Now we can do the interpolation by simply linearly interpolating between the (lifted) angles:

ClearAll[PolygonFamily];PolygonFamily[A_,B_]:= Block[{tA,tB},
tA = ToLiftedTantrix[A]; tB = ToLiftedTantrix[B];
tB = {#[[1]],tA[[1,2]]-tB[[1,2]] + #[[2]]}& /@ tB;
ConformalClosures[EdgeLengths[A],
Table[
FromLiftedTantrix[(1-t)*tA + t tB],
{t,1.0Subdivide[1024]}
]
]["ClosedPolygonVertexPositions"]
]

Here’s the video:

PolygonPath[A_,B_]:= Block[{pf},
pf = PolygonFamily[A,B];
AnimationVideo[
Graphics[{Line[pf[[i,All]]],{PointSize[Medium],Point /@ pf[[i,All]]}},
PlotRange->Transpose[List@@BoundingRegion[Join@@pf]]
],{i,1,Length[pf],1},DefaultDuration->10]
]

horseVideo = PolygonPath[A,B]

Export[NotebookDirectory[]<>"/horse-unfolding.mp4",horseVideo]

Export[NotebookDirectory[]<>"/horse-unfolding.gif",horseVideo]

Next up, we try two examples with winding number 4:

Equilateralize[p_]:= (ConformalClosures[ConstantArray[1.0,Length[p]-1],{ToPolygon[Normalize /@ ToEdges[p]]}])["ClosedPolygonVertexPositions"][[1]]

A = Equilateralize[Table[{6 Cos[θ]+2Cos[4θ],6 Sin[θ]+ 2Sin[4θ]},{θ,1.0Subdivide[2π,95]}]];
Graphics[Line[A],ImageSize->Small]

B = Equilateralize[Table[{6 Cos[θ]+2Sin[4θ],6 Sin[θ]+2 Cos[4θ]},{θ,Reverse[1.0Subdivide[2π,95]]}]];
Graphics[Line[B],ImageSize->Small]

loopsVideo = PolygonPath[A,B]

Export[NotebookDirectory[]<>"/loop-unfolding.mp4",loopsVideo]

Export[NotebookDirectory[]<>"/loop-unfolding.gif",loopsVideo]