Rigid Square Twists

4/26/03-4/27/03  by Thomas Hull
OK.  Yesterday I managed to animate a single vertex folding rigidly.  And at the request of sarah-marie, I also did an example that doesn't work: a degree 4 vertex with plane angles all 90 degrees and all mountain creases.  It's cool to see how it self-intersects!  Those animations are all in the "Square 1 vertex rigid.nb" file.

Now I'm going to try starting the arduous process of getting the homogeneous coordinate matricies and such for the complete, multivertex square twist crease pattern.

First we need to define a function that will turn a homogeneous coordinates polygon into a regular 3D polygon which Mathematica can draw:

Clear[dum,n];
Trunc[dum_,n_]:=Table[Drop[dum[[k]],-1],{k,1,n}]

Then we gotta define the polygons for the square twist crease pattern.  (F1 is the one that will remain fixed during the folding process.) These are on homogeneous coordinates, which is why everything has an extra 1 at the end.

F[1]={{0,0,0,1}, {1/4,0,0,1}, {1/4,1/2,0,1},{0,1/2,0,1}};
F[2]={{1/4,0,0,1},{1/2,0,0,1}, {1/2,1/4,0,1}, {1/4,1/2,0,1}};
F[3]={{1/2,0,0,1}, {1,0,0,1}, {1,1/4,0,1}, {1/2,1/4,0,1}};
F[4]={{1/2,1/4,0,1}, {1,1/4,0,1}, {1,1/2,0,1}, {3/4,1/2,0,1}};
F[5]={{3/4,1/2,0,1}, {1,1/2,0,1}, {1,1,0,1}, {3/4,1,0,1}};
F[6]={{1/2,1,0,1}, {1/2,3/4,0,1}, {3/4,1/2,0,1}, {3/4,1,0,1}};
F[7]={{0,1,0,1}, {0,3/4,0,1}, {1/2,3/4,0,1}, {1/2,1,0,1}};
F[8]={{0,1/2,0,1}, {1/4,1/2,0,1}, {1/2,3/4,0,1}, {0,3/4,0,1}};
F[9]={{1/4,1/2,0,1}, {1/2,1/4,0,1}, {3/4,1/2,0,1}, {1/2,3/4,0,1}};
Show[Graphics3D[Table[Polygon[Trunc[F[k],4]],{k,1,9}], PlotRange->{{-.25,1.25}, {-.25,1.25}, {-1,1}}]]

Now let's define the fundamental matrix transformations we'll need.  These are all right out of the "Modelling folding in three dimensions using affine transformations" paper that I wrote with sarah-marie.  They are:
B = translate by the vertex {vx,vy,vz}
H = rotate the y-z plane by angle x
A = rotate the x-y plane by angle x
χ = the composition of these which models folding along an arbitrary crease.  Here, x = the folding angle (= π - the dihedral angle of the fold), a = the "position angle", which is how much you have to rotate the x-axis by to move it in the position of the crease (assuming the vertex is at the origin), and {vx,vy} are the coordinates of the vertex the crease is connected to.  (Yes, some creases are connected to 2 vertices (remember, we don't count vertices on the boundary as real vertices), and in those cases we can pick either, as long as we're being consistent...).  Then χ does the following:  translate the vertex to the origin, rotate the crease line to the x-axis, rotate the y-z plane by the folding angle, rotate the x-y plane so the crease line is back in its original position, and finally translate the vertex back to where it came from.

B[vx_,vy_,vz_]={{1,0,0,vx},{0,1,0,vy}, {0,0,1,vz}, {0,0,0,1}};
H[x_]={{1,0,0,0},{0,Cos[x],-Sin[x],0},{0,Sin[x],Cos[x],0}, {0,0,0,1}};
A[x_]={{Cos[x],-Sin[x],0,0},{Sin[x],Cos[x],0,0},{0,0,1,0}, {0,0,0,1}};
χ[x_,a_,vx_, vy_]:=B[vx,vy,0].A[a].H[x].A[-a].B[-vx,-vy,0];

Now, Robert Lang's dihedral angle equations should still work here, meaning that one dihedral angle should determine all of the others.  The hard part is figuring out which equation to use where, given the MV assignment I want to follow in this version of the square twist...

But waitaminute.  We only have to keep track of two angles: γ1=γ3 and γ4 = 2π-γ2.  Now, γ1 is parameterized by t, so I'll just use t for that.  I'll let γ4 be the other one.

Clear[t,a1,a2]
a1=π/4;
a2=π/2;
γ4[t_]=Simplify[2π-ArcCos[Cos[t]-((Sin[t])^2*Sin[a1]*Sin[a2])/(1-(Cos[a1]*Cos[a2]+Sin[a1]*Sin[a2]*Cos[t]))]];
γ2[t_]=Simplify[2π-γ4[t]];

Now then, the matrix computations that handled faces F2, F9, and F8 in the single vertex experiment should be exactly the same here (except we have to add the translation vertex).
The other faces, F3, F4, F5, F6, and F7 will be determined by an artibrary vertex-avoiding path that we take from F1 to these faces.  Of course, we want to keep this as simple as possible.  So here are the paths I'll use:

for F3:  F1 -> F2 -> F3
for F4: F1-> F2 -> F3 -> F4
for F5: F1 -> F2 -> F3 -> F4 -> F5
for F6: F1 -> F2 -> F9 -> F6
for F7: F1 -> F8 -> F7

I'll use this space to test whether or not any of this is working...

t=2;
NewF[2]=Table[χ[π-γ4[t],3π/2, 1/4,1/2].F[2][[k]],{k,1,4}];
NewF[9]=Table[χ[π-γ4[t],3π/2,1/4,1/2].χ[π-t,-π/4,1/4,1/2].F[9][[k]],{k,1,4}];
NewF[8]=Table[χ[π-γ4[t],3π/2,1/4,1/2].χ[π-t,-π/4, 1/4,1/2].χ[π-γ2[t],π/4,1/4,1/2].F[8][[k]],{k,1,4}];
NewF[3]=Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].F[3][[k]],{k,1,4}];
NewF[4]=Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].χ[π-t, 0, 1/2, 1/4].F[4][[k]],{k,1,4}];
NewF[5]=Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].χ[π-t, 0, 1/2, 1/4].χ[π-(2π-t),0,3/4,1/2].F[5][[k]],{k,1,4}];
NewF[6]=Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-t,-π/4,1/4,1/2].χ[π-(2π-t), 7π/4, 1/2, 3/4].F[6][[k]],{k,1,4}];
NewF[7]=Table[χ[2π-(π-t), π, 1/4, 1/2].χ[π-t, π, 1/2,3/4].F[7][[k]], {k, 1,4}];
NewF[1]=F[1];
Show[Graphics3D[Table[Polygon[Trunc[NewF[k],4]],{k,1,9}], PlotRange->{{-.25,1.25}, {-.25,1.25}, {-1,1}}]]

