Elliptical Ma-Schlenker c-Octahedra

John C. Bowers and Philip L. Bowers

This notebook provides a visualization of the elliptical flow Ma-Schlenker c-Octahedra from [1]. To run the code, either evaluate the entire notebook, or evaluate the Code: sections first and then the Visualization: sections as desired.

References

[1] J. C. Bowers and P. L. Bowers. Ma-Schlenker c-Octahedra in the 2-sphere. Preprint. June, 2016.

Code: Inversive Distance Computation

F1[x1_, y_]:=(x1^2 + y^2) / (2 x1);
F2[x2_, y_]:=(x2^2 + y^2) / (2 x2);

R1[x1_, y_]:=x1 - F1[x1, y];
R2[x2_, y_]:=x2 - F2[x2, y];

α[x1_, y_]:=(x1+y)/(x1-y);

T[z_, x1_, y_]:=α[x1, y] (z - y) / (z + y);
Tinv[z_, x1_, y_]:= -y (z + α[x1, y])/(z - α[x1, y]);

A1[t_, x1_, y_] := Tinv[E^(I t), x1, y];
A2[t_, x1_, x2_, y_]:=Tinv[E^(I t) T[x2, x1, y], x1, y];

R[t_, x1_, x2_, y_]:= R1[x1, y] R2[x2, y] (A2[t, x1, x2, y] - A1[t, x1, y]) / (R2[x2, y](A1[t, x1, y] - F1[x1, y])+R1[x1, y](A2[t, x1, x2, y] - F2[x2, y]));

U[t_, x1_, x2_, y_]:=(A1[t, x1, y] - F1[x1, y])/R1[x1, y];

Z[t_, x1_, x2_, y_]:=F1[x1, y] + (R1[x1, y] + R[t, x1, x2, y]) U[t, x1, x2, y];

InvD[t_, x1_, x2_, y_]:= (1/2) (Abs[Sqrt[3] Z[t, x1, x2, y] - I] / R[t, x1, x2, y])^2 - 1;

Code: Helper Functions

ComplexToR2[z_]:={Re[N[z]],Im[N[z]]};
RotateZ[z_]:=(z-I/Sqrt[3])E^(2 Pi I / 3) + (I/Sqrt[3]);

Visualization: Flow and Inversive Distance Plot

Module[{}, 

Manipulate[

If[y < x1 && x1 < x2, 
{Graphics[
{
Circle[{F1[x1,y],0},R1[x1,y]],
Circle[{F2[x2,y],0},R2[x2,y]],

Black,
Circle[ComplexToR2[RotateZ[F1[x1,y]]],R1[x1,y]],
Circle[ComplexToR2[RotateZ[F2[x2,y]]],R2[x2,y]],

Black,
Circle[ComplexToR2[RotateZ[RotateZ[F1[x1,y]]]],R1[x1,y]],
Circle[ComplexToR2[RotateZ[RotateZ[F2[x2,y]]]],R2[x2,y]],

Blue,
Circle[ComplexToR2[Z[t, x1, x2, y]],R[t, x1, x2, y]],
Circle[ComplexToR2[RotateZ[Z[t, x1, x2, y]]],R[t, x1, x2, y]],
Circle[ComplexToR2[RotateZ[RotateZ[Z[t, x1, x2, y]]]],R[t, x1, x2, y]],

Gray,
Dashed,
Circle[{1,0}, 1],
Circle[ComplexToR2[RotateZ[1]], 1],
Circle[{-1, 0}, 1]
}
],
Show[
Plot[InvD[x, x1, x2, y], {x, mint, maxt}],Graphics[{PointSize[Large],Orange,Point[{t,InvD[t, x1, x2, y]}]}]
]
},
Graphics[Text["Please select y, x1, x2 so that y < x1 < x2."]]
]
, {{t, 0}, -10, 10}, {{y, 0.5}, 0, 1}, {{x1, 2}, 0.5, 4}, {{x2,6}, 1, 10},{{mint, -6.4},-100,0},{{maxt,8.6},1,100}
]
]

Visualization: Extreme Points

We first find the minimum near t = 0 and maximums near t = 0 and t = 4 for x1 = 2 and x2 = 6 and y = 0.5.

x1Param = 2;
x2Param = 6;
yParam = 0.5;
max1 = FindMaximum[InvD[t, x1Param, x2Param, yParam], {t,0.5}]
max2 = FindMaximum[InvD[t, x1Param, x2Param, yParam], {t,4}]
min1 = FindMinimum[InvD[t, x1Param, x2Param, yParam], {t,0}]

We now visualize the circles at the computed max and min values :

Module[{x1 = 2, x2 = 6, y = 0.5, t1 =t/.max1[[2]],t2 = t/.max2[[2]], t3=t/.min1[[2]]}, 

Manipulate[
{
Graphics[
{
Circle[{F1[x1,y],0},R1[x1,y]],
Circle[{F2[x2,y],0},R2[x2,y]],

Black,
Circle[ComplexToR2[RotateZ[F1[x1,y]]],R1[x1,y]],
Circle[ComplexToR2[RotateZ[F2[x2,y]]],R2[x2,y]],

Black,
Circle[ComplexToR2[RotateZ[RotateZ[F1[x1,y]]]],R1[x1,y]],
Circle[ComplexToR2[RotateZ[RotateZ[F2[x2,y]]]],R2[x2,y]],

Blue,
Circle[ComplexToR2[Z[t1, x1, x2, y]],R[t1, x1, x2, y]],
Circle[ComplexToR2[RotateZ[Z[t1, x1, x2, y]]],R[t1, x1, x2, y]],
Circle[ComplexToR2[RotateZ[RotateZ[Z[t1, x1, x2, y]]]],R[t1, x1, x2, y]],

Darker[Green],
Circle[ComplexToR2[Z[t2, x1, x2, y]],R[t2, x1, x2, y]],
Circle[ComplexToR2[RotateZ[Z[t2, x1, x2, y]]],R[t2, x1, x2, y]],
Circle[ComplexToR2[RotateZ[RotateZ[Z[t2, x1, x2, y]]]],R[t2, x1, x2, y]],

Orange,
Circle[ComplexToR2[Z[t3, x1, x2, y]],R[t3, x1, x2, y]],
Circle[ComplexToR2[RotateZ[Z[t3, x1, x2, y]]],R[t3, x1, x2, y]],
Circle[ComplexToR2[RotateZ[RotateZ[Z[t3, x1, x2, y]]]],R[t3, x1, x2, y]],

}
],
Show[
Plot[InvD[x, x1, x2, y], {x, mint, maxt}],
Graphics[
{
PointSize[Large],Blue,Point[{t1,InvD[t1, x1, x2, y]}],
PointSize[Large],Darker[Green],Point[{t2, InvD[t2, x1, x2, y]}],
PointSize[Large],Orange,Point[{t3, InvD[t3, x1, x2, y]}]
}
]
]
}
,{{mint, -2.6},-100,0},{{maxt,10.2},1,100}
]
]