Dynamics on the Clebsch Surface (wmg/ajeet 7 February 2019)

SetDirectory[NotebookDirectory[]];
Quiet[
<< PrecomputedVisuals//Plucker//Plucker27Lines.m;
<< PrecomputedVisuals//Plucker//PluckerToolbox.m;
<< PrecomputedVisuals//Plucker//PluckerVisualization.m;
<< ../Toolboxes//DynamicsToolbox.m;
<< ../Toolboxes//Utilities.m;]

MyCubic=Import["PrecomputedVisuals//MyCubic.mx"];
MyCubicColoredLines=Import["PrecomputedVisuals//MyCubicColoredLines.mx"];
{KappaMin,KappaMax,StepSize, CubicPlotRange,CubicShadowPlotRange}=Import["PrecomputedVisuals//KappaInfo.mx"];

(*****FUNCTIONS*****)
NewLineFormatter[string_]:=If[StringLength[string]≤50,string,StringTake[string,50]<>"\n"<>NewLineFormatter[StringTake[string,{51,StringLength[string]}]]];(*****LINE COLORS *****)
fileToLoadDyn="No File Selected";
xyzColoring=Flatten[Map[Table[#,{k,1,8}]&,{Red,Blue,Green}]];
CLinesSchlafiColoring={Yellow,Yellow,Yellow,Yellow,Magenta,Cyan,Magenta,Cyan,Yellow,Yellow,Yellow,Yellow,Magenta,Cyan,Magenta,Cyan,Yellow,Yellow,Yellow,Yellow,Magenta,Cyan,Magenta,Cyan};
(***** ECKHARDT POINTS *****)
EckhardtPoints[zoom_]:={Cyan,Sphere[{{-2,-2,-2},{-2,2,2},{2, 2, -2},{2, -2, 2}},0.6*zoom]};
(***** TOGGLER BAR CONTROLS *****)
(* Instructions: TogglerBar lets you edit the list LinesOn easily. When you click a button, it Joins a list to LinesOn, and if you un-click it, it will remove that list from LinesOn. The list of 24 lines is hit with the subset operation [[LinesOn]], and just selects waht you want.
LinesOn defaults to Range[24], which then means All24Lines[[Range[24]]] will grab you all of them.
So, for example, if you want an option that just selects the first 5 lines, you add to the TogglerBar list {1,2,3,4,5}->"First Five" *)
LinesOn={Range[24]};
(***** LINES AND INTERSECTIONS *****)
NumberOfPencils=Round[((KappaMax-KappaMin)/StepSize)]+1;
TwoPointsAll24Lines=Range[NumberOfPencils];
Intersections=Range[NumberOfPencils];
For[i=1,i≤ NumberOfPencils,i+=1,
k=KappaMin+(i-1)*StepSize;
If[k≥2,
All24Lines=Join[PLinesZ[k],CLinesZ[k],PLinesY[k],CLinesY[k],PLinesX[k],CLinesX[k]];
TwoPointsAll24Lines[[i]]=Map[ExtendLineEndPoints[PluckerLineToTwoPointsInAffinePatch[#],2*CubicPlotRange]&,All24Lines];
Intersections[[i]]=
Table[
If[SkewQ[All24Lines[[l1]], All24Lines[[l2]]],
{},
IntersectionPointInAffinePatch[All24Lines[[l1]],All24Lines[[l2]]]],
{l1,Range[24]},{l2, Range[24]}];
];
];
(***** START OF MANIPULATE BLOCK *****)
Manipulate[
iter=Round[(k-KappaMin)/StepSize]+1;
MyStuffToShow={Opacity[MyCubicOpacity],MyCubic[[iter]]};
If[k≥2,
LinesOnFiltered=DeleteDuplicates[Flatten[LinesOn]];
(***** CREATING THE TUBE OBJECTS FOR THE LINES *****)
TubeWidth=0.17*Zoom;
GraphicsAll24LinesUncolored=Map[{Tube[#,TubeWidth]}&,TwoPointsAll24Lines[[iter]][[Range[24]]]];
GraphicsAll24Lines=Partition[Riffle[lineColoring,GraphicsAll24LinesUncolored],2];
(***** SHOW INTERSECTIONS CONIDTIONAL *****)
Switch[ShowIntersectionsQ,3,
MyStuffToShow={
{Opacity[MyCubicOpacity],MyCubic[[iter]]}, 
(GraphicsAll24Lines)[[LinesOnFiltered]],
{{White,Sphere[DeleteCases[Flatten[(Intersections[[iter]])[[LinesOnFiltered,LinesOnFiltered]],1],{}],0.6*Zoom]}},
If[k==18,EckhardtPoints[Zoom],{}]};,
2,
MyStuffToShow={
{Opacity[MyCubicOpacity],MyCubic[[iter]]}, 
(GraphicsAll24Lines)[[LinesOnFiltered]],
{{White,Sphere[DeleteCases[Flatten[(Intersections[[iter]])[[LinesOnFiltered,LinesOnFiltered]],1],{}],0.6*Zoom]}}},
1,
MyStuffToShow={
{Opacity[MyCubicOpacity],MyCubic[[iter]]}, 
(GraphicsAll24Lines)[[LinesOnFiltered]],If[k==18,EckhardtPoints[Zoom],{}]};,
0 ,
MyStuffToShow={
{Opacity[MyCubicOpacity],MyCubic[[iter]]}, 
(GraphicsAll24Lines)[[LinesOnFiltered]]};
];
];
(***** ONE OCTANT RESTRICTION *****)
ZMin=If[k<-2,0,Sqrt[k+2]];
exportMe=Graphics3D[{MyStuffToShow},PlotRange->If[RestrictPositiveQ,{{0,CubicPlotRange*Zoom},{0,CubicPlotRange*Zoom},{-ZMin,CubicPlotRange*Zoom}},CubicPlotRange*Zoom],ImageSize->500, Boxed->ShowBoxQ,Axes->ShowBoxQ,AxesLabel->{"x","y","z"},ViewPoint->{viewX,viewY,viewZ}]
(***** MANIPULATE CONTROLS *****)
,
Style["Lines on the Cubic Surface",17,Bold],
Delimiter,
Style["                     κ = (x^2) + (y^2) + z\!\(\*SuperscriptBox[\(\\ \), \(2\)]\)- xyz - 2",13],
{{k,18.0,Style["κ",13]},-4.0,30.0,StepSize},
{{MyCubicOpacity,1, "Cubic Opacity"},0,1,0.1},
{{Zoom,3/4,"Zoom"},1,1/30,0.01},
{{viewX,0},-5,5},{{viewY,-2},-5,5},{{viewZ,0},-5,5}, (*changed ViewY from 2 to -2, 4/15/2019 *)
Button["Reset",{k=18,MyCubicOpacity=1,Zoom=1/2,viewX=0,viewZ=0,viewY=2,ShowIntersectionsQ=2,ShowBoxQ=True,RestrictPositiveQ=False,LinesOn=Range[24],lineColoring=xyzColoring}],
{{ShowIntersectionsQ,2,"Intersections"},{3->"Both",2-> "All",1-> "Eckhardt",0->"None"}},
{{ShowBoxQ,True,"Show Box?"},{True-> "Yes",False-> "No"}},
{{RestrictPositiveQ,False,"X, Y > 0 ?"},{True-> "Yes",False-> "No"}},{{picName,"cubic.bmp","Pic Name"}},Button["Export Image",{Export[picName,exportMe,ImageResolution->200]}],
Button["Export View Data",{Export[StringTake[picName,{1,StringLength[picName]-4}]<>" data.mx",{k,MyCubicOpacity,Zoom,viewX,viewY,viewZ,ShowIntersectionsQ,ShowBoxQ,RestrictPositiveQ,LinesOn,lineColoring}]}],
Delimiter,Column[{Text[Style["Load in Image Data",{Bold}]],Row[{FileNameSetter[Dynamic[fileToLoadDyn]],Dynamic[NewLineFormatter[fileToLoadDyn]]}],Button["Load Data",{{k,MyCubicOpacity,Zoom,viewX,viewY,viewZ,ShowIntersectionsQ,ShowBoxQ,RestrictPositiveQ,LinesOn,lineColoring}=Import[fileToLoadDyn]}]}],
Delimiter,
Row[{TogglerBar[Dynamic[LinesOn], 
{{5}-> "(Subscript[CZ, +]^(+))",{6}-> "(Subscript[CZ, -]^(+))",{7}-> "(Subscript[CZ, +]^(-))",{8}-> "(Subscript[CZ, -]^(-))",
{13}-> "(Subscript[CY, +]^(+))",{14}-> "(Subscript[CY, -]^(+))",{15}-> "(Subscript[CY, +]^(-))",{16}-> "(Subscript[CY, -]^(-))",
{21}-> "(Subscript[CX, +]^(+))",{22}-> "(Subscript[CX, -]^(+))",{23}-> "(Subscript[CX, +]^(-))",{24}-> "(Subscript[CX, -]^(-))",
{1}-> "(Subscript[PZ, +]^(+))",{2}-> "(Subscript[PZ, -]^(+))",{3}-> "(Subscript[PZ, +]^(-))",{4}-> "(Subscript[PZ, -]^(-))",
{9}-> "(Subscript[PY, +]^(+))",{10}-> "(Subscript[PY, -]^(+))",{11}-> "(Subscript[PY, +]^(-))",{12}-> "(Subscript[PY, -]^(-))",
{17}-> "(Subscript[PX, +]^(+))",{18}-> "(Subscript[PX, -]^(+))",{19}-> "(Subscript[PX, +]^(-))",{20}-> "(Subscript[PX, -]^(-))",
Range[24]-> "All Lines",
{5,6,7,8,13,14,15,16,21,22,23,24}->"C Lines",
{1,2,3,4,9,10,11,12,17,18,19,20}->"P Lines"},Appearance->"Vertical"->{Automatic,8}]}],Delimiter,Style["C Lines Schläfli Double Six",10],Row[{TogglerBar[Dynamic[LinesOn], 
{{5,13,21,7,15,23}-> "First Sextuple",{6,14,22,8,16,24}->"Second Sextuple"  
(*,{1,2,3,4,9,10,11,12,17,18,19,20}->"P Lines (The Dozen)"*)
}, Appearance->"Vertical"->{Automatic,3}]}],Delimiter,{{lineColoring,xyzColoring,"Line Coloring Scheme"},{xyzColoring->"XYZ Coloring",CLinesSchlafiColoring->"C Lines Schläfli Coloring"}}
] (* End of Manipulate block *)