OK now!  Here's the animation!

Mov=Table[  
Show[Graphics3D[{EdgeForm[Thick],
Polygon[Trunc[Table[χ[π-γ4[t],3π/2, 1/4,1/2].F[2][[k]],{k,1,4}],4]],
Polygon[Trunc[Table[χ[π-γ4[t],3π/2,1/4,1/2].χ[π-t,-π/4,1/4,1/2].F[9][[k]],{k,1,4}],4]],
Polygon[Trunc[ Table[χ[π-γ4[t],3π/2,1/4,1/2].χ[π-t,-π/4, 1/4,1/2].χ[π-γ2[t],π/4,1/4,1/2].F[8][[k]],{k,1,4}],4 ]],
Polygon[Trunc[ Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].F[3][[k]],{k,1,4}] ,4]],
Polygon[Trunc[ Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].χ[π-t, 0, 1/2, 1/4].F[4][[k]],{k,1,4}],4 ]],
Polygon[Trunc[Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-γ2[t], 3π/2, 1/2, 1/4].χ[π-t, 0, 1/2, 1/4].χ[π-(2π-t),0,3/4,1/2].F[5][[k]],{k,1,4}],4  ]],
Polygon[Trunc[Table[χ[π-γ4[t],3π/2, 1/4,1/2].χ[π-t,-π/4,1/4,1/2].χ[π-(2π-t), 7π/4, 1/2, 3/4].F[6][[k]],{k,1,4}] ,4 ]],
Polygon[Trunc[ Table[χ[2π-(π-t), π, 1/4, 1/2].χ[π-t, π, 1/2,3/4].F[7][[k]], {k, 1,4}],4 ]],
Polygon[Trunc[F[1],4]]},
PlotRange->{{-.25,1.25}, {-.25,1.25}, {-1,1}}]]
, {t,0,π, .1}]

Now, the following routine outputs the frames to JPEG files, so that we can make a movie out of them using Quicktime Pro.

Do[
  Display["sqtw" <> ToString[t] <> ".jpg",
    Show[Graphics3D[{
Polygon[Trunc[Table[χ[π-γ4[t*.1],3π/2, 1/4,1/2].F[2][[k]],{k,1,4}],4]],
Polygon[Trunc[Table[χ[π-γ4[t*.1],3π/2,1/4,1/2].χ[π-(t*.1),-π/4,1/4,1/2].F[9][[k]],{k,1,4}],4]],
Polygon[Trunc[ Table[χ[π-γ4[t*.1],3π/2,1/4,1/2].χ[π-(t*.1),-π/4, 1/4,1/2].χ[π-γ2[t*.1],π/4,1/4,1/2].F[8][[k]],{k,1,4}],4 ]],
Polygon[Trunc[ Table[χ[π-γ4[t*.1],3π/2, 1/4,1/2].χ[π-γ2[t*.1], 3π/2, 1/2, 1/4].F[3][[k]],{k,1,4}] ,4]],
Polygon[Trunc[ Table[χ[π-γ4[t*.1],3π/2, 1/4,1/2].χ[π-γ2[t*.1], 3π/2, 1/2, 1/4].χ[π-(t*.1), 0, 1/2, 1/4].F[4][[k]],{k,1,4}],4 ]],
Polygon[Trunc[Table[χ[π-γ4[t*.1],3π/2, 1/4,1/2].χ[π-γ2[t*.1], 3π/2, 1/2, 1/4].χ[π-(t*.1), 0, 1/2, 1/4].χ[π-(2π-(t*.1)),0,3/4,1/2].F[5][[k]],{k,1,4}],4  ]],
Polygon[Trunc[Table[χ[π-γ4[t*.1],3π/2, 1/4,1/2].χ[π-(t*.1),-π/4,1/4,1/2].χ[π-(2π-(t*.1)), 7π/4, 1/2, 3/4].F[6][[k]],{k,1,4}] ,4 ]],
Polygon[Trunc[ Table[χ[2π-(π-(t*.1)), π, 1/4, 1/2].χ[π-(t*.1), π, 1/2,3/4].F[7][[k]], {k, 1,4}],4 ]],
Polygon[Trunc[F[1],4]]},
PlotRange->{{-.25,1.25}, {-.25,1.25}, {-1,1}}],
      DisplayFunction -> Identity],
    "JPEG"],
{t,1,32}]

Export["sqtwist.gif",Mov,ImageSize->Medium,ImageResolution->300]