Triangular Orbits in Elliptic Billiards

© Dan S. Reznik, Ronaldo Garcia, Jair Koiller, May 2019

Idéias

To do intelligencer: show ellipse, conservation, open path, closed trajectory

Add cosine circle to p5.js

create p5.js w/ open trajectories and caustics

Utils

SetDirectory["C:\\Users\\drezn\\Dropbox\\Mathematica\\Billiards"];
newCentersFromFile=Get["data/x0001_0100-no-hold.m"]; 
(*//Drop[#,{30}]&;*)(*EULER INFINITY POINT*)

toDeg[r_]:=180.*r/π;
toRad[d_]:=π*d/180.;
Clear@negl;negl[v_]:=Abs[v]<10^-9;
Clear@safeDiv;
safeDiv[num_,denom_]:=If[negl[denom],0,num/denom];
magn2[v_]:=v.v;
magn[v_]:=Sqrt[magn2[v]];
flipY[{x_,y_}]:={x,-y};
flipX[{x_,y_}]:={-x,y};
perp[{x_,y_}]:={-y,x};
perpNeg[{x_,y_}]:={y,-x};
crossProduct[{x1_,y1_},{x2_,y2_}]:=-x2 y1 + x1 *y2;
refl[v_,n_]:=2(v.n)n/magn2[n]-v;
norm[v_]:=v/magn[v];
clamp[v_,max_:100]:=If[v>max,max,If[v<-max,-max,v]];
ray[p0_,phat_,d_]:=p0+phat*d;
Clear@rot;
rot[p_,st_,ct_]:=Module[{m},
m={{ct,-st},{st,ct}};
m.p];
rot[p_,t_]:=rot[p,Sin@t,Cos@t];
rotRel[p_,t_,p0_]:=p0+rot[p-p0,t];
getEquilateral[th_]:=Module[{s=Sin[2π/3.],c=Cos[2π/3.]},
NestList[rot[#,s,c]&,rot[{1.,0.},Sin@th,Cos@th],2]];

subscriptTxt[prefix_,sub_]:=ToString[Subscript[prefix,sub],StandardForm];
subscriptTxtClr[prefix_,sub_,clr_]:=ToString[Style[Subscript[prefix,sub],clr],StandardForm];
padZ[v_,n_:4]:=ToString@NumberForm[v,{n,0},NumberPadding->{"0",""},NumberPoint->""];

closestPerp[p_,l1_,l2_]:=Module[{dl=l2-l1,s},
s=safeDiv[(p-l1).dl,dl.dl];
ray[l1,dl,s]];

Clear@quadRoots;
quadRoots[a_,b_,c_]:=Module[{det=b^2-4a c,sqrtDet},
If[det<0,Print["quadRoots fail: {a,b,c}="<>ToString@{a,b,c}];False,
sqrtDet=Sqrt[det];{-b-sqrtDet,-b+sqrtDet}/(2a)]];
Clear@interRays;
interRays[p1_,n1_,p2_,n2_]:=Module[{m,b,sols},
m=Transpose[{n1,n2}];(*{{nx1,-nx2},{ny1,-ny2}};*)
If[negl[Det[m]],p1,
b=p2-p1;(*{x2-x1,y2-y1}];*)
sols=LinearSolve[m,b];
ray[p1,n1,sols[[1]]]]
];
interRaysIllConditioned[n1_,n2_]:=negl@Det@Transpose@{n1,n2};
interRaysUnprot[p1_,n1_,p2_,n2_]:=Module[{m,b,sols},
m=Transpose@{n1,n2};(*{{nx1,-nx2},{ny1,-ny2}};*)
b=p2-p1;(*{x2-x1,y2-y1}];*)
sols=LinearSolve[m,b];
ray[p1,n1,sols[[1]]]
];

Second[l_]:=l[[2]];
Third[l_]:=l[[3]];
Fourth[l_]:=l[[4]];
Fifth[l_]:=l[[5]];
Sixth[l_]:=l[[6]];
Seventh[l_]:=l[[7]];
Eighth[l_]:=l[[8]];
Nineth[l_]:=l[[9]];

signedArea[poly_]:=(1/2)Total@MapThread[(#1[[1]]#2[[2]]-#2[[1]]#1[[2]])&,{poly,RotateLeft@poly}];

Triangles

Clear@s;

cosHalfAngle[cosAngle_]:=Sqrt[(1.+cosAngle)/2];(* careful: plus or minus *)
sinHalfAngle[cosAngle_]:=Sqrt[(1.-cosAngle)/2];
tanHalfAngle[sinAngle_,cosAngle_]:=sinAngle/(1+cosAngle);
(* careful: plus or minus *)
cosDoubleAngle[cosAngle_]:=2*cosAngle*cosAngle-1.; (* cA^2-sA^2 = 2 cA^2-1 *)
sinDoubleAngle[sinAngle_]:=2*sinAngle*Sqrt[1.-sinAngle^2];(* 2 sA cA *)
sinDoubleAngle[sinAngle_,cosAngle_]:=2*sinAngle*cosAngle;(* 2 sA cA *)
(* gives cos(A) *)
lawOfCosines[a_,b_,c_]:=(b^2+c^2-a^2)/(2.b c);
lawOfCosines3[a_,b_,c_]:={lawOfCosines[a,b,c],lawOfCosines[b,c,a],lawOfCosines[c,a,b]};
getSin[theCos_]:=Sqrt[1.-theCos^2];
lawOfCosinesSymbol[a_,b_,c_]:=(b^2+c^2-a^2)/(2b c);
getSinSymbol[theCos_]:=Sqrt[1-theCos^2];
(* cos(3t) = cos(2t+t) = c2 c - s2t s; *)
(* sin(3t) = sin(2t+t) = s2 c + s c2 *)
sinCosTripleAngle[s_,c_,s2_,c2_]:=Module[{s3,c3},
c3=c2 c-s2 s;
s3=s2 c+s c2;
{s3,c3}];
cosTripleAngle[c_]:=4c^3-3c;
getSinCosApB[sa_,sb_,ca_,cb_]:={sa cb + sb ca ,ca cb - sa sb};
getSinCosAmB[sa_,sb_,ca_,cb_]:= {sa cb - sb ca,ca cb + sa sb};
getSinApmB[sa_,sb_,ca_,cb_]:= {sa cb + sb ca,sa cb - sb ca};

testCosTriple[t_]:=Module[{c,s3,c3,c3a,s,c2,s2},
{c,s}={Cos@t,Sin@t};
c3a=cosTripleAngle[c];
c2=cosDoubleAngle[c];
s2=sinDoubleAngle[s,c];
{s3,c3}=sinCosTripleAngle[s,c,s2,c2];
{c3a,c3}];

(*Plot[testCosTriple[t],{t,0,2π}]*)

cosDiffAngle[sa_,ca_,sb_,cb_]:=ca cb+sa sb;
cosSumAngle[sa_,ca_,sb_,cb_]:=ca cb-sa sb;
(* compute sin^2(A/2), by passing cosA *)
sin2HalfAngle[cosAngle_]:=(1-cosAngle)/2;(* sinHalfAngle[cos]^2 *)
cos2HalfAngle[cosAngle_]:=(1+cosAngle)/2;(* cosHalfAngle[cos]^2 *)

Clear@cosThird;
cosThird[cos_]:=Chop@N@Re[Module[{sin=Sqrt[1-cos^2]},
((cos+I sin)^(-1/3)+(cos+I sin)^(1/3))/2]];

Clear@getBisector;
getBisector[vbase_,v1_,v2_]:=Module[{v01,v02},
v01=norm[v1-vbase];
v02=norm[v2-vbase];
norm[v01+v02]];

Clear@getTriBisectors;
getTriBisectors[p1_,p2_,p3_]:=Module[{u12,u23,u31},
u12=norm[p2-p1];
u23=norm[p3-p2];
u31=norm[p1-p3];
{
norm[u12-u31],
norm[u23-u12],
norm[u31-u23]
}
];

export3[name_,plot_]:=Module[{subdir="pics/"},
Export[subdir<>name<>".pdf",plot];
Export[subdir<>name<>".eps",plot];
Export[subdir<>name<>".png",plot];
];

export4[name_,plot_]:=Module[{subdir="pics/"},
Export[subdir<>name<>".pdf",plot];
Export[subdir<>name<>".eps",plot];
Export[subdir<>name<>".png",plot];
Export[subdir<>name<>".svg",plot];
];

Circle

Clear@circleInter;
circleInter[c1_,r1_,c2_,r2_]:=Module[{d,x,y,chat},
d=magn[c2-c1];
chat=(c2-c1)/d;
x=(d^2-r2^2+r1^2)/(2d);
y=Sqrt[r1^2-x^2];
{c1+x chat+y perp[chat],c1+x chat-y perp[chat]}];

Manipulate[Module[{is},
is=circleInter[c1,1,c2,1.5];
Graphics[{Circle[c1,1],Circle[c2,1.5],Red,PointSize@Large,Point@is},PlotRange->{{-2,2},{-2,2}}]],
{{c1,{-1,-.5}},Locator},
{{c2,{1.25,.25}},Locator}]

Ellipse

Solve[(x/a)^2+(y/b)^2==1 ,y]//FullSimplify[#,a>0]&

ellEqn[a_,x_,y_]:=(x/a)^2+y^2-1;
ellEqnb[a_,b_,x_,y_]:=(x/a)^2+(y/b)^2-1;
ellGrad[a_,x_,y_]:=-{x,y a^2};(* (x/a)^2+y^2==1 *)
ellGradb[a_,b_,x_,y_]:=-2{x/a^2,y/b^2};(* (x/a)^2+y^2==1 *)
ellY[a_,x_]:=Sqrt[1-(x/a)^2];
ellYb[a_,b_,x_]:=b Sqrt[1-(x/a)^2];(*(x/a)^2+(y/b)^2==1 *);
ellError[a_,b_,{x_,y_}]:=(x/a)^2+(y/b)^2-1;
Clear@eccentricity;eccentricity[a_,b_]:=Sqrt[1-(b/a)^2];
ellPerimeterRamanujan2[a_,b_]:=Module[{h=((a-b)/(a+b))^2},
π(a+b)(1+3h/(10+Sqrt[4-3h]))];
ellPerimeterRamanujan[a_,b_]:=π(3(a+b)-Sqrt[(3a+b)(a+3b)]);
ellPerimeter[a_,b_]:=Module[{ecc=eccentricity[a,b]},4*a*EllipticE[ecc^2]];
ellArea[a_,b_]:=π a b;
focalDistance[a_,b_]:=Sqrt[a^2-b^2];
Clear@getFoci;getFoci[a_]:=Module[{c},If[a<1,c=Sqrt[1-a^2];{{0,c},{0,-c}},c=Sqrt[a^2-1];{{-c,0},{c,0}}]];
getFocib[a_,b_]:=b*getFoci[a/b];

(*ellRayCoeffs=Module[{r,eqn,sols},
r=ray[{x,y},{nx,ny},s];
eqn=FullSimplify[ellEqn[a,r[[1]],r[[2]]],Assumptions->a>0&&Abs[x]<=a&&(nx^2+ny^2==1)];
FullSimplify[a^2 CoefficientList[eqn,s],a>0]]*)

Clear@ellInterRay;
ellInterRay[a_,{x_,y_},{nx_,ny_}]:=Module[{c2,c1,c0,ss},
c2=(nx^2)+(a^2) (ny^2);
c1=2 (nx x+(a^2) ny y);
c0=(x^2)+(a^2) (-1+(y^2));
ss=quadRoots[c2,c1,c0];
If[ListQ[ss],
ray[{x,y},{nx,ny},#]&/@ss,
{{0,0},{0,0}}]
];

Used for Proofs

quadRootsUnprot[a_,b_,c_]:=Module[{det=b^2-4a c,sqrtDet},
sqrtDet=Sqrt[det];{-b-sqrtDet,-b+sqrtDet}/(2a)];Clear@ellInterRayUnprot;

ellInterRayUnprot[a_,{x_,y_},{nx_,ny_}]:=Module[{c2,c1,c0,ss},
c2=(nx^2)+(a^2) (ny^2);
c1=2 (nx x+(a^2) ny y);
c0=(x^2)+(a^2) (-1+(y^2));
ss=quadRootsUnprot[c2,c1,c0];
ray[{x,y},{nx,ny},#]&/@ss
];

(*ellRayCoeffsB=Module[{r,eqn,sols},
r=ray[{x,y},{nx,ny},s];
eqn=FullSimplify[ellEqnb[a,b,r[[1]],r[[2]]],Assumptions->a>0&&b>0&&Abs[x]<=a&&(nx^2+ny^2==1)];
Together/@FullSimplify[CoefficientList[eqn,s],a>0&&b>0]]*)

ellInterRaybUnprot[a_,b_,{x_,y_},{nx_,ny_}]:=Module[{c2,c1,c0,ss},
c2=(b^2) (nx^2)+(a^2) (ny^2);
c1=2 ((b^2) nx x+(a^2) ny y);
c0=-(a^2) (b^2)+(b^2) (x^2)+(a^2) (y^2);
ss=quadRootsUnprot[c2,c1,c0];
ray[{x,y},{nx,ny},#]&/@ss
];

Clear@ellInterRaybUnprotAny;
ellInterRaybUnprotAny[a_,b_,ctr_,axisA_,axisB_,p_,dir_]:=Module[{m,p0,dir0,inter0},
m={axisA,axisB};
p0=m.(p-ctr);
dir0=m.dir;
inter0=ellInterRaybUnprot[a,b,p0,dir0];
(Transpose[m].#+ctr)&/@inter0];

DynamicModule[{gr,xmax=2,ymax=2,axis1,axis2,t,interP1P2,lgt=.33},
Manipulate[
t=toRad@tDeg;
axis1={Cos@t,Sin@t};
axis2=perp@axis1;
interP1P2=ellInterRaybUnprotAny[a,b,ctr,axis1,axis2,p1,p2-p1];
gr=Graphics[{PointSize@Medium,
{Arrowheads@Medium,Arrow@{ctr,ctr+lgt axis1},Arrow@{ctr,ctr+lgt axis2}},
{Rotate[{Circle[ctr,{a,b}],Dashed,Line@{{-a,0},{a,0}},Line@{{0,-b},{0,b}}},t]},
{PointSize@Large,Blue,Point@interP1P2[[1]],Red,Point@interP1P2[[2]],Black,Line@interP1P2}
}];
Show[{gr},PlotRange->{{-xmax,xmax},{-ymax,ymax}}],
{{a,1.5},.5,2,.1,Appearance->"Labeled"},
{{b,1},.5,2,.1,Appearance->"Labeled"},
{{tDeg,30,"θ"},-180,180,.1,Appearance->"Labeled"},
{{ctr,{0,0}},Locator},
{{p1,{.5,.75}},Locator},
{{p2,{-.5,.25}},Locator}]]

(* works for circle: a==1 *)
Clear@ellTangents;
ellTangents[a_,p_]:=Module[{a2,px,py,px2,px3,py2,radicand,numFact,denomx,denomy},
{px,py}=p;
a2=a*a;
px2=px*px;py2=py*py;
px3=px*px2;
denomx=px3+a2 px py2;
denomy=px2+a2 py2;
radicand=px2+a2(py2-1);
numFact=Sqrt[radicand]*Abs[px];
(*["radicand=",radicand,", numFact=",numFact,", dx=",denomx,", dy=",denomy];*)
(* NOTE: the first one is Clockwise, the 2nd one is CCW *)
{{a2 safeDiv[px2+py numFact,denomx],safeDiv[a2 py-numFact,denomy]},
{a2 safeDiv[px2-py numFact,denomx],safeDiv[a2 py+numFact,denomy]}}
];

(* hack *)
(*tangsToCirc[ctr_,r_,p_]:=(ctr+r#)&/@ ellTangents[1.,(p-ctr)/r];*)

Clear@ellTangentsb;
ellTangentsb[a_,b_,p_]:=
Module[{a2,b2,px,py,px2,px3,py2,py3,radicand,numFact,denomx,denomy},
{px,py}=p;
a2=a*a;
b2=b*b;
px2=px*px;py2=py*py;
px3=px*px2;py3=py*py2;
denomx=b2 px2 +a2 py2;
denomy=b2 px2 py+a2 py3;
radicand= b2 px2+a2(py2-b2);
numFact=Sqrt[radicand]*Abs[py];
(*Print["radicand=",radicand,", numFact=",numFact,", dx=",denomx,", dy=",denomy];*)
(* NOTE: Reverse[] so first one is Clockwise, the 2nd one is CCW *)
Reverse@{{a2 safeDiv[b2 px- numFact,denomx],b2 safeDiv[a2 py2+px numFact,denomy]},
{a2 safeDiv[b2 px+ numFact,denomx],b2 safeDiv[a2 py2-px numFact,denomy]}}
];

Clear@tangsToCirc;
tangsToCirc[ctr_,R_,P_]:=Module[{d,t1,t2,xhat,yhat},
d=magn[P-ctr];
xhat=(P-ctr)/d;
yhat=perp[xhat];
If[d<R,t1=ctr+R xhat;{t1,t1},
t1={R,Sqrt[d^2-R^2]}/d;
t2=flipY@t1;
(ctr+R#.{xhat,yhat})&/@{t1,t2}]];

DynamicModule[{ts,gr},
Manipulate[
ts=tangsToCirc[ctr,R,P];
gr=Graphics[{PointSize@Large,Thick,
{Circle[ctr,R],Point@ctr,Point@P,Line@{ctr,P}},
{Red,Point@ts,Dashed,Line@{P,#}&/@ts,Line@ts},
MapThread[Text[Style[#1,20],#2,{-1.5,-1.5}]&,{{"O","P"},{ctr,P}}]}];
Show[{gr},PlotRange->{{-1.1,3},{-2,2}}],
{{R,1},.1,2,.01},
{{ctr,{0,0}},Locator},
{{P,{2,0}},Locator}]]

Hyperbola

hypC[a_,b_]:=a^2+b^2;
hypEqn[a_,b_,{x_,y_}]:=(x/a)^2-(y/b)^2==1;
hypErr[a_,b_,{x_,y_}]:=(x/a)^2-(y/b)^2-1;
hypGrad[a_,b_,{x_,y_}]:=-{x b^2,-y a^2};

hypParam[a_,b_,t_]:=Module[{x,y},
x=a Cosh[t];
y=b Sinh[t];
{{x,y},{-x,-y}}];

Triangles

Clear@triSides;triSides[vs_]:=MapThread[(#1-#2)&,{vs,RotateLeft@vs}];
Clear@triLengths;triLengths[vs_]:=magn/@triSides[vs];
Clear@triLengthsRL;triLengthsRL[vs_]:=RotateLeft@triLengths@vs;
triPer[tri_]:=Total[triLengths@tri];
(* a,b,c are side lengths *)
Clear@triAreaHeron;triAreaHeron[{a_,b_,c_}]:=Module[{s},
s=(a+b+c)/2;(* semi perimeter *)
Sqrt[s*(s-a)*(s-b)*(s-c)]];
(* order by oposition to vertices *)
getMedians[t1_,t2_,t3_]:={t2+t3,t1+t3,t1+t2}/2;
getMediansV[vs_]:=.5(vs+RotateLeft@vs);

Clear@getInradius;getInradius[{a_,b_,c_}]:=Module[{num1,num2,num3,denom},
num1=b+c-a;
num2=c+a-b;
num3=a+b-c;
denom=a+b+c;
Sqrt[num1*num2*num3/denom]/2];

getCircumradius[{a_,b_,c_}]:=Module[{s,num,denom1,denom2,denom3},
s=(a+b+c)/2;
num=a*b*c;
denom1=(a+b-s);
denom2=(a+c-s);
denom3=(b+c-s);
num/(4*Sqrt[s*denom1*denom2*denom3])];

getNinepointCircleRadius[sides_]:=getCircumradius[sides]/2;

getTriData[tri_]:=Module[{sides,perimeter,inc,inradius,circumradius,cosines,bisectors,area},
sides=RotateLeft@triLengths@tri;
perimeter=Total@sides;
inradius=getInradius[sides];
circumradius=getCircumradius[sides];
cosines=getTriCosines[tri];
bisectors=getTriBisectors@@tri;
area=inradius*perimeter/2;
{"sides"->sides,
"perimeter"->perimeter,
"inradius"->inradius,
"circumradius"->circumradius,
"rOvR"->inradius/circumradius,
"cosines"->cosines,
"area"->area,
"bisectors"->bisectors}];

getSubtriData[tri_]:=Module[{sides,inc,tps,incR,npc,npcR},
sides=triLengthsRL@tri;
inc=getIncenterTrilin[tri,sides];
(* the intouchpoints of this guy is on the billiard, needs to draw them *)
tps=intouchTriangle[tri,sides];
incR=getInradius[sides];
npc=getNinepointCenterTrilin[tri,sides];
npcR=getNinepointCircleRadius[sides];
<|"tri"->tri,"sides"->sides,"inc"->inc,"incR"->incR,"npc"->npc,"npcR"->npcR,"tps"->tps|>];

Clear@getAnticomplData;
getAnticomplData[orbit_,sides_]:=
getSubtriData@anticomplementaryTriangle[orbit,sides];

Clear@getMedialData;
getMedialData[orbit_,sides_]:=
getSubtriData@medialTriangle[orbit,sides];

getIncenterAxes[a_]:=Module[{δ,a1,b1},
δ=Sqrt[a^4-a^2+1];
a1=(δ-1)/a;b1=(a^2-δ);
{a1,b1}];

getExcenterAxes[a_]:=Module[{δ,ae,be},
δ=Sqrt[a^4-a^2+1];
ae=(δ+1)/a;be=(a^2+δ);
{ae,be}];

Clear@getCircularity;
getCircularity[locus_]:=Module[{rads,ctr,mean,sd},
(* assume it's zero since points may not be evenly distributed so "mean" won't work and RegionCentroid is too slow *)
ctr={0,0};
rads=magn[#-ctr]&/@locus;
mean=Mean@rads;
sd=StandardDeviation@rads;
{
"n"->Length@locus,
"ctr"->ctr,
"min"->Min@rads,
"max"->Max@rads,
"mean"->mean,
"sd"->sd,
"zscore"->sd/mean
}];

Clear@txtSubscript;
txtSubscript[txt_,subscr_,style_,where_,offset_:{0,0}]:=Text[Style[Subscript[txt,subscr],style],where,offset];
Clear@txtSuperSub;
txtSuperSub[txt_,superscr_,subscr_,style_,where_,offset_:{0,0}]:=Text[Style[Subsuperscript[txt,subscr,superscr],style],where,offset];
Clear@txtSubscriptSuffix;
txtSubscriptSuffix[txt_,subscr_,suffix_,style_,where_,offset_:{0,0}]:=Text[Style[ToString[Subscript[txt,subscr],FormatType->StandardForm]<>suffix,style],where,offset];

Clear@ellLabel;
Options@ellLabel={inward->False};
ellLabel[a_,p_,lgt_,OptionsPattern[]]:=p+If[OptionValue@inward,lgt,-lgt]*norm[ellGrad[a,Sequence@@p]];
Clear@ellLabelb;
Options@ellLabelb={inward->False};
ellLabelb[a_,b_,p_,lgt_,OptionsPattern[]]:=p+If[OptionValue@inward,lgt,-lgt]*norm@ellGradb[a,b,Sequence@@p];
Clear@ellLabelTxt;
Options@ellLabelTxtb={inward->False};
ellLabelTxtb[a_,b_,p_,txt_,lgt_,opts:OptionsPattern[]]:=Text[txt,ellLabelb[a,b,p,lgt,{opts}]];
Clear@ellLabelTxt;
Options@ellLabelTxt={inward->False};
ellLabelTxt[a_,p_,txt_,lgt_,opts:OptionsPattern[]]:=Text[txt,ellLabel[a,p,lgt,{opts}],{0,0}];

Clear@labelPoints;labelPoints[pts_,prefix_,style_,offset_:{0,0}]:=MapThread[txtSubscript[prefix,#1,style,#2,offset]&,{Range@Length@pts,pts}];
Clear@ellLabelPoints;
ellLabelPoints[a_,pts_,prefix_,style_,lgt_:.33]:=MapThread[txtSubscript[prefix,#1,style,ellLabel[a,#2,lgt]]&,{Range@Length@pts,pts}];
ellLabelPointsSuperSub[a_,pts_,prefix_,super_,style_,lgt_:.33]:=MapThread[txtSuperSub[prefix,super,#1,style,ellLabel[a,#2,lgt]]&,{Range@Length@pts,pts}];
ellLabelPointsSuffix[a_,pts_,prefix_,suffixes_,style_,lgt_:.33]:=MapThread[txtSubscriptSuffix[prefix,#1,#3,style,ellLabel[a,#2,lgt]]&,{Range@Length@pts,pts,suffixes}];
Clear@ellLabelPointsSuffixb;ellLabelPointsSuffixb[a_,b_,pts_,prefix_,suffixes_,style_,lgt_:.33]:=MapThread[txtSubscriptSuffix[prefix,#1,#3,style,ellLabelb[a,b,#2,lgt]]&,{Range@Length@pts,pts,suffixes}];
Clear@ellLabelPointsb;
ellLabelPointsb[a_,b_,pts_,prefix_,style_,lgt_:.33]:=MapThread[txtSubscript[prefix,#1,style,ellLabelb[a,b,#2,lgt]]&,{Range@Length@pts,pts}];
Clear@ellLabelPointsbInward;
ellLabelPointsbInward[a_,b_,pts_,prefix_,style_,lgt_:.33]:=MapThread[txtSubscript[prefix,#1,style,ellLabelb[a,b,#2,lgt,inward->True]]&,{Range@Length@pts,pts}];

Clear@getStats;
Options@getStats={label->""};
getStats[vals_,OptionsPattern[]]:=Module[{mean,sd,z},
mean=Mean@vals;
sd=StandardDeviation@vals;
z=safeDiv[sd,mean];
<|"n"->Length@vals,"mean"->mean,"sd"->sd,"z"->z,"min"->Min@vals,"max"->Max@vals,"median"->Median@vals,"label"->OptionValue@label|>];

Formatting

nfn[v_,n_]:=ToString@NumberForm[v,{n+2,n}];
nf[v_]:=ToString@NumberForm[v,{3,2}];
nf1[v_]:=ToString@NumberForm[v,{3,1}];
nf0[v_]:=ToString@IntegerPart[v];
padZ[v_,n_:4]:=ToString@NumberForm[v,{n,0},NumberPadding->{"0",""},NumberPoint->""];

Clear@getBilliardAngle;
getBilliardAngle[a_,b_,{px_,py_}]:=
ArcTan[px/a,py/b];

stereographicProj[x_,y_]:=Module[{c=x*x+y*y},
{2x,2y,c-1}/(c+1)];

imagine point at (x0, y0, 1), on plane tangent and above sphere x^2+y^2+z^2=1.
line from center to point: p(t) = t (x0,y0,1)
p(t) on sphere ⇔ t^2 (x0^2+y0^2+1) = 1 => t^2=1/(...) => p = (x0,y0,1)/sqrt(x0^2+y0^2+1) = (x0,y0,1)/α

r = 1, z=1/α => θ = arccos(1/α)
y/x=tan[ϕ] => ϕ = arctan[y/x] = arctan[y0/x0]

sphereProj[x0_,y0_]:=Module[{α=Sqrt[x0^2+y0^2+1]},
{1/α,y0/x0}]

sphereProj2[x0_,y0_]:=Module[{α=x0^2+y0^2},
{x0,y0}/α]

sphereProj3[x0_,y0_]:=Module[{α=x0^2+y0^2},
{x0,y0}/Sqrt@α]

logProj[x0_,y0_]:=Module[{α=Log[1+x0^2+y0^2]},
{x0,y0}/α]

Clear@makeMovie;
makeMovie[fname_,frames_,repeats_:3]:=Module[{framesConcat},
framesConcat=Flatten@ConstantArray[frames,repeats];
Print["Exporting "<>ToString@Length[framesConcat]<>" frames to "<>fname];
Export[fname,framesConcat,"VideoEncoding"->"MPEG-4 Video"];
];

Envelope Aux [most code on companion envelopes.nb]

Clear@getEnvelope;(* via intersection *)
Options@getEnvelope={epsDeg->.001,tDeg2Phase->0};
getEnvelope[a_?NumericQ,tDeg_?NumericQ,trilfn1_,trilfn2_,OptionsPattern[]]:=Module[{ons,onsPhase,p1,q1,p2,q2},
ons=orbitNormals[a,toRad@(tDeg-.5OptionValue@epsDeg)];
{p1,q1}=If[OptionValue@tDeg2Phase>0,
onsPhase=orbitNormals[a,toRad@(tDeg-.5OptionValue@epsDeg+OptionValue@tDeg2Phase)];
{trilfn1[ons[[1]],ons[[3]]],trilfn1[onsPhase[[1]],onsPhase[[3]]]},
#[ons[[1]],ons[[3]]]&/@{trilfn1,trilfn2}
];
ons=orbitNormals[a,toRad@(tDeg+.5OptionValue@epsDeg)];
{p2,q2}=If[OptionValue@tDeg2Phase>0,
onsPhase=orbitNormals[a,toRad@(tDeg+.5OptionValue@epsDeg+OptionValue@tDeg2Phase)];
{trilfn1[ons[[1]],ons[[3]]],trilfn1[onsPhase[[1]],onsPhase[[3]]]},
#[ons[[1]],ons[[3]]]&/@{trilfn1,trilfn2}
];
interRaysUnprot[p1,(q1-p1),p2,(q2-p2)]];

Clear@getEnvelopeb;
getEnvelopeb[a_?NumericQ,b_?NumericQ,tDeg_?NumericQ,trilfn1_,trilfn2_,epsDeg_:.001]:=Module[{ons,p1,q1,p2,q2},
ons=orbitNormalsb[a,b,toRad@tDeg];{p1,q1}=#[ons[[1]],ons[[3]]]&/@{trilfn1,trilfn2};
ons=orbitNormalsb[a,b,toRad@(tDeg+epsDeg)];{p2,q2}=#[ons[[1]],ons[[3]]]&/@{trilfn1,trilfn2};
interRaysUnprot[p1,(q1-p1),p2,(q2-p2)]];

(* new *)Clear@getEnvelopeLocus;
Options@getEnvelopeLocus=Options@getEnvelope;
getEnvelopeLocus[a_,trilinFn1_,trilinFn2_,ps_,opts:OptionsPattern[]]:=Module[{pp,ons},
pp=Quiet@ParametricPlot[ons=orbitNormals[a,toRad@tDeg];getEnvelope[a,tDeg,trilinFn1,trilinFn2,FilterRules[{opts},Options@getEnvelope]],{tDeg,0,360},
PerformanceGoal->"Speed",PlotStyle->ps]];

rayCircTs=Normal/@(t/.FullSimplify[Solve[magn2[{x0,y0}+{xhat,yhat} t-{ox,oy}]==R^2,t,Reals]])

interRayCircTs[{x0_,y0_},{xhat_,yhat_},{ox_,oy_},R_]=rayCircTs;

interRayCirc[r0_,rhat_,ctr_,R_]:=Module[{ts},
ts=interRayCircTs[r0,rhat,ctr,R];
ray[r0,rhat,#]&/@ts];

colorStr[str_,clr_]:=ToString[Style[str,clr],StandardForm]

(* for organizing buttons in manipulate UI *)
makeCtrlCol[ctrls_]:=Column[{Style[First@ctrls,Bold,Medium],Sequence@@Rest[ctrls]},Alignment->Right,BaselinePosition->1];

Ellipse Inversion, Isogonal and Isotomic Conjugates

https://arxiv.org/pdf/1309.6378.pdf

Clear@ellInversion;
ellInversion[a_,p_]:=Module[{q,w,p2},
q=ellInterRayUnprot[a,{0,0},p][[2]];
w=q.q;
p2=p.p;
{p*w/p2,q}]

ellInversion[1.5,{.5,.5}]

Manipulate[
DynamicModule[{a=1.5,ell,pinv,q,fs,gr},
{ell,fs}={plotEll[a],getFoci[a]};
Dynamic[{pinv,q}=ellInversion[a,p];
gr=Graphics[{PointSize@Large,Point@fs,Red,Point@pinv,Dashed,Line[{p,pinv}],Blue,Point@q}];
Show[{ell,gr},Frame->True,PlotRange->{{-2a,2a},{-2,2}},
PlotLabel->(Style["Inversion with Respect to Ellipse",{Black,Medium}])]]],
{{p,{.5,.5}},Locator},SaveDefinitions->True]

(*CloudDeploy[%,"inversion with respect to ellipse",Permissions->"Public"]*)

Clear@isogonalConjugate;
isogonalConjugate[p_,tri_,bisectors_]:=Module[{refla,reflb,inter},
refla=refl[p-First@tri,First@bisectors];
reflb=refl[p-Second@tri,Second@bisectors];
inter=interRaysUnprot[First@tri,refla,Second@tri,reflb];
inter];

(* could use cevianTriangle, but needs conversion from cartesian to trilinear *)

Clear@isotomicConjugate;
isotomicConjugate[p_,tri_]:=Module[{inters,meds,isos,n1,n2,n3,isoConj},
inters=MapThread[interRays[#1,p-#1,#2,#3-#2]&,{tri,RotateLeft@tri,RotateRight@tri}];
meds=getMedians@@tri;
isos=MapThread[(2#1-#2)&,{meds,inters}];
n1=isos[[1]]-tri[[1]];
n2=isos[[2]]-tri[[2]];
n3=isos[[3]]-tri[[3]];
isoConj=Which[
!interRaysIllConditioned[n1,n2],interRaysUnprot[tri[[1]],n1,tri[[2]],n2],
!interRaysIllConditioned[n1,n3],interRaysUnprot[tri[[1]],n1,tri[[3]],n3],
True,interRaysUnprot[tri[[2]],n2,tri[[3]],n3]];
<|"p"->p,"tri"->tri,"pconj"->isoConj,"inters"->inters,"meds"->meds,"isos"->isos|>];

Clear@showIsotomicConjugate;
Options@showIsotomicConjugate={drGr->False,"drLines"->False,drLabels->False,drLogQprime->False,drPs->True};
showIsotomicConjugate[p_,tri_,OptionsPattern[]]:=Module[{isoData,gr,grLines,grLabels,txtD=-1.25},
isoData=isotomicConjugate[p,tri];
gr=If[OptionValue@drGr,{
{FaceForm@None,PointSize@Large,
{Blue,Point@p},
If[OptionValue@drPs,{Blue,Text[Style["Q",16],p,{txtD,txtD}]},{}],
{EdgeForm@Black,Polygon@tri,Point@tri,labelPoints[tri,"P",16,{-2,0}]},
{Purple,Point@isoData["meds"]},
{Blue,Point@isoData["inters"]},
{Darker@Green,Point@isoData["isos"],Point@isoData["pconj"]},
If[OptionValue@drPs,Text[Style["Q'",16],isoData["pconj"],{txtD,txtD}],{}],
If[OptionValue@drLogQprime,Module[{isoConjLog},isoConjLog=isoData["pconj"]@Log[1+norm@isoData["pconj"]];
{Darker@Green,Point@isoConjLog,Text[Style["log[Q']",16],isoConjLog,{txtD,txtD}]}],{}]}
},{}];
grLines=If[OptionValue@"drLines",{Dashed,
{Blue,MapThread[Line[{#1,#2}]&,{tri,isoData["inters"]}]},
{Darker@Green,MapThread[Line[{#1,#2}]&,{tri,isoData["isos"]}]}},{}];
grLabels=If[OptionValue@drLabels,{
{Red,labelPoints[isoData["meds"],"m",16,{txtD,0}]},
{Blue,labelPoints[isoData["inters"],"i",16,{txtD,0}]},
{Darker@Green,labelPoints[isoData["isos"],"iso",16,{txtD,0}]}},{}];
{isoData["pconj"],Graphics/@{gr,grLines,grLabels}}];

Manipulate[
DynamicModule[{tri,actData,isoGr,actGr},
tri={{0,0},p2,p3};
isoGr=showIsotomicConjugate[p0,tri,drGr->True,"drLines"->drLines0,drLabels->drLabels0,drLogQprime->drLogQprime0][[2]];
actGr=If[drACT,
actData=getAnticomplData[tri,triLengthsRL@tri];
Graphics@{FaceForm@None,EdgeForm@{Blue,Dashed},Polygon@actData["tri"],Darker@Green,Circle[actData["inc"],actData["incR"]],PointSize@Medium,Point@actData["tps"]},
{}];
Show[{isoGr,actGr},
ImageSize->Large,
Frame->True,PlotRange->{{-5,5},{-5,5}},PlotLabel->Style["Isotomic Conjugate: Move Q or (Subscript[P, 3])",{Black,Medium}]]],
{{p0,{.75,.5}},Locator},
{{p2,{1,0}},Locator},
{{p3,{2,2}},Locator},
{{drLines0,False,"isotomic lines"},{True,False}},
{{drLabels0,False,"label points"},{True,False}},
{{drLogQprime0,False,"log Q'"},{True,False}},
{{drACT,False,"anticompl"},{True,False}}]

(*DeleteFile[isotApp]*)

(*isotApp=CloudDeploy[%,"isotomic conjugate",Permissions->"Public"]*)

DynamicModule[{p1={0,0},p2={1,0},gr,tri,bis,isogConj,isotConj,p0star,inc,bar,lgt=.2,lgtLine=3},
Manipulate[
tri={p1,p2,p3};
inc=getIncenter[tri];
bis=getTriBisectors@@tri;
p0star=isogonalConjugate[p0,tri,bis];
(*isoConj=showIsotomicConjugate[p0,tri][[1]];*)
isotConj=showIsotomicConjugate[p0,tri,drGr->True,"drLines"->drLinesIsot,"drLabels"->False,drPs->False];
gr=Graphics[{PointSize@Large,FaceForm@None,Arrowheads@Medium,
EdgeForm@{Thick,Black},Blue,Point@tri,Polygon@tri,Red,Point@p0star,Darker@Green,Point@isotConj[[1]],
{Blue,MapThread[Arrow@{#1,#1+lgt*#2}&,{tri,bis}]},
If[drLinesIsog,
{Gray,Line@{#,ray[#,norm[p0-#],lgtLine]}&/@tri,Red,Line@{#,ray[#,norm[p0star-#],lgtLine]}&/@tri},{}]}];
Show[{gr,
If[drLinesIsot,isotConj[[2]],{}]},Frame->False,ImageSize->Large,
PlotLabel->(Style["Isogonal and Isotomic Conjugates",{Medium,Black}]),
PlotRange->{{-.25,1.5},{-.25,1}}],
{{p3,{1.25,.75}},Locator},
{{p0,{.75,.1}},Locator},
{{drLinesIsog,False,"isogonal lines"},{True,False}},
{{drLinesIsot,False,"isotomic lines"},{True,False}},
SaveDefinitions->True]]

(*DeleteFile[isogApp]*)

(*isogApp=CloudDeploy[%,"isogonal conjugate",Permissions->"Public"]*)

Cyclic Quadrilaterals

Clear@orderVertices;
orderVertices[vs_,ctr_]:=Module[{vs0,atans},
vs0=(#-ctr)&/@vs;
atans=ArcTan@@@vs0;
vs[[Ordering[atans]]]];

Pick[{a,b,c},{True,False,True}]

(* assume ordered *)
Clear@getMaltitudes;getMaltitudes[vs_]:=Module[{ls,vsNonDegen,meds,feet,lines},
ls=MapThread[magn2[#1-#2]&,{vs,RotateLeft@vs}];
vsNonDegen=Pick[vs,Not/@(negl/@ls)];
meds=MapThread[.5(#1+#2)&,{vsNonDegen,RotateLeft@vsNonDegen}];
feet=MapThread[closestPerp[#1,#2,#3]&,{meds,RotateLeft[vsNonDegen,2],RotateLeft[vsNonDegen,3]}];
lines=MapThread[{#1,#2}&,{meds,feet}];
<|"meds"->meds,"feet"->feet,"lines"->lines|>];

Manipulate[DynamicModule[{quad,gr,malts},
quad={p1,p2,p3,p4};
malts=getMaltitudes[quad];
gr=Graphics[{FaceForm@None,
{EdgeForm@Blue,Polygon@quad},
{Red,Dashed,Line/@malts["lines"]},
{PointSize@Large,Red,Point@malts["meds"]},
{PointSize@Large,Blue,Point@malts["feet"]}}];
Show[{gr},PlotRange->{{-1,1},{-1,1}}]],
{{p1,{-.5,-.5}},Locator},
{{p2,{.5,-.5}},Locator},
{{p3,{.5,.5}},Locator},
{{p4,{-.5,.5}},Locator}]

Triangular Orbits

Ellipse Invariants

Constant Perimeter (Gaston Darboux, 1917)

Jean-Gaston Darboux (1842-1917)

deltaA[a_]:=Sqrt[a^4-a^2 +1];

Clear[darbouxP];
darbouxP[a_,b_:1]:=Module[{a2,b2,delta,per},
a2=a^2;
b2=b^2;
delta=Sqrt[a2^2-a2 b2+b2^2];
per=2Sqrt[2delta-a2-b2](a2+b2+delta)/(a2-b2);
per
];

Exit angle at (Subscript[x, 1]) which creates triangular orbit (Garcia, 2019)

Clear@cosAlpha;cosAlpha[a_,x_]:=Module[{x2,a2,a4,c2,denom},
x2=x^2;
a2=a^2;
a4=a2^2;
c2=a2-1;
denom=c2 Sqrt[a4-c2 x2];
a2 Sqrt[-a2-1+2Sqrt[a4-c2]]/denom];

cosAlpha[a,x]//TeXForm

Can I find an expression for the next orbit point (Subscript[P, 2]) in terms of “a” and (Subscript[x, 1])

Clear@getP2;getP2[a_,x1_]:=Module[{y,p1,norm,ca,sa,p2,normRot,normRotNeg,p2Neg},
y=-ellY[a,x1];
p1={x1,y};
ca=cosAlpha[a,x1]/.{Sqrt[1-a^2+a^4]->d}/.{-1-(a^2)+2 d->d2};(* to simplify *)
sa=Sqrt[1-ca^2];
norm=ellGrad[a,x1,y];
normRot=rot[norm,sa,ca];
normRotNeg=rot[norm,-sa,ca];
p2=ellInterRayUnprot[a,p1,normRot][[2]]; (* get 2nd solution *)
p2Neg=ellInterRayUnprot[a,p1,normRotNeg][[2]]; 
{p2,p2Neg}];

Clear@getReflData;getReflData [a_,p0_,normal_,sinAlpha_,cosAlpha_]:=Module[{nRot,inter,interNorm,interRefl,nextInter,nextInterNorm},
nRot=rot[normal,sinAlpha,cosAlpha];
inter=ellInterRay[a,p0,nRot][[2]];
interNorm=norm[ellGrad[a,inter[[1]],inter[[2]]]];
interRefl=refl[norm[p0-inter],interNorm];
nextInter=ellInterRay[a,inter,interRefl][[2]];
nextInterNorm=norm[ellGrad[a,nextInter[[1]],nextInter[[2]]]];
{ (* returns an "object" *)
"nRot"->nRot,
"inter"->inter,
"interNorm"->interNorm,
"interRefl"->interRefl,
"nextInter"->nextInter,
"nextInterNorm"->nextInterNorm
}];

Clear@getReflDatab;getReflDatab [a_,b_,p0_,normal_,sinAlpha_,cosAlpha_]:=Module[{nRot,inter,interNorm,interRefl,nextInter,nextInterNorm},
nRot=rot[normal,sinAlpha,cosAlpha];
inter=ellInterRaybUnprot[a,b,p0,nRot][[2]];
interNorm=norm[ellGradb[a,b,inter[[1]],inter[[2]]]];
interRefl=refl[norm[p0-inter],interNorm];
nextInter=ellInterRaybUnprot[a,b,inter,interRefl][[2]];
nextInterNorm=norm[ellGradb[a,b,nextInter[[1]],nextInter[[2]]]];
{ (* returns an "object" *)
"nRot"->nRot,
"inter"->inter,
"interNorm"->interNorm,
"interRefl"->interRefl,
"nextInter"->nextInter,
"nextInterNorm"->nextInterNorm
}];

Clear@getOrbitData;
Options@getOrbitData={posY->False};getOrbitData[a_,x_,OptionsPattern[]]:=Module[{y,o1,n1,ca,sa,sa2,ca2,halfAlpha,pos,neg,orbit,sides},
y=-ellY[a,x];
If[OptionValue@posY,y=-y];
o1={x,y};
n1=norm[ellGrad[a,x,y]];
ca=cosAlpha[a,x];
sa=Sqrt[1-ca^2];
pos=getReflData[a,o1,n1,sa,ca];
neg=getReflData[a,o1,n1,-sa,ca];(* orbit at -α *)
(* half-angle to display α at bisector *)
sa2=Sqrt[(1-ca)/2];
ca2=Sqrt[(1+ca)/2];
halfAlpha=rot[n1,sa2,ca2];
orbit={o1,"inter"/.pos,"nextInter"/.pos};
sides=triLengthsRL@orbit;
{
"ca"->ca,
"sa"->sa,
"halfAlpha"->halfAlpha,
"nRot"->("nRot"/.pos),
"interRefl"->("interRefl"/.pos),
"orbit"->orbit,
"sides"->sides,
"normals"->{n1,"interNorm"/.pos,"nextInterNorm"/.pos},
"nRotNeg"->("nRot"/.neg),
"interReflNeg"->("interRefl"/.neg),
"orbitNeg"->{o1,"inter"/.neg,"nextInter"/.neg},
"normalsNeg"->{n1,"interNorm"/.neg,"nextInterNorm"/.neg}
}
];

Clear@getOrbitDatab;
Options@getOrbitDatab={posY->False};getOrbitDatab[a_,b_,x_,OptionsPattern[]]:=Module[{y,o1,n1,ca,sa,sa2,ca2,halfAlpha,pos,neg,orbit,sides},
y=-ellYb[a,b,x];
If[OptionValue@posY,y=-y];
o1={x,y};
n1=norm[ellGradb[a,b,x,y]];
ca=cosAlpha[a/b,x/b];
sa=Sqrt[1-ca^2];
pos=getReflDatab[a,b,o1,n1,sa,ca];
neg=getReflDatab[a,b,o1,n1,-sa,ca];(* orbit at -α *)
(* half-angle to display α at bisector *)
sa2=Sqrt[(1-ca)/2];
ca2=Sqrt[(1+ca)/2];
halfAlpha=rot[n1,sa2,ca2];
orbit={o1,"inter"/.pos,"nextInter"/.pos};
sides=triLengthsRL@orbit;
{
"ca"->ca,
"sa"->sa,
"halfAlpha"->halfAlpha,
"nRot"->("nRot"/.pos),
"interRefl"->("interRefl"/.pos),
"orbit"->orbit,
"sides"->sides,
"normals"->{n1,"interNorm"/.pos,"nextInterNorm"/.pos},
"nRotNeg"->("nRot"/.neg),
"interReflNeg"->("interRefl"/.neg),
"orbitNeg"->{o1,"inter"/.neg,"nextInter"/.neg},
"normalsNeg"->{n1,"interNorm"/.neg,"nextInterNorm"/.neg}
}
];

getOrbitData[2.,1.,posY->False]//ColumnForm

{"orbit","sides"}/.getOrbitData[2.,1.,posY->False]

Clear@orbitDataT;
orbitDataT[a_,t_]:=Module[{ellP},
ellP=N@{a  Cos@t,Sin@t};
getOrbitData[N[a],ellP[[1]],posY->(ellP[[2]]>0)]
];

Clear@orbitNormals;
orbitNormals[a_,t_]:=Module[{ellP,orbitData},
ellP={N@a * Cos[N@t],Sin[N@t]};
orbitData=getOrbitData[N[a],ellP[[1]],posY->(ellP[[2]]>0)];
{"orbit","normals","sides"}/.orbitData
];

Clear@orbitNormalsb;
orbitNormalsb[a_,b_,t_]:=Module[{ellP,orbitData},
ellP={a  Cos@t,b Sin@t};
orbitData=getOrbitDatab[a,b,ellP[[1]],posY->(ellP[[2]]>0)];
{"orbit","normals","sides"}/.orbitData
];

getTriCosines[tri_]:=Module[{u12,u23,u31},
u12=norm[tri[[2]]-tri[[1]]];
u23=norm[tri[[3]]-tri[[2]]];
u31=norm[tri[[1]]-tri[[3]]];
{
-u12.u31,
-u23.u12,
-u31.u23
}];

getTriDoubleCosineSum[tri_]:=Total[cosDoubleAngle/@getTriCosines@tri];

getOrbitCosines[a_,t_]:=Module[{orbit,normals,sides},
{orbit,normals,sides}=orbitNormals[a,t];
getTriCosines[orbit]];

Clear@getTriCausticParams;
getTriCausticParams[a_]:=Module[{px,qy,delta},
delta=Sqrt[a^4-a^2+1];
px=a^3/(delta+1);
qy=1/(a^2+delta);
{px,qy}];

getTriAreaRatioHelman[a_]:=Module[{ts,tris},
ts=Table[toRad@t,{t,0,359,1}];
tris=orbitNormals[a,#]&/@ts;
MapThread[{#1,Area[Polygon@First[#2]]/Sqrt@Apply[Times,Third@#2]}&,{ts,tris}]];

Clear@getGammaL;
getGammaL[a_,b_]:=Module[{δ,c2,γ,L,a2,b2},
a2=a^2;
b2=b^2;
δ=Sqrt@(a2^2-a2 b2+b2^2);
c2=a2-b2;
γ=Sqrt@(2δ-a2-b2)/c2;
L=2(δ+a2+b2)γ;
{γ,L}];
(* robust for contour plot *)
Clear@getGammaLsym;
getGammaLsym[a_?NumericQ,b_?NumericQ]:=Module[{eps=10^-6},If[a>=b,getGammaL[a+eps,b],getGammaL[b+eps,a]]];

getOrthocenterAxes[a_,b_]:=Module[{a2=a*a,b2=b*b,delta,k4,c2},
delta=Sqrt[a2^2-a2 b2+b2^2];
c2=a2-b2;
k4=((a2+b2)delta-2(a2 b2))/c2;
{k4/a,k4/b}];

getCausticAxes[a_,b_]:=Module[{a2=a^2,b2=b^2,delta,c2,ac,bc},
delta=Sqrt[a2^2-a2 b2+b2^2];
c2=a2-b2;
ac=a(delta-b2)/c2;
bc=b(a2-delta)/c2;
{ac,bc}];

getDelta[a_,b_]:=Sqrt[a^4-a^2 b^2+b^4];

rOvR[a_]:=Module[{δ=getDelta[a,1]},
2(δ-1)/((a^2-1)(a^2+δ))]

Clear@getJoachimsthal;
getJoachimsthal[a_,b_]:=Module[{δ,a2=a*a,b2=b*b,c2},
c2=a2-b2;
δ=Sqrt[a2^2-a2 b2+b2^2];
Sqrt[2δ-a2-b2]/c2];

isoscelesP2[a_,b_]:=Module[{J=getJoachimsthal[a,b],p1,costpp,sintpp,p2,p3},
costpp=J a;
sintpp=Sqrt[1-costpp^2];
p1={0,-b};
p2=FullSimplify[{a costpp,b sintpp},a>b>0];
p3=flipX@p2;
{p1,p2,p3}]

isoscelesP2[1.5,1]

getOrbitAxes[a_,trilinFn_]:=Module[{ons0,ons90},
ons0=orbitNormals[a,0.];
ons90=orbitNormals[a,π/2.];
Abs/@{trilinFn[ons0[[1]],ons0[[3]]][[1]],trilinFn[ons90[[1]],ons90[[3]]][[2]]}];

Trilinears & Barycentrics

getBarycentrics[{x_,y_},{{x1_,y1_},{x2_,y2_},{x3_,y3_}}]:=Module[{detT,l1,l2,l3},
detT=(x1-x3)(y2-y3)-(x2-x3)(y1-y3);
l1=((y2-y3)(x-x3)+(x3-x2)(y-y3))/detT;
l2=((y3-y1)(x-x3)+(x1-x3)(y-y3))/detT;
l3=1-l1-l2;
{l1,l2,l3}];

Trilinears x : y : z convert via triangle vertices A, B, C  and sides a, b, c :

(* from barycentrics *)
getTrilinears[p_,tri_,sides_]:=Module[{bs},
MapThread[#1/#2&,{getBarycentrics[p,tri],sides}]]

Clear@trilinearToCartesianUnsafe;
trilinearToCartesianUnsafe[
{A_,B_,C_},(* vertices *)
{a_,b_,c_},(* side lengths *)
{x_,y_,z_} (* trilinears *)
]:=Module[{(*a,b,c,*)denom},
(* may not need *)
(*a=magn[C-B];b=magn[A-C];c=magn[B-A];*)
denom={a,b,c}.{x,y,z};
(#/denom)&/@(a x A+b y B+c z C)];

Clear@trilinearToCartesian;
trilinearToCartesian[
{A_,B_,C_},(* vertices *)
{a_,b_,c_},(* side lengths *)
{x_,y_,z_} (* trilinears *)
]:=Module[{(*a,b,c,*)denom},
(* may not need *)
(*a=magn[C-B];b=magn[A-C];c=magn[B-A];*)
denom={a,b,c}.{x,y,z};
safeDiv[#,denom]&/@(a x A+b y B+c z C)];

rotateSym[fabc_]:={fabc,fabc/.{a->b,b->c,c->a},fabc/.{a->c,b->a,c->b}}

(* trilinears: a:b:c *)
getIncenterTrilin[orbit_,sides_]:=trilinearToCartesian[orbit,sides,{1,1,1}];
getIncenterTrilinUnsafe[orbit_,sides_]:=trilinearToCartesianUnsafe[orbit,sides,{1,1,1}];
getCircumcenterTrilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},trilinearToCartesian[orbit,{a,b,c},{a(b2+c2-a2),b(c2+a2-b2),c(a2+b2-c2)}]];
getOrthocenterTrilin[orbit_,sides_]:=Module[{cs},
cs=getTriCosines[orbit];
trilinearToCartesian[orbit,sides,1/cs]
];
getCentroidTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b c,c a,a b}];
getFeuerbachTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
{b c(b+c-a)(b-c)^2,
c a(c+a-b)(c-a)^2,
a b(a+b-c)(a-b)^2}];
getNinepointCenterTrilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},trilinearToCartesian[orbit,{a,b,c},
{b c(a2(b2+c2)-(b2-c2)^2),
c a(b2(c2+a2)-(c2-a2)^2),
a b(c2(a2+b2)-(a2-b2)^2)}]];
getFirstIsodynamicTrilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinA,sinB,sinC,sqrt3=Sqrt[3]},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
trilinearToCartesian[orbit,{a,b,c},
{3 cosA+sqrt3 sinA,
3 cosB+sqrt3 sinB,
3 cosC+sqrt3 sinC}]];

getX9OrthicTrilin[o_,s_]:=Module[{ort,ortSides},
ort=orthicTriangle[o,s];
ortSides=triLengthsRL@ort;
getMittenTrilin[ort,ortSides]];
(* the incenter of the extouch is not currently catalogued *)
getExtouchX1Trilin[vs_,sides_]:=Module[{ext},
ext=extouchTriangle[vs,sides];
getIncenterTrilin[ext,triLengthsRL@ext]];
getX9ExtouchTrilin[o_,s_]:=Module[{ext,extSides},
ext=extouchTriangle[o,s];
extSides=triLengthsRL@ext;
getMittenTrilin[ext,extSides]];

(* X(356) *)
getFirstMorleyTrilin[orbit_,sides_]:=Module[{cs,c3},
cs=getTriCosines[orbit];
c3=cosThird/@cs;
trilinearToCartesian[orbit,sides,
{c3[[1]]+2c3[[2]] c3[[3]],
c3[[2]]+2c3[[3]] c3[[1]],
c3[[3]]+2c3[[1]] c3[[2]]}]
];
(* X(357) *)
getSecondMorleyTrilin[orbit_,sides_]:=Module[{cs,c3},
cs=getTriCosines[orbit];
c3=cosThird/@cs;
trilinearToCartesian[orbit,sides,1/c3]
];
(* X(358) *)
getThirdMorleyTrilin[orbit_,sides_]:=Module[{cs,c3},
cs=getTriCosines[orbit];
c3=cosThird/@cs;
trilinearToCartesian[orbit,sides,c3]
];
getSymmedianTrilin[orbit_,sides_]:=trilinearToCartesian[orbit,sides,sides];
getMittenTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b+c-a,c+a-b,a+b-c}];
getBarycenterTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{a,b,c}];
getGergonneTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b*c/(b+c-a),c*a/(c+a-b),a*b/(a+b-c)}];
getNagelTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c}, {(b+c-a)/a,(c+a-b)/b,(a+b-c)/c}];
getSpiekerTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b c(b+c),c a(c+a),a b (a+b)}];
(* X40 *)
getBevanTrilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{
b/(c+a-b)+c/(a+b-c)-a/(b+c-a),
c/(a+b-c)+a/(b+c-a)-b/(c+a-b),
a/(b+c-a)+b/(c+a-b)-c/(a+b-c)}];

getX12Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{
b c(b+c)^2/(b+c-a),
c a(c+a)^2/(c+a-b),
a b(a+b)^2/(a+b-c)
}];

(* (csc A)(-1+cos B+cos C)[sin 2B+sin 2C+2(-1+cos A)(sin B+sin C)]*)
Clear@getX119Trilin;
getX119Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
Module[{cosA,cosB,cosC,sinA,sinB,sinC,sin2A,sin2B,sin2C},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
{sin2A,sin2B,sin2C}=MapThread[sinDoubleAngle[#1,#2]&,{{sinA,sinB,sinC},{cosA,cosB,cosC}}];
{(1/sinA)(cosB+cosC-1)(sin2B+sin2C+2(cosA-1)(sinB+sinC)),
(1/sinB)(cosC+cosA-1)(sin2C+sin2A+2(cosB-1)(sinC+sinA)),
(1/sinC)(cosA+cosB-1)(sin2A+sin2B+2(cosC-1)(sinA+sinB))
}
]];

getX119Trilin[Sequence@@Part[orbitNormals[1.5,toRad@10.],{1,3}]]

getX142Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
{b+c-((b-c)^2)/a,
c+a-((c-a)^2)/b,
a+b-((a-b)^2)/c}];

(* X214 *)
getX214Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},
{(b+c-2a)(b2+c2-a2-b c),
(c+a-2b)(c2+a2-b2-c a),
(a+b-2c)(a2+b2-c2-a b)
}]];

(* bc(b2+c2-a2)(b2-c2)2 *)

(* X69: bc(b2+c2-a2)*)
getX69Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},
{b c(b2+c2-a2),
c a(c2+a2-b2),
a b(a2+b2-c2)
}]];

getX125Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},
{b c(b2+c2-a2)(b2-c2)^2,
c a(c2+a2-b2)(c2-a2)^2,
a b(a2+b2-c2)(a2-b2)^2}]];

(* X264: 1/[a3(a2-b2-c2)] *)
getX264Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},
1/{a a2(a2-b2-c2),b b2(b2-c2-a2),c c2(c2-a2-b2)}]];

(* X284 a (b+c-a)/(b+c) *)
getX284Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
{a (b+c-a)/(b+c),
b(c+a-b)/(c+a),
c(a+b-c)/(a+b)}];

(* X(442) COMPLEMENT OF SCHIFFLER POINT
Trilinears bc(v+w):ca(w+u):ab(u+v),where
u:v:w=X(284);e.g.,u(A,B,C)=(sin A)/(cos B+cos C) *)
getX442Trilin[orbit_,{a_,b_,c_}]:=Module[{u,v,w},
{u,v,w}={a (b+c-a)/(b+c),
b(c+a-b)/(c+a),
c(a+b-c)/(a+b)};
trilinearToCartesian[orbit,{a,b,c},{b c(v+w),c a(w+u),a b(u+v)}
]];

(* X264 of excentral *)
getX1742Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c,a3=a*a*a,b3=b*b*b,c3=c*c*c},
trilinearToCartesian[orbit,{a,b,c},
{(a3 b-2 a2 b2+a b3+a3 c+a2 b c-a b2 c-b3 c-2 a2 c2-a b c2+2 b2 c2+a c3-b c3),
(b3 c-2 b2 c2+b c3+b3 a+b2 c a-b c2 a-c3 a-2 b2 a2-b c a2+2 c2 a2+b a3-c a3),
(c3 a-2 c2 a2+c a3+c3 b+c2 a b-c a2 b-a3 b-2 c2 b2-c a b2+2 a2 b2+c b3-a b3)}]];

(* X600: a(bc+2S)[abc(b+c-a)+2(b2+c2-a2)S]:: *)

getX600Trilin[orbit_,{a_,b_,c_}]:=Module[{abc=a b c,a2=a*a,b2=b*b,c2=c*c,S},
S=2triAreaHeron@{a,b,c};
trilinearToCartesian[orbit,{a,b,c},
{a(b c+2S)(abc(b+c-a)+2(b2+c2-a2)S),
b(c a+2S)(abc(c+a-b)+2(c2+a2-b2)S),
c(a b+2S)(abc(a+b-c)+2(a2+b2-c2)S)
}]];

Geogebra is wrong about X600

Module[{tri,sides,x},
tri={{0,0},{1,0},{1,1}};
sides=triLengthsRL@tri;
x=getX600Trilin[tri,sides];
Print@x;
Graphics[{FaceForm@None,PointSize@Medium,drawPoly[tri,Blue],Point@x,Text["(Subscript[X, 600])",x,{-1,-1}]},ImageSize->Small]]

(* X(1145) bc(b+c-2a)[2abc-(b+c)(a2-(b-c)2)] *)
getX1145Trilin[orbit_,{a_,b_,c_}]:=Module[{abc=a b c},
trilinearToCartesian[orbit,{a,b,c},
{b c(b+c-2a)(2abc-(b+c)(a^2-(b-c)^2)),
c a(c+a-2b)(2abc-(c+a)(b^2-(c-a)^2)),
a b(a+b-2c)(2abc-(a+b)(c^2-(a-b)^2))}
]]

(* de Longchamps Point *)
getX20Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
trilinearToCartesian[orbit,{a,b,c},{
cosA-cosB cosC,
cosB-cosC cosA,
cosC-cosA cosB}]];

(* 1/(cos B+cos C) *)
getX21Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
trilinearToCartesian[orbit,{a,b,c},1/{cosB+cosC,cosC+cosA,cosA+cosB}]];

(*cos3A,cos3B,cos3C*)
Clear@getX49Trilin;getX49Trilin[orbit_,{a_,b_,c_}]:=Module[{coss,cos3s},
coss=lawOfCosines3[a,b,c];
cos3s=cosTripleAngle/@coss;
trilinearToCartesian[orbit,{a,b,c},cos3s]];

Clear@getX59Trilin;getX59Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinA,sinB,sinC,cosBC,cosCA,cosAB},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
cosBC=cosB*cosC+sinB*sinC;
cosCA=cosC*cosA+sinC*sinA;
cosAB=cosA*cosB+sinA*sinB;
trilinearToCartesian[orbit,{a,b,c},{
1/(1-cosBC),
1/(1-cosCA),
1/(1-cosAB)}]];

Clear@getX144Trilin;getX144Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinA,sinB,sinC,tanAov2,tanBov2,tanCov2},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
tanAov2=tanHalfAngle[sinA,cosA];
tanBov2=tanHalfAngle[sinB,cosB];tanCov2=tanHalfAngle[sinC,cosC];
(* (csc A)(tan B/2+tan C/2-tan A/2) *)
trilinearToCartesian[orbit,{a,b,c},{
(tanBov2+tanCov2-tanAov2)/sinA,
(tanCov2+tanAov2-tanBov2)/sinB,
(tanAov2+tanBov2-tanCov2)/sinC}]];

(* intersection of feuerbach hyp w/ billiard *)
Clear@getX1156Trilin;
getX1156Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{
(b-c)^2 + a(b+c-2a),
(c-a)^2 + b(c+a-2b),
(a-b)^2 + c(a+b-2c)
}];

Clear@getX1155Trilin;
getX1155Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{
(b-c)^2 + a(b+c-2a),
(c-a)^2 + b(c+a-2b),
(a-b)^2 + c(a+b-2c)
}];

(* a(b^2 Cos[2B]+ c^2 Cos[2C] - a^2 Cos[2A]) *)
getX26Trilin[orbit_,{a_,b_,c_}]:=
Module[{cosA,cosB,cosC,cos2A,cos2B,cos2C,a2=a*a,b2=b*b,c2=c*c},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
cos2A=2 cosA^2-1;
cos2B=2 cosB^2-1;
cos2C=2 cosC^2-1;
trilinearToCartesian[orbit,{a,b,c},
{a(b2 cos2B+ c2 cos2C - a2 cos2A),
b(c2 cos2C+ a2 cos2A - b2 cos2B),
c(a2 cos2A+ b2 cos2B - c2 cos2C)}
]];

getX359[orbit_,{a_,b_,c_}]:=
Module[{cosA,cosB,cosC,A,B,C},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
A=ArcCos[cosA];
B=ArcCos[cosB];
C=ArcCos[cosC];
trilinearToCartesian[orbit,{a,b,c},
{a/A,b/B,c/C}
]];

getX360[orbit_,{a_,b_,c_}]:=
Module[{cosA,cosB,cosC,A,B,C},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
A=ArcCos[cosA];
B=ArcCos[cosB];
C=ArcCos[cosC];
trilinearToCartesian[orbit,{a,b,c},
{A/a,B/b,C/c}
]];

getX364[orbit_,{a_,b_,c_}]:=Module[{ah=Sqrt@a,bh=Sqrt@b,ch=Sqrt@c},
trilinearToCartesian[orbit,{a,b,c},
{bh+ch-ah,ch+ah-bh,ah+bh-ch}
]];

getX365[orbit_,{a_,b_,c_}]:=
trilinearToCartesian[orbit,{a,b,c},
{Sqrt@a,Sqrt@b,Sqrt@c}
];

getX366[orbit_,{a_,b_,c_}]:=
trilinearToCartesian[orbit,{a,b,c},
1/{Sqrt@a,Sqrt@b,Sqrt@c}
];

getX367[orbit_,{a_,b_,c_}]:=Module[{ah=Sqrt@a,bh=Sqrt@b,ch=Sqrt@c},
trilinearToCartesian[orbit,{a,b,c},
1/{bh+ch,ch+ah,ah+bh}
]];

Module[{ons},
ons=orbitNormals[1.5,toRad@10.];
getX360[ons[[1]],ons[[3]]]]

(* incenter of excentral triangle *)
getX164Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinAov2,sinBov2,sinCov2},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinAov2,sinBov2,sinCov2}=sinHalfAngle/@{cosA,cosB,cosC};
trilinearToCartesian[orbit,{a,b,c},{
sinBov2+sinCov2-sinAov2,
sinCov2+sinAov2-sinBov2,
sinAov2+sinBov2-sinCov2
}]];

(* barycenter of excentral triangle *)
getX165Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a a,b2=b b,c2=c c},
trilinearToCartesian[orbit,{a,b,c},{
3a2-2a(b+c)-(b-c)^2,
3b2-2b(c+a)-(c-a)^2,
3c2-2c(a+b)-(a-b)^2
}]];

(* mittenpunkt of excentral triangle *)
getX168Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinAov2,sinBov2,sinCov2},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinAov2,sinBov2,sinCov2}=sinHalfAngle/@{cosA,cosB,cosC};
trilinearToCartesian[orbit,{a,b,c},{
b/(1-sinBov2)+c/(1-sinCov2)-a/(1-sinAov2),
c/(1-sinCov2)+a/(1-sinAov2)-b/(1-sinBov2),
a/(1-sinAov2)+b/(1-sinBov2)-c/(1-sinCov2)}]];

Module[{o,n,s},
{o,n,s}=orbitNormals[1.5,1.1];
getOrthocenterTrilin[o,s]]

Module[{o,n,s,cirs,incs},
{o,n,s}=orbitNormals[1.5,1.1];
cirs={getCircumcenterTrilin[o,s],getCircumcenter@@o};
incs={getIncenterTrilin[o,s],getIncenter[o[[1]],n[[1]],o[[2]],n[[2]]]};
{cirs,incs}//MatrixForm]

Generate Billiard as Locus

(* isog conj of X9 *)
getX57Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{b+c-a,c+a-b,a+b-c}];

getX100Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{b-c,c-a,a-b}];
getX513Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b-c,c-a,a-b}];
getX649Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{a(b-c),b(c-a),c(a-b)}];
getX101Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{safeDiv[a,b-c],safeDiv[b,c-a],safeDiv[c,a-b]}];
(* vtx of Yff parabola *)
getX3234Trilin[orbit_,{a_,b_,c_}]:=Module[{a2,b2,c2,a3,b3,c3,trils},
a2=a*a;b2=b*b;c2=c*c;
a3=a2*a;b3=b2*b;c3=c2*c;
trils={
((a-b) (a-c) (2a3-a2 b-b3-a2 c+b2 c+b c2-c3)^2)/a,
((b-c) (b-a) (2b3-b2 c-c3-b2 a+c2 a+c a2-a3)^2)/b,
((c-a) (c-b) (2c3-c2 a-a3-c2 b+a2 b+a b2-b3)^2)/c};
trilinearToCartesian[orbit,{a,b,c},trils]
];


getX88Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{b+c-2a,c+a-2b,a+b-2c}];
getX162Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},Module[{a2=a*a,b2=b*b,c2=c*c},
1/{(b2-c2)(b2+c2-a2),(c2-a2)(c2+a2-b2),(a2-b2)(a2+b2-c2)}]];
(* isogonal conjugate of X88, therefore all are inverted *)
getX36Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a a,b2=b b,c2=c c},
trilinearToCartesian[orbit,{a,b,c},{
a(b2+c2-a2-b c),
b(c2+a2-b2-c a),
c(a2+b2-c2-a b)}]
];
getX44Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b+c-2a,c+a-2b,a+b-2c}];
getX693Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{(b-c)/a^2,(c-a)/b^2,(a-b)/c^2}];

(* X(230) bc[a2(2a2-b2-c2)+(b2-c2)2] *)
getX230Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a a,b2=b b,c2=c c},
trilinearToCartesian[orbit,{a,b,c},{
b c(a2(2a2-b2-c2)+(b2-c2)^2),
c a(b2(2b2-c2-a2)+(c2-a2)^2),
a b(c2(2c2-a2-b2)+(a2-b2)^2)
}]];

(* YFF PARABOLIC POINT *)
getX190Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},{b c/(b-c),c a/(c-a),a b/(a-b)}];
(* X650 is both on the anti-orthic axis and on L55 Gergonne of ACT, i.e., L(31) of billiard, meaning *both* its isotomic and isogonal conjugates lie on the EB, i.e., the E9-centered circumellipse *)
(* X(650)=isogonal conjugate of X(651)
X(650)=isotomic conjugate of X(4554)
*) 
getX650Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
{(b-c)(b+c-a),
(c-a)(c+a-b),
(a-b)(a+b-c)}];
(*bc/[a(b-c)(b+c-a)] = 1/[a^2(b-c)(b+c-a)] *)
getX4554Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
1/{a^2(b-c)(b+c-a),b^2(c-a)(c+a-b),c^2(a-b)(a+b-c)}];
getX652Trilin[orbit_,{a_,b_,c_}]:=Module[{secA,secB,secC},
{secA,secB,secC}=1/lawOfCosines3[a,b,c];trilinearToCartesian[orbit,{a,b,c},{secB-secC,secC-secA,secA-secB}]];
getX655Trilin[orbit_,{a_,b_,c_}]:=Module[{cosA,cosB,cosC,sinA,sinB,sinC,cosAmB,cosBmC,cosCmA},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=Sqrt[1-#^2]&/@{cosA,cosB,cosC};
(* f(A,B,C):f(B,C,A):f(C,A,B),where f(A,B,C)=1/[cos(A-B)-cos(C-A)] *)
cosAmB=cosA cosB+sinA sinB;
cosBmC=cosB cosC+sinB sinC;
cosCmA=cosC cosA+sinC sinA;
trilinearToCartesian[orbit,{a,b,c},
1/{cosAmB-cosCmA,cosBmC-cosAmB,cosCmA-cosBmC}]
];
getX656Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},{(b2-c2)(b2+c2-a2),(c2-a2)(c2+a2-b2),(a2-b2)(a2+b2-c2)}]];
getX798Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},{a2(b2-c2),b2(c2-a2),c2(a2-b2)}]];
getX823Trilin[orbit_,{a_,b_,c_}]:=Module[{secA2,secB2,secC2},
{secA2,secB2,secC2}=1/{lawOfCosines[a,b,c]^2,lawOfCosines[b,a,c]^2,lawOfCosines[c,a,b]^2};
trilinearToCartesian[orbit,{a,b,c},1/{
secB2-secC2,
secC2-secA2,
secA2-secB2}]];
(* TRILINEAR POLE OF LINE X(1)X(3) *)
getX651Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},1/{(b-c)(b+c-a),(c-a)(c+a-b),(a-b)(a+b-c)}];

(* sec(A-π/6)=1/[cosA cosPi6+ sinA sinPi6] *)
getX13Trilin[orbit_,{a_,b_,c_}]:=Module[{coss,cosPi6=Cos[π/6],sinPi6=Sin[π/6],sins,cosABCmPi6},
coss=lawOfCosines3[a,b,c];
cosABCmPi6=cosDiffAngle[#,Sqrt[1-#^2],cosPi6,sinPi6]&/@coss;
trilinearToCartesian[orbit,{a,b,c},1/cosABCmPi6]];

(* (b-c)/a *) getX514Trilin[orbit_,{a_,b_,c_}]:=trilinearToCartesian[orbit,{a,b,c},
{(b-c)/a,(c-a)/b,(a-b)/c}
];

(* Peter Moses: Perspector of the Inner Conway Triangle, vertices on the EB *)
(* (a^2+(b-c)^2)(a^3-(b+c)*a^2+(b+c)^2*a-(b+c)(b^2+c^2)): *)
fnX11677[a_,b_,c_]:=Module[{a2=a a,b2=b b,c2=c c},(a2 + (b - c)^2) (a a2 - (b + c)a2 + a(b + c)^2 - (b + c) (b2 + c2))/a] ;
getX11677[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},{fnX11677[a,b,c],fnX11677[b,c,a],fnX11677[c,a,b]}]];

Novo resultado : X661 é o unico ponto no plano q esta simultaneamente no eixo antiortico e no [L(55) do anticomplementar] L(31) do de referencia. É o unico ponto no plano tal que seus conjugados isogonal e o isotomico caem (em pontos diferentes: 662 e 799) no bilhar.

(* b^2-c^2 *) 
getX661Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},{b2-c2,c2-a2,a2-b2}]];
(* X(661)=isogonal conjugate of X(662)
X(661)=isotomic conjugate of X(799) *)
(* x662 is isog conj of x661 *)
getX662Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},1/{b2-c2,c2-a2,a2-b2}]];
(* x799 is isot conj of x661 *)
getX663Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},{a(b-c)(b+c-a),b(c-a)(c+a-b),c(a-b)(a+b-c)}]];
getX664Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},1/{a(b-c)(b+c-a),b(c-a)(c+a-b),c(a-b)(a+b-c)}]];
getX664TestTrilin[orbit_,{a_,b_,c_}]:=
trilinearToCartesian[orbit,{a,b,c},
{(a-b) (a-c) (a+b-c) (a+c-b)/a,
(b-c) (b-a) (b+c-a) (b+a-c)/b,
(c-a) (c-b) (c+a-b) (c+b-a)/c}];
getX799Trilin[orbit_,{a_,b_,c_}]:=Module[{a2=a*a,b2=b*b,c2=c*c},
trilinearToCartesian[orbit,{a,b,c},1/{a2(b2-c2),b2(c2-a2),c2(a2-b2)}]];

(* X(908)= POINT ACUBENS = (cosB+cosC-1)/a *)
getX908Trilin[orbit_,{a_,b_,c_}]:=Module[{cA,cB,cC},
{cA,cB,cC}=lawOfCosines3[a,b,c];
trilinearToCartesian[orbit,{a,b,c},
{(cB+cC-1)/a,
(cC+cA-1)/b,
(cA+cB-1)/c}
]];

(* X(857)= INTERCEPT OF EULER LINE AND TRILINEAR POLAR OF X(75)
X(857)= sinC^2 sin2B sin(C-A) + sinB^2 sin2C sin(B-A) *)
getX857Trilin[orbit_,{a_,b_,c_}]:=Module[{cA,cB,cC,sA2,sB2,sC2,sA,sB,sC,sAmC,sAmB,sBmC,s2A,s2B,s2C},
{cA,cB,cC}=lawOfCosines3[a,b,c];
{sA2,sB2,sC2}=(1-#^2)&/@{cA,cB,cC};
{sA,sB,sC}=Sqrt/@{sA2,sB2,sC2};
{s2A,s2B,s2C}=MapThread[sinDoubleAngle,{{sA,sB,sC},{cA,cB,cC}}];
sAmB=sA cB-cA sB;
sAmC=sA cC-cA sC;
sBmC=sB cC-cB sC;
trilinearToCartesian[orbit,{a,b,c},{
-sC2 s2B sAmC-sB2 s2C sAmB,
sA2 s2C sAmB-sC2 s2A sBmC,
sB2 s2A sBmC+sA2 s2B sAmC}]];

(* X(2590)=X(2)-ISOCONJUGATE OF X(1381) *)
(* a/f(a,b,c):b/f(b,c,a):c/f(c,a,b),where f(a,b,c) is as at X(1381) *)
(* X(1381)=1st INTERCEPT OF LINE X(1)X(3) AND CIRCUMCIRCLE
Trilinears f(a,b,c):f(b,c,a):f(c,a,b),where f(a,b,c)=r+(|OI|-R) cos A *)
getX2590Trilin[orbit_,{a_,b_,c_}]:=Module[{cA,cB,cC,r,x3,x1,R,k},
{cA,cB,cC}=lawOfCosines3[a,b,c];
x1=getIncenterTrilin[orbit,{a,b,c}];
x3=getCircumcenterTrilin[orbit,{a,b,c}];
r=getInradius[{a,b,c}];
R=getCircumradius[{a,b,c}];
k=magn[x1-x3]-R;
trilinearToCartesian[orbit,{a,b,c},{
a/(r+k cA),b/(r+k cB),c/(r+k cC)
}]
];

getX2590Trilin@@Part[orbitNormals[1.2,toRad@0.],{1,3}]

getX101Trilin@@Part[orbitNormals[2,toRad@40.],{1,3}]

getX4554Trilin@@Part[orbitNormals[2,toRad@40.],{1,3}]

Chop[getMittenTrilin@@Part[orbitNormals[2,toRad@10.],{1,3}]]

Barycentrics (does not appear to work!)

barycentricToCartesian[orbit_,lambdas0_]:=Module[{x,y,area,lambdas},
(*area=Area[Polygon@orbit];*)
lambdas=lambdas0/Total@lambdas0;
x=Total@MapThread[(#1*#2)&,{First/@orbit,lambdas}];
y=Total@MapThread[(#1*#2)&,{Second/@orbit,lambdas}];
{x,y}];

Clear@X10405;X10405[orbit_,{a_,b_,c_}]:=barycentricToCartesian[orbit,
1/{3a^2-2a b-2a c-(b-c)^2,
3b^2-2b c-2b a-(c-a)^2,
3c^2-2c a-2c b-(a-b)^2}];

(* perpector of anticomplementary on extouch: http://mathworld.wolfram.com/Perspector.html  *)

X144b[orbit_,{a_,b_,c_}]:=barycentricToCartesian[orbit,
{1/(a-b-c)+1/(a-b+c)+1/(a+b-c),
1/(b-c-a)+1/(b-c+a)+1/(b+c-a),
1/(c-a-b)+1/(c-a+b)+1/(c+a-b)}];

Module[{o,n,s},
{o,n,s}=orbitNormals[1.5,.1];
{getX144Trilin[o,s],X144b[o,s]}
]

equiError[tri_]:=Module[{s,bar,inc,savg},
s=triLengthsRL@tri;
savg=Total@s/Length@s;
bar=getBarycenterTrilin[tri,s];
inc=getIncenterTrilin[tri,s];
magn2[bar-inc]/savg]

isEqui[tri_]:=equiError[tri]<10^-6;

drawPoly[poly_,clr_]:={EdgeForm@{clr,Thick},Polygon@poly,clr,Point@poly};
drawPolyThick[poly_,clr_]:={EdgeForm@{clr,AbsoluteThickness@3},Polygon@poly,clr,Point@poly};

Triangles form Trilinear Matrices

trilinearMatrixToCartesian[orbit_,sides_,tryM_]:=trilinearToCartesian[orbit,sides,#]&/@tryM;
trilinearMatrixToCartesianUnsafe[orbit_,sides_,tryM_]:=trilinearToCartesianUnsafe[orbit,sides,#]&/@tryM;

to do : anticomplementary, external tangents triangle.

intouchTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{0,(a c)/(a-b+c),(a b)/(a+b-c)},
{(b c)/(-a+b+c),0,(a b)/(a+b-c)},
{(b c)/(-a+b+c),(a c)/(a-b+c),0}}];

intouchTriangleUnsafe[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesianUnsafe[orbit,{a,b,c},
{{0,(a c)/(a-b+c),(a b)/(a+b-c)},
{(b c)/(-a+b+c),0,(a b)/(a+b-c)},
{(b c)/(-a+b+c),(a c)/(a-b+c),0}}];

extouchTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{0,(a-b+c)/b,(a+b-c)/c},
{(-a+b+c)/a,0,(a+b-c)/c},
{(-a+b+c)/a,(a-b+c)/b,0}}];

Clear@incentralTriangle;
incentralTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{0,1,1},
{1,0,1},
{1,1,0}}];

Clear@excentralTriangle;
excentralTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{-1,1,1},
{1,-1,1},
{1,1,-1}}];

Clear@medialTriangle;
medialTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{0,a c,a b},{b c,0,a b},{b c,a c,0}}];

Clear@yffTriangle;
yffTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{0,safeDiv[a c,c-a],safeDiv[a b,a-b]},(* error in mathworld http://mathworld.wolfram.com/YffContactTriangle.html which shows this as {0,ac/(c-a),ab/(b-a)}*)
{safeDiv[b c,b-c],0,safeDiv[a b,a-b]},
{safeDiv[b c,b-c],safeDiv[a c,c-a],0}}];

Module[{tri={{0,0},{1,0},{1,1}}},
medialTriangle[tri,triLengthsRL@tri]]

Clear@orthicTriangle;
orthicTriangle[orbit_,sides_]:=Module[{secA,secB,secC},
{secA,secB,secC}=1./getTriCosines[orbit];trilinearMatrixToCartesian[orbit,sides,{{0,secB,secC},{secA,0,secC},{secA,secB,0}}]];

Clear@eulerTriangle;
eulerTriangle[orbit_,{a_,b_,c_}]:=Module[{cA,cB,cC,sA,sB,sC,tA,tB,tC},
{cA,cB,cC}={
lawOfCosines[a,b,c],
lawOfCosines[b,a,c],
lawOfCosines[c,a,b]};
{sA,sB,sC}=getSin/@{cA,cB,cC};
{tA,tB,tC}={sA/cA,sB/cB,sC/cC};
trilinearMatrixToCartesian[orbit,{a,b,c},
{{2 tA+tB+tC,sA/cB,sA/cC},
{sB/cA,tA+2tB+tC,sB/cC},
{sC/cA,sC/cB,tA+tB+2tC}}]];

(* https://faculty.evansville.edu/ck6/encyclopedia/gemini.html *)
(* (a^2+b*c)/a:(-a*b-c*a)/b:(-a*b-c*a)/c *)
(* remember to rotate rows *)
gemini90Triangle[orbit_,{a_,b_,c_}]:=Module[{a2=a a,b2=b b,c2=c c},
trilinearMatrixToCartesian[orbit,{a,b,c},
{{(a2+b c)/a , (-a b-c a)/b , (-a b-c a)/c},
{ (-b c-a b)/a,(b2+c a)/b , (-b c-a b)/c },
{ (-c a-b c)/a,(-c a-b c)/b,(c2+a b)/c }}]];

gemini2Triangle[orbit_,{a_,b_,c_}]:=
trilinearMatrixToCartesian[orbit,{a,b,c},
{{-1,(b+c)/b,(b+c)/c},
{(c+a)/a,-1,(c+a)/c},
{(a+b)/a,(a+b)/b,-1}}];

gemini30Triangle[orbit_,{a_,b_,c_}]:=
trilinearMatrixToCartesian[orbit,{a,b,c},
{{1,(c-b)/b,(b-c)/c},
{(c-a)/a,1,(a-c)/c},
{(b-a)/a,(a-b)/b,1}}];

honsbergerVtxA[a_,b_,c_]:={(a-b+c)(a+b-c),(a+b-c)((b-c)^2-a(b+c))/b,(a-b+c)((b-c)^2-a(b+c))/c};

honsbergerTriangle[orbit_,{a_,b_,c_}]:=
trilinearMatrixToCartesian[orbit,{a,b,c},
{honsbergerVtxA[a,b,c],RotateRight[honsbergerVtxA[b,c,a],1],RotateRight[honsbergerVtxA[c,a,b],2]}];

(* intouch of ACT on the EB *)
innerConwayTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},
{{b c,(c-b)c,(b-c)b},
{(c-a)c,c a,(a-c)a},
{(b-a)b,(a-b)a,a b}}];

(* http://mathworld.wolfram.com/TangentialTriangle.html *)
tangentialTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},{{-a,b,c},{a,-b,c},{a,b,-c}}];
anticomplementaryTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},{1/{-a,b,c},1/{a,-b,c},1/{a,b,-c}}];
externaltangentsTriangle[orbit_,sides_]:=Module[{x,y,z},
{x,y,z}=getTriCosines[orbit];
trilinearMatrixToCartesian[orbit,sides,
{{-(x+1),x+z,x+y},
{y+z,-(y+1),y+x},
{z+y,z+x,-(z+1)}
}]];

hexylTriangle[orbit_,{a_,b_,c_}]:=Module[{x,y,z,diag},
{x,y,z}=lawOfCosines3[a,b,c];
diag=x+y+z+1;
trilinearMatrixToCartesian[orbit,{a,b,c},
{{diag,x+y-z-1,x-y+z-1},
{x+y-z-1,diag,-x+y+z-1},
{x-y+z-1,-x+y+z-1,diag}}]];

outerNapoleonTriangle[orbit_,{a_,b_,c_}]:=Module[{
cosA,cosB,cosC,sinA,sinB,sinC,
cPi6,sPi6,
sApPi6,sBpPi6,sCpPi6,sAmPi6,sBmPi6,sCmPi6},
cPi6=Cos[π/6.];
sPi6=Sin[π/6.];
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
{sApPi6,sAmPi6}=getSinApmB[sinA,sPi6,cosA,cPi6];
{sBpPi6,sBmPi6}=getSinApmB[sinB,sPi6,cosB,cPi6];
{sCpPi6,sCmPi6}=getSinApmB[sinC,sPi6,cosC,cPi6];
trilinearMatrixToCartesian[orbit,{a,b,c},
{{-1,2sCpPi6,2sBpPi6},
{2sCpPi6,-1,2sApPi6},
{2sBpPi6,2sApPi6,-1}}]];

firstMorleyTriangle[orbit_,{a_,b_,c_}]:=Module[{cs,cs3},
cs=lawOfCosines3[a,b,c];
cs3=cosThird/@cs;
trilinearMatrixToCartesian[orbit,{a,b,c},
{{1,2cs3[[3]],2cs3[[2]]},
{2cs3[[3]],1,2cs3[[1]]},
{2cs3[[2]],2cs3[[1]],1}}]];

secondMorleyTriangle[orbit_,{a_,b_,c_}]:=Module[{cs,cs3,ss3,s2p3,c2p3,a12,a13,a23},
cs=lawOfCosines3[a,b,c];
cs3=cosThird/@cs;
ss3=Sqrt[1-#^2]&/@cs3;
c2p3=-1/2;(*Cos[2π/3.];*)
s2p3=Sqrt[3]/2;(*Sin[2π/3.];*)
a12=cs3[[3]] c2p3+ss3[[3]] s2p3;
a13=cs3[[2]] c2p3+ss3[[2]] s2p3;
a23=cs3[[1]] c2p3+ss3[[1]] s2p3;
trilinearMatrixToCartesian[orbit,{a,b,c},
{{1,2a12,2a13},
{2a12,1,2a23},
{2a13,2a23,1}}]];

Sin[4π/3]

thirdMorleyTriangle[orbit_,{a_,b_,c_}]:=Module[{cs,cs3,ss3,s4p3,c4p3,a12,a13,a23},
cs=lawOfCosines3[a,b,c];
cs3=cosThird/@cs;
ss3=Sqrt[1-#^2]&/@cs3;
c4p3=-1/2;(*Cos[4π/3.];*)
s4p3=-Sqrt[3]/2;(*Sin[4π/3.];*)
a12=cs3[[3]] c4p3+ss3[[3]] s4p3;
a13=cs3[[2]] c4p3+ss3[[2]] s4p3;
a23=cs3[[1]] c4p3+ss3[[1]] s4p3;
trilinearMatrixToCartesian[orbit,{a,b,c},
{{1,2a12,2a13},
{2a12,1,2a23},
{2a13,2a23,1}}]];

cevianTriangle[orbit_,{a_,b_,c_},{t1_,t2_,t3_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},{{0,t2,t3},{t1,0,t3},{t1,t2,0}}];antiCevianTriangle[orbit_,{a_,b_,c_},{t1_,t2_,t3_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},{{-t1,t2,t3},{t1,-t2,t3},{t1,t2,-t3}}];

pedalTriangle[orbit_,{a_,b_,c_},{t1_,t2_,t3_}]:=Module[{cA,cB,cC},
{cA,cB,cC}=lawOfCosines3[a,b,c];
trilinearMatrixToCartesian[orbit,{a,b,c},{
{0,t2+t1 cC,t3+t1 cB},
{t1+t2 cC,0,t3+t2 cA},
{t1+t3 cB,t2+t3 cA,0}
}]];

antipedalTriangle[orbit_,{a_,b_,c_},{α_,β_,γ_}]:=Module[{cA,cB,cC},
{cA,cB,cC}=lawOfCosines3[a,b,c];
trilinearMatrixToCartesian[orbit,{a,b,c},{
{-(β+α cC)(γ+α cB),(γ+α cB)(α+β cC),(β+α cC)(α+γ cB)},
{(γ+β cA)(β+α cC),-(γ+β cA)(α+β cC),(α+β cC)(β+γ cA)},
{(β+γ cA)(γ+α cB),(α+γ cB)(γ+β cA),-(α+γ cB)(β+γ cA)}
}]];

trilinearCoords[tri_,p_]:=
RotateLeft@MapThread[magn[closestPerp[p,#1,#2]-p]&,
(* needs this crossed rotation so trilinears come out in the usual way *)
{tri,RotateLeft@tri}]

Module[{o,n,s,p,tril},
{o,n,s}=orbitNormals[1.5,toRad@35.];
p=getSymmedianTrilin[o,s];
tril=trilinearCoords[o,p];
tril
(*Print@(s/s[[1]]);
tril/tril[[1]]*)]

symmedialTriangle[orbit_,{a_,b_,c_}]:=trilinearMatrixToCartesian[orbit,{a,b,c},{{0,b,c},{a,0,c},{a,b,0}}];

Clear@feuerbachTriangle;
feuerbachTriangle[orbit_,{a_,b_,c_}]:=Module[{
sinA,sinB,sinC,
cosA,cosB,cosC,
cosBmC,cosCmA,cosAmB,
c2haAmB,c2haBmC,c2haCmA,
m},
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
cosBmC=cosDiffAngle[sinB,cosB,sinC,cosC];
cosCmA=cosDiffAngle[sinC,cosC,sinA,cosA];
cosAmB=cosDiffAngle[sinA,cosA,sinB,cosB];
c2haAmB=cos2HalfAngle[cosAmB];
c2haBmC=cos2HalfAngle[cosBmC];
c2haCmA=cos2HalfAngle[cosCmA];
m={
{-sin2HalfAngle[cosBmC],c2haCmA,c2haAmB},
{c2haBmC,-sin2HalfAngle[cosCmA],c2haAmB},
{c2haBmC,c2haCmA,-sin2HalfAngle[cosAmB]}
};trilinearMatrixToCartesian[orbit,{a,b,c},m]];

Module[{o,n,s},
{o,n,s}=orbitNormals[1.5,.1];
feuerbachTriangle[o,s]]

The first point in the extouch triangle flows on caustic at the exact same parametric than P1

Manipulate[Module[{o,ett,ell,a=1.5,gr,ca,cb},
o=orbitNormals[a,t][[1]];
{ca,cb}=getTriCausticParams[a];
ett=extouchTriangle[o,triLengthsRL@o];
gr=Graphics[{FaceForm@None,PointSize@Medium,
{EdgeForm@{Blue,Thick},Polygon@o,Red,Point@First@o,Blue,Circle[First@o,.05]},
{EdgeForm@Darker@Green,Polygon@ett},
{Darker@Green,Circle[ett[[1]],.05]},
{Red,Point[{-ca Cos[t],-cb Sin[t]}]}}];
Show[{plotEll[a],plotEllb[ca,cb,Brown],gr},AspectRatio->Automatic,Frame->True]],{t,0,2π,π/360.}]

Anticomplementary triangle seems like the more stable, more useful to produce higher order points.

DynamicModule[{cc,vs,sides,cir,cirRad,tt,ac,et,ortTril,ortCev,clrs,ort,ortAntiCev,hexyl},
Manipulate[
vs={{-1,0},{1,0},p1}; (*N@{{0,0},{1,-.6},{.7,.5}};*)
sides=triLengthsRL@vs;
cir=getCircumcenterTrilin[vs,sides];
cirRad=magn[vs[[1]]-cir];
tt=tangentialTriangle[vs,sides];
ac=anticomplementaryTriangle[vs,sides];
et=externaltangentsTriangle[vs,sides];
hexyl=hexylTriangle[vs,sides];
ortTril=1/getTriCosines[vs];
ort=trilinearToCartesian[vs,sides,ortTril];
ortCev=cevianTriangle[vs,sides,ortTril];
ortAntiCev=antiCevianTriangle[vs,sides,ortTril];
clrs={Black,Red,Green,Blue,Purple,Cyan,Pink};
Legended[Graphics[{PointSize@Medium,Black,FaceForm@None,
MapThread[{EdgeForm@#1,#1,Polygon@#2,Point@#2}&,{clrs,{vs,tt,ac,et,ortCev,ortAntiCev,hexyl}}],
{Circle[cir,cirRad],Point@cir},
{Orange,Point@ort}},ImageSize->Medium,Frame->True,PlotRange->{{-5,5},{-5,5}}],
LineLegend[Directive[{Thickness@Large,#}]&/@clrs,
{"reference","tangential","anticomplementary","external tangents","ortho cevian = orthic","ortho anticevian","hexyl"}]],
{{p1,{0,2}},Locator},SaveDefinitions->True]]

DynamicModule[{cc,vs,normals,sides,ell,cir,cirRad,tt,ac,et,ortTril,ortCev,clrs,ort,ortAntiCev,hexyl,gr,xmax=3,ymax=3},Manipulate[
ell=plotEll[a];
{vs,normals,sides}=orbitNormals[a,toRad@tDeg];
sides=triLengthsRL@vs;
cir=getCircumcenterTrilin[vs,sides];
cirRad=magn[vs[[1]]-cir];
tt=tangentialTriangle[vs,sides];
ac=anticomplementaryTriangle[vs,sides];
et=externaltangentsTriangle[vs,sides];
hexyl=hexylTriangle[vs,sides];
ortTril=1/getTriCosines[vs];
ort=trilinearToCartesian[vs,sides,ortTril];
ortCev=cevianTriangle[vs,sides,ortTril];
ortAntiCev=antiCevianTriangle[vs,sides,ortTril];
clrs={Black,Red,Green,Blue,Purple,Cyan,Pink};
gr=Legended[Graphics[{PointSize@Medium,Black,FaceForm@None,
MapThread[{EdgeForm@#1,#1,Polygon@#2,Point@#2}&,{clrs,{vs,tt,ac,et,ortCev,ortAntiCev,hexyl}}],
{Circle[cir,cirRad],Point@cir},
{Orange,Point@ort}},ImageSize->Medium,Frame->True,PlotRange->{{-5,5},{-5,5}}],
LineLegend[Directive[{Thickness@Large,#}]&/@clrs,
{"reference","tangential","anticomplementary","external tangents","ortho cevian = orthic","ortho anticevian","hexyl"}]];
Show[{ell,gr},PlotRange->{{-xmax,xmax},{-ymax,ymax}}],
{{a,1.5},1.01,3,.05},
{{tDeg,0},-360,360,.1},SaveDefinitions->True]]

Major Triangular Centers (Notables)

Linha de Euler: bari, ortho, circum, 9-pc all lie on a line (but not incenter)

getAltBases[p1_,p2_,p3_]:=Module[{sides},
sides={{p2,p3},{p3,p1},{p1,p2}};
MapThread[closestPerp[#1,#2[[1]],#2[[2]]]&,{{p1,p2,p3},sides}]];

getIncenter[p1_,n1_,p2_,n2_]:=interRays[p1,n1,p2,n2];
Clear@getBaricenter;getBaricenter[p1_,p2_,p3_]:=Module[{medians},(*(p1+p2+p3)/3;*)
medians=getMedians[p1,p2,p3];
interRays[p1,medians[[1]](*23*)-p1,p2,medians[[2]](*31*)-p2]
];
getOrthocenter[p1_,p2_,p3_]:=Module[{altBases},
altBases=getAltBases[p1,p2,p3];
interRays[p1,altBases[[1]]-p1,p2,altBases[[2]]-p2]
];
getCircumcenter[p1_,p2_,p3_]:=Module[{medians,medianPerps},
medians=getMedians[p1,p2,p3];
medianPerps={
medians[[1]]+norm[perp[p2-p3]],
medians[[2]]+norm[perp[p3-p1]],
medians[[3]]+norm[perp[p1-p2]]
};
interRays[medians[[1]](*2+3*),perp[p2-p3],medians[[2]](*3+1*),perp[p1-p3]]
];

Nine Point Circle: its center is the circumcenter of the medians, and is tangent to incircle (at Feuerbach point) and all 3 excircles

getNinepointcenter[p1_,p2_,p3_]:=Module[{medians},
medians=getMedians[p1,p2,p3];
getCircumcenter@@medians
];

Clear@inRadius0;
inRadius0[incenter_,p1_,p2_]:=Module[{ctr,foot},
foot=closestPerp[incenter,p1,p2];
magn[incenter-foot]];

circumRadius0[circumcenter_,p1_]:=magn[circumcenter-p1];

(* shoot ray from incenter *)
getFeuerbachpoint[npc_,incenter_,inradius_]:=Module[{inter},
ray[incenter,norm[incenter-npc],inradius]
];

getExcenters[orbit_,normals_]:=Module[{perps,perpsNeg,exc},
perps=perp/@normals;
perpsNeg=perpNeg/@normals;
exc=MapThread[interRays[#1,#2,#3,#4]&,{orbit,perps,RotateLeft@orbit,RotateLeft@perpsNeg}];
exc];

Gergonne Point:
perspector of ABC and its contact triangle Ta, Tb, Tc

Get Triangular Center (Notable) Info

Clear@getTouchPts;getTouchPts[orbit_,normals_]:=Module[{inc,tps},
inc=getIncenter[orbit[[1]],normals[[1]],orbit[[2]],normals[[2]]];
tps=MapThread[closestPerp[inc,#1,#2]&,{orbit,RotateLeft@orbit}];
tps];

getAntiComplement[p_,bar_]:=bar-2(p-bar);

Clear@getNotables;
getNotables[orbit_,normals_]:=Module[{inc,inradius,cir,circumradius,npc,exc,tps,ort,medians,npcradius,sides,bar,feu,antifeu,x88,perimeter},
inc=getIncenter[orbit[[1]],normals[[1]],orbit[[2]],normals[[2]]];
inradius=inRadius0[inc,orbit[[1]],orbit[[2]]];
tps=MapThread[closestPerp[inc,#1,#2]&,{orbit,RotateLeft@orbit}];
medians=getMedians@@orbit;
cir=getCircumcenter@@orbit;
circumradius=circumRadius0[cir,orbit[[1]]];
npc=getNinepointcenter@@orbit;
npcradius=magn[npc-medians[[1]]];
exc=getExcenters[orbit,normals];
sides=triLengthsRL@orbit;
feu=getFeuerbachpoint[npc,inc,inradius];
bar=getBaricenter@@orbit;
antifeu=getAntiComplement[feu,bar];(* anticomplement *)
x88=getX88Trilin[orbit,sides];
ort=getOrthocenter@@orbit;
perimeter=Total@sides;
(* we think this is constant for excentral triangle *)
{
"inc"->inc,
"bar"->bar,(* also: getCentroid[orbit,sides] *)
"ort"->ort,
"cir"->cir,
"npc"->npc,
"exc"->exc,
"ex12"->exc[[1]],
"ex23"->exc[[2]],
"ex31"->exc[[3]],
"feu"->feu,
"antifeu"->antifeu,
"x88"->x88,
(* all thru trilinears, each computing sides unnecessarily *)
"mit"->getMittenTrilin[orbit,sides],
"sym"->getSymmedianTrilin[orbit,sides],
"ger"->getGergonneTrilin[orbit,sides],
"nag"->getNagelTrilin[orbit,sides],
"spi"->getSpiekerTrilin[orbit,sides],
(* not really notables, aux info *)
"incRadius"->inradius,
"tps"-> tps,
"medians"->medians,
"cirRadius"->circumradius,
"npcRadius"->npcradius,
"sides"->sides,
"perimeter"->perimeter,
"area"->triAreaHeron@sides
}];

Orthic and orthic of orthic (similar to reference triangle?)

Clear@getOrthicData;getOrthicData[orbit_]:=Module[{feet,inc,sides,ort,
intouch,intouchSides,inradius,(* intouchInc = inc *)
intouchOrt,intouchOrtSides,intouchOrtInc,
intouchAnticompl,intouchAnticomplSides,
intouchAnticomplOrt,intouchAnticomplOrtSides,intouchAnticomplOrtInc,
orthic,orthicSides,orthicInc,
orthicAnticompl,orthicAnticomplSides,orthicAnticomplInc
},
(* orthic *)
feet=getAltBases@@orbit;
sides=triLengthsRL@feet;
inc=getIncenterTrilin[feet,sides];
ort=getOrthocenterTrilin[feet,sides];
(* intouch *)
intouch=intouchTriangle[feet,sides];
intouchSides=triLengthsRL@intouch;
inradius=magn[intouch[[1]]-inc];
intouchOrt=getAltBases@@intouch;
intouchOrtSides=triLengthsRL@intouchOrt;
intouchOrtInc=getIncenterTrilin[intouchOrt,intouchOrtSides];
(* anticomplement of intouch *)
intouchAnticompl=anticomplementaryTriangle[intouch,intouchSides];
intouchAnticomplSides=triLengthsRL@intouchAnticompl;
intouchAnticomplOrt=getAltBases@@intouchAnticompl;
intouchAnticomplOrtSides=triLengthsRL@intouchAnticomplOrt;
intouchAnticomplOrtInc=getIncenterTrilin[intouchAnticomplOrt,intouchAnticomplOrtSides];
(* orthic *)
orthic=getAltBases@@feet;
orthicSides=triLengthsRL@orthic;
orthicInc=getIncenterTrilin[orthic,orthicSides];
orthicAnticompl=anticomplementaryTriangle[orthic,orthicSides];
orthicAnticomplSides=triLengthsRL@orthicAnticompl;
orthicAnticomplInc=getIncenterTrilin[orthicAnticompl,orthicAnticomplSides];
{
(* orthic *)
"feet"->feet,
"sides"->sides,
"inc"->inc,
"ort"->ort,
(* intouch of orthic, we think similar to orbit *)
"intouch"->intouch,
"intouchSides"->intouchSides,
"inradius"->inradius,
(* orthic of intouch *)
"intouchOrt"->intouchOrt,
"intouchOrtSides"->intouchOrtSides,
"intouchOrtInc"->intouchOrtInc,
(* anticomplement of intouch of orthic, upside down orbit? *)
"intouchAnticompl"->intouchAnticompl,
"intouchAnticomplSides"->intouchAnticomplSides,
(*"intouchAnticomplInc"->intouchAnticomplInc,*)
(* orthic of anticomplement of intouch *)
"intouchAnticomplOrt"->intouchAnticompl,
"intouchAnticomplOrtSides"->intouchAnticomplOrtSides,
"intouchAnticomplOrtInc"->intouchAnticomplOrtInc,
(* orthic of orthic *)
"orthic"->orthic,
"orthicSides"->orthicSides,
"orthicInc"->orthicInc,
(* anticomplement of orthic's orthic *)
"orthicAnticompl"->orthicAnticompl;
"orthicAnticomplSides"->orthicAnticomplSides,
"orthicAnticomplInc"->orthicAnticomplInc
}];

Excenters and Excircles

Clear@showBisectors;showBisectors[vs_]:=Module[{bs},
bs=getTriBisectors@@vs;
Graphics[{FaceForm[None],EdgeForm[Black],Black,PointSize[Medium],
Polygon[vs],
Point[vs],
MapThread[Text[#1,#2,{1.5,0}]&,{{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])"},vs}],
MapThread[Arrow[{#1,ray[#1,#2,.25]}]&,{vs,bs}]},
ImageSize->Small]
];

(* show bisectors computed from vertices for equilateral *)
showBisectors[Table[{Sin[a],Cos[a]},{a,0,2π-π/3,2π/3}]]

Nagel Point

getExtouchPoints[orbit_,exc_]:=MapThread[closestPerp[#1,#2,#3]&,{exc,orbit,RotateLeft[orbit]}];

Clear@getExcircleData;
getExcircleData[orbit_,exc_(*12,23,31*),npc_]:=Module[{excFeet,altLengths,tps,radii,feus,nagel,medians,mitten,mittenPedals,
mittenFeet,sides,cosABC,cosSum,cosProd,sideProd,altLengthsProd,feusCir,feusCirR,mittenFeetCir,mittenFeetCirR},
(* side touch points to sides: 12,23,31 *)
tps=getExtouchPoints[orbit,exc];
excFeet=getAltBases@@exc;
altLengths=MapThread[magn[#1-#2]&,{exc,excFeet}];
radii=MapThread[magn[#1-#2]&,{exc,tps}];
feus=MapThread[ray[#1,norm[npc-#1],#2]&,{exc,radii}];
feusCir=getCircumcenter@@feus;
feusCirR=magn[feus[[1]]-feusCir];
medians=getMedians@@orbit;
mitten=interRays[exc[[1]],medians[[3]]-exc[[1]],exc[[2]],medians[[1]]-exc[[2]]];
mittenPedals=MapThread[closestPerp[mitten,#1,#2]&,{orbit,RotateLeft@orbit}];
(* symmedian triangle *)
mittenFeet=MapThread[interRays[#1,#2-#1,#3,#4-#3]&,{exc,RotateRight@medians,RotateLeft@exc,RotateRight@exc}];
mittenFeetCir=getCircumcenter@@mittenFeet;
mittenFeetCirR=magn[mittenFeet[[1]]-mittenFeetCir];
sides=triLengthsRL@exc;
cosABC=getTriCosines[exc];
cosSum=Total[cosABC];
cosProd=cosABC[[1]]*cosABC[[2]]*cosABC[[3]];
sideProd=sides[[1]]*sides[[2]]*sides[[3]];
altLengthsProd=altLengths[[1]]*altLengths[[2]]*altLengths[[3]];
{
"sides"->sides,
"perimeter"->Total[sides],
"cosABC"->cosABC,
"excFeet"->excFeet,
"altLengths"->altLengths,
"sumAltLengths"->Total@altLengths,
"prodAltLengths"->altLengthsProd,
"sumInvAltLengths"->Total[(1/#)&/@altLengths],
"cosSum"->cosSum,
"cosProd"->cosProd,
"sideProd"->sideProd,
"tps"->tps,(* extouchpoints*)
"radii"->radii,
"sumRadiiSqr"->Total[#^2&/@radii],
"sumInvRadiiSqr"->Total[(1/#^2)&/@radii],
"sumRadii"->Total@radii,
"sumInvRadii"->Total[(1/#)&/@radii],
"feus"->feus,
"feusCir"->feusCir,
"feusCirR"->feusCirR,
"mitten"->mitten,
"mittenPedals"->mittenPedals,
"mittenFeet"-> mittenFeet, (* BAD choice: intersecao do segm Vi-MITTEN com o lado oposto do extriangulo *)
"mittenFeetCir"->mittenFeetCir,
"mittenFeetCirR"->mittenFeetCirR
}
];

Module[{ons,exc,exc2,npc,ecd},
ons=orbitNormals[1.5,toRad@10.];
exc=excentralTriangle[ons[[1]],ons[[3]]];(* 23 31 12 *)
npc=getNinepointCenterTrilin[ons[[1]],ons[[3]]];
ecd=getExcircleData[ons[[1]],RotateRight@exc(*12,23,31*),npc]
]

Trilinears: X(1)~X(100), no hold

Clear@getNewCenters;
getNewCenters[tri_,sides_,singles_:{}]:=Block[{a,b,c,trils,
cosA,cosB,cosC,sinA,sinB,sinC,
secA,secB,secC,cscA,cscB,cscC,
tanA,tanB,tanC,cotA,cotB,cotC,
cos2A,cos2B,cos2C,sin2A,sin2B,sin2C,
sec2A,sec2B,sec2C,csc2A,csc2B,csc2C,
cos3A,sin3A,cos3B,sin3B,cos3C,sin3C,
sec3A,sec3B,sec3C,csc3A,csc3B,csc3C,
cPi3=Cos[π/3.],sPi3=Sin[π/3.],cPi6=Cos[π/6.],sPi6=Sin[π/6.],
sinApPi3,sinBpPi3,sinCpPi3,sinAmPi3,sinBmPi3,sinCmPi3,
sinApPi6,sinBpPi6,sinCpPi6,sinAmPi6,sinBmPi6,sinCmPi6,
cscApPi3,cscBpPi3,cscCpPi3,cscAmPi3,cscBmPi3,cscCmPi3,
cscApPi6,cscBpPi6,cscCpPi6,cscAmPi6,cscBmPi6,cscCmPi6},
{a,b,c}=sides;
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
{secA,secB,secC}=1./{cosA,cosB,cosC};
{cscA,cscB,cscC}=1./{sinA,sinB,sinC};
{tanA,tanB,tanC}={sinA,sinB,sinC}/{cosA,cosB,cosC};
{cotA,cotB,cotC}=1./{tanA,tanB,tanC};
{cos2A,cos2B,cos2C}=cosDoubleAngle/@{cosA,cosB,cosC};
{sec2A,sec2B,sec2C}=1./{cos2A,cos2B,cos2C};
(* getSin/@{cos2A,cos2B,cos2C};*)
{sin2A,sin2B,sin2C}=MapThread[sinDoubleAngle,{{sinA,sinB,sinC},{cosA,cosB,cosC}}];
{csc2A,csc2B,csc2C}=1./{sin2A,sin2B,sin2C};
{sin3A,cos3A}=sinCosTripleAngle[sinA,cosA,sin2A,cos2A];
{sin3B,cos3B}=sinCosTripleAngle[sinB,cosB,sin2B,cos2B];
{sin3C,cos3C}=sinCosTripleAngle[sinC,cosC,sin2C,cos2C];
{sec3A,sec3B,sec3C}=1./{cos3A,cos3B,cos3C};
{csc3A,csc3B,csc3C}=1./{sin3A,sin3B,sin3C};
{sinApPi3,sinAmPi3}=getSinApmB[sinA,sPi3,cosA,cPi3];
{sinBpPi3,sinBmPi3}=getSinApmB[sinB,sPi3,cosB,cPi3];
{sinCpPi3,sinCmPi3}=getSinApmB[sinC,sPi3,cosC,cPi3];
{sinApPi6,sinAmPi6}=getSinApmB[sinA,sPi6,cosA,cPi6];
{sinBpPi6,sinBmPi6}=getSinApmB[sinB,sPi6,cosB,cPi6];
{sinCpPi6,sinCmPi6}=getSinApmB[sinC,sPi6,cosC,cPi6];
{cscApPi3,cscBpPi3,cscCpPi3}=1./{sinApPi3,sinBpPi3,sinCpPi3};
{cscAmPi3,cscBmPi3,cscCmPi3}=1./{sinAmPi3,sinBmPi3,sinCmPi3};
{cscApPi6,cscBpPi6,cscCpPi6}=1./{sinApPi6,sinBpPi6,sinCpPi6};
{cscAmPi6,cscBmPi6,cscCmPi6}=1./{sinAmPi6,sinBmPi6,sinCmPi6};
Chop[(trils=N@#[[2]];{
#[[1]],#[[3]],
trilinearToCartesian[tri,{a,b,c},trils],trils})&/@
(* if singles ≠ {}, use the list to only evaluate requested indices *)
If[Length[singles]>0,newCentersFromFile[[singles]],newCentersFromFile]]
];

newCentersFromFile[[{49}]]

newCentersFromFile//Grid

centerEqns=TraditionalForm@First@First@#&/@List@@@((Second@#)&/@Get["data/x0001_0100.m"]);
centerNames=(#[[1]]<>": "<>#[[2]])&/@Quiet@getNewCenters[{{0,0},{1,0},{1,1}},RotateLeft@{1,1,Sqrt[2.]}];

Clear@newCentersLow;
newCentersLow[tri_,sides_,singles_:{}]:=Module[{o,n,s},
(*o=Reverse@o;*)
(*sides=triLengthsRL@orbit;*)
getNewCenters[tri,sides,singles]
];

Clear@newCenters;newCenters[a_,t_,singles_:{}]:=Module[{o,n,s},
{o,n,s}=orbitNormals[a,t];
(*o=Reverse@o;*)
(*sides=triLengthsRL@orbit;*)
getNewCenters[o,s,singles]
];

newCenters[1.5,10.,{9}]

Drawing Notables & Clrs

ColorData["HTML","Panel"]

ptClrs={
"ell"->Black,
"med"->Darker@Red,
"bar"->Brown,
"inc"->Darker@Green,
"ort"->Orange,
"cir"->Purple,
"npc"->ColorData["HTML","PaleVioletRed"],
"exc"->Darker@Green,
"ex12"->Darker@Green,
"ex23"->Darker@Green,
"ex31"->Darker@Green,
"dar"->ColorData["HTML","Navy"],
"x144"->ColorData["HTML","Navy"],
"x59"->ColorData["HTML","OrangeRed"],
"feu"-> ColorData["HTML","DarkKhaki"],
"antifeu"->ColorData["HTML","SlateGray"],
"anticompl"->Blue,
"steiner"->Brown,
"steinerinell"->Brown,
"x88"->Darker@Cyan,
"x100"->ColorData["HTML","SlateGray"],
"nag"->ColorData["HTML","MediumAquamarine"],
"mit"->Red(*Lighter@Blue*),
"sym"->ColorData["HTML","DodgerBlue"],
"bev"->Lighter@Purple,
"ger"->Darker@Cyan,
"spi"->ColorData["HTML","SpringGreen"],
"nap"->Red,
"hex"->Pink,
(* overrides *)
"red"->Red,
"green"->Green,
"blue"->Blue
};

ptClrs

Clear@plotEllb;
plotEllb[a_,b_,clr_:("ell"/.ptClrs)]:=Graphics[{
If[SameQ[clr,None],{},{If[ListQ@clr,Sequence@@clr,clr],Circle[{0,0},{a,b}]}]}];
Clear@plotEll;
plotEll[a_,clr_:("ell"/.ptClrs)]:=plotEllb[a,1,clr];

Clear@plotEllbAxesLow;
plotEllbAxesLow[a_,b_]:=Graphics@{Dashed,Gray,Thickness@Medium,{Line@{{-a,0},{a,0}},Line@{{0,-b},{0,b}}}};

Clear@plotEllAxesLow;
plotEllAxesLow[a_]:=plotEllbAxesLow[a,1];

Clear@plotEllAxes;plotEllAxes[a_,clr_:("ell"/.ptClrs)]:=Graphics@@Show[{plotEll[a,clr],plotEllAxesLow[a]}]
Clear@plotEllbAxes;
plotEllbAxes[a_,b_,clr_:("ell"/.ptClrs)]:=Graphics@@Show[{plotEllb[a,b,clr],plotEllbAxesLow[a,b]}]

Clear@plotEllFillb;
plotEllFillb[a_,b_,clrFill_,clr_:("ell"/.ptClrs)]:=Graphics[{
If[SameQ[clrFill,None],{},{If[ListQ@clrFill,Sequence@@clrFill,clrFill],Disk[{0,0},{a,b}]}],
If[SameQ[clr,None],{},{If[ListQ@clr,Sequence@@clr,clr],Circle[{0,0},{a,b}]}]
}];
Clear@plotEllFill;plotEllFill[a_,clrFill_,clr_:("ell"/.ptClrs)]:=plotEllFillb[a,1,clrFill,clr];

(*Clear@plotEll;
plotEll[a_,clr_:("ell"/.ptClrs)]:=ParametricPlot[{N[a] Cos[u],Sin[u]},{u,0.0,2.0π},
PlotStyle->clr,PerformanceGoal->"Quality"];
plotEllFill[a_,clrFill_,clr_:("ell"/.ptClrs)]:=Module[{int,ext},
int=ParametricPlot[r{N[a] Cos[u],Sin[u]},{u,0.0,2.0π},{r,0,1},
PlotStyle->clrFill,PerformanceGoal->"Quality"];
ext=plotEll[a,clr];
Show[{int,ext}]];
plotEllb[a_,b_,clr_:("ell"/.ptClrs)]:=ParametricPlot[{N[a] Cos[u],N[b]Sin[u]},{u,0.0,2.0π},
PlotStyle->clr,PerformanceGoal->"Quality"];*)

drawArrow[p0_,phat_,l_]:=Arrow[{p0,ray[p0,phat,l]}];

Clear@drawOrbit;
Options@drawOrbit={lgt->.25,drNormals->True,pSize->16,drVtxLabels->True,clr->{Thick,Darker@Blue}};
drawOrbit[orbitData_,OptionsPattern[](*lgt_:.25,drawNormals_:True,psize_:16*)]:=Module[{normals,orbit,halfAlpha},
orbit="orbit"/.orbitData;
normals="normals"/.orbitData;
halfAlpha="halfAlpha"/.orbitData;
Graphics[{
PointSize[Large],Arrowheads[Medium],
{OptionValue@clr,Point@orbit},
{FaceForm[GrayLevel@.9],EdgeForm@OptionValue@clr,Polygon@orbit},
If[OptionValue@drNormals,
{Black,
MapThread[drawArrow[#1,#2,OptionValue@lgt]&,{orbit,normals}],
Dashed,
drawArrow[orbit[[1]],"nRot"/.orbitData,OptionValue@lgt],
drawArrow[orbit[[1]],"nRotNeg"/.orbitData,OptionValue@lgt],
Text["α",ray[orbit[[1]],halfAlpha ,.33OptionValue@lgt]]},{}],
If[OptionValue@drVtxLabels,MapThread[txtSubscript["P",ToString@#1,OptionValue@pSize,ray[#2,-#3,.33OptionValue@lgt]]&,
{{1,2,3},orbit,normals}],{}]}]
];

Clear@drawOneNotable;drawOneNotable[clr_,at_,txt_,dx_:1.5,dy_:0,fntSize_:12]:={clr,Point@at,Text[Style[txt,fntSize],at,{dx,dy}]};
circOneNotable[clr_,at_,rad_,txt_,dx_:1.5,dy_:0,fntSize_:12]:={clr,Circle[at,rad],Text[Style[txt,fntSize],at,{dx,dy}]};
Clear@drawNotableLines;drawNotableLines[notables_]:=Graphics@{Darker[Gray],Dashed,
(* euler line: cir,bar,npc,ort *)
Line[{"cir","ort"}/.notables],
(* npc to feuerbach: npc,inc,feu *)
Line[{"npc","feu"}/.notables],
(* mittenpunkt to symmedian: mit,inc,sym *)
Line[{"mit","sym"}/.notables],
(* gergonne to mit: ger,bar,mit *)
Line[{"mit","ger"}/.notables],
(* nagel line: nag,bar,spi,inc *)
Line[{"nag","inc"}/.notables]};
Clear@drawNotables;
drawNotables[notables_,prefix_:""]:=Graphics[{PointSize[Large],
drawOneNotable[(#/.ptClrs),(#/.notables),prefix<>#]&/@
{"inc","bar","ort","cir","npc","feu","ex12","ex23","ex31","sym","mit","ger","nag","spi","antifeu","x88"}}];
drawNotablesSingleClr[notables_,clr_,prefix_:""]:=Graphics[{PointSize[Large],
drawOneNotable[clr,(#/.notables),prefix<>#]&/@
{"inc","bar","ort","cir","npc","feu","ex12","ex23","ex31","sym","mit","ger","nag","spi","antifeu","x88"}}];
Clear@circNotables;
circNotables[notables_,rad_,prefix_:""]:=Graphics[{PointSize[Large],
circOneNotable[(#/.ptClrs),(#/.notables),rad,prefix<>#]&/@
{"inc","bar","ort","cir","npc","feu","ex12","ex23","ex31","sym","mit","ger","nag","spi","antifeu","x88"}}];
Clear@circNotablesSingleClr;
circNotablesSingleClr[notables_,rad_,clr_,prefix_:""]:=Graphics[{PointSize[Large],
circOneNotable[clr,(#/.notables),rad,prefix<>#]&/@
{"inc","bar","ort","cir","npc","feu","ex12","ex23","ex31","sym","mit","ger","nag","spi","antifeu","x88"}}];
Clear@drawSomeNotables;
drawSomeNotables[notables_,nots_,prefix_:""]:=Graphics[{PointSize[Large],
drawOneNotable[(#/.ptClrs),(#/.notables),prefix<>#]&/@nots}];
Clear@drawBasicNotables;
drawBasicNotables[notables_,prefix_:""]:=drawSomeNotables[notables,{"inc","bar","ort","cir","npc","mit","feu","ger"},prefix];
Clear@drawBasicNotablesSingleClr;
drawBasicNotablesSingleClr[notables_,clr_,prefix_:""]:=Graphics[{PointSize[Large],
drawOneNotable[clr,(#/.notables),prefix<>#]&/@
{"inc","bar","ort","cir","npc","mit","feu"}}];
Clear@circBasicNotables;
circBasicNotables[notables_,rad_,prefix_:""]:=Graphics[{PointSize[Large],
circOneNotable[(#/.ptClrs),(#/.notables),rad,prefix<>#]&/@
{"inc","bar","ort","cir","npc","mit","feu"}}];
Clear@circBasicNotablesSingleClr;
circBasicNotablesSingleClr[notables_,rad_,clr_,prefix_:""]:=Graphics[{PointSize[Large],
circOneNotable[clr,(#/.notables),rad,prefix<>#]&/@
{"inc","bar","ort","cir","npc","mit","feu"}}];

ManipX: Visualize the locus of a few centers

Clear@manipX;
Options@manipX={clr->Darker@Red,n->-1,slackX->.2,slackY->.2,perfGoal->"Speed"};
manipX[a_,trilinFn_,OptionsPattern[]]:=
DynamicModule[{ell,ons,gr,pl,x,xlab,pr,lab},
Manipulate[
ell=plotEllAxes[a,{Thick,Black}];
pl=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@tDeg2];
trilinFn[ons[[1]],ons[[3]]],{tDeg2,0,180},PlotStyle->OptionValue@clr,PerformanceGoal->OptionValue@perfGoal];
xlab=ToString[Subscript["X",OptionValue@n],StandardForm];
lab="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1];
pr={{-a-OptionValue@slackX,a+OptionValue@slackX},{-1-OptionValue@slackY,1+OptionValue@slackY}};
Dynamic[
ons=orbitNormals[a,toRad@tDeg];
x=trilinFn[ons[[1]],ons[[3]]];
gr=Graphics[{FaceForm@None,PointSize@Large,
drawPoly[ons[[1]],Blue],
{Darker@Red,Point@x,If[OptionValue@n>0,Text[Style[xlab,16],x,{-1.25,-1.25}],{}]}}];
Show[{ell,pl,gr},PlotLabel->Style[lab,{Black,16}],PlotRange->pr]],
{{tDeg,10.},-180,180,.1,Appearance->"Labeled"}],SaveDefinitions->True];

manipX[1.5,getX661Trilin,n->661,slackX->50,slackY->50]

manipX[1.45,getX49Trilin,n->49]

Locus X661 and major-axis-bound X2590

DynamicModule[{a=3,ell,ons,gr,pl,x,xlab,pr,pr2,lab,slackX=50,slackY=50,slackX2=5,slackY2=.2,n=661,x662,x799,x2590,gr2,clr=Purple},
Manipulate[
ell=plotEllAxes[a,{Thick,Black}];
pl=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@tDeg2];
getX661Trilin[ons[[1]],ons[[3]]],{tDeg2,1,13},PlotStyle->clr,PerformanceGoal->"Speed"];
xlab=ToString[Subscript["X",n],StandardForm];
lab="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1];
pr={{-a-slackX,a+slackX},{-1-slackY,1+slackY}};
pr2={{-a-slackX2,a+slackX2},{-1-slackY2,1+slackY2}};
Dynamic[
ons=orbitNormals[a,toRad@tDeg];
x=getX661Trilin[ons[[1]],ons[[3]]];
x662=getX662Trilin[ons[[1]],ons[[3]]];
x799=getX799Trilin[ons[[1]],ons[[3]]];
x2590=getX2590Trilin[ons[[1]],ons[[3]]];
gr=Graphics[{FaceForm@None,PointSize@Large,
drawPoly[ons[[1]],Blue],
{Darker@Red,Point@x,If[n>0,Text[Style[xlab,16],x,{-1.25,-1.25}],{}]}}];
gr2=Graphics[{PointSize@Large,Point@x662,Point@x799,Red,Point@x2590}];
Grid[{{Show[{ell,pl,gr},PlotRange->pr,ImageSize->400],Show[{ell,gr,gr2},PlotRange->pr2,ImageSize->400]}}]],
{{tDeg,10.},-180,180,.1,Appearance->"Labeled"}],SaveDefinitions->True]

Orbit and Derived Triangles

(* {"billiard","caustic",
"orbit","medial","orthic","intouch","excentral","extouch","anticompl","exfeuer"} *)

Clear@showDerivedTris;
Options@showDerivedTris={drLegends->True,drCaustic->True};
showDerivedTris[a_,tDeg_,OptionsPattern[]]:=Module[{caustic,ell,ca,cb,ellCaustic,clrs,orbit,normals,sides,tris,gr,maxX=2,maxY=2},
{ca,cb}=getTriCausticParams[a];
ell=plotEllAxes[a,{Thick,Black}];
ellCaustic=If[OptionValue@drCaustic,plotEllb[ca,cb,{Thick,Dashed,"feu"/.ptClrs}],{}];
clrs=If[OptionValue@drCaustic,
{Black,{Dashed,"feu"/.ptClrs},Blue,Darker@Red,"ort"/.ptClrs,{Dashed,"inc"/.ptClrs},"inc"/.ptClrs,{Dashed,Orange},{Dashed,Blue},"feu"/.ptClrs},
{Black,Blue,Darker@Red,"ort"/.ptClrs,{Dashed,"inc"/.ptClrs},"inc"/.ptClrs,{Dashed,Orange},{Dashed,Blue},"feu"/.ptClrs}];
{orbit,normals,sides}=orbitNormals[a,toRad@tDeg];
tris=(#[orbit,sides]&)/@{medialTriangle,orthicTriangle,intouchTriangle,
excentralTriangle,extouchTriangle,anticomplementaryTriangle,feuerbachTriangle};
gr=Graphics[{FaceForm@None,Dotted,Black,MapThread[{EdgeForm@{Thick,If[ListQ@#1,Sequence@@#1,#1]},Polygon@#2,If[ListQ@#1,Sequence@@#1,#1],Point@#2}&,
{Drop[clrs,If[OptionValue@drCaustic,2,1]],Prepend[tris,orbit]}]}];
If[OptionValue@drLegends,
Legended[Show[{ell,ellCaustic,gr},
Frame->True,ImageSize->Large,PlotLabel->Style["Orbit and Derived Triangles",Directive[{Black,14}]],PlotRange->{{-maxX,maxX},{-maxY,maxY}}],
LineLegend[Directive[{Thickness@Large,#}]&/@clrs,
Style[#,20]&/@{"billiard",Sequence@@If[OptionValue@drCaustic,{"caustic"},{}],"orbit",
"medial","orthic","intouch","excentral","extouch","anticompl","feuerbach"}]],
Show[{ell,ellCaustic,gr},
Frame->True,ImageSize->Large,PlotLabel->Style["Orbit and Derived Triangles",Directive[{Black,14}]],PlotRange->{{-maxX,maxX},{-maxY,maxY}}]]
];

Manipulate[showDerivedTris[a,tDeg,drCaustic->False],
{{a,1.5},1.01,3.0,Appearance->"Labeled"},
{{tDeg,31},-180,180,1,Appearance->"Labeled"}]

(*DeleteFile[trisObj]*)

(*trisObj=CloudDeploy[%,"orbit and its derived triangles v1",Permissions->"Public"]*)

Study of the Extouch Triangle: any points = X(9) ?

getExtouchPoints[a_,t_]:=Module[{ons,ext,extSides,mit,ctrs,ctrsToMit},
ons=orbitNormals[a,t];
mit=getMittenTrilin[ons[[1]],ons[[3]]];
ext=extouchTriangle[ons[[1]],ons[[3]]];
extSides=triLengthsRL@ext;
ctrs=getNewCenters[ext,extSides];
ctrsToMit=magn2[#[[3]]-mit]&/@ctrs;
Sort@ctrsToMit]

getExtouchPoints[1.5,.1]

Draw Orbits: Parametrize by (Subscript[x, 1])

Clear@drawSim;
Options@drawSim=Join[Options@getOrbitData,Options@drawOrbit,{drNotables->True,drLines->False,drTh->False,drVtxLabels->True,lgt->.5}];
drawSim[a_,x_,opts:OptionsPattern[]]:=Module[{ellPlot,orbitData,orbit,normals,notables,lab},
ellPlot=plotEll[a,{Thick,Black}];
orbitData=getOrbitData[N[a],N[x], FilterRules[{opts}, Options@getOrbitData]];(* N for speed *)
(* half-angle to display α at bisector *)
orbit="orbit"/.orbitData;
normals="normals"/.orbitData;
notables=getNotables[orbit,normals];
Show[{
ellPlot,
drawOrbit[orbitData,FilterRules[{opts},Options@drawOrbit]],
If[OptionValue@drNotables,drawNotables[notables],{}],
If[OptionValue@drLines,drawNotableLines[notables],{}]
},
ImageSize->Large,
AspectRatio->Automatic,
PlotRange->{{-2,2},{-1.1,1.1}},Frame->True,AxesStyle->Directive[RGBColor[.66,.66,.66]],
PlotLabel->Style["a="<>nf@a<>"; x="<>nf@x,20]]];

Clear@drawSimT;
Options@drawSimT=Options@drawSim;
drawSimT[a_,t_,opts:OptionsPattern[]]:=Module[{x,y},
x=a Cos@t;
y=Sin@t;
drawSim[a,x,{opts,posY->y>0}]];

Manipulate[
drawSim[a,clamp[x1,a],drLines->drLines0,posY->(!negY),drNotables->drNotables0],
{{a,1.5,"a/b"},1.01,3,.01,Appearance->"Labeled"},
{{x1,.5,"(Subscript[x, 1])"},-2,2,.01,Appearance->"Labeled"},
{{negY,False,"(Subscript[y, 1])<0"},{False,True}},
{{drNotables0,True,"show notables"},{False,True}},
{{drLines0,False,"show lines"},{False,True}},
SaveDefinitions->True]

Ellipticity: which loci are elliptic w/ least squares (findEllParams)

Clear@findEllParams;
findEllParams[a_,i_,locus_,name_]:=Module[{m,b,c2,lsc2,causticC,ls,lsa,lsb,err,causticA,causticB,abRatio,causticRatio,lsRatio},
abRatio=a;
c2=Abs[a^2-1];
m=(#^2)&/@locus;(* { {x1^2,y1^2}, {x2^2,y2^2}, ... } *)
b=ConstantArray[1,Length@locus];
ls=LeastSquares[m,b];
{lsa,lsb}=Sqrt[1/#]&/@ls;
lsRatio=lsa/lsb;
lsc2=Abs[lsa^2-lsb^2];
err=Norm[m.ls-b];
{causticA,causticB}=getTriCausticParams[a];
causticRatio=causticA/causticB;
causticC=Sqrt@Abs[causticA^2-causticB^2];
<|"i"->i,
"name"->name,
"errNegl"->(Abs[err]<10^-6),
"ellSim"->negl[abRatio-lsRatio],
"ellSimInv"->negl[abRatio-1/lsRatio],
"ellEq"->(negl[a-lsa]&&negl[1-lsb]),
"ellEqInv"->(negl[1-lsa]&&negl[a-lsb]),
"causticSim"->negl[causticRatio-lsRatio],
"causticSimInv"->negl[causticRatio-1/lsRatio],
"causticEq"->(negl[causticA-lsa]&&negl[causticB-lsb]),
"causticEqInv"->(negl[causticB-lsa]&&negl[causticA-lsb]),
"confocal"->negl[c2-lsc2],
"err"->err,
"a"->a,"b"->1,"a/b"->abRatio,"b/a"->(1/abRatio),
"c2"->c2,"lsc2"->lsc2,
"lsA"->lsa,"lsB"->lsb,"lsA/lsB"->lsRatio,"lsB/lsA"->(1/lsRatio),
"caustic_a"->causticA,"caustic_b"->causticB,"caustic_a/b"->causticRatio,"caustic_b/a"->(1/causticRatio),
"caustic_c"->causticC
|>];

Clear@getLociTable;
getLociTable[a_,ctrFn_,tmax_:π,step_:toRad[.1]]:=Module[{nc,pts,loci},
loci=Table[
nc=ctrFn[a,t]//Quiet;
pts=(#[[3]]&/@nc);
{t,pts},
{t,.5*step,tmax,step}];
Transpose[#[[2]]&/@loci]];

findEllParamsSingle[a_,n_]:=Module[{locus},
(* locus of single center *)
locus=getLociTable[a,newCenters[#1,#2,{n}]&];
findEllParams[a,1,locus[[1]],centerNames[[n]]]]

Clear@findEllParamsFn;
Options@findEllParamsFn={minDeg->0,maxDeg->359,degStep->1.};
findEllParamsFn[a_,getFn_,OptionsPattern[]]:=Module[{locus,ons},
(* locus of single center *)
locus=Table[ons=orbitNormals[a,toRad@t];getFn[ons[[1]],ons[[3]]],{t,OptionValue@minDeg,OptionValue@maxDeg,OptionValue@degStep}];
findEllParams[a,-1,locus,"n/a"]]

[slow] Draw Loci: w/ and without lobes

Clear@medialLocus;
medialLocus[a_,tmax_,ps_:("med"/.ptClrs)]:=Module[{orbit,normals,sides,meds},
Quiet@ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
meds=getMedians@@orbit;
meds[[1]],
{t,0,tmax},PlotStyle->ps]
];

Clear@orthicVertexLocus;
orthicVertexLocus[a_,tmax_,ps_:("ort"/.ptClrs)]:=Module[{orbit,normals,sides,meds},
Quiet@ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthicTriangle[orbit,sides][[1]],
{t,0,tmax},PlotStyle->ps]
];

Clear@symmedianLocus;
symmedianLocus[a_,tmax_,ps_:("sym"/.ptClrs),psExc_:("exc"/.ptClrs)]:=Module[{o,n,s,ppOrbit,ppExc,exc,syms},
ppOrbit=Quiet@ParametricPlot[
{o,n,s}=Evaluate[orbitNormals[a,t]];
syms=symmedialTriangle[o,s];
syms[[1]],
{t,0,tmax},PlotStyle->ps];
ppExc=Quiet@ParametricPlot[
{o,n,s}=Evaluate[orbitNormals[a,t]];
exc=excentralTriangle[o,s];
syms=symmedialTriangle[exc,triLengthsRL@exc];
syms[[1]],
{t,0,tmax},PlotStyle->psExc];
Show[{ppOrbit,ppExc},PlotRange->All]
];

Clear@incenterLocus;
incenterLocus[a_,tmax_,ps_:("inc"/.ptClrs)]:=Module[{ons},
Quiet@ParametricPlot[
ons=Evaluate[orbitNormals[a,t]];
getIncenterTrilin[ons[[1]],ons[[3]]],
{t,0,tmax},PerformanceGoal->"Speed",PlotStyle->ps]
];

Clear@baricenterLocus;
baricenterLocus[a_,tmax_,ps_:("bar"/.ptClrs)]:=Module[{orbit,normals,sides},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
(*getCentroid[orbit,triLengths@orbit]*)
getBaricenter@@orbit,
{t,0,tmax},PlotStyle->ps]
];

Clear@orthocenterLocus;
orthocenterLocus[a_,tmax_,ps_:("ort"/.ptClrs)]:=Module[{orbit,normals,sides},
Quiet@ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
getOrthocenter@@orbit,
{t,0,tmax},PlotStyle->ps]
];

Clear@circumcenterLocus;
circumcenterLocus[a_,tmax_,ps_:("cir"/.ptClrs)]:=Module[{orbit,normals,sides},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
getCircumcenter@@orbit,
{t,0,tmax},PlotStyle->ps]
];

Clear@ninepointcenterLocus;
ninepointcenterLocus[a_,tmax_,ps_:("npc"/.ptClrs)]:=Module[{orbit,normals,sides},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
getNinepointcenter@@orbit,
{t,0,tmax},PlotStyle->ps]
];

Clear@excenterLocus;
excenterLocus[a_,tmax_,ps_:("exc"/.ptClrs)]:=Module[{orbit,normals,sides},
Quiet@ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
getExcenters[orbit,normals][[1]],
{t,0,tmax},PlotStyle->ps]
];

(*Module[{a=1.5,o,n,s,tDeg=35.,gr,inc},
{o,n,s}=orbitNormals[a,toRad@tDeg];
inc=getIncenterTrilin[o,s];
gr=Graphics[{FaceForm@None,
{EdgeForm@{Thick,Blue},Polygon@o,EdgeForm@{Thick,Darker@Green,Dashed}},
{PointSize@Large,Darker@Green,Point@inc},
{Dashed,Black,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}}}];
Show[{plotEll[a,{Thick,Black}],gr,incenterLocus[a,π/1.2,Darker@Green]},Frame->True,PlotRange->All,ImageSize->Large]]*)

(*Module[{a=1.25,o,n,s,tDeg=30.,gr,exc,inc},
{o,n,s}=orbitNormals[a,toRad@tDeg];
inc=getIncenterTrilin[o,s];
exc=excentralTriangle[o,s];
gr=Graphics[{FaceForm@None,EdgeForm@{Thick,Blue},Polygon@o,EdgeForm@{Thick,Darker@Green,Dashed},Polygon@exc,PointSize@Large,Darker@Green,Point@exc,Point@inc}];
Show[{plotEll[a,{Thick,Black}],gr,incenterLocus[a,π/1.2,Darker@Green],excenterLocus[a,2π,Darker@Green]},Frame->True,PlotRange->All,ImageSize->Large]]*)

Clear@exFeuerbachcenterLocus;
exFeuerbachcenterLocus[a_,tmax_,ps_:("feu"/.ptClrs)]:=Module[{ons,eps=.01},
Quiet@ParametricPlot[
ons=orbitNormals[a,t+eps];
feuerbachTriangle[ons[[1]],ons[[3]]][[1]],
{t,0,tmax},PlotStyle->ps]]

Clear@feuerbachcenterLocus;
feuerbachcenterLocus[a_,tmax_,ps_:("feu"/.ptClrs)]:=Module[{orbit,normals,sides,npc,inc,inradius,feu},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
npc=getNinepointcenter@@orbit;
inc=getIncenter[orbit[[1]],normals[[1]],orbit[[2]],normals[[2]]];
inradius=inRadius0[inc,orbit[[1]],orbit[[2]]];
getFeuerbachpoint[npc,inc,inradius],
{t,0,tmax},PlotStyle->ps]
];

(*GraphicsRow[{
incenterLocus[2,π/1.2]//Quiet,
baricenterLocus[2,π/1.2]//Quiet,
orthocenterLocus[2,π/1.2]//Quiet,
circumcenterLocus[2,π/1.2]//Quiet,
ninepointcenterLocus[2,π/1.2]//Quiet,
excenterLocus[2,π]//Quiet,
feuerbachcenterLocus[2,π/1.2]//Quiet}
]*)

Clear@intouchLocus;
intouchLocus[a_,tmax_,ps_:("exc"/.ptClrs)]:=Module[{orbit,normals,sides,tps},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
tps=intouchTriangle[orbit,sides];
tps[[1]],
{t,0,tmax},PlotStyle->ps]
];

(*Show[intouchLocus[1.5,2π]//Quiet,ImageSize->Small]*)

Clear@getFeuLoci;getFeuLoci[a_,showExFeu_:False]:=Show[{
plotEll[a],
feuerbachcenterLocus[a,π/1.2]//Quiet,
If[showExFeu,exFeuerbachcenterLocus[a,2π]//Quiet,{}]}];

Clear@getDashedFeuLoci;
getDashedFeuLoci[a_]:=feuerbachcenterLocus[a,π/1.2,{Dashed,"feu"/.ptClrs}]//Quiet

Clear@getAntiComplementaryVertexLocus;
getAntiComplementaryVertexLocus[a_,tmax_:2π,ps_:{Dashed,Blue}]:=Module[{orbit,normals,sides,act},
Quiet@ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
act=anticomplementaryTriangle[orbit,triLengthsRL@orbit];
act[[1]],
{t,0,tmax},PlotStyle->ps]];

(*getAntiComplementaryVertexLocus[1.5]*)

Module[{a=1.5,orbitData,lgt=.2},
orbitData=getOrbitData[a,toRad[30.]];
Legended[Show[{
(*drawOrbit[orbitData,lgt],*)
plotEll[a],
feuerbachcenterLocus[a,π/1.2,{Dashed,"feu"/.ptClrs}],
exFeuerbachcenterLocus[a,2π],
intouchLocus[a,2π],
incenterLocus[a,π,{Dashed,"exc"/.ptClrs}],
medialLocus[a,2π],
getAntiComplementaryVertexLocus[a]
}, PlotRange->All,ImageSize->Large],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell","inc","feu","inc","feu","med","anticompl"},
{{},Dashed,Dashed,{},{},{},{}}}],
{"billiard","inc","feu / extouch","intouch","xfeu","med","anticompl"}]]]//Quiet

nonEllipticPlot=Module[{a=1.5,orbitData,lgt=.2,thick=.0075},
orbitData=getOrbitData[a,toRad[30.]];
Legended[Show[{
(*drawOrbit[orbitData,lgt],*)
plotEll[a,{Thickness@thick,Black}],
(*feuerbachcenterLocus[a,π/1.2,{"bar"/.ptClrs}],*)
feuerbachcenterLocus[a,π/1.2,Directive["feu"/.ptClrs,Thickness@thick]],
exFeuerbachcenterLocus[a,2π,Directive["sym"/.ptClrs,Thickness@thick]],
intouchLocus[a,2π,Directive["inc"/.ptClrs,Thickness@thick]],
medialLocus[a,2π,Directive["med"/.ptClrs,Thickness@thick]]
}, PlotRange->All,ImageSize->Large],
LineLegend[MapThread[
Directive[{Thickness@.015,#2,#1/.ptClrs}]&,
{{"ell","feu",(*"bar",*)"inc","sym","med"},
{{},{},(*{},*){},{},{}}}],
Style[#,20]&/@{"Billiard & (Subscript[X, 100])",(*"Feuerbach Point",*)"Extouch Triangle & (Subscript[X, 11])","Intouch Triangle","Feuerbach Triangle","Medial Triangle"}]]]//Quiet;

nonEllipticPlot

(*export3["0040_non_elliptic",nonEllipticPlot]*)

(*Module[{a=1.5,orbitData,lgt=.2},
orbitData=getOrbitData[a,toRad[30.]];
Legended[Show[{
(*drawOrbit[orbitData,lgt],*)
plotEll[a],
intouchLocus[a,2π],
medialLocus[a,2π,"med"/.ptClrs],
getAntiComplementaryVertexLocus[a]
}, PlotRange->All,ImageSize->Large],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell","inc","med","anticompl"},
{{},{},{},Dashed}}],
{"billiard","intouch vertex","medial vertex","anticompl vertex"}]]]//Quiet*)

The locus of the Outer Napoleon Point is not particularly interesting

Clear@outerNapoleonLocus;
outerNapoleonLocus[a_,tmax_,ps_:("nap"/.ptClrs)]:=Module[{orbit,normals,sides,nap},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
nap=outerNapoleonTriangle[orbit,sides];
nap[[1]],
{t,0,tmax},PlotStyle->ps]
];

(*outerNapoleonLocus[1.5,2π]//Quiet*)

Path of First Morley Center Just outside Incenter' s

Clear@morleyIncenterLocus;
morleyIncenterLocus[a_,tmax_]:=Module[{orbit,normals,sides,mor1,mor2,mor3,inc},
ListLinePlot[Transpose@Table[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
mor1=getFirstMorleyTrilin[orbit,sides];
mor2=getSecondMorleyTrilin[orbit,sides];
mor3=getThirdMorleyTrilin[orbit,sides];
inc=getIncenterTrilin[orbit,sides];
{inc,mor1,mor2,mor3},
{t,0,tmax,tmax/100}],PlotStyle->{Darker@Green,Automatic,Automatic,Automatic},
PlotLegends->{"inc","morley 1","morley 2","morley 3"},ImageSize->Large]
];

(*Quiet@morleyIncenterLocus[1.5,π/1.27]*)

Clear@orthicIncenterLocus;
orthicIncenterLocus[a_,tmax_,ps_:("inc"/.ptClrs)]:=Module[{orbit,normals,sides,feet,ortInc,ortSides},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
feet=getAltBases@@orbit;
ortSides=triLengthsRL@feet;
ortInc=getIncenterTrilin[feet,ortSides];
ortInc,
{t,0,tmax},PlotStyle->ps]
];

(*Show[orthicIncenterLocus[1.5,π/1.2]//Quiet,ImageSize->Small]*)

(* using anticomplementary triangle, but needs higher frequency *)
Clear@orthicIntouchTriangleIncenterLocus;
orthicIntouchTriangleIncenterLocus[a_,tmax_,ps_:Red]:=Module[{orbit,normals,sides,orthic},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthic=getOrthicData@orbit;
"intouchAnticomplOrtInc"/.orthic,
{t,0,tmax},PlotStyle->ps]
];

Shows orthic' s orthocenter (dashed) too

getOrthicIncOrt[a_,t_]:=Module[{orbit,normals,sides,orthic,ort,inc},
{orbit,normals,sides}=orbitNormals[a,t];
orthic=getOrthicData@orbit;
inc="orthicInc"/.orthic;
ort="ort"/.orthic;
{inc,ort}];

Clear@orthicsOrthicIncenterLocus2;
orthicsOrthicIncenterLocus2[a_,tmax_:π/1.2,ps_:Blue]:=
ParametricPlot[
Evaluate@List@@getOrthicIncOrt[a,t],{t,0,tmax},
PlotStyle->({ps,{Dashed,ps}}),
PlotRange->All];

(*orthicsOrthicIncenterLocus2[1.5]//Quiet*)

Clear@orthicsOrthicIncenterLocus;
orthicsOrthicIncenterLocus[a_,tmaxInc_:π/1.2,tmaxOrt_:π/1.2,psOrthicOrt_:{Dashed,Blue},psOrtOrtInc_:Blue]:=Module[{orbit,normals,sides,orthic,ppInc,ppOrt,mr=8},
ppInc=ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthic=getOrthicData@orbit;
"orthicInc"/.orthic,
{t,0,tmaxInc},PlotStyle->Directive[Thick,psOrtOrtInc],PerformanceGoal->"Quality",MaxRecursion->mr];
ppOrt=ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthic=getOrthicData@orbit;
"ort"/.orthic,
{t,0,tmaxOrt},PlotStyle->psOrthicOrt,PerformanceGoal->"Quality",MaxRecursion->mr];
Show[{ppOrt,ppInc},PlotRange->All]
];

Clear@orthicsOrthicAnticomplIncenterLocus;
orthicsOrthicAnticomplIncenterLocus[a_,tmax_,ps_:Pink]:=Module[{orbit,normals,sides,orthic},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthic=getOrthicData@orbit;
"orthicAnticomplInc"/.orthic,
{t,0,tmax},PlotStyle->ps]
];

Legended[Show[{
orthicIncenterLocus[1.5,π/1.2],
orthicIntouchTriangleIncenterLocus[1.5,π/1.2],
orthicsOrthicIncenterLocus[1.5,π/1.2],
orthicsOrthicAnticomplIncenterLocus[1.5,π/1.2]},PlotRange->All
]//Quiet,
LineLegend[Directive[{Thickness@Large,#}]&/@{Green,Red,Blue,Pink},
{"orthicInc","orthicIntouchInc","orthicsOrthicInc + orthicOrthocenter (dashed)","orthicsOrthicAnticomplInc"}]]

[slow] Test Ellipticity of Actual Centers

A few irrationals, showing finite  least-squares error, i.e., their locus isn't an ellipse

findEllParamsFn[1.5,#]["err"]&/@{getX359,getX360,getX364,getX365,getX367}

Locus of Excentral's Mittenpunkt isn' t elliptic

findEllParamsFn[1.5,getX168Trilin]["err"]

Locus of Excentral's Incenter X164 isn' t elliptic

findEllParamsFn[1.5,getX164Trilin]["err"]

Locus of Excentral' s Barycenter X164 *is* elliptic

findEllParamsFn[1.5,getX165Trilin]["err"]

Locus of Extouch Incenter X1’’ is ??? elliptic

Module[{a=1.5,ons},
Quiet@ParametricPlot[ons=orbitNormals[a,toRad@tDeg];getExtouchX1Trilin[ons[[1]],ons[[3]]],{tDeg,0,360}]]

findEllParamsFn[1.5,getExtouchX1Trilin]["err"]

Locus of ACT' s Mittenpunkt X7 is elliptic. Locus of Medial' s Mitenpunkt X142 is elliptic.

findEllParamsFn[1.5,getX142Trilin]["err"]

findEllParamsFn[1.98,getX9OrthicTrilin,minDeg->80,maxDeg->100]["err"]

Compare w/ error of  Symmedian

findEllParamsFn[1.5,getSymmedianTrilin]["err"]

doLociTables2=False;
Module[{fname="data/loci15t2.m"},
If[doLociTables2,
loci125t=getLociTable[1.25,newCenters];
loci15t=getLociTable[1.5,newCenters];
loci20t=getLociTable[2.0,newCenters];
loci25t=getLociTable[2.5,newCenters];
loci30t=getLociTable[3.0,newCenters];
Print@"saving..." ;
Save[fname,{loci125t,loci15t,loci20t,loci25t,loci30t}],
Print@"loading...";Get[fname]]];

ellParams125=Quiet@Table[findEllParams[1.25,i,loci125t[[i]],centerNames[[i]]],{i,Length@loci125t}]//Sort[#,#1["err"]<#2["err"]&]&;
ellParams15=Quiet@Table[findEllParams[1.5,i,loci15t[[i]],centerNames[[i]]],{i,Length@loci15t}]//Sort[#,#1["err"]<#2["err"]&]&;
ellParams20=Quiet@Table[findEllParams[2.,i,loci20t[[i]],centerNames[[i]]],{i,Length@loci20t}]//Sort[#,#1["err"]<#2["err"]&]&;
ellParams25=Quiet@Table[findEllParams[2.5,i,loci25t[[i]],centerNames[[i]]],{i,Length@loci25t}]//Sort[#,#1["err"]<#2["err"]&]&;
ellParams30=Quiet@Table[findEllParams[3.,i,loci30t[[i]],centerNames[[i]]],{i,Length@loci30t}]//Sort[#,#1["err"]<#2["err"]&]&;

leastSquaresErrorPlot=ListLogPlot[{
#["err"]&/@Take[ellParams15,100],
#["err"]&/@Take[ellParams20,100],
#["err"]&/@Take[ellParams30,100]}
,Frame->True,GridLines->Automatic,PlotRange->{{1,100},All},FrameStyle->16,FrameTicks->{{Automatic,None},{Prepend[Range[10,100,10],1],None}},FrameLabel->(Style[#,{Black,16}]&/@{"error rank","∑(error^2)"}),PlotStyle->Thick,ImageSize->Large,Joined->True,PlotLegends->SwatchLegend[Style[nfn[#,2],{Black,20}]&/@{1.5,2.,3},LegendFunction->"Frame",LegendLabel->Style["a/b",{Black,20}]]]

(*export3["1100_least_squares_error",leastSquaresErrorPlot]*)

tabErrs15=Prepend[MapIndexed[{First@#2,#1["i"],Sequence@@If[#1["errNegl"],{nfn[#1["lsA"],2],nfn[#1["lsB"],2]},{"--","--"}],ScientificForm[N@#1["err"],2]}&,ellParams15],{"rank","center","a","b","∑err^2"}];

Grid[tabErrs15,Alignment->Right]

Grid[Take[tabErrs15,29],Alignment->Right]//TeXForm

Grid[Drop[#,{3,4}]&/@Drop[tabErrs15,{2,30}],Alignment->Right]//TeXForm

ellParamsSorted=Sort[Select[ellParams15,(#["errNegl"])&],#1["i"]<#2["i"]&];

Which are ellipses?

MapIndexed[{First@#2,#1["name"]}&,ellParamsSorted]//TableForm

What are their trilinears

centerEqns//Length

centerEqns[[7]]

Module[{ell,notEll,both},
notEll=Sort[Select[ellParams15,(!#["errNegl"])&],#1["i"]<#2["i"]&];
ell=Sort[Select[ellParams15,(#["errNegl"])&],#1["i"]<#2["i"]&];
both=Join[ell,notEll];
(*Print[both[[6]]];*)
Grid[Append[#,centerEqns[[#[[3]]]]]&/@MapIndexed[{First@#2,#1["name"],#1["i"]}&,both],ItemStyle->{Automatic,Join[ConstantArray[Blue,Length@ell],ConstantArray[Red,Length@notEll]]}, Alignment->Left]]

Which are similar to the billiard?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["ellSim"])&]]//TableForm

Which are similar to rotated billiard?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["ellSimInv"])&]]//TableForm

Which are identical to the billiard?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["ellEq"]||#["ellEqInv"])&]]//TableForm

Which are similar to the caustic?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["causticSim"])&]]//TableForm

Which are similar to rotated caustic?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["causticSimInv"])&]]//TableForm

Which are identical to the caustic?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["causticEq"]||#["causticEqInv"])&]]//TableForm

Which are confocal?

MapIndexed[{First@#2,#1["name"]}&,Select[ellParamsSorted,(#["confocal"])&]]//TableForm

Clear@tab2TeX;tab2TeX[ellParams_,test_]:=TeXForm@MapIndexed[{First@#2,#1["name"]}&,Select[ellParams,test]];

allTeXtables=Module[{texEll,texBilSim,texBilEq,texCauSim,texCauEq,texConf},
MapThread[{#1,tab2TeX[ellParamsSorted,#2]}&,
Transpose@{
{"00_ell",True&},
{"11_simBill",(#["ellSim"])&},
{"12_simBillRot",(#["ellSimInv"])&},
{"13_eqBill",(#["ellEq"]||#["ellEqInv"])&},
{"21_simCaus",(#["causticSim"])&},
{"21_simCausRot",(#["causticSimInv"])&},
{"23_causEq",(#["causticEq"]||#["causticEqInv"])&},
{"31_confoc",(#["confocal"])&}
}]];

(*Export["tex/tex_"<>#[[1]]<>".txt",#[[2]]]&/@allTeXtables*)

Export to XLS

(*Export["ellParams.xlsx",{Keys[findEllParams[[1]]],
Sequence@@(Values/@Sort[Select[findEllParams,#["errNegl"]&],#1["i"]<#2["i"]&])}]*)

Precomp Loci

Clear@precompLoci;
precompLoci[a_]:=Module[{ell,tmax=π/1.2},
Show[{
incenterLocus[a,tmax]//Quiet,
baricenterLocus[a,tmax]//Quiet,
orthocenterLocus[a,tmax]//Quiet,
circumcenterLocus[a,tmax]//Quiet,
ninepointcenterLocus[a,tmax]//Quiet,
(* note excenters require full 2π *)
excenterLocus[a,2π]//Quiet,
feuerbachcenterLocus[a,tmax]//Quiet
}]];

precompLociBasic[a_]:=Module[{ell,tmax=π/1.2},
Show[{
incenterLocus[a,tmax]//Quiet,
baricenterLocus[a,tmax]//Quiet,
orthocenterLocus[a,tmax]//Quiet,
circumcenterLocus[a,tmax]//Quiet,
ninepointcenterLocus[a,tmax]//Quiet
}]];

precompLociNonEll[a_]:=Module[{ell,tmax=π/1.2},
Quiet@Show[{
exFeuerbachcenterLocus[a,2π],
intouchLocus[a,2π,{Dashed,"inc"/.ptClrs}],
medialLocus[a,2π,{Dashed,"npc"/.ptClrs}]
}]];

Show[precompLociNonEll[1.5],PlotRange->All]

Load Loci Tables for X(1) ~ X(100) [[or generate/save]]

Directory[]

(*loci15t=getLociTable[1.5,newCenters];*)

doLociTables=False;
Module[{a=1.5,fname="data/loci15t.m"},
If[doLociTables,
loci15t=getLociTable[a,newCenters];
lociOrt15t=getLociTable[a,newCentersOrthic];
lociMed15t=getLociTable[a,newCentersMedial];
lociExc15t=getLociTable[a,newCentersExc,π/1.28];
lociIntouch15t=getLociTable[a,newCentersIntouch,π/1.2];
lociExtouch15t=getLociTable[a,newCentersExtouch,π/1.27];
lociAnticompl15t=getLociTable[a,newCentersAnticompl,π/1.28];
lociExfeuerbach15t=getLociTable[a,newCentersExfeuer];
Print@"saving..." ;
Save[fname,{loci15t,lociOrt15t,lociMed15t,lociExc15t,lociIntouch15t,lociExtouch15t,lociAnticompl15t,lociExfeuerbach15t}],
Print@"loading...";Get[fname]]];

newCenters[2.,t,{1}]

ListLinePlot[Table[newCenters[1.5,t+.001,{1}][[1,3]],{t,0,2π,π/1000}]]

*** GENERATES BILLIARD
X(100)  ANTICOMPLEMENT OF FEUERBACH POINT IS THE BILLIARD

*** GENERATES BILLIARD
X(88) = ISOGONAL CONJUGATE OF X(44)

X(44) = X(6)-LINE CONJUGATE OF X(1)
*** X(44) lies on these lines:
Trilinears       b + c - 2a : c + a - 2b : a + b - 2c
Barycentrics  a(b + c - 2a) : b(c + a - 2b) : c(a + b - 2c)
X(44) = (3r2 + 6rR + s2)*X(1) - 18rR*X(2) - 6r2*X(3)    (Peter Moses, April 2, 2013)

LINE-CONJUGATE: (looked up glossary)
Let P = p : q : r, U = u : v : w
The P-line conjugate of U is the point of intersection of line PU and the trilinear polar of the isogonal conjugate of U.

I.e., intersect line X(6)X(1) with the trilinear polar (TP) of the isog conjugate of X(1) which is X(1) itself.

The TP of X(1) is L1, the antiorthic axis, i.e., the orthic axis of the excentral triangle.

the orthic axis of a triangle are give by points (Oa, Ob,Oc) where each side of the orthic triangle meet the triangle sides (Oa, Ob, Oc)


*** to summarize:

1) to get X(44) intersect the line connecting the incenter X(1) and the symmedian point X(6) with the orthic axis of the extriangle.
2) to get X(88) which generates the billiard, get the isogonal conjugate of X(44).

DynamicModule[{a=1.5,o,n,s,gr,ell,o2,o3,locus2,exc,exc2,locusExc2,causticAB,ellCaustic},
ell=plotEll[a,{Thick,Black}];
locus2=Table[Module[{o2a,n2a,s2a},
{o2a,n2a,s2a}=orbitNormals[a,toRad@tDeg2+.01];
{o2a[[1,1]]/a,o2a[[1,2]]}],{tDeg2,0,359,1}];
locusExc2=Table[Module[{o2a,n2a,s2a,exc2a},
{o2a,n2a,s2a}=orbitNormals[a,toRad@tDeg2+.01];
exc2a=excentralTriangle[o2a,s2a];
{exc2a[[1,1]]/a,exc2a[[1,2]]}],{tDeg2,0,359,1}];
causticAB=getTriCausticParams[a];
ellCaustic=plotEllb[Sequence@@causticAB,{Thick,Brown}];
Manipulate[
{o,n,s}=orbitNormals[a,toRad@tDeg+.01];
exc=excentralTriangle[o,s];
o2={#[[1]]a/ causticAB[[1]],#[[2]]/causticAB[[2]]}&/@o;
exc2={#[[1]]/a,#[[2]]}&/@exc;
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@o,Blue,Point@o},
{EdgeForm@{Thick,Dashed,Blue},Polygon@o2,Blue,Point@o2}
(*,{EdgeForm@{Thick,Darker@Green},Polygon@exc,Darker@Green,Point@exc},
{EdgeForm@{Thick,Dashed,Darker@Green},Polygon@exc2,Darker@Green,Point@exc2},
{Blue,Line@locus2},
{Darker@Green,Line@locusExc2}*)
}];
Show[{ell,ellCaustic,gr},PlotRange->{{-3,3},{-3,3}}],
{{tDeg,30},-180,180,1}]]

Order - Dependent has to change that

Clear@showLoci;
showLoci[locus_,a_,lociList_,
auto_,range_,imgSize_:400]:=Module[{ell,ellCaustic,ca,cb,name,lociMaxX,maxX,lociMaxY,maxY,pts,clrs,ncs,lls},
ell=plotEll[a,Black];
{ca,cb}=getTriCausticParams[a];
ellCaustic=plotEllb[ca,cb,{Dashed,Black}];
ncs=#[[locus]]&/@lociList;
clrs={
Black(* billiard *),
{Dashed,Black}(*caustic*),
Blue,(* orbit *)
Red,(* medial *)
"ort"/.ptClrs,(* orthic *)
"inc"/.ptClrs,(* intouch *)
{Dashed,Blue},(* excentral *)
{Dashed,"inc"/.ptClrs},(* extouch *)
{Dashed,Red},(* anticompl *)
"feu"/.ptClrs (* feuer *)
};
pts={PointSize@Medium,MapThread[{If[ListQ@#1,Second@#1,#1],Point@#2[[1]]}&,{Drop[clrs,2],ncs}]};
name=centerNames[[locus]];
(* NEED NOT DO THIS FOR ALL LOCI!!! *)
lociMaxX=clamp[#,10]&/@Table[Max[Select[Join[{a},Sequence@@((First/@(#[[l]]))&/@lociList)],NumberQ]],
{l,1,Length@lociList[[1]]}];
lociMaxY=clamp[#,10]&/@Table[Max[Select[Join[{1},(* b = 1 *) Sequence@@((Second/@(#[[l]]))&/@lociList)],NumberQ]],
{l,1,Length@lociList[[1]]}];
lls=MapThread[ListLinePlot[#1[[locus]],ClippingStyle->None,PlotStyle->#2]&,{lociList,Drop[clrs,2]}];
{maxX,maxY}=If[auto,
1.1{lociMaxX[[locus]],lociMaxY[[locus]]},
{range,range}];
Legended[Show[{ell,ellCaustic,Sequence@lls,Graphics@pts},
ImageSize->{imgSize,imgSize},
Axes->True,
PlotLabel->Style[name,Directive[{Black,14}]],
PlotRange->{{-maxX,maxX},{-maxY,maxY}}],
LineLegend[Directive[{Thickness@Large,#}]&/@clrs,
{"billiard","caustic","orbit",
"medial","orthic","intouch","excentral","extouch","anticompl","feuerbach"}]]];

lociList15t={loci15t,lociMed15t,lociOrt15t,lociIntouch15t,lociExc15t,lociExtouch15t,lociAnticompl15t,lociExfeuerbach15t};

showLoci[2,1.5,lociList15t, True,2,200]

Feuerbach point of anticomplementary triangle sweeps the billiard just like the anticomplement of feuerbach of reference triangle.

Module[{d=.001,loci0},
(* fake other empty loci *)
loci0=ConstantArray[{{-d,-d/2},{d,-d/2},{0,d/2}},100];
showLoci[11,1.5,{loci15t,loci0,loci0,loci0,loci0,loci0,lociAnticompl15t,loci0},
True,2,500]]

Module[{d=.001,loci0},
(* fake other empty loci *)
loci0=ConstantArray[{{-d,-d/2},{d,-d/2},{0,d/2}},100];
showLoci[6,1.5,{loci15t,loci0,loci0,loci0,loci0,loci0,loci0,loci0},
True,2,500]]

showAllLoci=False;
If[showAllLoci,
Manipulate[showLoci[locus,1.5,lociList15t,
auto,range,500],
{{locus,1},1,Length@loci15t,1,Appearance->"Open"},
{{auto,True},{True,False}},
{{range,2},{1,2,4,8,16}},SaveDefinitions->True]];

Save Loci Frames to File

createLociFrames=False;
If[createLociFrames,showLociFrames=Table[Print@locus;showLoci[locus,1.5,lociList15t,
True,2,500],{locus,1,Length@loci15t,1}]; 
Length@showLociFrames];

Directory[]

getLocusFname[i_]:="loci/locus_"<>padZ[i]<>".png";

createLociFrames=False;If[createLociFrames,
If[!DirectoryQ["loci"],CreateDirectory["loci"]];
MapIndexed[Export[getLocusFname[First[#2]],#1]&,showLociFrames]];

Napoleon Summits and Loci

getOuterNapoleonInfoLow[orbit_,sides_]:=Module[{sqrt3ov2=.5Sqrt@3.,meds,naps,napGs,side,area,centroid,tri},
meds=getMedians@@orbit;
naps=MapThread[#1+#2sqrt3ov2 perp[norm@(#4-#3)]&,{meds,sides,RotateLeft@orbit,RotateRight@orbit}];
napGs=MapThread[#1+(#2-#1)/3&,{meds,naps}];
side=magn[napGs[[2]]-napGs[[1]]];
area=.5sqrt3ov2*(side^2);
centroid=Total[napGs]/3;
<|"summits"->naps,"tri"->napGs,"side"->side,"area"->area,"meds"->meds,"centroid"->centroid,"orbit"->orbit|>];

Clear@getOuterNapoleonSummits;
getOuterNapoleonSummits[a_,t_]:=Module[{sqrt3ov2=.5Sqrt@3.,o,n,s},
{o,n,s}=orbitNormals[a,t];
getOuterNapoleonInfoLow[o,s]];

Clear@getOuterNapoleonExcSummits;
getOuterNapoleonExcSummits[a_,t_]:=Module[{sqrt3ov2=.5Sqrt@3.,o,n,s,exc,excSides},
{o,n,s}=orbitNormals[a,t];
exc=excentralTriangle[o,s];
excSides=triLengthsRL@exc;
Join[getOuterNapoleonInfoLow[exc,excSides],<|"baseOrbit"->o,"baseSides"->s|>]];

Clear@makeOneNapoleonFrame;
makeOneNapoleonFrame[a_,ell_,napPts_,tDeg_]:=Module[{ons,gr,aequi,lab},
ons=getOuterNapoleonSummits[a,toRad@tDeg];
gr=Graphics[{FaceForm@None,PointSize@Large,Point@{0,0},ellLabelPoints[a,ons["orbit"],"P",14,.15],
{EdgeForm@{Blue,Thick},Polygon@ons["orbit"],Blue,Point@ons["meds"]},{Darker@Green,MapThread[{{Dashed,Line@{#1,#2}},{Thick,Line@{#3,#2},Line@{#4,#2}},Point@#2}&,{ons["meds"],ons["summits"],RotateLeft@ons["orbit"],RotateRight@ons["orbit"]}]},
{EdgeForm@{Thick,Purple},FaceForm@{Purple,Opacity@.1},Polygon@ons["tri"],Purple,Point@ons["tri"],Point@ons["centroid"]},
(* loci *)
{{EdgeForm@{Thick,Dashed,Blue},Polygon@(First[#@"meds"]&/@napPts)},
{EdgeForm@{Thick,Dashed,Darker@Green},Polygon@(First[#@"summits"]&/@napPts)},
{EdgeForm@{Thick,Dashed,Purple},Polygon@(First[#@"tri"]&/@napPts)},
{EdgeForm@{Purple},Polygon@(#["centroid"]&/@napPts)}}}];
lab="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°, (Subscript[L, equi])="<>nfn[ons["side"],3]<>", (Subscript[A, equi])="<>nfn[ons["area"],3];
Show[{gr,ell},PlotRange->{{-3,3},{-3,3}},PlotLabel->Style[lab,{20,Black}],ImageSize->Large,Frame->True]];

DynamicModule[{ell,ons,gr,napPts},
Manipulate[
ell=plotEll[a,{Black,Thick}];
napPts=Table[getOuterNapoleonSummits[a,toRad@tDeg0],{tDeg0,0,359,1}];
Dynamic@makeOneNapoleonFrame[a,ell,napPts,tDeg],
{{a,1.5},1.01,3,.1,Appearance->"Open"},
{{tDeg,30},-360,360,1,Appearance->"Open"},SaveDefinitions->True]]

Clear@makeOneNapoleonFrameExc;
makeOneNapoleonFrameExc[a_,ell_,napPts_,tDeg_]:=Module[{ons,gr,aequi,lab,o},
ons=getOuterNapoleonExcSummits[a,toRad@tDeg];
o=orbitNormals[a,toRad@tDeg][[1]];
gr=Graphics[{FaceForm@None,PointSize@Large,Point@{0,0},ellLabelPoints[a,ons["orbit"],"P",14,.15],
{EdgeForm@{Black},Polygon@o},
{EdgeForm@{Blue,Thick},Polygon@ons["orbit"],Blue,Point@ons["meds"]},{Darker@Green,MapThread[{{Dashed,Line@{#1,#2}},{Thick,Line@{#3,#2},Line@{#4,#2}},Point@#2}&,{ons["meds"],ons["summits"],RotateLeft@ons["orbit"],RotateRight@ons["orbit"]}]},
{EdgeForm@{Thick,Purple},FaceForm@{Purple,Opacity@.1},Polygon@ons["tri"],Purple,Point@ons["tri"],Point@ons["centroid"]},
(* loci *)
{{EdgeForm@{Thick,Dashed,Blue},Polygon@(First[#@"meds"]&/@napPts)},
{EdgeForm@{Thick,Dashed,Darker@Green},Polygon@(First[#@"summits"]&/@napPts)},
{EdgeForm@{Thick,Dashed,Purple},Polygon@(First[#@"tri"]&/@napPts)},
{EdgeForm@{Purple},Polygon@(#["centroid"]&/@napPts)}}}];
lab="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°, (Subscript[L, equi])="<>nfn[ons["side"],3]<>", (Subscript[A, equi])="<>nfn[ons["area"],3];
Show[{gr,ell},PlotRange->{{-8,8},{-5,5}},PlotLabel->Style[lab,{20,Black}],ImageSize->Large,Frame->True]];

DynamicModule[{ell,ons,gr,napPts},
Manipulate[
ell=plotEll[a,{Black,Thick}];
napPts=Table[getOuterNapoleonExcSummits[a,toRad@tDeg0],{tDeg0,0,359,1}];
Dynamic@makeOneNapoleonFrameExc[a,ell,napPts,tDeg],
{{a,1.5},1.01,3,.1,Appearance->"Open"},
{{tDeg,30},-360,360,1,Appearance->"Open"},SaveDefinitions->True]]

Module[{a=1.5,ell,ons,gr,napPts,tDeg=10.},
ell=plotEll[a,{Black,Thick}];
napPts=Table[getOuterNapoleonSummits[a,toRad@tDeg0],{tDeg0,0,359,.5}];
makeOneNapoleonFrame[a,ell,napPts,tDeg]]

(*DeleteFile[napApp];*)

(*napApp=CloudDeploy[%,"napoleon summits v1",Permissions->"Public"]*)

Outer locus is *not* elliptic

Module[{a=2.,napPts,outerEllPars,centroidEllPars,summitLocus,centroidLocus},
napPts=Table[getOuterNapoleonSummits[a,toRad@tDeg0],{tDeg0,0,359,1}];
summitLocus=First[#@"summits"]&/@napPts;
centroidLocus=#["centroid"]&/@napPts;
centroidEllPars=findEllParams[a,1,centroidLocus,"centroid"];
outerEllPars=findEllParams[a,1,summitLocus,"outer"];
<|"centroidEllErr"->centroidEllPars["err"],"outerEllErr"->outerEllPars["err"]|>]

Circumbilliard (using linear algebra)

ellExtremum[{mx_,my_},{vx_,vy_},{c1_,c2_,c3_,c4_,c5_},t_]=Module[{xt,yt},
xt=mx+t vx;
yt=my+t vy;
Collect[1+c1 xt+c2 yt+c3 xt yt+c4 xt^2+c5 yt^2,t]]

(* by symmetry, b=0 of the quadratic*)
Clear@ellExtremumSym;
ellExtremumSym[{mx_,my_},{vx_,vy_},{c1_,c2_,c3_,c4_,c5_}]:=Module[{a,c,d,sqrtd,sol},
a=c4 (vx^2)+c3 vx vy+c5 (vy^2);
(* b=c1 vx+2 c4 mx vx+c3 my vx+c2 vy+c3 mx vy+2 c5 my vy; *)
c=1+c1 mx+c4 (mx^2)+c2 my+c3 mx my+c5 (my^2);
(*(-b + sqrt(b2-4ac)/(2a)) => sqrt(-4ac)/(2a) => sqrt(-ac)/a*)  
sol=Sqrt[-c/a];(*Sqrt[-a*c]/a;*)(* sqrt(-a)*sqrt(c)/a => sqrt(c/a) *)
{sol,-sol}];

(* grad = { c1 + c3 y + 2 c4 x, c2 + c3 x + 2 c5 y *)
Clear@circumTangent;circumTangent[{c1_,c2_,c3_,c4_,c5_},{x_,y_}]:=Module[{grad,tang},
grad={c1+c3 y+2c4 x,c2+c3 x+2c5 y};
tang=perp@grad;
tang];

Clear@getHessianDet;
getHessianDet[tri_,ctr_]:=Module[{mtx123,mtx45,mtx,rhs,ls,hess},
(* c1 x + c2 y + c3 x y + c4 x^2 + c5 y^2 == -1 *)
(* grad = { c1 + c3 y + 2 c4 x, c2 + c3 x + 2 c5 y *)
mtx123={#[[1]],#[[2]],#[[1]]*#[[2]],#[[1]]^2,#[[2]]^2}&/@tri;
mtx45={
{1,0,ctr[[2]],2ctr[[1]],0},
{0,1,ctr[[1]],0,2ctr[[2]]}};
mtx=Join[mtx123,mtx45];
rhs={-1,-1,-1,0,0};
ls=LinearSolve[mtx,rhs];
hess={{2ls[[4]],ls[[3]]},{ls[[3]],2ls[[5]]}};
Det[hess]];

Clear@getCircumAny;
getCircumAny[orbit_,ctr_]:=Module[{mtx123,mtx45,mtx,rhs,ls,hess,vals,vects,lengths,lgt1,lgt2,vertices,valsMinMax,orbitTangents,area,major,minor,c,fs},
(* c1 x + c2 y + c3 x y + c4 x^2 + c5 y^2 == -1 *)
(* grad = { c1 + c3 y + 2 c4 x, c2 + c3 x + 2 c5 y *)
mtx123={#[[1]],#[[2]],#[[1]]*#[[2]],#[[1]]^2,#[[2]]^2}&/@orbit;
mtx45={
{1,0,ctr[[2]],2ctr[[1]],0},
{0,1,ctr[[1]],0,2ctr[[2]]}};
mtx=Join[mtx123,mtx45];
rhs={-1,-1,-1,0,0};
ls=LinearSolve[mtx,rhs];
hess={{2ls[[4]],ls[[3]]},{ls[[3]],2ls[[5]]}};
{vals,vects}=Eigensystem@hess;
lgt1=Abs[First@ellExtremumSym[ctr,vects[[1]],ls]];
lgt2=lgt1*Sqrt[vals[[1]]/vals[[2]]];
lengths={lgt1,lgt2};
valsMinMax=If[Abs@vals[[1]]<Abs@vals[[2]],{vals[[1]],vals[[2]]},{vals[[2]],vals[[1]]}];
major=If[Abs@vals[[1]]<Abs@vals[[2]],vects[[1]],vects[[2]]];
minor=If[Abs@vals[[1]]<Abs@vals[[2]],vects[[2]],vects[[1]]];
c=Sqrt[Abs[lgt2^2-lgt1^2]];
fs={ctr+Sign[valsMinMax[[1]]]major c,ctr-Sign[valsMinMax[[1]]]major c};
orbitTangents=circumTangent[ls,#]&/@orbit;
vertices=MapThread[(ctr+#1*#2)&,{lengths,vects}];
area=π*lengths[[1]]*lengths[[2]];
<|"ctr"->ctr,"coeffs"->Chop@ls,"vals"->Chop@vals,"valsMinMax"->valsMinMax,"axes"->Chop@vects,"major"->major,"minor"->minor,"minorVal"->valsMinMax[[1]],"majorVal"->valsMinMax[[2]],"lengths"->lengths,"ratio"->safeDiv[lgt1,lgt2],"prod"->lgt1*lgt2,"vertices"->Chop@vertices,"foci"->fs,"c"->c,
"orbit"->orbit,"orbitTangents"->orbitTangents,"area"->area|>];

Clear@getEll5ctr;
getEll5ctr[ctrs5_]:=Module[{mtx,rhs,ls,discr,x0,y0},
(* A x^2 + B x y + C y^2 + D x + E y == -1 *)
mtx={#[[1]]^2,#[[1]]*#[[2]],#[[2]]^2,#[[1]],#[[2]]}&/@ctrs5;
rhs={-1,-1,-1,-1,-1};
ls=LinearSolve[mtx,rhs];
discr=ls[[2]]^2-4ls[[1]]ls[[3]];
x0=(2*ls[[3]]*ls[[4]]-ls[[2]]ls[[5]])/discr;
y0=(2*ls[[1]]*ls[[5]]-ls[[2]]ls[[4]])/discr;
{x0,y0}];

Module[{a=1.5,ps},
ps=Table[N@{a Cos[t]+5,Sin[t]+7},{t,0,2π,2π/7}];
getEll5ctr[Take[ps,5]]]

Clear@getCircumMit;
getCircumMit[orbit_]:=Module[{ctr},
ctr=getMittenTrilin[orbit,triLengthsRL@orbit];
getCircumAny[orbit,ctr]];
(* Steiner Circumellipse *)
Clear@getCircumBar;getCircumBar[orbit_]:=getCircumAny[orbit,getBaricenter@@orbit];

getCircumMit[orbitNormals[1.5,π/3.][[1]]]

(* {ctrLab->"*",drTri->False,drOrbitTangents->False,ps->,drVertices->False,drLgl->0.2`,labClr->,labPos->{-1.25`,-1.25`},labSize->20} *)

Clear@drawCircumAnyLow;
Options@drawCircumAnyLow={ctrLab->"*",drAxes->True,drTri->False,drOrbitTangents->False,ps->Black,drVertices->False,drFoci->False,drLgl->.2,labClr->Darker@Red,labPos->{-1.25,-1.25},labSize->20};
drawCircumAnyLow[cII_,tri_,OptionsPattern[]]:=Module[{o,vl,v,ul,u,pp,ax1,ax2,gr,grTri,grGrads,ps2},
o=cII["ctr"];
vl=cII["lengths"][[1]];
v=cII["axes"][[1]];
ul=cII["lengths"][[2]];
u=cII["axes"][[2]];
pp=ParametricPlot[o+vl Cos[t]v+ul Sin[t] u,{t,0,2π},PlotStyle->OptionValue@ps];
ax1=Graphics[{Dashed,OptionValue@ps,Line@{o-vl v,o+vl v}}];
(*ParametricPlot[(o+vl v)t+(o-vl v)(1-t),{t,0,1},PlotStyle->{Dashed,OptionValue@ps}];*)
ax2=Graphics[{Dashed,OptionValue@ps,Line@{o-ul u,o+ul u}}];(*ParametricPlot[(o+ul u)t+(o-ul u)(1-t),{t,0,1},PlotStyle->{Dashed,OptionValue@ps}];*)
grTri=If[OptionValue@drTri,{FaceForm@{OptionValue@ps,Opacity@.1},EdgeForm@OptionValue@ps,EdgeForm@{Thick,Blue},Polygon@tri},{}];
grGrads=If[OptionValue@drOrbitTangents,{Arrowheads@Medium,OptionValue@ps,MapThread[Arrow@{#1,#2}&,{cII["orbit"],cII["orbit"]+.5norm/@cII["orbitTangents"]}]},{}];
ps2=OptionValue@ps;
gr={
If[OptionValue@drVertices,{PointSize@Large,Black,Point@tri,ellLabelPoints[1,tri,"P",16,OptionValue@drLgl]},{}],
If[ListQ@ps2,Sequence@@ps2,ps2],
If[OptionValue@drFoci,{Directive[OptionValue@ps],PointSize@Medium,Point@cII["foci"]},{}],
{PointSize@Large,OptionValue@labClr,Point@o,Text[Style[OptionValue@ctrLab,OptionValue@labSize],o,OptionValue@labPos]}
};
Show[{If[OptionValue@drAxes,{ax1,ax2},{}],pp,Graphics/@{grTri,gr,grGrads}}]];

Clear@drawCircumAny;
Options@drawCircumAny=Options@drawCircumAnyLow;
drawCircumAny[tri_,ctr_,opts:OptionsPattern[]]:=drawCircumAnyLow[getCircumAny[tri,ctr],tri,{opts}];

Clear@drawCircumMit;
Options@drawCircumMit=Options@drawCircumAnyLow;drawCircumMit[tri_,opts:OptionsPattern[]]:=drawCircumAny[tri,getMittenTrilin[tri,triLengthsRL@tri],{opts}];
(* Steiner Circumellipse *)
Clear@drawCircumBar;
Options@drawCircumBar=Options@drawCircumAnyLow;
drawCircumBar[tri_,opts:OptionsPattern[]]:=drawCircumAny[tri,getBaricenter@@tri,{opts}];

Clear@drawSteinerInellipse;
drawSteinerInellipse[tri_,opts:OptionsPattern[]]:=Module[{meds},
meds=getMedians@@tri;
drawCircumAny[meds,getBaricenter@@tri,{opts}]
];
Clear@drawCircumExc;drawCircumExc[tri_,opts:OptionsPattern[]]:=drawCircumAny[tri,getMittenTrilin[tri,triLengthsRL@tri],{opts}];
Clear@drawCircumInc;drawCircumInc[tri_,opts:OptionsPattern[]]:=drawCircumAny[tri,getIncenterTrilin[tri,triLengthsRL@tri],{opts}];

Conic Coeffs

(* A x^2 + B x y + C y^2 + D x + E y + F = 0 *) 
(* axx x^2 + 2 axy x y + ayy y^2 + 2 bx x + 2by y + C = 0 *) 

(* A=axx, B=2 axy, C = ayy, D = 2 bx,E = 2 by *)

Clear@getConicCoeffs;
getConicCoeffs[fivePs_]:=Module[{mtx,rhs,coeffs,det,isHyp,hess,evals,evecs,majorAxis,S,a,b,ctr,c2,c,foci,errs,err2sum},
mtx={
(* A *) #[[1]]^2,
(* B *)#[[1]]*#[[2]],
(* C *) #[[2]]^2,
(* D *) #[[1]],
(* E *)#[[2]]
}&/@fivePs;
(*Print["m=",MatrixForm@mtx,"; det=",Det[mtx]];*)
rhs=ConstantArray[-1,5];
coeffs=LinearSolve[mtx,rhs];
errs=Chop[(coeffs[[1]]#[[1]]^2+
coeffs[[2]]#[[1]]#[[2]]+
coeffs[[3]]#[[2]]^2+
coeffs[[4]]#[[1]]+
coeffs[[5]]#[[2]]+1)&/@fivePs];
err2sum=Total[errs^2];
det=coeffs[[1]]*coeffs[[3]]-coeffs[[2]]coeffs[[2]]/4;
isHyp=det<0;
(* xc=-(bx*ayy-axy*by)/det;
yc=-(axx*by-axy*bx)/det; *)
ctr={2 coeffs[[3]]coeffs[[4]]-coeffs[[2]]coeffs[[5]],2 coeffs[[1]]coeffs[[5]]-coeffs[[2]]coeffs[[4]]}/(-4 det);

hess={{coeffs[[1]],coeffs[[2]]/2},{coeffs[[2]]/2,coeffs[[3]]}};
{evals,evecs}=Eigensystem@hess;
majorAxis=If[evals[[1]]<evals[[2]],evecs[[1]],evecs[[2]]];
(* axx * ayy - axy^2 *)
(* it will be zero if hyp wrt tr *)
S=Det[{
{coeffs[[1]],coeffs[[2]]/2,coeffs[[4]]/2},
{coeffs[[2]]/2,coeffs[[3]],coeffs[[5]]/2},
{coeffs[[4]]/2,coeffs[[5]]/2,1}}];
a=Sqrt@Abs[S/(Min[evals[[1]],evals[[2]]]det)];
b=Sqrt@Abs[S/(Max[evals[[1]],evals[[2]]]det)];

c2=If[isHyp,a^2+b^2,a^2-b^2];
c=Sqrt@c2;
foci={ctr+c majorAxis,ctr-c majorAxis };
<|"fivePs"->fivePs,"discr"->S,"det"->det,"isHyp"->isHyp,
"ctr"->ctr,"foci"->foci,"a"->a,"b"->b,"c"->c,"c2"->c2,"coeffs"->coeffs,"majorAxis"->majorAxis,"errs"->errs,"err2sum"->err2sum|>];

(* https://en.wikipedia.org/wiki/Hyperbola *)
(* axx x^2 + 2 axy x y + ayy y^2 + 2 bx x + 2by y + C = 0 *) 
Clear@getConicCoeffsOld;
getConicCoeffsOld[fivePs_]:=Module[{mtx,rhs,axx,ayy,axy,bx,by,discr,det,xc,yc,ctr,a,b,c,r1,r2,l1,l2,c2,hess,eigenvals,eigenvecs,majorAxis,foci},
mtx={
(* axx *) #[[1]]^2,
(* ayy *) #[[2]]^2,
(* 2 axy *) 2#[[1]]*#[[2]],
(* 2 bx *) 2#[[1]],
(* 2 by *) 2#[[2]]
}&/@fivePs;
(*Print["m=",MatrixForm@mtx,"; det=",Det[mtx]];*)
rhs=ConstantArray[-1,5];
{axx,ayy,axy,bx,by}=LinearSolve[mtx,rhs];
discr=Det[{
{axx,axy,bx},
{axy,ayy,by},
{bx,by,1}}];
det=axx*ayy-axy^2;
hess={{axx,axy},{axy,ayy}};
{eigenvals,eigenvecs}=Eigensystem@hess;
majorAxis=If[eigenvals[[1]]<eigenvals[[2]],eigenvecs[[1]],eigenvecs[[2]]];
(* axx * ayy - axy^2 *)
(* it will be zero if hyp wrt tr *)
xc=-(bx*ayy-axy*by)/det;
yc=-(axx*by-axy*bx)/det;
ctr={xc,yc};
(*tan2phi=(2axy)/(axx-ayy);*)
(*sin2phi=axy;
cos2phi=(axx-ayy)/2;
phi=ArcTan[cos2phi,sin2phi]/2;*)
(* ronaldo: considerar quadrante do par ordenado (c2p,s2p) *)
(* (c,s) = coseno e seno do angulo normal *)
(*  Q1:c>0,s>0; Q2:c>0,s>0; Q3:c<0,s>0; Q4:c<0,s>0 *)
(* ou seja, seno sempre positivo, coseno negativo se em Q2 ou Q3, i.e., cos2phi < 0 *)
{r1,r2}=quadRootsUnprot[1,-axx-ayy,det];
(* ronaldo: trocar a por b *)
l1=Min[Abs/@{r1,r2}];
l2=Max[Abs/@{r1,r2}];
(*{l1,l2}=quadRootsUnprot[1,-axx-ayy,det];*)
a=Sqrt@Abs[discr/(l1 det)];
b=Sqrt@Abs[discr/(l2 det)];
c2=If[det<0,a^2+b^2,a^2-b^2];
c=Sqrt@c2;
foci={ctr+c majorAxis,ctr-c majorAxis };
<|"fivePs"->fivePs,"discr"->discr,"det"->det,"isHyp"->(det<0),
"ctr"->ctr,"foci"->foci,"l1"->l1,"l2"->l2,"a"->a,"b"->b,"c"->c,"c2"->c2,"coeffs"->{axx,ayy,axy,bx,by},"majorAxis"->majorAxis|>];

Clear@drawConic;
Options@drawConic={ctrLab->"",ps->Directive[Thick,Darker@Red],lgt->.1,showFoci->False,psAxes->Directive[Dashed,Black],maxX->2,maxY->2};
drawConic[conic_,OptionsPattern[]]:=Module[{o,a,v,b,u,ctr,fs,pp,ax,gr,foci,maxT=π,cp,sp,ell},
o=conic["ctr"];
a=conic["a"];
b=conic["b"];
(* major axis *)
v=conic["majorAxis"];
u=perp@v;
foci=conic["foci"];
{pp,ax}=If[conic["isHyp"],
{ParametricPlot[{o+a Cosh[t]v+b Sinh[t] u,o-a Cosh[t]v-b Sinh[t] u},{t,-maxT,maxT},PlotStyle->OptionValue@ps],Graphics[{OptionValue@psAxes,Line@{o-OptionValue@maxX(v+u (b/a)),o+OptionValue@maxX(v+u (b/a))},Line@{o-OptionValue@maxY(v-u (b/a)),o+OptionValue@maxY(v-u (b/a))}}]},
{ParametricPlot[o+a v Cos@t+b u Sin@t,{t,0,2π},PlotStyle->OptionValue@ps],
Graphics[{OptionValue@psAxes,Line@{o-a v,o+a v},Line@{o-b u,o+b u}}]}];
fs=Graphics@If[OptionValue@showFoci,{PointSize@Medium,First@Cases[OptionValue@ps,_RGBColor],Point@foci,Thick,Line@foci,Text[Style["f",20],#,{0,-1}]&/@foci},{}];
gr=Graphics[{First@Cases[OptionValue@ps,_RGBColor],PointSize@Large,Point@o,If[OptionValue@ctrLab!="",ellLabelTxt[conic["ellA"],o,Style[OptionValue@ctrLab,20],OptionValue@lgt],{}]}];
Show[{fs,ax,pp,gr}]];

Clear@x;Clear@y;

Clear@drawConicImplicit;
Options@drawConicImplicit={ctrLab->"",ps->Directive[Thick,Darker@Red],lgt->.1,showFoci->False,psAxes->Directive[Dashed,Black],maxX->2,maxY->2};
drawConicImplicit[conic_,OptionsPattern[]]:=Module[{coeffs,cp,gr},
coeffs=conic["coeffs"];
gr=Graphics[{PointSize@Large,OptionValue@ps,Point@conic["ctr"]}];
cp=ContourPlot[coeffs[[1]]x^2+coeffs[[2]]x y +coeffs[[3]]y^2+coeffs[[4]]x+coeffs[[5]]y+1==0,{x,-OptionValue@maxX,OptionValue@maxX},{y,-OptionValue@maxY,OptionValue@maxY},ContourStyle->OptionValue@ps];
Show[{cp,gr}]];

Five Point Hyperbola, Feuerbach, and Excentral Jerabek

(* https://en.wikipedia.org/wiki/Hyperbola *)
(* axx x^2 + 2 axy x y + ayy y^2 + 2 bx x + 2by y + C = 0 *) Clear@getHypCoeffs5b;
Clear@getHypCoeffs5b;
getHypCoeffs5b[fivePs_,tr_]:=Module[{mtx,rhs,axx,ayy,axy,bx,by,discr,det,xc,yc,ctr,a,b,c,l1,l2,c2,hess,eigenvals,eigenvecs,majorAxis,foci,fiveErrs},
mtx={
(* axx *) #[[1]]^2,
(* ayy *) #[[2]]^2,
(* 2 axy *) 2#[[1]]*#[[2]],
(* 2 bx *) 2#[[1]],
(* 2 by *) 2#[[2]]
}&/@((#-tr)&/@fivePs);(* trick to remove ill-conditioning on origin-centered conics *)
(*Print["m=",MatrixForm@mtx,"; det=",Det[mtx]];*)
rhs=ConstantArray[-1,5];
{axx,ayy,axy,bx,by}=LinearSolve[mtx,rhs];
fiveErrs=(axx #[[1]]^2 + 2 axy #[[1]]#[[2]] + ayy #[[2]]^2 + 2 bx #[[1]] + 2by #[[2]]+1)&/@((#-tr)&/@fivePs);
hess={{axx,axy},{axy,ayy}};
{eigenvals,eigenvecs}=Eigensystem@hess;
majorAxis=If[eigenvals[[1]]<eigenvals[[2]],eigenvecs[[1]],eigenvecs[[2]]];
(* axx * ayy - axy^2 *)
discr=Det[{
{axx,axy,bx},
{axy,ayy,by},
{bx,by,1}}];
det=axx*ayy-axy^2;
(* it will be zero if hyp wrt tr *)
xc=-(bx*ayy-axy*by)/det;
yc=-(axx*by-axy*bx)/det;
ctr={xc,yc}+tr;
(*tan2phi=(2axy)/(axx-ayy);*)
(*sin2phi=axy;
cos2phi=(axx-ayy)/2;
phi=ArcTan[cos2phi,sin2phi]/2;*)
{l1,l2}=quadRootsUnprot[1,-axx-ayy,det];
a=Sqrt@Abs[-discr/(l1 det)];
b=Sqrt@Abs[-discr/(l2 det)];
c2=a^2+b^2;
c=Sqrt@c2;
foci={ctr+c majorAxis,ctr-c majorAxis };
<|"fivePs"->fivePs,"fiveErrs"->fiveErrs,"discr"->discr,"det"->det,"isHyp"->(det<0),
"ctr"->ctr,"foci"->foci,"l1"->l1,"l2"->l2,"a"->a,"b"->b,"c"->c,"c2"->c2,"coeffs"->{axx,ayy,axy,bx,by},"majorAxis"->majorAxis|>];

(* https://en.wikipedia.org/wiki/Hyperbola *)
(* axx x^2 + 2 axy x y + ayy y^2 + 2 bx x + 2by y + C = 0 *)

Clear@d;
Module[{l,d,h},
d=getDelta[a,1];
l=(a^2/(a^2-1)) Sqrt[2d-a^2-1];
h=(a^2+d+1)/(a^2+d);
Solve[h/l==Sqrt[3]/3,a,Reals]]

Clear@getHypCoeffs5bNoTr;
getHypCoeffs5bNoTr[fivePs_]:=Module[{randCtr,mtx,rhs,axx,ayy,axy,bx,by,fiveErrs,discr,det,xc,yc,ctr,hess,eigenvals,eigenvecs,majorAxis,
l1,l2,a,b,c2,c,r1,r2,foci},
randCtr=RandomReal[{-1,1},2];
mtx={
(* axx *) #[[1]]^2,
(* ayy *) #[[2]]^2,
(* 2 axy *) 2#[[1]]*#[[2]],
(* 2 bx *) 2#[[1]],
(* 2 by *) 2#[[2]]
}&/@((#-randCtr)&/@fivePs);
(* trick to remove ill conditioning on origin-centered *)
(*Print["m=",MatrixForm@mtx,"; det=",Det[mtx]];*)
rhs=ConstantArray[-1,5];
{axx,ayy,axy,bx,by}=LinearSolve[mtx,rhs];
fiveErrs=(axx #[[1]]^2 + 2 axy #[[1]]#[[2]] + ayy #[[2]]^2 + 2 bx #[[1]] + 2by #[[2]]+1)&/@fivePs;
(* axx * ayy - axy^2 *)
discr=Det[{
{axx,axy,bx},
{axy,ayy,by},
{bx,by,1}}];
det=axx*ayy-axy^2;
(* restores to center *)
xc=-(bx*ayy-axy*by)/det;
yc=-(axx*by-axy*bx)/det;
(* add random center back *)
ctr={xc,yc}+randCtr;
hess={{axx,axy},{axy,ayy}};
{eigenvals,eigenvecs}=Eigensystem@hess;
majorAxis=If[eigenvals[[1]]<eigenvals[[2]],eigenvecs[[1]],eigenvecs[[2]]];
(* ronaldo: considerar quadrante do par ordenado (c2p,s2p) *)
(* (c,s) = coseno e seno do angulo normal *)
(*  Q1:c>0,s>0; Q2:c>0,s>0; Q3:c<0,s>0; Q4:c<0,s>0 *)
(* ou seja, seno sempre positivo, coseno negativo se em Q2 ou Q3, i.e., cos2phi < 0 *)
{r1,r2}=quadRootsUnprot[1,-axx-ayy,det];
(* ronaldo: trocar a por b *)
l1=Min[Abs/@{r1,r2}];
l2=Max[Abs/@{r1,r2}];
a=Sqrt@Abs[-discr/(l1 det)];
b=Sqrt@Abs[-discr/(l2 det)];
c2=a^2+b^2;
c=Sqrt@c2;
foci={ctr+c majorAxis,ctr-c majorAxis};
<|"fivePs"->fivePs,"fiveErrs"->fiveErrs,"discr"->discr,"det"->det,"isHyp"->(det<0),
"ctr"->ctr,"foci"->foci,"l1"->l1,"l2"->l2,"a"->a,"b"->b,"c"->c,"c2"->c2,"coeffs"->{axx,ayy,axy,bx,by},"eigenvals"->eigenvals,"eigenvecs"->eigenvecs,"majorAxis"->majorAxis|>];

Clear@drawHyp5b;
Options@drawHyp5b={ctrLab->"",ps->{Darker@Red},lgt->.1,showFoci->False,psAxes->Directive[Dashed,Black],fntSize->16};
drawHyp5b[hyp5_,OptionsPattern[]]:=Module[{o,a,v,b,u,ctr,fs,pp1,pp2,ax1,ax2,gr,foci,maxAsymptT=3,maxT=π,cp,sp},
o=hyp5["ctr"];
a=hyp5["a"];
b=hyp5["b"];
(* major axis *)
v=hyp5["majorAxis"];
u=perp@v;
foci=hyp5["foci"];
pp1=ParametricPlot[o+a Cosh[t]v+b Sinh[t] u,{t,-maxT,maxT},PlotStyle->OptionValue@ps];
pp2=ParametricPlot[o-a Cosh[t]v-b Sinh[t] u,{t,-maxT,maxT},PlotStyle->OptionValue@ps];
(* axes could be lines Line@{} *)
(*ax1=ParametricPlot[o+v t+u (b/a)t,{t,-maxAsymptT,maxAsymptT},PlotStyle->{Dashed,OptionValue@psAxes}];
ax2=ParametricPlot[o+v t-u (b/a)t,{t,-maxAsymptT,maxAsymptT},PlotStyle->{Dashed,OptionValue@psAxes}];*)
ax1=Graphics[{OptionValue@psAxes,Line@{o-maxAsymptT(v+u (b/a)),o+maxAsymptT(v+u (b/a))}}];
ax2=Graphics[{OptionValue@psAxes,Line@{o-maxAsymptT(v-u (b/a)),o+maxAsymptT(v-u (b/a))}}];
fs=Graphics@If[OptionValue@showFoci,{PointSize@Medium,First@Cases[OptionValue@ps,_RGBColor],Point@foci,Thick,Line@foci,Text[Style["F",OptionValue@fntSize],#,{0,-1}]&/@foci},{}];
gr=Graphics[{First@Cases[OptionValue@ps,_RGBColor],PointSize@Large,Point@o,If[OptionValue@ctrLab!="",ellLabelTxt[hyp5["ellA"],o,Style[OptionValue@ctrLab,20],OptionValue@lgt],{}]}];
Show[{fs,pp1,pp2,ax1,ax2,gr}]];

https://mathworld.wolfram.com/JerabekHyperbola.html
Jerabek Hyp goes thru:
3, 4 , 6 , 54, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 248, 265, 290, 695, 879, 895, 1173, 1175, 1176, 1177, 1242, 1243, 1244, 1245, 1246, 1439, 1798, 1903, 1942, 1987, 2213, 2435, 2574, 2575, 2992, 2993.

Clear@getJerabekHyp;
getJerabekHyp[tri_,sides_]:=Module[{fivePs,hyp5,ctr},
fivePs={Sequence@@tri,getOrthocenterTrilin[tri,sides],getSymmedianTrilin[tri,sides]};
ctr=getX125Trilin[tri,sides];
(* displace origin to avoid ill-conditioning, since mit=0 *)
(* ronaldo: quando ela passa pela origem, constant term -> 0 *)
hyp5=getHypCoeffs5b[fivePs,ctr]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->tri,"sides"->sides,"ctr"->ctr,"ellA"->0,
"labels"->{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])","(Subscript[X, 4])","(Subscript[X, 6])"},
"ctrLabel"->"(Subscript[X, 125])",
"colors"->({"orbit","orbit","orbit","ort","sym"}/.ptClrs)|>]
];

Clear@getFeuerbachHyp;
getFeuerbachHyp[tri_,sides_]:=Module[{fivePs,hyp5,ctr},
fivePs={Sequence@@tri,getIncenterTrilin[tri,sides],getOrthocenterTrilin[tri,sides]};
ctr=getFeuerbachTrilin[tri,sides];
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=getHypCoeffs5b[fivePs,ctr]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->tri,"sides"->sides,"ctr"->ctr,"ellA"->0,
"labels"->{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])","(Subscript[X, 1])","(Subscript[X, 4])"},
"ctrLabel"->"(Subscript[X, 11])",
"colors"->({"orbit","orbit","orbit","ort","sym"}/.ptClrs)|>]
];

Clear@getFeuerbachHypMitten;
getFeuerbachHypMitten[tri_,sides_]:=Module[{fivePs,hyp5,ctr},
fivePs={Sequence@@tri,getIncenterTrilin[tri,sides],getMittenTrilin[tri,sides]};
ctr=getFeuerbachTrilin[tri,sides];
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=getHypCoeffs5b[fivePs,ctr]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->tri,"sides"->sides,"ctr"->ctr,"ellA"->0,
"labels"->{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])","(Subscript[X, 1])","(Subscript[X, 9])"},
"ctrLabel"->"(Subscript[X, 11])",
"colors"->({"orbit","orbit","orbit","ort","sym"}/.ptClrs)|>]
];

Clear@getJerabekHypExc;
getJerabekHypExc[tri_,sides_]:=Module[{exc,excSides},
exc=excentralTriangle[tri,sides];
excSides=triLengthsRL@exc;
getJerabekHyp[exc,excSides]];

Clear@getHypX100;
getHypX100[a_,tDeg_]:=Module[{o,n,s,exc,inc,mit,x100,fivePs,hyp5},
{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
inc=getIncenterTrilin[o,s];
mit=getMittenTrilin[o,s];
x100=getX100Trilin[o,s];
fivePs={inc,Sequence@@exc,mit};
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=getHypCoeffs5b[fivePs,x100]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->o,"sides"->s,"ctr"->x100,"ellA"->a,
"labels"->{"(Subscript[X, 1])","(Subscript[E, 12])","(Subscript[E, 23])","(Subscript[E, 31])","(Subscript[X, 9])"},
"ctrLabel"->"(Subscript[X, 100])",
"colors"->({"inc","inc","inc","inc","mit"}/.ptClrs)|>]
];

Clear@getHypFeuerbach;
getHypFeuerbach[a_,tDeg_]:=Module[{o,n,s,inc,ort,feu,fivePs,hyp5},
{o,n,s}=orbitNormals[a,toRad@tDeg];
inc=getIncenterTrilin[o,s];
ort=getOrthocenterTrilin[o,s];
feu=getFeuerbachTrilin[o,s];
fivePs={Sequence@@o,inc,ort};
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=getHypCoeffs5b[fivePs,feu]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->o,"sides"->s,"ctr"->feu,"ellA"->a,
"labels"->{"","","","(Subscript[X, 1])","(Subscript[X, 4])"},
"ctrLabel"->"(Subscript[X, 11])",
"colors"->({"ell","ell","ell","inc","ort"}/.ptClrs)|>]
];

CB pictures

DynamicModule[{tri,act},
Manipulate[
tri={P1,P2,P3};
act=If[showAnticompl,anticomplementaryTriangle[tri,triLengthsRL@tri],{}];
Show[{
drawCircumMit[tri,drTri->True,ctrLab->"M",drOrbitTangents->drOrbitTangents0,drFoci->True],
If[showSteiner,drawCircumBar[tri,ctrLab->"G",ps->Darker@Pink,drOrbitTangents->drOrbitTangents0],{}],
If[showInc,drawCircumInc[tri,ctrLab->"I",ps->Darker@Green,drOrbitTangents->drOrbitTangents0],{}],
If[showAnticompl,drawCircumMit[act,drTri->True,ctrLab->"(Subscript[X, 7])",ps->Blue,drOrbitTangents->drOrbitTangents0],{}],
If[showSteinerInell,drawSteinerInellipse[tri,drTri->True,ctrLab->"G",ps->Purple,drOrbitTangents->drOrbitTangents0],{}]
},PlotLabel->(Style["Circumbilliard of N=3 Orbit and\nits Anticomplementary Triangle",{Black,Medium}]),
Frame->True,ImageSize->Large,GridLines->Automatic,PlotRange->{{-2,3},{-2,3}}],
{{P1,{0.0,0.001}},Locator},
{{P2,{1,0}},Locator},
{{P3,{1.5,1.5}},Locator},
{{showInc,False,"incenter circumell"},{True,False}},
{{showSteiner,False,"steiner circumell"},{True,False}},
{{showSteinerInell,False,"steiner inellipse"},{True,False}},
{{showAnticompl,False,"anticomplementary"},{True,False}},
{{drOrbitTangents0,False,"orbit tangents"},{True,False}}
]]

(*DeleteFile[circumApp]*)

(*circumApp=CloudDeploy[%,"circumbilliard and anticomplementary",Permissions->"Public"]*)

circumPlot=
Grid[{Show[#,Axes->False,PlotRange->All,ImageSize->400]&/@{drawCircumMit[{{3,.5},{-1.5,1.5},{-.75,-1}},drTri->True,ctrLab->"(Subscript[X, 9])",drVertices->True,drLgl->.25],
drawCircumMit[rot[#,toRad@30]&/@{{5,2.5},{-5,.5},{3,-1.5}},drTri->True,ctrLab->"(Subscript[X, 9])",drVertices->True,drLgl->.5]
}},Spacings->0]

export3["0056_circumplot",circumPlot]

Module[{c,x655,vs,ls,gr},
vs={{1,0},{2,1},{.5,.5}};
ls=triLengthsRL@vs;
x655=getX655Trilin[vs,ls];
gr=Graphics[{PointSize@Large,Point@x655,Text[Style["(Subscript[X, 655])",Large],x655,{-1,-1}]}];
c=drawCircumMit[vs,drTri->True,ctrLab->"(Subscript[X, 9])",drVertices->True,drLgl->.15];
Show[{c,gr},PlotRange->All]]

DynamicModule[{ons,a=1.5,x655,ell,gr,slack=.1},
ell=plotEllAxes[a,{Thick,Black}];
Manipulate[
ons=orbitNormals[a,toRad@tDeg];
x655=getX655Trilin[ons[[1]],ons[[3]]];
gr=Graphics[{PointSize@Large,FaceForm@None,
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{Red,Point@x655,Text[Style["(Subscript[X, 655])",20],x655,{-1,-1}]}}];
Show[{ell,gr},PlotRange->{{-a-slack,a+slack},{-1-slack,1+slack}}],
{{tDeg,10.},-180,180,.1}]]

Hyp Stats & Figures

Clear@getHyps;
getHyps[a_,tDeg_]:=Module[{hfeu,hjer},
hfeu=getHypFeuerbach[a,tDeg];
hjer=getHypX100[a,tDeg];
{hfeu,hjer}]

getHypsTab[a_,tDeg_]:=Module[{hyps,fields={"discr","det","phi","l1","l2","a","b","c","c2"}},
hyps=getHyps[a,tDeg];
Prepend[(fields/.#)&/@hyps,fields]]

Phi (axis angle) is 45° for both, as expected

getHypsTab[1.5,10.]//TableForm

getHypsTab[1.5,20.]//TableForm

Clear@getHypsRatios;
getHypsRatios[a_,tDeg_,field_]:=Module[{hyp11,hyp100,fields={"discr","det","phi","l1","l2","a","b","c"}},
{hyp11,hyp100}=getHyps[a,tDeg];
hyp11[[field]]/hyp100[[field]]]

Ratios of is constant! (though a11=b11, and a100=b100 change)

{(1.59061/.677326),(1.41938/.604413)}

getStats[Table[getHypsRatios[1.5,tDeg,"c"],{tDeg,1,89}]]

getStats[Table[getHypsRatios[2.,tDeg,"c"],{tDeg,1,89}]]

Ratios of det=axx*ayy-axy^2; seems constant!

getStats[Table[getHypsRatios[1.5,tDeg,"det"],{tDeg,1,89}]]

getStats[Table[getHypsRatios[2.,tDeg,"det"],{tDeg,1,89}]]

Clear@showHyp5vizapp;
Options@showHyp5vizapp=Options@drawHyp5b;
showHyp5vizapp[a_,tDeg_,hypFn_,opts:OptionsPattern[]]:=Module[{hyp5,gr,drHyp},
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=hypFn[a,tDeg];
gr=Graphics[{PointSize@Large,FaceForm@None,
MapThread[{#1,Point@#2,Text[Style[#3,20],#2,{-1.25,-1.25}]}&,
{hyp5["colors"],
hyp5["fivePs"],
hyp5["labels"]}]}];
drHyp=drawHyp5b[hyp5,FilterRules[{opts,ctrLab->hyp5["ctrLabel"]},Options@drawHyp5b]];
Show[{drHyp,gr}]];

(* for movie *)
Clear@showOneHyp5;
Options@showOneHyp5=Join[Options@drawHyp5b,{showExc->False,showEll->True}];
showOneHyp5[a_,tDeg_,hypFn_,opts:OptionsPattern[]]:=Module[{ell,hyp5b,grHyp5,gr,maxX=3,maxY=3,exc},
ell=plotEllAxes[a,{Thick,Black}];
hyp5b=hypFn[a,tDeg];
exc=excentralTriangle[hyp5b[["orbit"]],hyp5b[["sides"]]];
gr=Graphics[{PointSize@Large,FaceForm@None,
MapThread[{#1,Point@#2,Text[Style[#3,20],#2,{-1.25,-1.25}]}&,
{hyp5b["colors"],
hyp5b["fivePs"],
hyp5b["labels"]}],
{EdgeForm@{Thick,Blue},Polygon@hyp5b["orbit"]},
If[OptionValue@showExc,{EdgeForm@{Thick,Darker@Green},Polygon@exc,Darker@Green,Point@exc},{}]}];
grHyp5=drawHyp5b[hyp5b,FilterRules[{opts},Options@drawHyp5b]];
Show[{If[OptionValue@showEll,ell,{}],grHyp5,gr},
PlotRange->{{-maxX,maxX},{-maxY,maxY}},Frame->True,ImageSize->800]];

getCausticAxes[1.5,1]

Clear@showHypsImg;
Options@showHypsImg={drMoses->True,drMosesIsot->False,thickness->.005,drCaustic->True,lgt->.2};
showHypsImg[a_,tDeg_,OptionsPattern[]]:=Module[{hypX100,feuClr=Purple,x100Clr=Orange,hypFeu,grCaustic,gr,grMoses,grMosesIsot,ons,x1156,causticAB},
hypX100=showOneHyp5[a,tDeg,getHypX100,
ps->{Thickness@OptionValue@thickness,feuClr},psAxes->Directive[Dashed,feuClr,Thick],
lgt->.2,ctrLab->"(Subscript[X, 100])",showFoci->True,showExc->True];
hypFeu=showOneHyp5[a,tDeg,getHypFeuerbach,
ps->{Thickness@OptionValue@thickness,x100Clr},psAxes->Directive[Dashed,x100Clr,Thick],
lgt->.2,ctrLab->"(Subscript[X, 11])",showFoci->True,showEll->False];
ons=orbitNormals[a,toRad@tDeg];
x1156=getX1156Trilin[ons[[1]],ons[[3]]];
causticAB=getCausticAxes[a,1];
grCaustic=If[OptionValue@drCaustic,Graphics@{Brown,Thick,Circle[{0,0},causticAB]},{}];
gr=Graphics@{PointSize@Large,x100Clr,Point@x1156,ellLabelTxt[a,x1156,Style["(Subscript[X, 1156])",{x100Clr,20}],OptionValue@lgt]};
grMoses=If[OptionValue@drMoses,
Module[{moses},
moses=getMosesCartesians[ons[[1]],ons[[3]]];
Graphics[{PointSize@Medium,Point[Third/@moses],MapThread[ellLabelTxt[a,#1,Subscript["X",#2],.1]&,{Third/@moses,First/@moses}]}]],{}];
grMosesIsot=If[OptionValue@drMosesIsot,
Module[{mosesIsot},
(* Range@carts,Second/@Rest@trils,carts,Fifth/@Rest@trils} *)
mosesIsot=getMosesIsotCartesians[ons[[1]],ons[[3]]];
Graphics[{PointSize@Medium,Point[Third/@mosesIsot],MapThread[ellLabelTxt[a,#1,Subscript["X",#2],.1]&,{Third/@mosesIsot,Second/@mosesIsot}]}]],{}];
Show[{grCaustic,hypX100,hypFeu,gr,grMoses,grMosesIsot},PlotRange->{{-3,3},{-3,3}},ImageSize->800]];

getCausticAxes[a,b]

Manipulate[
showHypsImg[a,tDeg,drMoses->drMoses0,drMosesIsot->drMosesIsot0],
{{a,1.5},1.01,3,.1,Appearance->"Labeled"},
{{tDeg,30},-360,360,.1,Appearance->"Labeled"},
{{drMoses0,False},{True,False}},
{{drMosesIsot0,False},{True,False}},ControlPlacement->Left
(* not working *)
(*,{{useSinCos0,False,"use sin/cos"},{True,False}}*)
]

(*DeleteFile[hypObj]*)

(*hypObj=CloudDeploy[%,"Feuerbach and Jerabek Hyperbolae v1",Permissions->"Public"]*)

circumHypsPlot=Show[showHypsImg[1.5,22,drMoses->False,lgt->.15],Frame->None,PlotRange->{{-2.5,2.5},{-2.25,1.5}}]

export3["0060_circumhyps",circumHypsPlot]

X6 Quartic

Clear@x6quarticEqn;
x6quarticEqn[x_,y_,c1_,c2_,c3_,c4_,c5_]:=c1 x^4+c2 y^4+c3 x^2 y^2+c4 x^2+c5 y^2;

x6quarticCoeffs[a_,b_]:=Module[{c1,C2,c3,c4,c5,a6,b6,delta,delta2,a2,b2,a2b2,a4,b4,c2},
a2=a a;b2=b b;a2b2=a2 b2;
c2=a2-b2;
a4=a2 a2;b4=b2 b2;
delta2=a4-a2b2+b4;
delta=Sqrt@delta2;
c1=b4 (5delta2-4c2 delta-a2b2);
C2=a4(5delta2+4c2 delta-a2b2);
c3=2 a2b2(a2b2+3delta2);
c4=a2 b4(3b4+2(2 a2-b2)delta-5delta2);
c5=a4 b2(3a4+2(2 b2-a2)delta-5delta2);
{c1,C2,c3,c4,c5}
];

onX6quartic[a_,b_,x_,y_]:=Module[{c1,c2,c3,c4,c5},
{c1,c2,c3,c4,c5}=x6quarticCoeffs[a,b];
x6quarticEqn[x,y,c1,c2,c3,c4,c5]]

onX6quartic[1.5,1,1,1]

x6idealOld[a_,b_]:=Module[{a6,b6,δ,denom},
δ=Sqrt[a^4-a^2 b^2+b^4];
denom=(3*a^4-2*a^2*b^2+3*b^4);
a6=(-b^4-a^2*b^2-δ*b^2+3*δ*a^2)*a/denom;
b6=(a^4+b^2*a^2+δ*a^2-3*δ*b^2)*b/denom;
{a6,b6}]

x6ideal[a_,b_]:=Module[{a6,b6,delta,delta2,a2,b2,a4,b4},
a2=a a;b2 =b b;
a4=a2 a2;b4=b2 b2;
delta2=a4-a2 b2+b4;
delta=Sqrt@delta2;
a6=((3a2-b2)delta-(a2+b2)b2)a/(a4+b4+2delta2);
b6=((a2-3b2)delta+(a2+b2)a2)b/(a4+b4+2delta2);
{a6,b6}
];

x6quarticCoeffsNormC3[a_,b_]:=Module[{c1,c2,c3,c4,c5,a6,b6,delta,delta2},
delta2=a^4-a^2 b^2+b^4;
delta=Sqrt@delta2;
c1=b^4 (5delta2-4(a^2-b^2)delta-a^2 b^2);
c2=a^4(5delta2+4(a^2-b^2)delta-a^2b^2);
c3=2 a^2 b^2(a^2 b^2+3delta2);
c4=a^2 b^4(3 b^4+2(2 a^2-b^2)delta-5delta2);
c5=a^4 b^2(3 a^4+2(2 b^2-a^2)delta-5delta2);
{c1,c2,c4,c5}/c3
]

x6ideal[1.5,1]

x6quarticCoeffs[1.5,1]

x6errors=findEllParamsFn[#,getSymmedianTrilin]["err"]&/@{1.25,1.5,2.,3.}

x6coeffs=Map[nfn[#,3]&,{#,Sequence@@x6ideal[#,1],Sequence@@x6quarticCoeffsNormC3[#,1]}&/@{1.25,1.5,2.,3.},{2}]

areaX6quartic[a_,b_]:=Module[{c1,c2,c3,c4,c5},
{c1,c2,c3,c4,c5}=x6quarticCoeffs[a,b];
Area[ImplicitRegion[x6quarticEqn[x,y,c1,c2,c3,c4,c5]<0,{x,y}]]]

areaX6quartic[1.5,1]

areaX6ideal[a_,b_]:=Module[{a6,b6},
{a6,b6}=x6ideal[a,b];
π a6*b6]

areaX6ideal[1.5,1]

areaRatioX6[a_,b_]:=areaX6ideal[a,b]/areaX6quartic[a,b]

areaRatioX6[3.,1]

areaRatiosX6=areaRatioX6[#,1]&/@{1.25,1.5,2.,3.}

x6coeffsGrid=Grid[Prepend[Transpose@Append[Transpose@x6coeffs,nfn[#,5]&/@areaRatiosX6],{"a/b","(Subscript[a, 6])","(Subscript[b, 6])","(Subscript[c, 1])/(Subscript[c, 3])","(Subscript[c, 2])/(Subscript[c, 3])","(Subscript[c, 4])/(Subscript[c, 3])","(Subscript[c, 5])/(Subscript[c, 3])","(Subscript[AE, 6])/(Subscript[AX, 6])"}]]

TeXForm[x6coeffsGrid]

FullSimplify@x6quarticCoeffs[3/2,1]

drawX6[a_,b_]:=Module[{c1,c2,c3,c4,c5,a6,b6,a6old,b6old,quartic,ell,ellOld,locus,ons,eps=.0001},
{a6,b6}=x6ideal[a,b];
{a6old,b6old}=x6idealOld[a,b];
{c1,c2,c3,c4,c5}=x6quarticCoeffs[a,b];
locus=Quiet@ParametricPlot[ons=orbitNormals[a/b,t+eps];getSymmedianTrilin[ons[[1]],ons[[3]]],{t,0,π},PlotStyle->Darker@Green,AspectRatio->Automatic];
quartic=ContourPlot[x6quarticEqn[x,y,c1,c2,c3,c4,c5]==0,{x,-a,a},{y,-b,b},ContourStyle->Red,AspectRatio->Automatic];
ell=ContourPlot[(x/a6)^2+(y/b6)^2-1==0,{x,-a,a},{y,-b,b},ContourStyle->{Dashed,Blue},AspectRatio->Automatic];
(*ellOld=ContourPlot[(x/a6old)^2+(y/b6old)^2-1==0,{x,-a,a},{y,-b,b},ContourStyle->Blue];*)
ellOld=ParametricPlot[{a6old Cos@t,b6old Sin@t},{t,0,2π},PlotStyle->Blue,AspectRatio->Automatic];
Show[{quartic,ell,ellOld,locus},AspectRatio->Automatic]]

drawX6[1.5,1]

Clear@showSymmErrTest;
showSymmErrTest[a_,b_]:=Module[{x6s,o,n,s,δ,denom,a6,b6,ell6,gr,err=.025},
x6s=Table[{o,n,s}=orbitNormals[a,t];getSymmedianTrilin[o,s],{t,0,2π,π/180}];
δ=Sqrt[a^4-a^2*b^2+b^4];
denom=(3*a^4-2*a^2*b^2+3*b^4);
a6=(-b^4-a^2*b^2-δ*b^2+3*δ*a^2)*a/denom;
b6=(a^4+b^2*a^2+δ*a^2-3*δ*b^2)*b/denom;
Print@{a6,b6};
ell6=Table[{a6 Cos@t,b6 Sin@t+err},{t,0,2π,π/180}];
gr=Graphics[{Thick,
{Blue,Line@x6s},
{Darker@Green,Line@ell6}}];
Show[{plotEllb[a,b,{Thick,Black}],gr},Frame->True,GridLines->Automatic,PlotRange->{{-1.6,1.6},{-1.1,1.1}},ImageSize->800]];

showSymmErrTest[1.5,1]

Zariski Closure Test X2

X2=100*x^2+ 225 y^2+ 52*sqrt(61)−413

x2ab15=Module[{a=1.5,b=1,delta,c2,k2,a2,b2,c2z,a2z,b2z,ons,x2l,x2t,eps=10^-6},
delta=Sqrt[a^4-a^2 b^2+b^4];
c2=a^2-b^2;
k2=(2delta-a^2-b^2)/(3c2);
{a2,b2}=k2{a,b};
c2z=-52Sqrt@61+413;
a2z=Sqrt[c2z/100];
b2z=Sqrt[c2z/225];
x2l=(ons=orbitNormals[a,0+eps];getBarycenterTrilin[ons[[1]],ons[[3]]]);
x2t=(ons=orbitNormals[a,π/2+eps];getBarycenterTrilin[ons[[1]],ons[[3]]]);
N/@<|"a2z"->a2z,"b2z"->b2z,"a2"->a2,"b2"->b2,
"x2l"->Abs[x2l[[1]]],"x2t"->Abs[x2t[[2]]]|>]

X3: 5832 x^2 + (320 Sqrt@61 − 2752) y^2 + 729 Sqrt@61 - 5751

N[320 Sqrt@61 − 2752]

N[−729 Sqrt@61+5751]

x3ab15=Module[{a=1.5,b=1,delta,k3,a3,b3,c3z,a3z,b3z,ons,x3l,x3t,eps=10^-6},
delta=Sqrt[a^4-a^2 b^2+b^4];
{a3,b3}={(a^2-delta)/(2a),(delta-b^2)/(2b)};
c3z=-729 Sqrt@61+5751;
a3z=Sqrt[c3z/5832];
b3z=Sqrt[c3z/(2752-320 Sqrt@61)];
x3l=(ons=orbitNormals[a,0+eps];getCircumcenterTrilin[ons[[1]],ons[[3]]]);
x3t=(ons=orbitNormals[a,π/2+eps];getCircumcenterTrilin[ons[[1]],ons[[3]]]);
N/@<|"a3z"->a3z,"b3z"->b3z,"a3"->a3,"b3"->b3,
"x3l"->Abs[x3l[[1]]],"x3t"->Abs[x3t[[2]]]|>]

N[-3969 Sqrt@61+22761]

x1ab15=Module[{a=1.5,b=1,delta,a1,b1,c1z,a1z,b1z,ons,x1l,x1t,eps=10^-6,L,Lsym},
delta=Sqrt[a^4-a^2 b^2+b^4];
{a1,b1}={(delta-b^2)/a,(a^2-delta)/b};
x1l=(ons=orbitNormals[a,0+eps];getIncenterTrilin[ons[[1]],ons[[3]]]);
L=Total@ons[[3]];
Lsym=FullSimplify@getGammaL[3/2,1][[2]];
Print@{L,Lsym,N@Lsym,FullSimplify[Lsym^2]};
(* 450 L^2 x^2 (125 sqrt@61+1075)L^2 y^2 + 22761 - 3969 sqrt@61 *)
c1z=3969Sqrt@61-22761;
b1z=Sqrt[c1z/(125Sqrt@61+1075)]/L;
a1z=Sqrt[c1z/450]/L;
x1l=(ons=orbitNormals[a,0+eps];getIncenterTrilin[ons[[1]],ons[[3]]]);
x1t=(ons=orbitNormals[a,π/2+eps];getIncenterTrilin[ons[[1]],ons[[3]]]);
N/@<|"a1z"->a1z,"b1z"->b1z,"a1"->a1,"b1"->b1,
"x1l"->Abs[x1l[[1]]],"x1t"->Abs[x1t[[2]]]|>]

N[3969Sqrt@61-22761]

Module[{L2=(2/25) (91+61 (Sqrt[61])),c=3969Sqrt@61-22761},
FullSimplify[450 L2]x^2+FullSimplify[(125 Sqrt@61+1075) L2]y^2-c]

[*** paper 04] CBs of Excentral, ACT, Medial & Orthic

Clear@showAnyLocus;
showAnyLocus[a_,trilinFn_,clr_]:=Module[{o,n,s,x,xps},
Quiet@ParametricPlot[{o,n,s}=orbitNormals[a,toRad@tDeg];
x=trilinFn[o,s];
x,{tDeg,0,180},PlotStyle->clr,PerformanceGoal->"Quality"]]

Clear@showX168Locus;
showX168Locus[a_,ps_:Darker@Red]:=Module[{o,n,s,x168,x168ps},
Quiet@ParametricPlot[{o,n,s}=orbitNormals[a,toRad@tDeg];
x168=getX168Trilin[o,s];
x168,{tDeg,0,360},PlotStyle->ps,PerformanceGoal->"Speed"]]

Length of Excentral Circumbilliard Axes: their ratio is *not* constant

plotExcCircAxes[a_]:=
ListLinePlot[
Transpose@Module[{o,n,s,exc,excCirc,lgts},
Table[{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
excCirc=getCircumMit[exc];
lgts=excCirc["lengths"];
Join[lgts,{lgts[[1]]/lgts[[2]],lgts[[1]]lgts[[2]],lgts[[1]]+lgts[[2]],lgts[[1]]-lgts[[2]]}],
{tDeg,0,360,1}]],PlotStyle->Automatic,
PlotLegends->{"circumA","circumB","circumA/circumB","circumA*circumB","A+B","A-B"},Frame->True,GridLines->Automatic,ImageSize->Large]

plotExcCircAxes[1.5]

a/b for which locus of X168 touches the EB top vertex

Clear@getX168Y;getX168Y[a_?NumericQ]:=Module[{ons,x168},
ons=orbitNormals[a,-π/2];
getX168Trilin[ons[[1]],ons[[3]]][[2]]];

Quiet@FindMinimum[(getX168Y[a]-1)^2,{a,1.2}]

a/b for which X9* of orthic touches EB top vertex (orthic is equilateral)

Clear@getX9ortY;getX9ortY[a_?NumericQ]:=Module[{x9ort,ons},
ons=orbitNormals[a,π/2];
x9ort=getX9OrthicTrilin[ons[[1]],ons[[3]]];
x9ort[[2]]];

FindMinimum[(getX9ortY[a]-1)^2,{a,2.}]

ronaldo: este número é raiz de quartica

Solve[a^4+6 a^2 -39==0,a]

N@%

aEquiOrt=(Sqrt[4 (Sqrt[3])-3]);
N@aEquiOrt

aEquiOrt//TeXForm

isoscelesP2[1.5,1]

isoscelesP2[aEquiOrt,1]

N@%

equiOrtP2y=-isoscelesP2[aEquiOrt,1][[2,2]]

equiOrtSide=FullSimplify[magn[{0,1}+isoscelesP2[aEquiOrt,1][[2]]]]

N@equiOrtSide

equiOrtP2x=-isoscelesP2[aEquiOrt,1][[2,1]]

equiOrtBase=FullSimplify[-2*equiOrtP2x]

equiOrtHeight=1-equiOrtP2y

N@%

equiOrtBaseToHeight=FullSimplify[equiOrtBase/equiOrtHeight]

N@1/equiOrtBaseToHeight

FullSimplify[equiOrtHeight*equiOrtBase/2]

N@%

N@equiOrtP2y

Radius of circumcircle (and CB) of orthic equi: goes from (0,1) to (0,equiP2y) = 1-equiP2y

equiOrtR=1-equiOrtP2y

N@equiOrtR

Side of equilateral : radius x Sqrt[3]

equiOrtSide=FullSimplify[equiOrtR Sqrt[3]]

N@equiOrtSide

FullSimplify[equiOrtHeight=equiOrtSide*Sqrt[3]/2]

Is the intersection of the equi circle with the P2P1 segment on the quartic?

N@isoscelesP2[aEquiOrt,1]

equiOrbitP2=(-isoscelesP2[aEquiOrt,1][[2]]);N@isoP2

Module[{a=aEquiOrt,intCirc,ons,ell,gr,err,p1={0,1},cs,cp,pl,slack=.1,axesIdeal,errIdeal,equiBot,equi},
cs=x6quarticCoeffs[a,1];
ons=orbitNormals[a,π/2];
intCirc=FullSimplify[p1+equiOrtR norm[(equiOrbitP2-p1)]];
err=FullSimplify@onX6quartic[a,1,Sequence@@intCirc];
axesIdeal=x6ideal[a,1];
errIdeal=FullSimplify@ellError[Sequence@@axesIdeal,intCirc];
(*Print@ FullSimplify[onX6quartic[a,1,axesIdeal[[1]],0]];
Print@ FullSimplify[onX6quartic[a,1,0,axesIdeal[[2]]]];*)
equiBot={0,equiOrbitP2[[2]]};
equi={equiBot,rotRel[equiBot,2π/3,p1],rotRel[equiBot,-2π/3,p1]};
ell=plotEllAxes[a,{Thick,Black}];
gr=Graphics[{PointSize@Large,Thick,FaceForm@None,
drawPoly[ons[[1]],Blue],
{Orange,Circle[p1,equiOrtR],Point@intCirc,drawPoly[equi,Orange]}}];
cp=ContourPlot[x6quarticEqn[x,y,Sequence@@cs]==0,{x,-a,a},{y,-1,1},ContourStyle->Directive[Thick,Darker@Red]];
pl="a/b="<>nfn[N@a,3]<>", err="<>nfn[N@err,3]<>", errIdeal="<>nfn[N@errIdeal,3];
Show[{ell,gr,cp},ImageSize->Large,PlotRange->{{-a-slack,a+slack},{-1-slack,1+slack}},PlotLabel->Style[pl,{Black,16}]]]

DynamicModule[{a=1.5,trilFn1=getIncenterTrilin,n1=1,x1,trilFn2=getCircumcenterTrilin,n2=3,
ons,ell,exc,gr,pr,slackX=.5,slackY=2,sides1,preTris,pl,preTrisAreas,preTrisPers,preTris1s,equiErr},
Manipulate[
ell=plotEllAxes[a,{Thick,Black}];
Dynamic[
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
x1=trilFn1[ons[[1]],ons[[3]]];
(* pre tris: 3 sutriangles forrmed by sides of exc and x1 *)
preTris=MapThread[{#1,x1,#2}&,{ons[[1]],RotateLeft@ons[[1]]}];
preTrisAreas=signedArea/@preTris;
preTrisPers=triPer/@preTris;
(* pretris1: triangle formed by trilFn2 centers of each in preTris *)
preTris1s=trilFn2[#,triLengthsRL@#]&/@preTris;
(*preTrisX3s=getCircumcenterTrilin[#,triLengthsRL@#]&/@preTris;*)
equiErr=equiError[preTris1s];
(*sides1=triLengthsRL@preTris1s;
central1=trilFn1[preTris1s,sides1];
central2=trilFn2[preTris1s,sides1];*)
gr=Graphics[{FaceForm@None,PointSize@Large,Thick,
drawPoly[ons[[1]],Blue],drawPoly[exc,Darker@Green],
{Darker@Green,Point@x1,Text[Style[ToString[Subscript["X",n1],StandardForm],16],x1,{-1,-1}]},
MapThread[{#3,Point@#2,drawPoly[#1,#3]}&,{preTris,preTris1s,{Red,Purple,Cyan}}],
{drawPoly[preTris1s,Black](*,Circle[central1,.1],Circle[central2,.1]*)}}];
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°\n"<>"areas: "<>(nfn[#,3]<>", "&/@preTrisAreas)<>"\npers: "<>(nfn[#,3]<>", "&/@preTrisPers)<>" ∑="<>nfn[Total@preTrisPers,2]<>"\nequiErr="<>nfn[equiErr,3];
pr={{-a-slackX,a+slackX},{-1-slackY,1+slackY}};
Show[{ell,gr},PlotRange->pr,ImageSize->Large,PlotLabel->Style[pl,{Black,16}]]],{{tDeg,10.},-180,180,.1}]]

ronaldo: x6 of right triangle, points of detachment, midpoint of right tris altitude?

rightTriangleX6[a_,b_]:=Module[{delta=getDelta[a,b],x6,y6,c=Sqrt[a^2-b^2]},
x6=-(-a^6-2a^2b^4-b^6+3a^2b^2delta+b^4delta)Sqrt@(a^4+3b^4-4b^2delta)a^2/c^9; y6=(-a^6-2a^4b^2-b^6+a^4delta+3a^2b^2delta)Sqrt@(-3a^4-b^4+4a^2delta)b^2/c^9;
{x6,y6}]

rightTriangleX6[a,b]

rightTriangleX6simple=Module[{x6,y6},
x6=-(-a^6-2a^2b^4-b^6+3a^2b^2δ+b^4δ)Sqrt@(a^4+3b^4-4b^2δ)a^2/c^9; y6=(-a^6-2a^4b^2-b^6+a^4δ+3a^2b^2δ)Sqrt@(-3a^4-b^4+4a^2δ)b^2/c^9;
{x6,y6}]

rightTriangleX6simple//TeXForm

rightTriangleX6[1.5,1]

What is the point on the EB such that the orbit is a right triangle

rightTriangleOnBilliard[a_,b_]:=Module[{δ=Sqrt[a^4-a^2 b^2+b^4],c=Sqrt[a^2-b^2]},
{a^2 Sqrt[a^4+3 b^4-4 δ b^2],b^2 Sqrt[-b^4-3 a^4+4δ a^2]}/c^3];

rtonEBsimple={a^2 Sqrt[a^4+3 b^4-4 δ b^2],b^2 Sqrt[-b^4-3 a^4+4δ a^2]}/c^3

showRectZones[a_,tDeg1_,tDeg2_]:=Module[{ell,ons1,ons2,pperp,pperps,gr,tMin,tMax,zoneTop,zoneBot,cAB,causticEll},
ell=plotEllAxes[a,{Black,Thick}];
pperp=rightTriangleOnBilliard[a,1];
cAB=getCausticAxes[a,1];
causticEll=plotEllb[Sequence@@cAB,{Thick,Brown}];
pperps={pperp,flipX@pperp,-pperp,flipY@pperp};
{ons1,ons2}=orbitNormals[a,toRad@#]&/@{tDeg1,tDeg2};
(* a Cos@t, b Sin@t *)
tMin=ArcTan[pperp[[1]]/a,pperp[[2]]];
tMax= ArcTan[-pperp[[1]]/a,pperp[[2]]];
zoneTop=ParametricPlot[{a Cos@t,Sin@t},{t,tMin,tMax},PlotStyle->Directive[AbsoluteThickness@3,Red]];
zoneBot=ParametricPlot[{a Cos@t,-Sin@t},{t,tMin,tMax},PlotStyle->Directive[AbsoluteThickness@3,Red]];
gr=Graphics[{PointSize@Large,FaceForm@None,
{Point@pperps,ellLabelPointsSuperSub[a,pperps,"P","⊥",20,.1]},
{drawPoly[ons1[[1]],Blue],drawPoly[ons2[[1]],Directive[Dashed,Blue]]}}];
Show[{ell,causticEll,zoneTop,zoneBot,gr},ImageSize->800]];

rectZonePlot=showRectZones[1.618,40.,60.]

export3["0080_rect_zones",rectZonePlot]

rtonEBsimple//TeXForm

Note : the argument of sqrt becomes zero at the a/b~1.35219 which only contains one right - triangle

Solve[a^4+3 -4 Sqrt[a^4-a^2+1]==0,a]

N@%

rightTriangleCosine[a_,b_]:=Module[{δ=Sqrt[a^4-a^2 b^2+b^4],c=Sqrt[a^2-b^2]},
a Sqrt[a^4+3 b^4-4 δ b^2]/c^3];

rightTriangleSine[a_,b_]:=Module[{δ=Sqrt[a^4-a^2b^2+b^4],c=Sqrt[a^2-b^2]},
b Sqrt[-3a^4-b^4+4a^2 δ]/c^3]

rightTriangleT[a_]=FullSimplify[ArcTan[rightTriangleCosine[a,1],rightTriangleSine[a,1]],a>1]

rightTriangleT[1.5]

What is the a/b such that the box of the right triangle points on the billiard is tangent to the side vertices of the X6 (quartic) locus

N@Solve[15a^8-56 a^6+58 a^4-40 a^2+7==0,a]

1/.4907

Clear@getCBVizObjs;
Options@getCBVizObjs={clrOrt->{Dashed,Thick,Orange}};
getCBVizObjs[a_,OptionsPattern[]]:=Module[{ell,loci,excLocus,medLocus,extLocus,actLocus,ortLocus,ra,ras,rX6,rX6s,x6axes},
ell=plotEllAxes[a,{Thick,Black}];
loci=MapThread[showAnyLocus[a,#1,#2]&,
Transpose@{
{getX168Trilin,{Thick,Darker@Red}},
{getGergonneTrilin,{Thick,Darker@Red}},
{getX142Trilin,{Thick,Darker@Red}},
{getX9OrthicTrilin,{Thick,Darker@Red}},
{getSymmedianTrilin,{Thick,Lighter@Blue}},
{getX9ExtouchTrilin,{Thick,Brown}}}];
ra=rightTriangleOnBilliard[a,1];
ras={ra,flipX@ra,-ra,flipY@ra};
rX6=rightTriangleX6[a,1];
rX6s={rX6,flipX@rX6,-rX6,flipY@rX6};
x6axes=x6ideal[a,1];
(* Darker@Green,Blue,ColorData["HTML","Teal"],Orange,Brown *)
excLocus=plotEllb[Sequence@@getExcenterAxes[a],{Dashed,Thick,Darker@Green}];
actLocus=getAntiComplementaryVertexLocus[a,2π,{Dashed,Thick,Lighter@Blue}];
medLocus=medialLocus[a,2π,{Dashed,Thick,ColorData["HTML","Teal"]}];
ortLocus=orthicVertexLocus[a,2π,OptionValue@clrOrt];
extLocus=plotEllb[Sequence@@getCausticAxes[a,1],{Dashed,Thick,Brown}];
<|"a"->a,"ell"->ell,"loci"->loci,
"excLocus"->excLocus,
"extLocus"->extLocus,
"medLocus"->medLocus,
"ortLocus"->ortLocus,
"actLocus"->actLocus,
"ras"->ras,
"rX6s"->rX6s,
"x6axes"->x6axes|>];

Clear@drCBVizObjs;
drCBVizObjs[a_,tDeg_,objs_,ui_]:=Module[{o,n,s,tris,exc,act,med,ort,ext,ortExc,
drCB,CBs,x168,ortX9,x6,x7,x4,gr,pl},
{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
act=anticomplementaryTriangle[o,s];
med=medialTriangle[o,s];
ort=orthicTriangle[o,s];
ext=extouchTriangle[o,s];
tris={exc,act,med,ort,ext};
ortExc=excentralTriangle[ort,triLengthsRL@ort];
drCB=Lookup[ui,{"drExcCB","drActCB","drMedCB","drOrtCB","drExtCB"}];
CBs=If[Count[drCB,True]==0,{},getCircumMit/@Pick[tris,drCB]];(*{drExcCB,drActCB,drMedCB,drOrtCB,drExtCB} *)
(* mitten of excentral *)
x168=getX168Trilin[o,s];
(*ortX9=getMittenTrilin[ort,triLengthsRL@ort];*)
ortX9=getSymmedianTrilin[ortExc,triLengths@ortExc];
x6=getSymmedianTrilin[o,s];
x7=getGergonneTrilin[o,s];
x4=getOrthocenterTrilin[o,s];
gr=Graphics[{FaceForm@None, PointSize@Large,
{
{drawPoly[o,Black],If[ui["drPs"],ellLabelPoints[a,o,"P",16,.1],{}]},
MapThread[drawPoly[#1,#2]&,
Pick[#,drCB]&/@
Transpose@{{exc,Darker@Green},
{act,Blue},
{med,ColorData["HTML","Teal"]},
{ort,Orange},
{ext,Brown}}],
{Point@{0.,0.},Text[Style["(Subscript[X, 9])",20],{0.,0.},{-1.25,-1.25}]},
If[ui["drRas"],{Black,Point@objs["ras"],ellLabelPointsSuperSub[a,objs["ras"],"P","⊥",20,.1]},{}],
If[ui["drRasPoly"],drawPoly[objs["ras"],Directive[Thickness@Small,Dashed,Black]],{}],
(*,{Orange,Text["(Subscript[tX, 168])",x168ic,{-1.5,-1.5}],Point@x168ic}*),
If[ui["drX9X7"],{Black,Text[Style["(Subscript[X, 7])",16],x7,{1.25,1.25}],Dashed,Line@{{0,0},x7},PointSize@Medium,Point@x7},{}],
If[ui["drOrtExc"],{(*Dashed,Line@{x4,ortX9},*)(*Orange,Point@x4,*)drawPoly[ortExc,Directive[Dashed,Orange]],
{Orange,Point@x4,Text[Style["(Subscript[X, 4])",20],x4,ui["x4pos" ]]},
{Lighter@Blue,Point@x6,ellLabelTxtb[Sequence@@objs["x6axes"],x6,Style["(Subscript[X, 6])",20] ,.1,inward->True],Point@objs["rX6s"],ellLabelPointsb[Sequence@@objs["x6axes"],objs["rX6s"],"Q",16,.075]}},{}]}}];
pl="a/b="<>nfn[a,ui["adigs"]]<>", θ="<>nfn[tDeg,1]<>"°";
(* If[drActCB,drawCircumAnyLow[actCB,act,ctrLab->"(Subscript[X, 7])",ps->Blue,labClr->Blue],{}], *)
Show[{objs["ell"],
If[ui["drVtxLoci"],
{If[ui["drExcCB"],objs["excLocus"],{}],
If[ui["drActCB"],objs["actLocus"],{}],
If[ui["drMedCB"],objs["medLocus"],{}],
If[ui["drOrtCB"],objs["ortLocus"],{}]},{}],
If[Count[drCB,True]>0,
MapThread[drawCircumAnyLow[#1,#2,ctrLab->Subsuperscript["X",#3,#4],ps->#5,labClr->#6,labPos->{-1,-1}]&,
{CBs,Sequence@@(Pick[#,drCB]&/@{tris,
{168,7,142,6,9},
{"","","","*","**"},
{Darker@Green,Blue,ColorData["HTML","Teal"],Orange,Brown},
{Darker@Red,Darker@Red,Darker@Red,Darker@Red,Brown}})}],{}]},
If[ui["drLoci"],Pick[objs["loci"],Lookup[ui,{"drExcCB","drActCB","drMedCB","drOrtCB","drOrtCB","drExtCB"}]],{}],
gr,
PlotRange->{{ui["minX"],ui["maxX"]},{ui["minY"],ui["maxY"]}},
GridLines->None,If[ui["pl"],PlotLabel->Style[pl,{Black,16}],{}],ImageSize->ui["imgSize"]]];

rightTriangleOnBilliard[1.4,1]

rightTriangleSine[a_,b_]:=Module[{δ=Sqrt[a^4-a^2*b^2+b^4],c=Sqrt[a^2-b^2]},
b Sqrt[-3*a^4-b^4+4a^2 δ]/c^3]

rightTriangleCosine[1.5,1]

DynamicModule[{objs,ui,vals=Range[1,10,.25]},
Manipulate[
objs=getCBVizObjs[a,clrOrt->{Thick,Darker@Green}];
Dynamic[
ui=<|
"a"->a,
"tDeg"->tDeg,
"drLoci"->drLoci,
"drExcCB"->drExcCB,
"drActCB"->drActCB,
"drMedCB"->drMedCB,
"drOrtCB"->drOrtCB,
"drExtCB"->drExtCB,
"drOrtExc"->drOrtExc,
"minX"->minX,
"maxX"->maxX,
"minY"->minY,
"maxY"->maxY,
"imgSize"->imgSize,
"drRas"->drRas,
"drRasPoly"->False,
"pl"->drPl,
"drX9X7"->drX9X7,
"drVtxLoci"->drVtxLoci,
"x4pos"->{-1.25,-1.25},
"adigs"->3,
"drPs"->True
|>;
drCBVizObjs[a,tDeg,objs,ui]
],
{{a,1.5},1.3522,3.,.001},
{{tDeg,120.},-360,360,.1},
{{drLoci,True},{True,False}},
{{drExcCB,False},{True,False}},
{{drActCB,False},{True,False}},
{{drMedCB,False},{True,False}},
{{drOrtCB,True},{True,False}},
{{drOrtExc,False},{True,False}},
{{drExtCB,False},{True,False}},
{{drVtxLoci,True},{True,False}},
{{drPl,True},{True,False}},
{{drX9X7,False},{True,False}},
Row[{Control[{{minX,-2},-vals}],Control[{{maxX,2},vals}]}],
Row[{Control[{{minY,-2},-vals}],Control[{{maxY,2},vals}]}],
{{imgSize,600},{400,600,800,1200}},
Row[{Control[{{drRas,False,"right tri pts"},{True,False}}],Button["right tri",tDeg=toDeg@(rightTriangleT[a]+.00001),ImageSize->Medium],
Button["equi tri",a=N@aEquiOrt;tDeg=90.,ImageSize->Medium],
Button["print ui",Print@ui,ImageSize->Medium]}],
ControlPlacement->Left]]

Clear@oneCBPrintObjs;oneCBPrintObjs[objs_,ui_]:=drCBVizObjs[ui["a"],ui["tDeg"],objs,ui];

Clear@oneCBPrint;
oneCBPrint[ui_]:=Module[{objs},
objs=getCBVizObjs@ui["a"];
oneCBPrintObjs[objs,ui]];

orthicEquiPlot=oneCBPrint[\[LeftAssociation]"a"->1.981969533135035`,
"tDeg"->90.01,
"drLoci"->True,
"drExcCB"->False,
"drActCB"->False,
"drMedCB"->False,
"drOrtCB"->True,
"drExtCB"->False,
"drOrtExc"->True,
"minX"->-2,
"maxX"->2,
"minY"->-1.1,
"maxY"->2.2,
"imgSize"->800,
"drRas"->True,
"drRasPoly"->False,
"pl"->True,
"drX9X7"->False,
"drVtxLoci"->False,
"x4pos"->{-1.25`,-1.25`},
"adigs"->3,
"drPs"->False\[RightAssociation]]

export3["0040_cb_ort_equi",orthicEquiPlot]

orthicPositions=Module[{a=1.5,sz=800,objs,horiz,equi,scalene,right,minY=-1.1,maxY=1.6,maxX=1.7},
objs=getCBVizObjs[a];
horiz=oneCBPrintObjs[objs,\[LeftAssociation]"a"->a,"tDeg"->180.,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->False,"drOrtCB"->True,"drExtCB"->False,"drOrtExc"->True,"minX"->-maxX,"maxX"->maxX,"minY"->minY,"maxY"->1.1,"imgSize"->sz,"drRas"->True,"drRasPoly"->False,"pl"->True,"drX9X7"->False,"drVtxLoci"->False,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation]];
right=oneCBPrintObjs[objs,\[LeftAssociation]"a"->a,"tDeg"->57.38,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->False,"drOrtCB"->True,"drExtCB"->False,"drOrtExc"->False,"minX"->-maxX,"maxX"->maxX,"minY"->minY,"maxY"->1.1,"imgSize"->sz,"drRas"->True,"drRasPoly"->False,"pl"->True,"drX9X7"->False,"drVtxLoci"->False,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation]];
scalene=oneCBPrintObjs[objs,\[LeftAssociation]"a"->a,"tDeg"->68.6,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->False,"drOrtCB"->True,"drExtCB"->False,"drOrtExc"->True,"minX"->-maxX,"maxX"->maxX,"minY"->minY,"maxY"->maxY,"imgSize"->sz,"drRas"->True,"drRasPoly"->False,"pl"->True,"drX9X7"->False,"drVtxLoci"->False,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation]];
equi=oneCBPrintObjs[objs,\[LeftAssociation]"a"->a,"tDeg"->90.,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->False,"drOrtCB"->True,"drExtCB"->False,"drOrtExc"->True,"minX"->-maxX,"maxX"->maxX,"minY"->minY,"maxY"->maxY,"imgSize"->sz,"drRas"->True,"drRasPoly"->False,"pl"->True,"drX9X7"->False,"drVtxLoci"->False,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation]];
{horiz,right,scalene,equi}];

ortX6plot=Grid[Partition[orthicPositions,2],Frame->All]

export3["0030_cb_ort",ortX6plot]

Clear@oneCBPrintObjs;oneCBPrintObjs[ui_,objs_]:=drCBVizObjs[ui["a"],ui["tDeg"],objs,ui];

Clear@drawOneCBtrio;drawOneCBtrio[a_,tDeg_]:=Module[{objs,uiExc,uiAct,uiMed,cbExc},
objs=getCBVizObjs[a];
uiExc=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->True,"drActCB"->False,"drMedCB"->False,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-3.,"maxX"->3.5`,"minY"->-2.5`,"maxY"->5.,"imgSize"->640,"drRas"->False,"drRasPoly"->False,"pl"->False,"drX9X7"->False,"drVtxLoci"->True,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation];
cbExc=oneCBPrintObjs[objs,uiExc];
uiAct=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->False,"drActCB"->True,"drMedCB"->False,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-4.,"maxX"->3.`,"minY"->-2.75,"maxY"->1.75,"imgSize"->600,"drRas"->False,"drRasPoly"->False,"pl"->False,"drX9X7"->False,"drVtxLoci"->True,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation];
uiMed=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->True,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-2.,"maxX"->2.`,"minY"->-1.25`,"maxY"->1.125`,"imgSize"->600,"drRas"->False,"drRasPoly"->False,"pl"->False,"drX9X7"->True,"drVtxLoci"->True,"x4pos"->{-1.25,-1.25},"adigs"->3,"drPs"->False\[RightAssociation];
Grid[{{Style["a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°",{Black,30}],SpanFromLeft},{cbExc,Grid[{{oneCBPrintObjs[objs,uiAct]},{oneCBPrintObjs[objs,uiMed]}},Spacings->0,Dividers->{None,{False,True}}]}},Spacings->0,Frame->All,Alignment->Top]]

plotCBtrio=drawOneCBtrio[1.618,7.]

export3["0020_cb_trio",plotCBtrio]

[*** paper 04] Study Various Circumconics and Midline Limits

Options@drawCircumAnyLow

(* drawCircumAny[tri_,ctr_,opts:OptionsPattern[]]:=drawCircumAnyLow[getCircumAny[tri,ctr],tri,{opts}];*)

Clear@showCircuparabolaLimits;
Clear@slackX;Clear@slackY;
Options@showCircuparabolaLimits={slackX-> 1,slackY->1,addGr->None,
drExc->True,drMed->True,drExcMed->True,
circumFn-> getGergonneTrilin,circumN-> 7,circumClr->Pink,
circumFn2->(Function[{o,s},o[[1]]]),circumN2->-1,circumClr2->Darker@Green,
circumFn3->(Function[{o,s},o[[1]]]),circumN3->-1,circumClr3->Purple};
showCircuparabolaLimits[a_,tDeg_,OptionsPattern[]]:=Module[{rayL=5,
ons,med,exc,excMed,medLines,excLines,
xs,is,
ell,ellCaustic,gr,cp,pr,pl,
circumData,circumX,ratio,
circumData2,circumX2,ratio2,
circumData3,circumX3,ratio3},
ell=plotEllAxes[a,{Thick,Black}];
ellCaustic=plotEllbAxes[Sequence@@getCausticAxes[a,1],{Thick,Dashed,Black}];
ons=orbitNormals[a,toRad@tDeg];
med=medialTriangle[ons[[1]],ons[[3]]];
exc=excentralTriangle[ons[[1]],ons[[3]]];
is={1,9,11,100(*,650,4554*)};
xs=#[ons[[1]],ons[[3]]]&/@{getIncenterTrilin,getMittenTrilin,getFeuerbachTrilin,getX100Trilin(*,getX650Trilin,getX4554Trilin*)};
circumData=getCircumAny[ons[[1]],(OptionValue@circumFn)[ons[[1]],ons[[3]]]];
circumX=drawCircumAnyLow[circumData,ons[[1]],labClr->OptionValue@circumClr,ctrLab->ToString[Subscript["X",OptionValue@circumN],StandardForm],ps->OptionValue@circumClr];
circumX2=If[OptionValue@circumN2>0,
circumData2=getCircumAny[ons[[1]],(OptionValue@circumFn2)[ons[[1]],ons[[3]]]];
drawCircumAnyLow[circumData2,ons[[1]],labClr->OptionValue@circumClr2,ctrLab->ToString[Subscript["X",OptionValue@circumN2],StandardForm],ps->OptionValue@circumClr2],{}];
circumX3=If[OptionValue@circumN3>0,
circumData3=getCircumAny[ons[[1]],(OptionValue@circumFn3)[ons[[1]],ons[[3]]]];
drawCircumAnyLow[circumData3,ons[[1]],labClr->OptionValue@circumClr3,ctrLab->ToString[Subscript["X",OptionValue@circumN3],StandardForm],ps->OptionValue@circumClr3],{}];
excMed=medialTriangle[exc,triLengthsRL@exc];
medLines=Join[MapThread[{#1,ray[#2,norm[#2-#1],rayL]}&,{med,RotateLeft@med}],
MapThread[{#2,ray[#1,norm[#1-#2],rayL]}&,{med,RotateLeft@med}]];
excLines=MapThread[{#1,#2}&,{ons[[1]],exc}];
gr=Graphics[{PointSize@Large,FaceForm@None,
{drawPoly[ons[[1]],Blue],
If[OptionValue@drExc,drawPoly[exc,Darker@Green],{}],
If[OptionValue@drMed,{drawPoly[med,Darker@Red],{Red,Line/@medLines}},{}],
If[OptionValue@drExcMed,{drawPoly[excMed,Directive[Dashed,Red]],{Darker@Green,Thick,Dashed,Line/@excLines}},{}]},
MapThread[{Black,Point@#1,Text[Style[ToString[Subscript["X",#2],StandardForm],16],#1,{-1.25,-1.25}]}&,
{xs,is}]}];
(* won't calculate cp, as we have seen it is the medial and the extensions of its sides *)
(*cp=ContourPlot[N@getHessianDet[ons[[1]],{x,y}]==0,{x,-a-slackX,a+slackX},{y,-1-slackY,1+slackY},ContourStyle->Red,ContourLabels->None,PerformanceGoal->"Quality"];*)
pr={{-a-OptionValue@slackX,a+OptionValue@slackX},{-1-OptionValue@slackY,1+OptionValue@slackY}};
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°"<>"\nn1="<>nfn[circumData["lengths"][[1]],3]<>", n2="<>nfn[circumData["lengths"][[2]],3]<>", n2/n1="<>nfn[1/circumData["ratio"],3]<>If[OptionValue@circumN2>0,", n1'/n2'="<>nfn[circumData2["ratio"],2],""];
Show[{ell,ellCaustic,OptionValue@addGr,gr,circumX,circumX2,circumX3},PlotRange->pr,PlotLabel->Style[pl,{Black,16}],ImageSize->600]]

(* lemma0: o locus de hessiana = 0 é o tri medial e as extensoes de seus lados. *)
(* lemma1: x1,x2,x9 sempre interior ao medial ; x3: interior ao medial qdo tri é agudo (exterior e hiperbolico qdo é obtuso). x40 sempre interior ao medial do excentral, ja q este é sempre agudo. *)

(* outra propriedade: a circumconic is a parabola if and only if its perspector is on the Steiner inellipse *)

Circumellipses for X1(*), X2, X9(*), X10(*), X12, X21,...?
(*) means parallel axes and constant ratio of semiaxes!
X(100): common intersection of E1,E3 (circumcircle), E9, E10
to do: draw circumcircle which also passes thru X(100)

Peter Moses 3/19/2020: E(n) has parallel axes if X(n) is on the Feuerbach circumhyperbola of the medial triangle ... i=
tested: i = 1, 3, 9, 10, 142, 442, 600,

tested axis aligned hyperbolas 119(hyp), 214(hyp), 1145 (hyp)

to do 2092, 3126, 3307, 3308, 3647, 5507, 6184, 6260, 6594, 6600, 10427, 10472, 11517, 11530, 12631, 12639, 12640, 12864, 13089, 15346, 15347, 15348, 17057, 17060, 18258, 18642, 19557, 19584, 22754, 34261, 35204}

DynamicModule[{x650locus,a=1.5},
Manipulate[
(*x650locus=showAnyLocus[a,getX650Trilin,Pink];*)
Dynamic@showCircuparabolaLimits[a,tDeg,slackX->.4,slackY->.5,
circumFn->getIncenterTrilin,circumN->1,circumClr->Darker@Green,
addGr->(*x650locus*){},
drMed->False,
drExc->False,
drExcMed->False],{{tDeg,10.},-180,180,-.1},ControlPlacement->Left]]

DynamicModule[{x650locus,a=1.5},
Manipulate[
(*x650locus=showAnyLocus[a,getX650Trilin,Pink];*)
Dynamic@showCircuparabolaLimits[a,tDeg,slackX->.4,slackY->.5,
circumFn->getX142Trilin,circumN->142,circumClr->Red,
addGr->(*x650locus*){},
drMed->False,
drExc->False,
drExcMed->False],{{tDeg,10.},-180,180,-.1},ControlPlacement->Left]]

DynamicModule[{x650locus,a=1.5},
Manipulate[
(*x650locus=showAnyLocus[a,getX650Trilin,Pink];*)
Dynamic@showCircuparabolaLimits[a,tDeg,slackX->.5,slackY->.5,
circumFn->getSpiekerTrilin,circumN->10,circumClr->Red,
addGr->(*x650locus*){},
drExc->False,
drMed->True,
drExcMed->False,
circumN2->1,circumFn2->getIncenterTrilin,circumClr2->Darker@Green,
circumN3->600,circumFn3->getX600Trilin,circumClr3->Lighter@Purple],{{tDeg,10.},-180,180,-.1},ControlPlacement->Left]]

Moses Centers which lie on the Feuerbach Hyp of the Medial : Xi, i:
 1, 3, 9, 10, 119, 142, 214, 442, 600, 1145, 2092, 3126, 3307, 3308, 3647, 5507, 6184, 6260, 6594, 6600, 10427, 10472, 11517, 11530, 12631, 12639, 12640, 12864, 13089, 15346, 15347, 15348, 17057, 17060, 18258, 18642, 19557, 19584, 22754, 34261, 35204.

Clear@showCircumPencil;
Options@showCircumPencil={slackX-> 1,slackY->1,addGr->None,
drExc->True,drMed->False,drMedLines->False,drExcMed->False,drEllRegions->False,circumClrs->{},labPoss->{},
drX100->True,lgt->.1,
circumFns->{},circumNs->{},rayL->1};
showCircumPencil[a_,tDeg_,OptionsPattern[]]:=Module[{
ons,med,exc,excMed,medLines,excLines,
xs,ell,ellCaustic,gr,cp,pr,pl,
circumXs,ratio,x100},
ell=plotEllAxes[a,{Thick,Black}];
ellCaustic=plotEllbAxes[Sequence@@getCausticAxes[a,1],{Thick,Dashed,Black}];
ons=orbitNormals[a,toRad@tDeg];
med=medialTriangle[ons[[1]],ons[[3]]];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excMed=medialTriangle[exc,triLengthsRL@exc];
medLines=Riffle[
MapThread[{#1,ray[#1,norm[#1-#2],OptionValue@rayL]}&,{med,RotateLeft@med}],
MapThread[{#1,ray[#1,norm[#1-#2],OptionValue@rayL]}&,{med,RotateRight@med}]
];
excLines=MapThread[{#1,#2}&,{ons[[1]],exc}];
x100=getX100Trilin[ons[[1]],ons[[3]]];
xs=#[ons[[1]],ons[[3]]]&/@OptionValue@circumFns;
circumXs=Module[{circumData},
MapThread[
(circumData=getCircumAny[ons[[1]],#1[ons[[1]],ons[[3]]]];
drawCircumAnyLow[circumData,ons[[1]],labClr->#3,labPos->#4,ctrLab->ToString[Subscript["X",#2],StandardForm],ps->#3])&,{OptionValue@circumFns,OptionValue@circumNs,OptionValue@circumClrs,OptionValue@labPoss}]];
gr=Graphics[{PointSize@Large,FaceForm@None,
{drawPoly[ons[[1]],Blue],
(* ellLabelTxt[a,#[[3]],Subscript["X",#[[1]]],OptionValue@labelDist] *)

If[OptionValue@drExc,drawPoly[exc,Darker@Green],{}],
If[OptionValue@drMed,drawPoly[med,Darker@Red],{}],
If[OptionValue@drMedLines,{Red,Line/@medLines},{}],
If[OptionValue@drEllRegions,{FaceForm@{Opacity@.1,Red},EdgeForm@None,Polygon[{#[[1,1]],#[[1,2]],#[[2,2]]}&/@Partition[medLines,2]],Polygon@med},{}],
If[OptionValue@drExcMed,{drawPoly[excMed,Directive[Dashed,Red]],{Darker@Green,Thick,Dashed,Line/@excLines}},{}],
If[OptionValue@drX100,{Point@x100,ellLabelTxt[a,x100,Style["(Subscript[X, 100])",20],OptionValue@lgt]},{}]}
(*,MapThread[{Black,Point@#1,Text[Style[ToString[Subscript["X",#2],StandardForm],16],#1,{-1.25,-1.25}]}&,
{xs,is)]*)}];
(* won't calculate cp, as we have seen it is the medial and the extensions of its sides *)
(*cp=ContourPlot[N@getHessianDet[ons[[1]],{x,y}]==0,{x,-a-slackX,a+slackX},{y,-1-slackY,1+slackY},ContourStyle->Red,ContourLabels->None,PerformanceGoal->"Quality"];*)
pr={{-a-OptionValue@slackX,a+OptionValue@slackX},{-1-OptionValue@slackY,1+OptionValue@slackY}};
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°";
Show[{circumXs,gr},PlotRange->pr,PlotLabel->Style[pl,{Black,16}],ImageSize->600]]

ceX100plot=showCircumPencil[1.5,20.,drExc->False,drMed->True,
circumFns->{getIncenterTrilin,getCircumcenterTrilin,getMittenTrilin, getSpiekerTrilin, getX142Trilin},
circumNs->{1,3,9,10,142},
circumClrs->{Darker@Green,Purple,Black,Orange,Pink},
labPoss->{{-1.5,1},{1.5,0},{-1.2,-1.2},{1,.75},{-1,-1}}]//Show[#,Axes->None,PlotRange->All,ImageSize->800]&

Clear@getHypMedFeuerbach;
getHypMedFeuerbach[a_,tDeg_]:=Module[{o,n,s,med,medSides,inc,ort,feu,fivePs,hyp5},
{o,n,s}=orbitNormals[a,toRad@tDeg];
med=medialTriangle[o,s];
medSides=triLengthsRL@med;
feu=getFeuerbachTrilin[med,medSides];
inc=getIncenterTrilin[med,medSides];
ort=getOrthocenterTrilin[med,medSides];
fivePs={Sequence@@med,inc,ort};
(* displace origin to avoid ill-conditioning, since mit=0 *)
hyp5=getHypCoeffs5b[fivePs,feu]; (*RandomReal[{-1,1},2]];*)
Append[hyp5,<|"orbit"->o,"sides"->s,"ctr"->feu,"ellA"->a,
"labels"->{"","","","(Subscript[X, 1])","(Subscript[X, 4])"},
"ctrLabel"->"(Subscript[X, 11])",
"colors"->({"ell","ell","ell","inc","ort"}/.ptClrs)|>]
];

cex100plotHyp=Module[{hf},
hf=getHypMedFeuerbach[1.5,20.];
(*Options@drawHyp5b={ctrLab->"",ps->Darker@Red,useSinCos->False,lgt->.1,showFoci->False,psAxes->{Dashed,Black,Thick}};*)
Show[{drawHyp5b[hf,ps->{Darker@Red},ctrLab->"(Subscript[X, 3035])",psAxes->Darker@Red,lgt->.05],ceX100plot},PlotRange->{{-1.6,1.6},{-1.2,1.1}},ImageSize->800]]

export3["0050_ce_x100",cex100plotHyp]

ceMidlinesplot=Module[{hf},
hf=drawHyp5b[getHypFeuerbach[1.5,20.],ps->{Purple},ctrLab->"(Subscript[X, 11])",psAxes->Purple,lgt->.15];
showCircumPencil[1.5,20.,drExc->False,drMed->True,drMedLines->True,rayL->2,drEllRegions->True,
circumFns->{getIncenterTrilin,getMittenTrilin},
circumNs->{1,9},
circumClrs->{Darker@Green,Black},
labPoss->{{-1.5,1},{1.5,0}}]//Show[{hf,#},Axes->None,PlotRange->{{-2,2.5},{-1.25,1.25}},ImageSize->800]&]

export3["0070_medial_midlines",ceMidlinesplot]

[*** paper 04] Circuminvariants over 3-Periodics: Ratio of Focal Lengths, Hessians, Discriminants

Clear@getFJexcHypCoeffs;
getFJexcHypCoeffs[a_?NumericQ,tDeg_?NumericQ]:=Module[{tri,norms,triL,exc,excL,F,Jexc,cF,cJexc},
{tri,norms,triL}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[tri,triL];
excL=triLengthsRL@exc;
F=getFeuerbachHypMitten[tri,triL];
cF=Chop@F["coeffs"];
Jexc=getJerabekHyp[exc,excL];
cJexc=Chop@Jexc["coeffs"];
{cF,cJexc,MapThread[safeDiv[#1,#2]&,{cF,cJexc}]}]

getFJexcHypCoeffs[2,70]//TableForm

getFJexcHypCoeffs[1.5,57.38]//TableForm

Module[{a=1.5,pperp},
pperp=rightTriangleOnBilliard[a,1];
toDeg@ArcTan[pperp[[1]]/a,pperp[[2]]]]

orbitNormals[1.5,toRad@57.38][[1]]

getIncenterTrilin[Sequence@@Part[orbitNormals[1.5,toRad@57.38],{1,3}]]

Ronaldo: constancia em (Subscript[c, 3]) e determinante da hessiana pois a hiperbole foi normalizada (centro na origem) e constante 1.

(* 2 (Subscript[c, 3]) x y + 1 = 0 => eixo: 1/(Sqrt[2(Subscript[c, 3])])*)

Clear@showZeroHyps;
Options@showZeroHyps={slackX->.1,slackY->.1,sz->600,eps->.001,lgt->.125,drFCircs->True,drLegend->True,drCxy->True};showZeroHyps[a_,tDeg_,OptionsPattern[]]:=Module[{ell,ellC,ons,exc,excSides,F,Jexc,c3F,c3Jexc,x1,x3,x4,x11,x40,x100,x1156,gr,cps,cpsZero,fociF,fociJexc,halfFocalDistF,halfFocalDistJexc,pl,pr,toShow},
ell=plotEllAxes[a,{AbsoluteThickness@3,Black}];
ellC=plotEllb[Sequence@@getCausticAxes[a,1],{AbsoluteThickness@3,Brown}];
ons=orbitNormals[a,toRad@(tDeg+OptionValue@eps)];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excSides=triLengthsRL@exc;
F=getFeuerbachHypMitten[ons[[1]],ons[[3]]];
Jexc=getJerabekHyp[exc,excSides];
c3F=F["coeffs"][[3]];
c3Jexc=Jexc["coeffs"][[3]];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
(*x3=getCircumcenterTrilin[ons[[1]],ons[[3]]];*)
x4=getOrthocenterTrilin[ons[[1]],ons[[3]]];
x11=getFeuerbachTrilin[ons[[1]],ons[[3]]];
x40=getBevanTrilin[ons[[1]],ons[[3]]];
x100=getX100Trilin[ons[[1]],ons[[3]]];
x1156=getX1156Trilin[ons[[1]],ons[[3]]];
fociF=(#-x11)&/@F["foci"];
fociJexc=(#-x100)&/@Jexc["foci"];
halfFocalDistJexc=Sqrt[2./Abs@c3Jexc];
halfFocalDistF=Sqrt[2./Abs@c3F];
pr={{-a-OptionValue@slackX,a+OptionValue@slackX},{-1-OptionValue@slackY,1+OptionValue@slackY}};
gr=Graphics[{FaceForm@None,PointSize@Large,drawPoly[exc,Darker@Green],drawPoly[ons[[1]],Blue],
MapThread[{Point@#1,Text[Style[Subscript["X",#2],20],#1,(1+OptionValue@lgt){-1,1}]}&,{{x1,(*x3,*)x4,{0,0},x11,x40,x100,x1156},{1,(*3,*)4,9,11,40,100,1156}}],
(*{Orange,Point@x11,Point@-x11,Purple,Point@x100,Point@-x100},*)
{Dashed,Thick,Line@fociJexc,Blue,Point@fociF,Text[Style["f",16],#,{-1.25,-1.25}]&/@fociF,Darker@Green,Point@fociJexc,Text[Style["f'",16],#,{-1.25,-1.25}]&/@fociJexc},
If[OptionValue@drFCircs,{Dashed,Darker@Green,Circle[{0,0},halfFocalDistJexc],Blue,Circle[{0,0},halfFocalDistF]},{}]},PlotRange->pr];
cps=ContourPlot[{2 c3F (x-x11[[1]]) (y-x11[[2]])+1==0,2 c3Jexc (x-x100[[1]])(y-x100[[2]])+1==0},{x,-a-OptionValue@slackX,a+OptionValue@slackX},{y,-1-OptionValue@slackY,1+OptionValue@slackY},ContourStyle->{Directive[AbsoluteThickness@3,,Blue],Directive[AbsoluteThickness@3,,Darker@Green]},PerformanceGoal->"Quality"];
cpsZero=ContourPlot[{2 c3F x y+1==0,2 c3Jexc x y+1==0},{x,-a-OptionValue@slackX,a+OptionValue@slackX},{y,-1-OptionValue@slackY,1+OptionValue@slackY},ContourStyle->{Directive[AbsoluteThickness@3,Dashed,Blue],Directive[AbsoluteThickness@3,Dashed,Darker@Green]},PerformanceGoal->"Quality"];

pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°\n"<>If[OptionValue@drCxy,"1/(Subscript[a, xy])="<>nfn[1/c3F,3]<>", 1/(Subscript[a, xy])'="<>nfn[1/c3Jexc,3]<>", (Subscript[a, xy])/(Subscript[a, xy])'="<>nfn[c3F/c3Jexc,3]<>"\n",""]<>"λ="<>nfn[2halfFocalDistF,3]<>", λ'="<>nfn[2halfFocalDistJexc,3]<>", λ'/λ="<>nfn[halfFocalDistJexc/halfFocalDistF,3];
toShow=Show[{ell,ellC,cps,cpsZero,gr},PlotLabel->Style[pl,{Black,20},Background->White],PlotRange->pr,ImageSize->OptionValue@sz];
If[OptionValue@drLegend,Legended[toShow,
LineLegend[Directive[AbsoluteThickness@3,#]&/@{Black,Brown,Blue,{Dashed,Blue},Darker@Green,{Dashed,Darker@Green}},
Style[#,{Black,20}]&/@{"EB","Caustic","F","F-(Subscript[X, 11])","(Subscript[J, exc])","(Subscript[J, exc])-(Subscript[X, 100])"}]],toShow]];

Ronaldo: if hyperbola equation is: (Subscript[a, xy]) x y + 1 = 0
half focal length = Sqrt[2/|(Subscript[a, xy])|]

Manipulate[
showZeroHyps[1.5,tDeg,slackX->1,slackY->1,drFCircs->drFCircs0,sz->800],
{{drFCircs0,True},{True,False}},
{{tDeg,10.},-180,180,.1},
ControlPlacement->Left]

Module[{hc},Quiet@Plot[Evaluate[
hc=getFJexcHypCoeffs[1.5,tDeg];1/{hc[[1,3]],hc[[2,3]],safeDiv[hc[[1,3]],hc[[2,3]]]}],{tDeg,0,180},PlotStyle->{Red,Green,Blue},PlotLegends->(Style[#,20]&/@{"1/(Subscript[c, 3])","1/(Subscript[c, 3])'","(Subscript[c, 3])'/(Subscript[c, 3])" }),Frame->True,GridLines->Automatic,FrameStyle->Directive[Black,16],FrameLabel->(Style[#,20]&/@{"t (degrees)","coeff"}),ImageSize->800]]

Clear@getFJexcHypFocals;
getFJexcHypFocals[a_?NumericQ,tDeg_?NumericQ]:=Module[{tri,norms,triL,exc,excL,F,Jexc,cF,cJexc,focalDistJexc,focalDistF},
{tri,norms,triL}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[tri,triL];
excL=triLengthsRL@exc;
F=getFeuerbachHypMitten[tri,triL];
cF=Chop@F["coeffs"];
Jexc=getJerabekHyp[exc,excL];
cJexc=Chop@Jexc["coeffs"];
focalDistJexc=2Sqrt[2./Abs@cJexc[[3]]];
focalDistF=2Sqrt[2./Abs@cF[[3]]];
{focalDistF,focalDistJexc,safeDiv[focalDistJexc,focalDistF]}];

getFJexcHypFocals[1.4,10.]

hypFocalsPlot=Module[{a1=1.5,a2=1.3,fs,eps=.001,pl,p1,p2,clrs0={Red,Darker@Green,Blue},clrs,clrsDashed,clrsAT,clrsDashedAT,rhos,toShow},
clrs=Directive[Thick,#]&/@clrs0;
clrsDashed=Directive[Thick,Dotted,#]&/@clrs0;
clrsAT=Directive[AbsoluteThickness@3,#]&/@clrs0;
clrsDashedAT=Directive[AbsoluteThickness@3,Dashed,#]&/@clrs0;
pl="a/b="<>nfn[a1,1]<>" (solid), a/b="<>nfn[a2,1]<>" (dashed)";
p1=Quiet@ListLinePlot[
Transpose@Table[fs=getFJexcHypFocals[a1,tDeg+eps];
{tDeg,#}&/@fs,
{tDeg,0,90,.05}],
PlotStyle->clrs,Frame->True,FrameStyle->Directive[Black,16],
FrameLabel->(Style[#,20]&/@{"t (degrees)","coeff"})];
p2=Quiet@ListLinePlot[
Transpose@Table[fs=getFJexcHypFocals[a2,tDeg+eps];{tDeg,#}&/@fs,
{tDeg,0,90,.05}],PlotStyle->clrsDashed,Frame->True,
FrameStyle->Directive[Black,16],FrameLabel->(Style[#,20]&/@{"t (degrees)","coeff"})];
rhos={"λ","λ'","λ'/λ"};
toShow=Show[{p1,p2},AspectRatio->.4,PlotRange->All,Frame->True,GridLines->Automatic,ImageSize->800];
Legended[toShow,
LineLegend[Join[clrsAT,clrsDashedAT],Style[#,{Black,20}]&/@Join[#<>", a="<>nfn[a1,1]&/@rhos,#<>", a="<>nfn[a2,1]&/@rhos]]]
]

getFJexcHypFocals[1.5,20.]

export3["0110_hyp_focals",hypFocalsPlot]

zeroHypPlot=Grid[
{MapThread[showZeroHyps[1.5,#1,slackX->.66,slackY->.8,drFCircs->False,sz->800,drLegend->#2,drCxy->False]&,{{10.1,6.2},{False,False}}],
{LineLegend[Directive[AbsoluteThickness@3,#]&/@{Black,Brown,Blue,Darker@Green,{Dashed,Blue},{Dashed,Darker@Green}},
Style[#,{Black,20}]&/@{"EB","Caustic","F","(Subscript[J, exc])","F'=transl[F,-(Subscript[X, 11])]",ToString[Subscript["J'","exc"],StandardForm]<>"=transl[(Subscript[J, exc]),-(Subscript[X, 100])]"},LegendLayout->{"Row",1}],SpanFromLeft}},Frame->All,FrameStyle->Thick]

export3["0100_zero_hyps",zeroHypPlot]

Clear@getOrbitHyps;
Options@getOrbitHyps={addHeader->False};
getOrbitHyps[ellA_,tDeg_,OptionsPattern[]]:=Module[{tri,norms,triL,exc,excL,hyps,as,bs,cs,ellAs,tDegs,names,dets,discr,header,mas,ns,vals},
{tri,norms,triL}=orbitNormals[ellA,toRad@tDeg];
exc=excentralTriangle[tri,triL];
excL=triLengthsRL@exc;
names={"F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
hyps={
getFeuerbachHyp[tri,triL],
getJerabekHyp[tri,triL],
getFeuerbachHyp[exc,excL],
getJerabekHyp[exc,excL]};
as=#["a"]&/@hyps;
bs=#["b"]&/@hyps;
cs=#["c"]&/@hyps;
dets=#["det"]&/@hyps;
discr=#["discr"]&/@hyps;
mas=#["majorAxis"]&/@hyps;
ns=magn/@mas;
ellAs=ConstantArray[ellA,Length@hyps];
tDegs=ConstantArray[tDeg,Length@hyps];
header={"ellA","tDeg","name","a","b","c","det","discr","majorAxis","norm"};
vals=Transpose@{ellAs,tDegs,names,as,bs,cs,dets,discr,mas,ns};
If[OptionValue@addHeader,Prepend[vals,header],vals]];

Clear@ratioFocalAllOrbits;
ratioFocalAllOrbits[a_]:=Module[{ss,hyp,names},
names={"F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
ss=Subsets[Range@4,{2}];
getStats[Table[
hyp=getOrbitHyps[a,tDeg];
hyp[[#[[1]],6]]/hyp[[#[[2]],6]],{tDeg,1,81,1}],label->Part[names,#]]&/@ss]

Clear@ratioDetsAllOrbits;
ratioDetsAllOrbits[a_]:=Module[{ss,hyp,names},
names={"F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
ss=Subsets[Range@4,{2}];
getStats[Table[
hyp=getOrbitHyps[a,tDeg];
hyp[[#[[1]],7]]/hyp[[#[[2]],7]],{tDeg,1,81,1}],label->Part[names,#]]&/@ss]

Clear@dotAxesAllOrbits;dotAxesAllOrbits[a_]:=Module[{ss,hyp,names},
names={"F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
ss=Subsets[Range@4,{2}];
getStats[Table[
hyp=getOrbitHyps[a,tDeg];
hyp[[#[[1]],9]].perp[hyp[[#[[2]],9]]],{tDeg,1,81,1}],label->Part[names,#]]&/@ss]

ratioFocalAllOrbits[1.5]//TableForm

1/.425828

Sqrt[5.515]

ratioDetsAllOrbits[1.5]//TableForm

dotAxesAllOrbits[1.5]//TableForm

Clear@getOrbitHypsCoeffs;
Options@getOrbitHypsCoeffs={addHeader->False};
getOrbitHypsCoeffs[ellA_,tDeg_,OptionsPattern[]]:=Module[{tri,norms,triL,exc,excL,hyps,as,bs,cs,ellAs,tDegs,names,dets,discr,header,mas,ns,vals},
{tri,norms,triL}=orbitNormals[ellA,toRad@tDeg];
exc=excentralTriangle[tri,triL];
excL=triLengthsRL@exc;
names={"F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
hyps={
getFeuerbachHyp[tri,triL],
getJerabekHyp[tri,triL],
getFeuerbachHyp[exc,excL],
getJerabekHyp[exc,excL]};
(* {axx,ayy,axy,bx,by} *)
names={"coeff","F","J","(Subscript[F, exc])","(Subscript[J, exc])"};
Prepend[Transpose@Prepend[Chop[#["coeffs"]]&/@hyps,{"axx","ayy","axy","bx","by"}],names]];

getDelta[1.5,1]

hessianDetRatio[a_,b_]:=Module[{δ=getDelta[a,b]},
((b^2-δ)/(a^2-b^2))^2];

1/hessianDetRatio[1.5,1]

Limit[hessianDetRatio[a,1],a->1]

Plot[{hessianDetRatio[a,1],Sqrt@hessianDetRatio[a,1]},{a,.1,3},PlotLegends->{"hessDet","c3'/c3"}]

Ronaldo has provided a closed form to the focal length

focalLengthRatio[a_,b_]:=Module[{δ=getDelta[a,b]},
(a^4+b^4+δ (a^2+b^2))/(a b)^2]

focalLengthRatio[1,1]

Plot[focalLengthRatio[a,1],{a,.1,2}]

focalLengthRatio[a,b]//TeXForm

showOneCircumHypInvariantTable[a_,tDeg_]:=Module[{coeffs,axyRatio,rhoRatio},
coeffs=getOrbitHypsCoeffs[a,tDeg];
axyRatio=coeffs[[4,2]]/coeffs[[4,5]];
rhoRatio=focalLengthRatio[a,1];
Grid[Prepend[coeffs,{"a="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°, axyRatio="<>nfn[axyRatio,3]<>", ρ/ρ'="<>nfn[rhoRatio,3],SpanFromLeft}],Alignment->Left,Dividers->{All,{True,True,True,False,False,False,False,True}}]]

showOneCircumHypInvariantTable[1.2,50.]

showOneCircumHypInvariantTable[2.,20.]

showOneCircumHypInvariantTable[1.5,30.]

showOneCircumHypInvariantTable[2.,10.]

showOneCircumHypInvariantTable[2,20.]

Module[{coeffs},
Plot[coeffs=getOrbitHypsCoeffs[a,11.];
coeffs[[4,2]]/coeffs[[4,5]],{a,1.1,3},Frame->True,FrameLabel->(Style[#,{Black,16}]&/@{"a/b","ratio: (Subscript[c, xy])"})]]

(* axy x y + bx x + by y + C = 0 *)

Isogonal and Isotomic of Foci

Locus of Gemini90 triangle vertex: clearly non-elliptic

ellGrad[1.,1,0]

(* with respect to X9, the center of the EB *)
getBilliardPolar[a_,tri_]:=Module[{tangs},
tangs=perp[ellGrad[a,#[[1]],#[[2]]]]&/@tri;
MapThread[interRaysUnprot[#1,#2,#3,#4]&,{tri,tangs,RotateLeft@tri,RotateLeft@tangs}]];

Test: Polar of 3-periodic should be equal to excentral

getBilliardPolar[1.5,orbitNormals[1.5,toRad@10.][[1]]]

excentralTriangle[Sequence@@Part[orbitNormals[1.5,toRad@10.],{1,3}]]

Clear@showGeminiLocus;
Options@showGeminiLocus={pp->{},drExc->False,drG90->False,yslack->.5,xslack->.25,drInnerConwayPolar->False,drG2Polar->False,drTrio->False,drG2PolarA->False};
Clear@showGeminiLocus;
showGeminiLocus[a_,tDeg1_,OptionsPattern[]]:=Module[{ons,ons1,g90,g2,g30,honsberger,innerConway(* intouch tri of ACT *),innerConwayPolar,exc,δ,excAxes,pr,fs,pl,causticAxes,gr,ell,oliveClr,g2Polar},
pr={{-a-OptionValue@xslack,a+OptionValue@xslack},{-1-OptionValue@yslack,1+OptionValue@yslack}};
fs=getFoci[a];
ons1=orbitNormals[a,toRad@tDeg1];
exc=excentralTriangle[Sequence@@Part[ons1,{1,3}]];
δ=getDelta[a,1.];
excAxes={(δ+1.)/a,δ+a^2};
causticAxes=getCausticAxes[a,1];
ell=plotEllAxes[a,{Thick,Black}];
g90=gemini90Triangle[Sequence@@Part[ons1,{1,3}]];
g2=gemini2Triangle[Sequence@@Part[ons1,{1,3}]];
g2Polar=getBilliardPolar[a,g2];
g30=(*{.01,0}+#&/@*)gemini30Triangle[Sequence@@Part[ons1,{1,3}]];
honsberger=honsbergerTriangle[Sequence@@Part[ons1,{1,3}]];
innerConway=(*RandomReal[{-.05,.05},3]+*)innerConwayTriangle[Sequence@@Part[ons1,{1,3}]];
innerConwayPolar=getBilliardPolar[a,innerConway];
oliveClr=ColorData["HTML","OliveDrab"];
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg1,2]<>", L="<>nfn[triPer[ons1[[1]]],2]<>If[OptionValue@drG2PolarA,"\n(Subscript[A, G2])="<>nfn[signedArea@g2,3]<>", (Subscript[A, G2])'="<>nfn[signedArea@g2Polar,3]<>", (Subscript[A, G2])'(Subscript[A, G2])="<>nfn[signedArea@g2Polar signedArea@g2,3]<>", (Subscript[A, G2])'/(Subscript[A, G2])="<>nfn[signedArea@g2Polar/signedArea@g2,3],""]<>"\n";
gr=Graphics@{FaceForm@None,EdgeForm@{Thick,Purple},PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@ons1[[1]],Blue,Point@ons1[[1]],Point@{0,0},Text[Style["(Subscript[X, 9])",{Blue,16}],{0,0},{0,1.5}]},
If[OptionValue@drG90,{EdgeForm@{Thick,Purple},Polygon@g90,Purple,Point@g90},{}],
{EdgeForm@{Thick,Orange},Polygon@g2},
If[OptionValue@drTrio,{{EdgeForm@{Thick,oliveClr},Polygon@innerConway},
{EdgeForm@Directive[Thick,Dashed,Orange],Polygon@g30},
{EdgeForm@{Thick,Red},Polygon@honsberger}},{}],
If[OptionValue@drExc,{EdgeForm@{Thick,Darker@Green},Polygon@exc,Darker@Green,Point@exc,Thick,Dashed,Circle[{0,0},excAxes]},{}],
If[OptionValue@drInnerConwayPolar,{EdgeForm@{Thick,oliveClr},Polygon@innerConwayPolar,oliveClr,Point@innerConwayPolar},{}],
If[OptionValue@drG2Polar,{EdgeForm@{Thick,Orange},Polygon@g2Polar,Orange,Point@g2Polar},{}],
{Brown,Thick,Circle[{0,0},causticAxes]},
{Black,PointSize@Medium,Point@fs}};
Legended[Show[{ell,If[OptionValue@drG90,OptionValue@pp,{}],gr},PlotLabel->Style[pl,{Black,20}],ImageSize->600,Frame->True,PlotRange->pr,PlotRangeClipping->True],Placed[LineLegend[{Black,Brown,Blue,Darker@Green,Purple,Orange,{Dashed,Orange},Red,oliveClr},Style[#,16]&/@{"EB","Caustic","3-Per","Exc","Gem90","Gem2","Gem30","Honsberger","Inner Conway"},LegendLayout->"Column"],Right]]];

DynamicModule[{pp2,pp90,ons,eps=.01},
pp90=Graphics[{Thick,Dashed,Purple,Line@Table[
ons=orbitNormals[1.5,toRad@(tDeg+eps)];
gemini90Triangle[ons[[1]],ons[[3]]][[1]],
{tDeg,0,360,1}]}];
pp2=Graphics[{Thick,Dashed,Orange,Line@Table[
ons=orbitNormals[1.5,toRad@(tDeg+eps)];
getBilliardPolar[1.5,gemini2Triangle[ons[[1]],ons[[3]]]][[1]],
{tDeg,0,360,1}]}];
Manipulate[
showGeminiLocus[a,tDeg1,
pp->{pp2,pp90},
drExc->drExc0,
drG90->drG90a,
xslack->xslack0,
yslack->yslack0,
drInnerConwayPolar->drInnerConwayPolar0,
drG2Polar->drG2Polar0,
drTrio->drTrio0],
Style["Elliptic Billiard 3-Periodics:",{Darker@Red,20}],
Style["The Gemini 90 Triangle",{Darker@Red,20}],
Style["D. Reznik, April 2020",{Blue,14}],
Delimiter,
{{a,1.5},1.01,3,.01,Appearance->"Labeled"},
{{tDeg1,10.},-180.,180.,.5,Appearance->"Labeled"},
{{xslack0,.5},{.5,1,2,4,8}},
{{yslack0,.5},{.5,1,2,4,8}},
{{drExc0,False},{True,False}},
{{drG90a,False},{True,False}},
{{drTrio0,True},{True,False}},
{{drInnerConwayPolar0,False},{True,False}},
{{drG2Polar0,False},{True,False}},
ControlPlacement->Left]]

Clear@focusIsotIsog;
focusIsotIsog[a_?NumericQ,tDeg_?NumberQ]:=Module[{ons,fs,isot,isog,isogExc,isotExc,isogExt,exc,ext,excL},
fs=getFoci[a];
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
ext=extouchTriangle[ons[[1]],ons[[3]]];
excL=triLengthsRL@exc;
isog=isogonalConjugate[fs[[1]],ons[[1]],ons[[2]]];
isogExc=isogonalConjugate[fs[[1]],exc,getTriBisectors@@exc];
isogExt=isogonalConjugate[fs[[1]],ext,getTriBisectors@@ext];
isot=isotomicConjugate[fs[[1]],ons[[1]]]["pconj"];
isotExc=isotomicConjugate[fs[[1]],exc]["pconj"];
{isog,isot,isogExc,isotExc,isogExt}]

focusIsotIsog[1.5,0.]

Isogonal of F1 wrt tri is F2

getStats[Table[focusIsotIsog[1.5,tDeg][[1,1]],{tDeg,0,360}]]

getStats[Table[focusIsotIsog[1.5,tDeg][[5,1]],{tDeg,0,360}]]

getStats[Table[focusIsotIsog[1.5,tDeg][[5,2]],{tDeg,0,360}]]

Isogonal of F1 wrt excentral is F2

getStats[Table[focusIsotIsog[1.5,tDeg][[3,1]],{tDeg,0,360}]]

Isot of F1 wrt tri is green oval, and wrt to exc is purple oval

Clear@getFocusConjugateTable;
getFocusConjugateTable[a_,maxDeg_:360]:=Table[Delete[focusIsotIsog[a,tDeg2],3],{tDeg2,0,maxDeg}];

Clear@showFocusConjugate;
Options@showFocusConjugate={isogLines->False,isogExcLines->False,isotLoci->False,isogLines->False,isogLinesExc->False,isogLinesExt->False,isogLinesGemini90->False,drExc->False,drExt->False,xmin->-.5,xmax->.5,ymin->-1,ymax->1,drX9->True,drTriIncs->False,drCircumX1->False,drGemini90->False,drXs->False};
showFocusConjugate[a_,tDeg_,conjTable_,OptionsPattern[]]:=Module[{ell,ellCaustic,lp,pl,pr,ons,exc,ext,x1,x164,f1,f2,gr,x1ext,triIncs,triIncsA,circumX1,circumX1f1,circumX1f1isog,extIsog,extIsogX9,extIsogX1,gemini90,gemini90sides,gemini90x,gemini90Isog,x1g90},
ons=orbitNormals[a,toRad@tDeg];
gemini90=gemini90Triangle[ons[[1]],ons[[3]]];
gemini90sides=triLengthsRL@gemini90;
gemini90x=If[OptionValue@drXs,getNewCenters[gemini90,gemini90sides],{}];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
x164=getX164Trilin[ons[[1]],ons[[3]]];
exc=excentralTriangle[ons[[1]],ons[[3]]];
ext=extouchTriangle[ons[[1]],ons[[3]]];
x1ext=getIncenterTrilin[ext,triLengthsRL@ext];
x1g90=getIncenterTrilin[gemini90,gemini90sides];
triIncs={x1,x164,x1ext};
triIncsA=Abs@signedArea@triIncs;
ell=plotEllAxes[a,{Thick,Black}];
ellCaustic=plotEllb[Sequence@@getCausticAxes[a,1],{Thick,Brown}];
circumX1=getCircumAny[ons[[1]],x1];
circumX1f1=circumX1["foci"][[1]];
circumX1f1isog=isogonalConjugate[circumX1f1,ons[[1]],ons[[2]]];
{f1,f2}=getFoci[a];
gemini90Isog=isogonalConjugate[f1,gemini90,getTriBisectors@@gemini90];
extIsog=isogonalConjugate[f1,ext,getTriBisectors@@ext];
extIsogX9=isogonalConjugate[{0,0},ext,getTriBisectors@@ext];
extIsogX1=isogonalConjugate[x1,ext,getTriBisectors@@ext];
pl="a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°"<>If[OptionValue@drTriIncs,", (Subscript[A, 3])="<>nfn[triIncsA,3],""];
pr={{-a+OptionValue@xmin,a+OptionValue@xmax},{-1+OptionValue@ymin,1+OptionValue@ymax}};
lp=If[OptionValue@isotLoci,ListLinePlot[Transpose[conjTable],PlotStyle->{Red,Blue,Darker@Green}],{}];
gr=Graphics@{PointSize@Medium,FaceForm@None,
drawPoly[ons[[1]],Blue],If[OptionValue@drExc,drawPoly[exc,Darker@Green],{}],If[OptionValue@drExt,{drawPoly[ext,Darker@Red],Darker@Red,Point@extIsog,Text[Style["isog[(Subscript[f, 1]),T'']",12],extIsog,{0,1.5}](*,Purple,Point@extIsogX9,Point@extIsogX1*)},{}],
If[OptionValue@isogLinesExc,{Darker@Green,Point@x164,Dashed,Line@{x164,#}&/@exc,Text[Style["(Subscript[X, 164])",16],x164,{0,1.5}],Black,Dashed,Line@{f1,#}&/@exc,Line@{f2,#}&/@exc},{}],
If[OptionValue@isogLinesGemini90,{Purple,Point@x1g90,Dashed,Line@{x1g90,#}&/@gemini90,Text[Style["(Subscript[X, 1])[(Subscript[G, 90])]",16],x1g90,{0,1.5}],Black,Dashed,Line@{f1,#}&/@gemini90,Line@{f2,#}&/@gemini90},{}],
If[OptionValue@isogLinesExt,{Darker@Red,Point@x1ext,Dashed,Line@{x1ext,#}&/@ext,Text[Style["(Subscript[X, 1])''",16],x1ext,{0,1.5}],Black,Dashed,Line@{f1,#}&/@ext,Line@{f2,#}&/@ext},{}],
If[OptionValue@isogLines,{Blue,Point@x1,Dashed,Line@{x1,#}&/@ons[[1]],Text[Style["(Subscript[X, 1])",16],x1,{0,1.5}],Black,Dashed,Line@{f1,#}&/@ons[[1]],Line@{f2,#}&/@ons[[1]]},{}],
{Black,Point@{f1,f2},MapThread[{#3,Text[Style[Subscript["f",#2],16],#1,{0,1.5}]}&,{{f1,f2},{1,2},{Black,Black}}]},
If[OptionValue@drTriIncs,drawPoly[triIncs,Orange],{}],
If[OptionValue@isotLoci,
{Red,Point@conjTable[[1,1]],
Blue,Point@conjTable[[1,2]],Darker@Green,Point@conjTable[[1,3]]},{}],
If[OptionValue@drCircumX1,{Darker@Green,Circle[circumX1f1,.05],Purple,Circle[circumX1f1isog,.05]},{}],
If[OptionValue@drGemini90,{drawPoly[gemini90,Purple],Purple,Point@gemini90Isog,If[OptionValue@drXs,{Orange,MapThread[Tooltip[Point@#1,#2]&,{Third/@gemini90x,First/@gemini90x}]},{}]},{}],
If[OptionValue@drX9,{Blue,Point@{0,0},Text[Style["(Subscript[X, 9])",16],{0,0},{0,1.5}]},{}]};
Show[{lp,ell,ellCaustic,gr,If[OptionValue@drCircumX1,drawCircumAnyLow[circumX1,ons[[1]],ctrLab->"(Subscript[X, 1])",labSize->16,labClr->Darker@Green,ps->Darker@Green,drFoci->True],{}]},PlotLabel->Style[pl,{Black,16}],PlotRange->pr,
AspectRatio->Automatic,ImageSize->800,Axes->False,Frame->True]]

Peter Moses :
  1) X1 of the extouch triangle is (a - b - c)*(Sqrt[a*c*(a*b^2*c - S^2)] + Sqrt[a*b*(a*b*c^2 - S^2)]) ::
  2) Two foci are isogonal conjugates for triangles ABC, excentral and Gemini 90.
The (E9) foci are also on cubics
K040, K351, K352, K710, K716, K1060.
List of Gemini Triangles: https://faculty.evansville.edu/ck6/encyclopedia/gemini.html
Gemini 90: (a^2+b*c)/a : (-a*b-c*a)/b : (-a*b-c*a)/c

DynamicModule[{isoTable},
Manipulate[
isoTable=If[isotLoci0,getFocusConjugateTable[a],getFocusConjugateTable[a,1]];
Dynamic@showFocusConjugate[a,tDeg,{},drExc->drExc0,drExt->drExt0,isotLoci->isotLoci0,isogLines->isogLines0,isogLinesExc->isogLinesExc0,isogLinesExt->isogLinesExt0,isogLinesGemini90->isogLinesG90a,
drTriIncs->drTriIncs0,drCircumX1->drCircumX1a,
xmin->xmin0,xmax->xmax0,ymin->ymin0,ymax->ymax0,drGemini90->drGemini90a],
Style["Elliptic Billiard 3-Periodics:",{Darker@Red,20}],
Style["When are the foci isogonal conjugates?",{Darker@Red,16}],
Style["D. Reznik, April 2020",{Blue,14}],
Delimiter,
{{a,1.33,"a/b"},1.01,2,.01},
{{tDeg,10.,"θ"},-180.,180,.1},
{{xmin0,-.5,"(Subscript[x, min])"},{-0.1,-.5,-1,-2,-4}},
{{xmax0,.5,"(Subscript[x, max])"},{0.1,.5,1,2,4}},
{{ymin0,-.5,"(Subscript[y, min])"},{-0.1,-.5,-1,-2,-4}},
{{ymax0,.5,"(Subscript[y, max])"},{0.1,.5,1,2,4}},
{{drExc0,False,"excentral"},{True,False}},
{{drGemini90a,False,"gemini 90"},{True,False}},
{{drExt0,False,"extouch"},{True,False}},
{{isogLines0,False,"isog. lines"},{True,False}},
{{isogLinesExc0,False,"exc isog. lines"},{True,False}},
{{isogLinesG90a,False,"g90 isog. lines"},{True,False}},
{{isogLinesExt0,False,"ext isog. lines"},{True,False}},
{{isotLoci0,False,"isotomic"},{True,False}},
{{drTriIncs0,False,"tri (Subscript[X, 1]),(Subscript[X, 164]),(Subscript[X, 1])''"},{True,False}},
{{drCircumX1a,False,"circum (Subscript[X, 1])"},{True,False}},
ControlPlacement->Left]]

showFocusIsogonalTriple[a_,tDeg_]:=Module[{plOrb,plExc,plExt},
plOrb=showFocusConjugate[a,tDeg,{},
drExc->False,drExt->False,
isogLines->True,isogLinesExc->False,isogLinesExt->False,
xmin->-.25,xmax->.25,ymin->-.25,ymax->.25];
plExc=showFocusConjugate[a,tDeg,{},
drExc->True,drExt->False,
isogLines->False,isogLinesExc->True,isogLinesExt->False,
xmin->-.25,xmax->.25,ymin->-.75,ymax->2.5];
plExt=showFocusConjugate[a,tDeg,{},
drExc->False,drExt->True,
isogLines->False,isogLinesExc->False,isogLinesExt->True,
xmin->-.25,xmax->.25,ymin->-.25,ymax->.25];
Grid[{{Grid[{{plOrb},{plExt}},Alignment->Top],plExc}},Alignment->Top]];

showFocusIsogonalTriple[1.5,20.]

Invariants: Orbit, Antipedal and Pedal Areas

Three new area invariants :
  - A*pedalX9
  - antipedX9/A
  - corollary1: pedalX9*antipedX9 invariant
  - corollary2: A*ped9/(aped9/A) = inv = A^2 (ped9/aped9) => (aped9/ped9)/A^2 is inv
  - corollary 3: A ped9 (A’/A) = ped9 A’ = inv
  - corollary 4: aped9/A (A/A’) = aped9/A’ = inv
  - corollary 5: ped9 A’ / (aped9/A’) = inv = (ped9/aped9) A’^2

pedalAntipedalAreas[a_,tDeg_]:=Module[{ons,exc,x1,apedx1,x9trils,apedx9,orbitArea,pedx9,pedx9area,apedx9area},
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
apedx1=antipedalTriangle[ons[[1]],ons[[3]],{1,1,1}];
x9trils={ons[[3,2]]+ons[[3,3]]-ons[[3,1]],ons[[3,3]]+ons[[3,1]]-ons[[3,2]],ons[[3,1]]+ons[[3,2]]-ons[[3,3]]};
apedx9=antipedalTriangle[ons[[1]],ons[[3]],x9trils];
pedx9=pedalTriangle[ons[[1]],ons[[3]],x9trils];
orbitArea=Abs@signedArea[ons[[1]]];
apedx9area=Abs@signedArea[apedx9];
pedx9area=Abs@signedArea[pedx9];
<|"A"->orbitArea,"A^2"->orbitArea^2,"apedx9area"->apedx9area,"apedx9areaOvA"->apedx9area/orbitArea,"apedx9areaTimesA"->apedx9area orbitArea,"pedx9area"->pedx9area,"pedx9areaOvA"->pedx9area/orbitArea,"pedx9areaTimesA"->pedx9area orbitArea,"pedx9Timesantipedx9Area"->pedx9area apedx9area,"prodx9OvA"->pedx9area apedx9area/orbitArea,"prodx9OvA2"->pedx9area apedx9area/orbitArea^2,"ratiox9areaOvA2"->(apedx9area /pedx9area)/orbitArea^2,"apedOvpedx9A"->apedx9area/pedx9area,
"orbit"->ons[[1]],"apedx9"->apedx9,"pedx9"->pedx9|>]

pedalAntipedalAreas[1.5,10.]

0

pedalAntipedalAreas[1.5,20.]

Module[{a=1.5,tDeg=10.,ons,exc,x1,apx1,apx9},
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
apx1=antipedalTriangle[ons[[1]],ons[[3]],{1,1,1}];
getTrilinears[]
apx9=antipedalTriangle[ons[[1]],ons[[3]],{1,1,1}];
{exc,apx1}]//Grid

pedalAntipedalAreas[1.5,10.]//Keys

getCausticAxes[1.5,1]

Clear@showPedalAntipedal;
Options@showPedalAntipedal={xmin->-2,xmax->2,ymin->-3,ymax->3,drInc->False,drCir->False,drExc->False,drPedal->False,drAntipedal->False,drMittenLines->False,drX9->False};
showPedalAntipedal[a_,tDeg_,OptionsPattern[]]:=Module[{ell,cAB,ellCaustic,pl,ons,exc,excA,pr,f1,f2,gr,pedData,x1,r,x3,R},
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excA=Abs@signedArea[exc];
cAB=getCausticAxes[a,1];
ell=plotEllAxes[a,{Thick,Black}];
ellCaustic=plotEllb[Sequence@@cAB,{Thick,Brown}];
pedData=pedalAntipedalAreas[a,tDeg];
{f1,f2}=getFoci[a];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
r=getInradius[ons[[3]]];
x3=getCircumcenterTrilin[ons[[1]],ons[[3]]];
R=magn[ons[[1,1]]-x3];
pr={{-a+OptionValue@xmin,a+OptionValue@xmax},{-1+OptionValue@ymin,1+OptionValue@ymax}};
pl="a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°"<>", L="<>nfn[triPer[ons[[1]]],3]<>If[OptionValue@drInc||OptionValue@drCir,"\nr="<>nfn[r,3]<>", R="<>nfn[R,3]<>", r/R="<>nfn[r/R,3],""]<>
If[OptionValue@drExc,"\n"<>
colorStr["A="<>nfn[pedData["A"],3],Blue]<>", "<>colorStr["A'="<>nfn[excA,3],Darker@Green]<>", "<>colorStr["A'",Darker@Green]<>"/"<>colorStr["A",Blue]<>"="<>nfn[excA/pedData["A"],3],""]<>
If[OptionValue@drPedal,
"\n"<>colorStr["(Subscript[A, 9])="<>nfn[pedData["pedx9area"],3],Orange]<>", "<>colorStr["(Subscript[A, 9])",Orange]<>colorStr["A'",Darker@Green]<>"="<>nfn[pedData["pedx9area"]excA,3],""]<>
If[OptionValue@drAntipedal,
"\n"<>colorStr["(Subscript[A, 9])'="<>nfn[pedData["apedx9area"],3],Red]<>
", "<>colorStr["(Subscript[A, 9])'",Red]<>"/"<>colorStr["A'",Darker@Green]<>"="<>nfn[pedData["apedx9area"]/excA,3],""]<>
If[OptionValue@drPedal&&OptionValue@drAntipedal,
"\n"<>colorStr["(Subscript[A, 9])",Orange]<>colorStr["(Subscript[A, 9])'",Red]<>"="<>nfn[pedData["pedx9area"]pedData["apedx9area"],3]<>
", ("<>colorStr["(Subscript[A, 9])'",Red]<>"/"<>colorStr["(Subscript[A, 9])",Orange]<>")/"<>colorStr["(A^2)",Blue]<>"="<>nfn[pedData["ratiox9areaOvA2"],3]<>
", ("<>colorStr["(Subscript[A, 9])",Orange]<>"/"<>colorStr["(Subscript[A, 9])'",Red]<>")"<>colorStr["(A')^2",Darker@Green]<>"="<>nfn[(excA^2)/pedData["apedOvpedx9A"],3],""];
gr=Graphics[{FaceForm@None,Thick,PointSize@Medium,
If[OptionValue@drInc,{Darker@Green,Point@x1,Circle[x1,r],Text[Style["(Subscript[X, 1])",16],x1,{0,-1.5}]},{}],
If[OptionValue@drCir,{Purple,Point@x3,Circle[x3,R],Text[Style["(Subscript[X, 3])",16],x3,{0,-1.5}]},{}],
FaceForm@None,drawPoly[ons[[1]],Blue],
If[OptionValue@drExc,drawPoly[exc,Darker@Green],{}],
If[OptionValue@drMittenLines,{Darker@Green,Dashed,Line@{#,{0,0}}&/@exc,Blue,Point@medialTriangle[ons[[1]],ons[[3]]],},{}],
{Black,Point@{f1,f2}(*,MapThread[{#3,Text[Style[Subscript["f",#2],16],#1,{0,1.5}]}&,{{f1,f2},{1,2},{Black,Black}}]*)},
If[OptionValue@drAntipedal,{FaceForm@Red,Opacity@.05,drawPoly[pedData["apedx9"],Red]},{}],
If[OptionValue@drPedal,{FaceForm@Orange,Opacity@.05,drawPoly[pedData["pedx9"],Orange]},{}],
If[OptionValue@drX9,{Blue,Point@{0,0},Text[Style["(Subscript[X, 9])",16],{0,0},{0,1.5}]},{}]
}];
Legended[Show[{ell,ellCaustic,gr},PlotLabel->Style[pl,{Black,16}],PlotRange->pr,AspectRatio->Automatic,
ImageSize->700,Axes->False,Frame->True],SwatchLegend[{Black,Blue,Darker@Green,Orange,Red},Style[#,16]&/@{"billiard","3-periodic","excentral","(Subscript[X, 9]) pedal","(Subscript[X, 9]) antipedal"}]]];

pedalManip=Manipulate[
showPedalAntipedal[a,tDeg,xmin->xmin0,xmax->xmax0,ymin->ymin0,ymax->ymax0,drInc->drInc0,drCir->drCir0,drExc->drExc0,drPedal->drPedal0,drAntipedal->drAntipedal0,drMittenLines->drMittenLines0,drX9->drX9a],
Style["Elliptic Billiard 3-Periodics:",{Darker@Red,20}],
Style["Pedal and Antipedal Invariants",{Darker@Red,20}],
Style["D. Reznik, R. Garcia, J. Koiller, 2019-2020",{Blue,12}],
Delimiter,
{{a,1.33},1.01,2,.01,Appearance->"Labeled"},
{{tDeg,10.},-180.,180,.1,Appearance->"Labeled"},
{{xmin0,-1,"(Subscript[x, min])"},{-.5,-1,-2,-4,-8}},
{{xmax0,1,"(Subscript[x, max])"},{.5,1,2,4,8}},
{{ymin0,-1,"(Subscript[y, min])"},{-.5,-1,-2,-4,-8}},
{{ymax0,1,"(Subscript[y, max])"},{.5,1,2,4,8}},
{{drX9a,False,"(Subscript[X, 9])"},{True,False}},
{{drExc0,False,"excentral"},{True,False}},
{{drMittenLines0,False,"(Subscript[X, 9]) constr"},{True,False}},
{{drInc0,False,"incircle"},{True,False}},
{{drCir0,False,"circumcircle"},{True,False}},
{{drPedal0,False,"(Subscript[X, 9]) pedal"},{True,False}},
{{drAntipedal0,False,"(Subscript[X, 9]) antipedal"},{True,False}},
ControlPlacement->Left,SaveDefinitions->True];

pedalManip

Isotomic and Isogonal Axes (to get X44)

Iosogonal / Antiorthic

Clear@getAntiOrthicAxis;
getAntiOrthicAxis[tri_,exc_]:=Module[{inters},
inters=MapThread[interRays[#1,#2-#1,#3,#4-#3]&,{tri,RotateLeft@tri,exc,RotateLeft@exc}];
inters];

Clear@drawAntiOrthicAxis;
Options@drawAntiOrthicAxis={"clr"->("inc"/.ptClrs),"drConstr"->False};
drawAntiOrthicAxis[orbit_,exc_,OptionsPattern[]]:=Module[{aoa,gr},
aoa=getAntiOrthicAxis[orbit,exc];
gr=Graphics[{FaceForm@None,PointSize@Large,
(*{MapThread[Text[#1,#2,{-1.5,-1.5}]&,{{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])"},orbit}]},
{MapThread[Text[#1,#2,{-1.5,-1.5}]&,{{"(Subscript[X, 1])","(Subscript[X, 2])","(Subscript[X, 3])"},exc}]},*)
{OptionValue@"clr",Point@aoa,Thick,Line[Part[aoa,{1,2,3}]]},
If[OptionValue@"drConstr",{
{"inc"/.ptClrs,Dashed,MapThread[Line@{#1,#2}&,{exc,aoa}]},
{"ell"/.ptClrs,Dashed,MapThread[Line@{#1,#2}&,{orbit,aoa}]}},{}]}]];

Clear@getOrthicAxisFoot;getOrthicAxisFoot[a_,pt_,t_]:=Module[{o,n,s,exc,aoa,oaFoot},
{o,n,s}=orbitNormals[a,t];
exc=excentralTriangle[o,s];
aoa=getAntiOrthicAxis[o,exc];
oaFoot=closestPerp[pt,First@aoa,Second@aoa];
oaFoot];

Clear@getIsotomicAxisLow;
getIsotomicAxisLow[tri_,sides_,actData_]:=Module[{axisPts},
(*<|"tri"->tri,"sides"->sides,"inc"->inc,"incR"->incR,"npc"->npc,"npcR"->npcR,"tps"->tps|>];*)
axisPts=MapThread[interRays[#1,#2-#1,#3,#4-#3]&,{actData["tri"],RotateLeft@actData["tri"],actData["tps"],RotateLeft@actData["tps"]}];
axisPts];

Isotomic (should contain X(693) =X’(100), e os conj. isot dos pes dos incirculo do ACT)

Also: X (100) = trilinear pole of line X(1)X (6) (and PU (28)) (van Aubel line of excentral triangle)

(*CloudDeploy[%,"isotomic axis",Permissions->"Public"]*)

Isotomic Conjugate: L(31) of orbit. L(55) of ACT

Clear@drawIsotomicAxis;
Options@drawIsotomicAxis={"clr"->("anticompl"/.ptClrs),"drConstr"->False};
drawIsotomicAxis[tri_,sides_,actData_,OptionsPattern[]]:=Module[{isoAxis,gr},
isoAxis=getIsotomicAxisLow[tri,sides,actData];
gr=Graphics[{FaceForm@None,PointSize@Large,
{OptionValue@"clr",PointSize@Large,Point@isoAxis,Thick,Line[Part[isoAxis,{1,2,3}]]},
If[OptionValue@"drConstr",{
{"anticompl"/.ptClrs,Dashed,MapThread[Line@{#1,#2}&,{actData["tri"],isoAxis}]},
{"anticompl"/.ptClrs,Dashed,MapThread[Line@{#1,#2}&,{actData["tps"],isoAxis}]}},{}]}];
gr];

Clear@getIsotomicAxis;
getIsotomicAxis[tri_]:=Module[{sides,actData,x100,x693,x693trilin,
(*actTpsIsotConj*)
actTpsIsogConj,axisPts,noise},
sides=triLengthsRL@tri;
(*<|"tri"->tri,"sides"->sides,"inc"->inc,"incR"->incR,"npc"->npc,"npcR"->npcR,"tps"->tps|>];*)
actData=getAnticomplData[tri,sides];
x100=getX100Trilin[tri,sides];
x693=showIsotomicConjugate[x100,tri][[1]];
x693trilin=getX693Trilin[tri,sides];
axisPts=getIsotomicAxisLow[tri,sides,actData];
actTpsIsogConj=isogonalConjugate[#,tri,getTriBisectors@@tri]&/@(actData["tps"]);
(*noise=RandomReal[{-1,1},2]*10^-6;
actTpsIsotConj=(showIsotomicConjugate[#+noise,tri][[1]])&/@(actData["tps"]);
*)
<|"x100"->x100,
"x693"->x693,
"x693trilin"->x693trilin,
"act"->actData["tri"],
"actTps"->actData["tps"],
"actInc"->actData["inc"],
"actIncR"->actData["incR"],
"axisPts"->axisPts,
"actTpsIsogConj"->actTpsIsogConj
(*,"actTpsIsotConj"->actTpsIsotConj*)|>];

getIsotomicAxis[{{0,0},{1.,0},{2,2}}]

Peter Moses' 33 Billiard Points [requires previous 2 Circum sections]

Length@{88,100,162,190,651,653,655,658,660,662,673,771,799,823,897,1156,1492,1821,2349,2580,2581,3257,4598,4599,4604,4606,4607,8052,20332,23707,24624,27834,32680}

(* thomson cubic *)
Length@{1,2,3,4,6,9,57,223,28,1073,1249,3341,3342,3343,3344,3349,3350,3351,3352,3356,14481}

Clear@getMosesCartesians;
Options@getMosesCartesians={doIsog->False};
getMosesCartesians[tri_,{a_,b_,c_},OptionsPattern[]]:=Module[{ctrs,
sinA,sinB,sinC,
cosA,cosB,cosC,
cosA2,cosB2,cosC2,(*squared*)
cosA3,cosB3,cosC3,(*cubed*)
secA,secB,secC,
a2,b2,c2,a3,b3,c3,a4,b4,c4,
cirR,cir,ort,d34},
a2=a*a;b2=b*b;c2=c*c;
a3=a2*a;b3=b2*b;c3=c2*c;
a4=a2*a2;b4=b2*b2;c4=c2*c2;
cirR=getCircumradius[{a,b,c}];
cir=getCircumcenter@@tri;
ort=getOrthocenter@@tri;
d34=magn[cir-ort];
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
{secA,secB,secC}=1./{cosA,cosB,cosC};
{cosA2,cosB2,cosC2}=(#^2)&/@{cosA,cosB,cosC};
{cosA3,cosB3,cosC3}=(#^3)&/@{cosA,cosB,cosC};
ctrs={
{"X","name","trilinears"},
{88,"ISOGONAL CONJUGATE OF X(44)",{1/(b+c-2 a),1/(c+a-2 b),1/(a+b-2 c)}},
{100,"ANTICOMPLEMENT OF FEUERBACH POINT",{1/(b-c),1/(c-a),1/(a-b)}},
(* new! *)
{162,"CEVAPOINT OF X(108) AND X(109)",1/{(b2-c2)(b2+c2-a2),(c2-a2)(c2+a2-b2),(a2-b2)(a2+b2-c2)}},
{190,"YFF PARABOLIC POINT",{b c/(b-c),c a/(c-a),a b/(a-b)}},
{651,"TRILINEAR POLE OF LINE X(1)X(3)",1/{(b-c)(b+c-a),(c-a)(c+a-b),(a-b)(a+b-c)}},
{653,"TRILINEAR POLE OF LINE X(1)X(4)",1/{(secB - secC),(secC - secA),(secA - secB)}},
(* 1/[cos(A-B)-cos(C-A)] *)
{655,"TRILINEAR POLE OF LINE X(1)X(5)",1/{
cosA cosB+sinA sinB-cosC cosA-sinA sinB,
cosB cosC+sinB sinC-cosA cosB-sinB sinC,
cosC cosA+sinC sinA-cosB cosC-sinC sinA}
},
{658,"TRILINEAR POLE OF LINE X(1)X(7)",1/{
(1+cosA)(cosB-cosC),
(1+cosB)(cosC-cosA),
(1+cosC)(cosA-cosB)}
},
{660,"TRILINEAR POLE OF LINE X(1)X(39)",1/{
(a2-b c)(b-c),
(b2-c a)(c-a),
(c2-a b)(a-b)}},
{662,"TRILINEAR POLE OF LINE X(1)X(21)",1/{b2-c2,c2-a2,a2-b2}},
{673,"TRILINEAR POLE OF LINE X(1)X(514)",{
(b c)/(b2+c2-a(b+c)),
(c a)/(c2+a2-b(c+a)),
(a b)/(a2+b2-c(a+b))}
},
{771,"ISOGONAL CONJUGATE OF X(770)", 1/{cosB3-cosC3,cosC3-cosA3,cosA3-cosB3}},
{799,"ISOGONAL CONJUGATE OF X(798)",{(b c)/(a(b2-c2)),(c a)/(b(c2-a2)),(a b)/(c(a2-b2))}},
{823,"ISOGONAL CONJUGATE OF X(822)",{
b2 c2/((b2-c2)(b2+c2-a2)^2),
c2 a2/((c2-a2)(c2+a2-b2)^2),
a2 b2/((a2-b2)(a2+b2-c2)^2)}},
{897,"ISOGONAL CONJUGATE OF X(896)",1/{2a2-b2-c2,2 b2-c2-a2,2c2-a2-b2}},
{1156,"ISOGONAL CONJUGATE OF X(1155)",1/{
(b-c)^2 + a(b+c-2a),
(c-a)^2 + b(c+a-2b),
(a-b)^2 + c(a+b-2c)
}
},
{1492,"COLUMBUS POINT",1/{b3-c3,c3-a3,a3-b3}},
{1821,"ISOGONAL CONJUGATE OF MIMOSA TRANSFORM OF X(287)", 1/{
a2(a2 b2+a2 c2-b4-c4),
b2(b2 c2+b2 a2-c4-a4),
c2(c2 a2+c2 b2-a4-b4)}
},
{2349,"X(2)-ISOCONJUGATE OF X(1495)",1/{
(b2-c2)^2+a2(b2+c2-2a2),
(c2-a2)^2+b2(c2+a2-2b2),
(a2-b2)^2+c2(a2+b2-2c2)}
},
(* X(1113)=1st EULER-LINE-CIRCUMCIRCLE INTERSECTION
Trilinears (R-d) cosA - 2R cosB cosC,where R=circumradius,d=distance|OH|between X(3) and X(4).(Joe Goggins,2002)*)
{2580,"X(6)-ISOCONJUGATE OF X(2574)",{
((cirR-d34)cosA-2cirR cosB cosC)/a,
((cirR-d34)cosB-2cirR cosC cosA)/b,
((cirR-d34)cosC-2cirR cosA cosB)/c
}
},
(* Trilinears (1/a)f(a,b,c):(1/b)f(b,c,a):(1/c)/f(c,a,b),where f(a,b,c) is as at X(1114):
Trilinears (R+d) cosA - 2R cosB cosC *)
{2581,"X(6)-ISOCONJUGATE OF X(2575)",{
((cirR+d34)cosA-2cirR cosB cosC)/a,
((cirR+d34)cosB-2cirR cosC cosA)/b,
((cirR+d34)cosC-2cirR cosA cosB)/c}
},
{3257,"ISOGONAL CONJUGATE OF X(1635)",1/{
(b-c)(b+c-2a),
(c-a)(c+a -2b),
(a-b)(a+b -2c)}
},
(*Barycentrics: 1/[(b - c)(ab + ac - bc)]*)
{4598,"TRILINEAR POLE OF THE LINE X(1)X(87)",1/{
a(b-c)(a b+a c-b c),
b(c-a)(b c+b a-c a),
c(a-b)(c a+c b-a b)}
},
(* Barycentrics: a/(b4 - c4)*) 
{4599,"TRILINEAR POLE OF THE LINE X(1)X(82)",1/
{b4-c4,
c4-a4,
a4-b4}},
(* Barycentrics: a/[(b - c)(2b+2c-a)]*)
{4604,"TRILINEAR POLE OF THE LINE X(1)X(89)",1/{
(b-c)(2b+2c-a),
(c-a)(2c+2a-b),
(a-b)(2a+2b-c)
}},
{4606,"TRILINEAR POLE OF THE LINE X(1)X(210)",1/{
(b-c)(3a+b+c),
(c-a)(3b+c+a),
(a-b)(3c+a+b)
}},
(* Barycentrics: 1/[(b - c)(ab + ac - 2bc)] *)
{4607,"TRILINEAR POLE OF THE LINE X(1)X(190)",1/{
a(b-c)(a b+a c-2b c),
b(c-a)(b c+b a-2c a),
c(a-b)(c a+c b-2a b)
}
},
(* Barycentrics: 1/[(b - c)(a^3 + b^3 + c^3 + abc + 2b^2 c + 2bc^2)] *)
{8052,"ISOTOMIC CONJUGATE OF X(8045)",1/{
a(b-c)(a3+b3+c3 + a b c + 2b2 c + 2b c2),
b(c-a)(b3+c3+a3 + a b c + 2c2 a + 2c a2),
c(a-b)(c3+a3+b3 + a b c + 2a2 b + 2a b2)}
},
(* Barycentrics: a/(a b^2 + a c^2 - b^2 c - b c^2) *)
{20332,"(name pending)",1/{
a b2+a c2-b2 c-b c2,
b c2+b a2-c2 a-c a2,
c a2+c b2-a2 b-a b2}
},
(* not working *)
{23707,"ISOGONAL CONJUGATE OF X(2635)", 1/{
2 secA-secB-secC,
2 secB-secC-secA,
2 secC-secA-secB}
},
(* Barycentrics: a/[(b - c)(3a + b + c)] *)
(* 1/(sin(A-B)+sin(A-C)) *)
{24624,"(A,B,C,X(2); A',B',C',X(2)) COLLINEATION IMAGE OF X(662), WHERE A'B'C' = GEMINI TRIANGLE 2",1/{
sinA cosB-sinB cosA+sinA cosC-sinC cosA,
sinB cosC-sinC cosB+sinB cosA-sinA cosB,
sinC cosA-sinA cosC+sinC cosB-sinB cosC
}
},
(* Barycentrics: a (a - b) (a + b - 3 c) (a - c) (a - 3 b + c) *)
{27834,"(A,B,C,X(2); A',B',C',X(2)) COLLINEATION IMAGE OF X(190), WHERE A'B'C' = GEMINI TRIANGLE 71",{(a-b) (a+b-3c)(a-c)(a-3 b+c) ,
(b-c) (b+c-3a)(b-a)(b-3 c+a) ,
(c-a) (c+a-3b)(c-b)(c-3 a+b) }
},
(* Barycentrics: b c/((b^2-c^2) ((a^2-b^2-c^2)^2-b^2 c^2)) *)
{32680,"TRILINEAR PRODUCT X(2)*X(476)",{
b c/((b2-c2) ((a2-b2-c2)^2-b2 c2))/a,
c a/((c2-a2) ((b2-c2-a2)^2-c2 a2))/b,
a b/((a2-b2) ((c2-a2-b2)^2-a2 b2))/c}}
};
{#[[1]],#[[2]],trilinearToCartesian[tri,{a,b,c},If[OptionValue@doIsog,1/#[[3]],#[[3]]]]}&/@Select[Rest@ctrs,Length@#[[3]]==3&]];

Test it

Module[{o,n,s,mosesCtrs},
{o,n,s}=orbitNormals[1.5,.1];
mosesCtrs=getMosesCartesians[o,s];
("X("<>ToString@#<>")")&/@First/@mosesCtrs]

Module[{o,n,s,mosesCtrs},
{o,n,s}=orbitNormals[1.5,.1];
mosesCtrs=getMosesCartesians[o,s];
MapIndexed[Prepend[#1,First@#2]&,mosesCtrs]]//Grid[#,Alignment->Left]&

Clear@showMosesPts;
Options@showMosesPts={drPeterMoses1k->True,drPeterMosesAbove1k->False,drPeterMosesAbove4k->False,labelDist->.1};
showMosesPts[a_,mosesCtrs_,OptionsPattern[]]:=Module[{pmCtrs},
{
{If[OptionValue@drPeterMoses1k,
pmCtrs=Select[mosesCtrs,#[[1]]<=1000&];
{Point[Third/@pmCtrs],ellLabelTxt[a,#[[3]],Subscript["X",#[[1]]],OptionValue@labelDist]&/@pmCtrs},{}],
If[OptionValue@drPeterMosesAbove1k,
pmCtrs=Select[mosesCtrs,(#[[1]]>1000&&#[[1]]<=4000)&];
{Red,Point[Third/@pmCtrs],ellLabelTxt[a,#[[3]],Subscript["X",#[[1]]],OptionValue@labelDist]&/@pmCtrs},{}],
If[OptionValue@drPeterMosesAbove4k,
pmCtrs=Select[mosesCtrs,(#[[1]]>4000)&];
{Blue,Point[Third/@pmCtrs],ellLabelTxt[a,#[[3]],Subscript["X",#[[1]]],OptionValue@labelDist,inward->True]&/@pmCtrs},{}]
}
}];

Find where tangents to incenter circumellipse fall

Manipulate[
DynamicModule[{ell,orbit,normals,sides,grMoses,grOrbit,x100,x190,x651,
barCircum,bar,grBarCircum,barX190tang,barX190tangInter,
incCircum,inc,grIncCircum,incX100tang,incX100tangInter,incTangsInters,incTangsIntersFarther,
grTangs,gr100,gr651,gr190},
ell=plotEll[a];
Dynamic[
{orbit,normals,sides}=orbitNormals[a,toRad@tDeg];
grMoses=If[moses1k||moses4k||mosesAbove4k,Module[{mosesPts},
mosesPts=getMosesCartesians[orbit,sides];
Graphics[{PointSize@Medium,showMosesPts[a,mosesPts,
drPeterMoses1k->moses1k,
drPeterMosesAbove1k->moses4k,
drPeterMosesAbove4k->mosesAbove4k]}]],{}];
x100=getX100Trilin[orbit,sides];
x190=getX190Trilin[orbit,sides];
x651=getX651Trilin[orbit,sides];
grOrbit=Graphics[{FaceForm@None,EdgeForm@{Thick,Blue},Polygon@orbit,"mit"/.ptClrs,PointSize@Large,Point@{0,0},Text[Style["(Subscript[X, 9])",16],{0,0},{-1.5,-1.5}]}];
inc=getIncenterTrilin[orbit,sides];
incCircum=getCircumAny[orbit,inc];
incX100tang=circumTangent[incCircum["coeffs"],x100];
incX100tangInter=First@Select[ellInterRay[a,x100,incX100tang],!negl[magn[x100-#]]&];
(* to the vertices *)
incTangsInters=MapThread[ellInterRay[a,#1,#2]&,{orbit,incCircum["orbitTangents"]}];
incTangsIntersFarther=MapThread[Function[{vtx,tangs},First@Select[tangs,!negl[magn[vtx-#]]&]],{orbit,incTangsInters}];

bar=getBaricenter@@orbit;
barCircum=getCircumAny[orbit,bar];
barX190tang=circumTangent[barCircum["coeffs"],x190];
barX190tangInter=First@Select[ellInterRay[a,x190,barX190tang],!negl[magn[x190-#]]&];

grTangs=Graphics@{PointSize@Medium,Red,Dashed,MapThread[Line@{#1,#2}&,{orbit,incTangsIntersFarther}],Point@incTangsIntersFarther};
gr100=Graphics@{Black,PointSize@Large,Point@x100,ellLabelTxt[a,x100,Style[Subscript["X","100"],Medium],.1]};
gr651=Graphics@{Darker@Green,PointSize@Large,Point@x651,ellLabelTxt[a,x651,Style[Subscript["X","651"],Medium],.1]};
gr190=Graphics@{Darker@Pink,PointSize@Large,Point@x190,ellLabelTxt[a,x190,Style[Subscript["X","190"],Medium],.1]};
grIncCircum=If[drX1,Show[{drawCircumAnyLow[incCircum,orbit,ctrLab->"(Subscript[X, 1])",ps->Darker@Green,drOrbitTangents->showVtxInters],Graphics@{Thick,Darker@Green,Dashed,Line@{2x100-incX100tangInter,incX100tangInter},Point@incX100tangInter}}],{}];
grBarCircum=If[drSteiner,Show[{drawCircumAnyLow[barCircum,orbit,ctrLab->"(Subscript[X, 2])",ps->Darker@Pink,drOrbitTangents->showVtxInters],Graphics@{Thick,Darker@Pink,Dashed,Line@{x190-2(barX190tangInter-x190),x190+3(barX190tangInter-x190)},Point@barX190tangInter}}],{}];
Show[{ell,grOrbit,grMoses,grIncCircum,grBarCircum,If[showVtxInters,grTangs,{}](*,gr100,gr651,gr190*)},Frame->True,ImageSize->800,PlotRange->{{-2,2},{-1.2,1.2}}]]],
{{a,1.5},1.01,3,.1},
{{tDeg,30},-360,360,1},
{{drX1,True,"incenter circumell"},{False,True}},
{{drSteiner,False,"steiner circumell"},{False,True}},
{{moses1k,False},{False,True}},
{{moses4k,False},{False,True}},
{{mosesAbove4k,False},{False,True}},
{{showVtxInters,False},{False,True}}
]

(*DeleteFile[mosesApp];
mosesApp=CloudDeploy[%,"moses billiard points v1",Permissions->"Public"]*)

Peter Moses’ Points on L(31) whose isotomics are on E(9)

Peter Moses, July 2 and 3, 2019: The X(9)-centered circumellipse E is the:

isogonal conjugate of the antiorthic axis, [X(44),X(513)], with barycentric equation x + y + z = 0, 
isotomic conjugate L(31) = [X(514),X(661)], with barycentric equation a x + b y + c z = 0.

L(31) is the perspectrix of the anticomplementary triangle and the inner Conway triangle (which is the intouch triangle of the anticomplementary triangle).

Points lying on L(55) include X(i) for i = 514 [at infinity], 661, 693, 857, 908, 914, 1577, 1959, 2084, 2582, 2583, 3239, 3250, 3762, 3766, 3835, 3904, 3912, 3936, 3948, 4129, 4358, 4391, 4462, 4468, 4486, 4728, 4766, 4776, 4789, 4791, 4801, 4823, 4978, 5074, 5179, 6332, 6381, 6590, 8045, 14206, 14207, 14208, 14209, 14210, 14281, 14349, 14350, 14963, 18669, 18715, 24018, 30565, 30566, 30804, 30806, 32679

S6 = S(6) = a6 + b6 + c6;
S24 = a2 b4 + a2 c4 + b2 c4 + b2 a4 + c2 a4 + c2 b4;
J =  Sqrt[S6 - S24 + 3 a2 b2 c2]/(a b c);
X1113 = (1-J) cosA - 2 cosB cosC;
X1114 = (1+J) cosA - 2 cosB cosC;

mosesIsotomics={
{"index","center","description","trilin","isotomic","in pm list"},
{01,514,"ISOGONAL CONJUGATE OF X(101)",(b-c)/a,190,True},
{02,661,"CROSSDIFFERENCE OF X(1) AND X(21)",b2-c2,799,True},
{03,693,"ISOTOMIC CONJUGATE OF X(100)",(b-c)/a2,100,True},
(* sinC^2 sin2B sin(C-A)+sinB^2 sin2C sin(B-A) *)
{04,857,"INTERCEPT OF EULER LINE AND TRILINEAR POLAR OF X(75)",sinC^2 sin2B (sinC cosA-cosC sinA)+sinB^2 sin2C (sinB cosA-cosB sinA),Null,False},
{05,908,"POINT ACUBENS",(cosB+cosC-1)/a,34234,True},
(* u:v:w as in X4 *)
(* u: cosA-sinB sinC, v: cosB-sinC sinA, w: cosC-sinA sinB *)
{06,914,"ISOGONAL CONJUGATE OF X(913)",(((cosC-sinA sinB) b+(cosB-sinC sinA) c)/a-(cosB-sinC sinA)-(cosC-sinA sinB))/a,Null,False},
{07,1577,"ISOGONAL CONJUGATE OF X(163)",b2 c2(b2-c2),662,True},
{08,1959,"CROSSDIFFERENCE OF PU(23)",b4+c4-a2 b2-a2 c2,1821,True},
{09,2084,"PK-TRANSFORM OF X(31)",a2(b4-c4),Null,False},
{10,2582,"X(6)-ISOCONJUGATE OF X(1113)",b c/((1-J) cosA-2 cosB cosC),2580,True},
{11,2583,"X(2)-ISOCONJUGATE OF X(2575)",b c/((1+J)cosA-2 cosB cosC),2581,True},(* a X1114(a,b,c) *)
{12,3239,"ISOGONAL CONJUGATE OF X(1461)",b c(b-c)(b+c-a)^2,658,True},
{13,3250,"INTERSECTION OF X(37)X(513) AND X(187)X(237)",a(b3-c3),Null,False},
{14,3762,"X(1491)com[T(bc, c2)]",b c(b-c)(b+c-2a)/a,3257,True},
{15,3766,"X(3250)com[T(bc, c2)]",b c(b-c)(b c-a2)/a,660,True},
{16,3835,"X(693)com(3rd EULER TRIANGLE)",(b-c)(a b+a c-b c)/a,4598,True},
{17,3904,"X(3716)com[INVERSE(n(4th EULER TRIANGLE))]",(b-c)(b+c-a)(b2+c2-a2-b c)/a,655,True},(* &&& *)
{18,3912,"X(3747)com[INTOUCH TRIANGLE))]",(b2+c2-a b-a c)/a,673,True},
{19,3936,"X(902)com[INVERSE(n(INCENTRAL TRIANGLE))]",(b+c)(b2+c2-a2-b c)/a,24624,True},
(* debug *)
{20,3948,"X(3009)com[INVERSE(n(INCENTRAL TRIANGLE))]",b c(b+c)(b c-a2)/a,Null,False},
{21,4129,"X(667)com[INVERSE(n(INCENTRAL TRIANGLE))]",(b2-c2)(a2+a b+a c-b c)/a,Null,False},
{22,4358,"X(244)com[T(a, c)]",b c(b+c-2a)/a,88,True},
{23,4391,"X(1769)com[INVERSE(nT(a, c))]",b c(b-c)(b+c-a)/a,651,True},
{24,4462,"X(663)com[T(a, c - b)]",b c(b-c)(b+c-3a)/a,27834,True},
{25,4468,"X(650)com[T(a, c - b)]",(b-c)(a2+b2+c2-2a b-2a c)/a,Null,False},
{26,4486,"X(1491)com[T(a, c)]",(b-c)(a2-b c)(b2+c2+b c)/a,Null,False},
{27,4728,"X(659)com[INVERSE(nT(-a, a + b))]",(b-c)(a b+a c-2b c)/a,4607,True},
{28,4766,"X(2243)com[INVERSE(nT(-a, a + b))]",(b4+c4-a3 b-a3 c)/a,Null,False},
{29,4776,"X(649)com[INVERSE(nT(-a, a + b))]",(b-c)(2a b+2a c-b c)/a,Null,False},
{30,4789,"X(661)com[INVERSE(nT(-a, a + b))]",(b-c)(a2+b2+c2+3b c)/a,Null,False},
{31,4791,"X(650)com[INVERSE(nT(-a, b + c))]",b c(b-c)(2b+2c-a)/a,4604,True},
{32,4801,"X(663)com[INVERSE(nT(a, a + b))]",b c(b-c)(3a+b+c)/a,4606,False},
{33,4823,"X(905)com[INVERSE(nT(a, a + c))]",b c(b-c)(a+2b+2c)/a,Null,False},
{34,4978,"X(4391)com[INVERSE(nT(b + c, a))]",b c(b-c)(b+c+2a)/a,Null,False},
{35,5074,"INVERSE-IN-CIRCUMCIRCLE OF X(1631)",(a3 b+a3 c-2a2 b c-b4+b3 c+b c3-c4)/a,Null,False},
(* debug: not working *)
{36,5179,"INVERSE-IN-POLAR-CIRCLE OF X(19)",
(a3 b-a2 b2+a b3-b4+a3 c-a b2 c-a2 c2-a b c2+2b2 c2+a c3-c4)/a
(*(a3 b2+a3 c2
-a2 (b2+c2)
+a(b3+c3)
-a(b2 c+b c2)
-b4-c4
+2b2 c2)/a*),Null,False},
(* falling on 655, weird *)
(* alternate baryc: (1/cosB-1/cosC)/a *)
{37,6332,"ISOTOMIC CONJUGATE OF X(653)",(1/cosB-1/cosC)/a^2(*(a-b-c) (b-c) (a2-b2-c2)/a*),653,False},
{38,6381,"SS(a → bc) OF X(44)",b c(2b c-a b-a c)/a,Null,False},
{39,6590,"X(6590) [name pending]",b c(b-c)(a2+(b+c)^2),Null,False},
{40,8045," FARHANGI-CYCLOCEVIAN IMAGE OF X(75)",(b-c) (a3+b3+a b c+2 b2 c+2 b c2+c3)/a,8052,True}, 
{41,14206,"NGUYEN IMAGE OF X(511)",(cosA-2 cosB cosC)/a,2349,True},
{42,14207,"NGUYEN IMAGE OF X(512)",b c (b2-c2) (-5 a2+b2+c2)/a,Null,False},
{43,14208,"NGUYEN IMAGE OF X(520)",b c (b2-c2) (-a2+b2+c2)/a,162,True},
{44,14209,"NGUYEN IMAGE OF X(525)",(a2-b2-c2) (b2-c2) (a4-b4+4 b2 c2-c4),Null,False},
{45,14210,"NGUYEN IMAGE OF X(9027)",b c (-2 a2+b2+c2)/a,897(*1/(2 a2-b2-c2) *),True},
{46,14281,"TRIAXIAL POINT OF THESE TRIANGLES: ABC, 2nd CONWAY, HUTSON EXTOUCH",(b-c)(a3+(b+c)a2-(5b2+6b c+5c2)a+3(b2-c2)(b-c))(3a3-5(b+c)a2+(b-c)^2a+(b2-c2)(b-c))/a,Null,False},
{47,14349,"TRIAXIAL POINT OF THESE TRIANGLES: ABC, 2nd CIRCUMPERP, 4th CONWAY",(b-c)((b+c)a+b2+b c+c2),Null,False},
{48,14350,"TRIAXIAL POINT OF THESE TRIANGLES: ABC, 4th CONWAY, EXCENTERS-MIDPOINTS",(b-c)(a-3b-3c)*(3a-b-c)/a,Null,False},
{49,14963,"BROCARD(P(169),U(169))-HARMONIC CONJUGATE OF X(386)",a (b+c) (a2 b2-b4-a2 b c+b3 c+a2 c2-b2 c2+b c3-c4),Null,False},
{50,18669,"(A',B',C',X(1); A,B,C,X(2)) COLLINEATION INVERSE-IMAGE OF X(23), WHERE A'B'C' = INCENTRAL TRIANGLE",(b2+c2)a4-2b2 c2 a2-(b4-c4)(b2-c2),Null,False},
{51,18715,"(A',B',C',X(1); A,B,C,X(2)) COLLINEATION INVERSE-IMAGE OF X(23), WHERE A'B'C' = ANTICEVIAN TRIANGLE OF X(75)",(b2+c2)*(a4-b4+b2 c2-c4),Null,False},
{52,24018,"X(6)-ISOCONJUGATE OF X(107)",(b2-c2) (b2+c2-a2)^2,823,True},
{53,30565,"CENTROID OF SIDE-TRIANGLE OF GEMINI TRIANGLES 2 AND 30",(b-c) (a2+b2+c2-2 a b-2 a c+b c)/a,Null,False},
{54,30566,"CENTROID OF CROSS-TRIANGLE OF GEMINI TRIANGLES 2 AND 30",a (b+c)-4  b c-(b+c) (b2-3 b c+c2)/a,Null,False},
{55,30804,"X(30804) [name pending]",b c (b-c) (3a2+b2+c2-2 b c)/a,Null,False},
{56,30806,"X(30806) [name pending]",b c (-2 a2+b2+c2-2 b c+a b+a c)/a,1156,True},
(* a/(2 a^3-a^2 (b+c)-(b-c)^2 (b+c)) *)
(*{56,30807,"X(30807) [name pending]",
(2 a3-a2 (b+c)-(b-c)(b2-c2))/a3,
36101,True},*)
(*{56,30807,"X(30807) [name pending]",
b c (-2 a3+b3+c3+a2 b+a2 c-b2 c-b c2),
36101,True},*)
{57,32679,"ISOGONAL CONJUGATE OF X(32678)", (b2-c2) ((a2-b2-c2)^2-b2 c2),32680,True}
};

Second/@Rest@mosesIsotomics

Length@Rest[Second/@mosesIsotomics]

(* this is helpful to use to see if all subs have been made *)
replCycle0[expr_]:=expr/.{
a->X,b->X,c->X,
a2->X,b2->X,c2->X,
a3->X,b3->X,c3->X,
a4->X,b4->X,c4->X,
a6->X,b6->X,c6->X,
sinA->X,sinB->X,sinC->X,
cosA->X,cosB->X,cosC->X,
sin2A->X,sin2B->X,sin2C->X};

replCycle[expr_]:=expr/.{
a->b,b->c,c->a,
a2->b2,b2->c2,c2->a2,
a3->b3,b3->c3,c3->a3,
a4->b4,b4->c4,c4->a4,
a6->b6,b6->c6,c6->a6,
sinA->sinB,sinB->sinC,sinC->sinA,
cosA->cosB,cosB->cosC,cosC->cosA,
sin2A->sin2B,sin2B->sin2C,sin2C->sin2A};

converts to trilinears (from isotomics) and generate triple: f (a, b, c) : f (b, c, a) : f (c, a, b)

mosesIsotomicsTrils=Module[{trils1,trils2,trils3,trils123},
(* invert and divide by a^2 to apply isotomic conjug -- https://en.wikipedia.org/wiki/Isotomic_conjugate *)
trils1=(1/(#[[4]]a2))&/@Rest@mosesIsotomics;
(*trils1=(#/.{(a a2)->a3})&/@trils1;*)
trils2=replCycle/@trils1;
trils3=replCycle/@trils2;
trils123=Transpose@{trils1,trils2,trils3};
Prepend[MapThread[ReplacePart[#1,4->#2]&,{Rest@mosesIsotomics,trils123}],First@mosesIsotomics]];

Save["mosesIsotTrils.m",mosesIsotomicsTrils]

mosesIsotomicsTrils[[2]]

No Isotomics

mosesOrigsTrils=Module[{trils1,trils2,trils3,trils123},
(* invert and divide by a^2 to apply isotomic conjug -- https://en.wikipedia.org/wiki/Isotomic_conjugate *)
trils1=(#[[4]])&/@Rest@mosesIsotomics;
(*trils1=(#/.{(a a2)->a3})&/@trils1;*)
trils2=replCycle/@trils1;
trils3=replCycle/@trils2;
trils123=Transpose@{trils1,trils2,trils3};
Prepend[MapThread[ReplacePart[#1,4->#2]&,{Rest@mosesIsotomics,trils123}],First@mosesIsotomics]];

Clear@getMosesIsotomics;
getMosesIsotomics[sides_,ctrs_]:=Block[{a,b,c,
sinA,sinB,sinC,sin2A,sin2B,sin2C,(*sinBmA,sinCmA,*)
cosA,cosB,cosC,(*cos2A,cos2B,cos2C,*)
(*cosA2,cosB2,cosC2,*)
(*cosA3,cosB3,cosC3,*)(*cubed*)
secA,secB,secC,
a2,b2,c2,a3,b3,c3,a4,b4,c4,a6,b6,c6,S6,S24,J(*,X1113,X1114*)},
(*{o,n,s}=orbitNormals[theA,t];*)
{a,b,c}=sides;
a2=a*a;b2=b*b;c2=c*c;
a3=a2*a;b3=b2*b;c3=c2*c;
a4=a2*a2;b4=b2*b2;c4=c2*c2;
a6=a4*a2;b6=b4*b2;c6=c4*c2;
{cosA,cosB,cosC}=lawOfCosines3[a,b,c];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
(*sinBmA=sinB cosA-sinA cosB;sinCmA=sinC cosA-sinA cosC;*)
{secA,secB,secC}=1./{cosA,cosB,cosC};
(* sinDoubleAngle[sinAngle_,cosAngle_] *)
{sin2A,sin2B,sin2C}=MapThread[sinDoubleAngle,{{sinA,sinB,sinC},{cosA,cosB,cosC}}];
(*{cos2A,cos2B,cos2C}=cosDoubleAngle/@{cosA,cosB,cosC};*)
(*{cosA2,cosB2,cosC2}=(#^2)&/@{cosA,cosB,cosC};
{cosA3,cosB3,cosC3}=(#^3)&/@{cosA,cosB,cosC};*)

S6=a6+b6+c6;
S24=a2 b4+a2 c4+b2 c4+b2 a4+c2 a4+c2 b4;
J=Sqrt[S6-S24+3 a2 b2 c2]/(a b c);
(*X1113=(1-J)cosA-2 cosB cosC;*)
(*X1114=(1+J)cosA-2 cosB cosC;*)
Part[#,{1,2,4,6,5}]&/@ctrs];

(*mosesIso=Take[getMosesIsotomics[ons[[3]],If[OptionValue@noIsot,mosesOrigsTrils,mosesIsotomicsTrils]],{min,max+1}];
mosesIsoCart=trilinearToCartesian[
ons[[1]],(* vertices *)
ons[[3]],(* side lengths *)
#[[3]] (* trilinears *)]&/@Rest@mosesIso;*)

(* for envelope calculation *)

Clear@getOneMosesIsotomicTrils;
(* ns must be list of integers between 1 and Length@mostesIsotomicsTrils-1 *)
getOneMosesIsotomicTrils[sides_,ns_]:=
getMosesIsotomics[sides,mosesIsotomicsTrils[[ns+1]]]

Part[#,{1,2,5,6}]&/@mosesIsotomicsTrils//TableForm

Clear@getOneMosesIsotomic;
(* ns must be list of integers between 1 and Length@mostesIsotomicsTrils-1 *)
getOneMosesIsotomic[a_,tDeg_,ns_]:=Module[{ons,trils,carts},
ons=orbitNormals[a,toRad@tDeg];
trils=getOneMosesIsotomicTrils[ons[[3]],ns];
carts=trilinearToCartesian[
ons[[1]],(* vertices *)
ons[[3]],(* side lengths *)
#[[3]] (* trilinears *)
]&/@trils;
carts];

Clear@getOneMosesIsotomicTrilin;
(* n must be integer between 1 and Length@mostesIsotomicsTrils-1 *)
getOneMosesIsotomicTrilin[orbit_,sides_,n_]:=Module[{ons,tril,cart},
tril=First@getOneMosesIsotomicTrils[sides,{n}];
cart=trilinearToCartesian[
orbit,(* vertices *)
sides,(* side lengths *)
tril[[3]] (* trilinears *)
];
cart];

getOneMosesIsotomicTrilin[Sequence@@Part[orbitNormals[1.5,toRad@10.],{1,3}],1]

getOneMosesIsotomic[2,30.,Range@57]

Take[getMosesIsotomics[orbitNormals[1.5,.0001][[3]],mosesIsotomicsTrils],10]//Grid

Take[getMosesIsotomics[orbitNormals[1.5,.0001][[3]],mosesOrigsTrils],10]//Grid

Clear@getMosesIsotCartesians;
Options@getMosesIsotCartesians={noIsot->False};
getMosesIsotCartesians[orbit_,sides_,OptionsPattern[]]:=Module[{trils,carts,rest},
trils=getMosesIsotomics[sides,If[OptionValue@noIsot,mosesOrigsTrils,mosesIsotomicsTrils]];
rest=Rest@trils;
carts=trilinearToCartesian[
orbit,(* vertices *)
sides,(* side lengths *)
#[[3]] (* trilinears *)]&/@rest;
Transpose@{Range@carts,Second/@rest,carts,Fifth/@rest}]

Length/@{mosesOrigsTrils,mosesIsotomicsTrils}

Length[(Rest@mosesOrigsTrils)]

The point common to both the (Subscript[L, 1]) and (Subscript[L, 31]) X(661), corresponding to a very special point on E9: X(799)
X(661) = isotomic conjugate of X(799):
X(661) = isogonal conjugate of X(662)

DynamicModule[{a=1.5,ell,ons,ps,exc,aoa,actData,l55,gr,inter,noise={.1,1},is,maxX=10,maxY=10,pl,x661,x799,x662},
ell=plotEll[a,{Thick,Black}];
Manipulate[
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
aoa=getAntiOrthicAxis[ons[[1]],exc];
actData=getAnticomplData[ons[[1]],ons[[3]]];
l55=getIsotomicAxisLow[ons[[1]],ons[[3]],actData];
ps=getMosesIsotCartesians[ons[[1]],ons[[3]],noIsot->True];
is=Second/@(Rest@mosesOrigsTrils);
inter=interRays[aoa[[1]],aoa[[2]]-aoa[[1]],l55[[1]],l55[[2]]-l55[[1]]];
x661=getX661Trilin[ons[[1]],ons[[3]]];
(* isot of x661 *)
x799=getX799Trilin[ons[[1]],ons[[3]]];
(* isog of x662 *)
x662=getX662Trilin[ons[[1]],ons[[3]]];
pl="err[(Subscript[X, 661]),inter]="<>nfn[Chop@magn[inter-x661],2]<> "\n"<>"err[(Subscript[X, 799]),(Subscript[X, 662])]="<>nfn[Chop@magn[x662-x799],2];
gr=Graphics[{PointSize@Medium,Thick,
{Darker@Green,Line@aoa,Lighter@Blue,Line@l55},
{Black,Point[Third/@ps],Red,Point[inter+noise]},
MapThread[Text[ToString[Subscript["X",#1],StandardForm],#2,{-1,-1}]&,{is,Third/@ps}]}];
Show[{ell,gr},PlotLabel->pl,ImageSize->800,PlotRange->{{-maxX,maxX},{-maxY,maxY}}],{{tDeg,5.},-180,180,.1}]]

DynamicModule[{a=2,ons,x799,x662,pl,pr,ell,gr,slack=.5},
Manipulate[
ell=plotEllAxes[a,{Thick,Black}];
Dynamic[
ons=orbitNormals[a,toRad@tDeg];
(* isot of x661 *)
x799=getX799Trilin[ons[[1]],ons[[3]]];
(* isog of x662 *)
x662=getX662Trilin[ons[[1]],ons[[3]]];
pl="a/b="<>nfn[a,2];
gr=Graphics[{PointSize@Medium,Thick,
MapThread[{Point@#2,Text[ToString[Subscript["X",#1],StandardForm],#2,{-1,-1}]}&,{{799,662},{x799,x662}}]}];
pr={{-a-slack,a+slack},{-1-slack,1+slack}};
Show[{ell,gr},PlotLabel->pl,ImageSize->800,PlotRange->pr]],{{tDeg,5.},-180,180,.1}]]

Clear@showMosesIsot;
Options@showMosesIsot={noIsot->False};
showMosesIsot[a_,tDeg_,min_,max_,OptionsPattern[]]:=Module[{ons,mosesIso,mosesIsoCart,gr,ell,origList,errs,errLabs,probs,lab},
ell=plotEll[a,{Black,Thick}];
ons=orbitNormals[a,toRad@tDeg];
mosesIso=Take[getMosesIsotomics[ons[[3]],If[OptionValue@noIsot,mosesOrigsTrils,mosesIsotomicsTrils]],{min,max+1}];
mosesIsoCart=trilinearToCartesian[
ons[[1]],(* vertices *)
ons[[3]],(* side lengths *)
#[[3]] (* trilinears *)]&/@Rest@mosesIso;
errLabs="X("<>ToString@#<>")"&/@(Second/@Rest@mosesIso);
errs=ellError[a,1,#]^2&/@mosesIsoCart;
probs=Select[Transpose@{Range[min,max],errLabs,errs},!negl[#[[3]]]&];
lab="a/b="<>nfn[a,2]<>If[Length@probs>0,", Probs: " <>ToString@probs,""];
gr=Graphics[{FaceForm@None,PointSize@Large,Thick,
{Gray,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{EdgeForm@{Thick,Blue},Polygon@ons[[1]]},
{Darker@Green,,Point@Pick[mosesIsoCart,Fourth/@Rest@mosesIso],Red,Point@Pick[mosesIsoCart,Not/@Fourth/@Rest@mosesIso]},
(* ellLabelTxt[hyp5["ellA"],o,Style[OptionValue@ctrLab,20],OptionValue@lgt] *)
{MapThread[ellLabelTxt[a,#2,Style[Subscript["X",#1],16],.075]&,{Second/@Rest@mosesIso,mosesIsoCart}]}}];
Show[{ell,gr},PlotLabel->Style[lab,{Black,Large}],PlotRange->{{-a,a}1.1,{-1.2,1.2}},ImageSize->800]];

Manipulate[showMosesIsot[1.5,tDeg,1,Length@mosesIsotomics-1,noIsot->noIsot0],{{tDeg,10.},-180,180,.1},{{noIsot0,False},{True,False}}]

(*DeleteFile[mosesApp2];*)
(*osesApp2=CloudDeploy[%,"moses billiard isotomics v1",Permissions->"Public"]*)

There’s a consistency problem:
- the isot[X(6332)] is matching X(655), though X(655) = isot[X(3904)]
- however isot[X(6332)] = X(653)
Also: looks like {{4604,4791},{4606,4801}} are new isotomic pairs!

(*note: the isotomic conjugate of 6332 is matching the cartesians of 655, and but X(6332) is the isot conj of 653, not appearing on the list.... *)

moses15=Module[{ons=orbitNormals[1.5,toRad@30.],mosesOrigRaw,mosesOrigCodes,mosesOrigCart,mosesIsotRaw,mosesIsotCodes,mosesIsotCart,mosesIsotShould},
mosesOrigRaw=getMosesCartesians[ons[[1]],ons[[3]]];
mosesOrigCodes=First/@mosesOrigRaw;
mosesOrigCart=Third/@mosesOrigRaw;
mosesIsotRaw=getMosesIsotCartesians[ons[[1]],ons[[3]]];
mosesIsotCodes=Second/@mosesIsotRaw;
mosesIsotCart=Third/@mosesIsotRaw;
mosesIsotShould=Fourth/@mosesIsotRaw;
Prepend[Select[Flatten[Outer[{#1,mosesOrigCodes[[#1]],#2,mosesIsotCodes[[#2]],magn2[mosesOrigCart[[#1]]-mosesIsotCart[[#2]]],mosesIsotShould[[#2]],If[IntegerQ[mosesIsotShould[[#2]]],mosesIsotShould[[#2]]==mosesOrigCodes[[#1]],Null]}&,
Range@Length@mosesOrigCart,Range@Length@mosesIsotCart],1],Abs@#[[5]]<10^-6&],
{"origLine","origX","isotLine","isotX","error","should","matches"}]];
moses15//Grid[#,Background->{None,{None,If[!BooleanQ@#,Lighter@Cyan,If[#,None,Yellow]]&/@Last/@Rest@moses15}}]&

mosesIsot15=Module[{ons=orbitNormals[1.5,toRad@30.],mosesOrigRaw,mosesOrigCodes,mosesOrigCart,mosesIsotRaw,mosesIsotCodes,mosesIsotCart,mosesIsotShould},
mosesOrigRaw=getMosesCartesians[ons[[1]],ons[[3]]];
mosesOrigCodes=First/@mosesOrigRaw;
mosesOrigCart=Third/@mosesOrigRaw;
mosesIsotRaw=getMosesIsotCartesians[ons[[1]],ons[[3]]];
mosesIsotCodes=Second/@mosesIsotRaw;
mosesIsotCart=Third/@mosesIsotRaw;
mosesIsotShould=Fourth/@mosesIsotRaw;
Prepend[Select[Flatten[Outer[{(*#1,*)mosesIsotCodes[[#1]],(*#2,*)mosesOrigCodes[[#2]],Chop@magn2[mosesOrigCart[[#2]]-mosesIsotCart[[#1]]],mosesIsotShould[[#1]],If[IntegerQ[mosesIsotShould[[#1]]],mosesIsotShould[[#1]]==mosesOrigCodes[[#2]],Null]}&,
Range@Length@mosesIsotCart,Range@Length@mosesOrigCart],1],Abs@#[[3]]<10^-6&],
Style[#,{Bold}]&/@{(*"isotLine",*)"isotX",(*"origLine",*)"origX","error","ETC IsotConj","matches"}]];
Module[{colClr=Lighter@Lighter@Lighter@Pink},Transpose@Prepend[Transpose@mosesIsot15,{Style["case#",Bold],Sequence@@Range[Length@mosesIsot15-1]}]//Grid[#,Frame->All,Background->{{None,None,colClr,None,colClr,None,colClr},{None,If[!BooleanQ@#,Lighter@Cyan,If[#,None,Yellow]]&/@Last/@Rest@mosesIsot15}}]&]

*** Main Viz Common

assign[symbols_,idx_,val_]:=symbols[[{idx}]]/._[x_]:>(x=val);

(* trick is to use Unevaluated *)
Clear@assign1;assign1[symbol_,val_]:={symbol}/._[x_]:>(x=val);

Clear@subscrCtr;subscrCtr[str_]:=Module[{ds},
ds=StringCases[str,DigitCharacter..][[1]];
Subscript["X",ds]]

Clear@drawNewCenters;drawNewCenters[orbit_,sides_,clr_:Red]:=Module[{ctrs},
ctrs=getNewCenters[orbit,sides];
Graphics[{PointSize@Medium,clr,Point[Third/@ctrs],Text[subscrCtr[#[[1]]],#[[3]],{0,-1.5}]&/@ctrs}]];

orthocenterMaxY[a_,tmax_]:=Module[{orbit,normals,sides,orthocenter,theY},
(* FindMaximum[] pukes *)
Table[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
orthocenter=getOrthocenter@@orbit;
theY=orthocenter[[2]];
theY,{t,0,tmax,π/360}]
]//Max;

anticomplMax[a_,tmax_]:=Module[{orbit,normals,sides,act,acts},
(* FindMaximum[] pukes *)
acts=Table[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
act=anticomplementaryTriangle[orbit,triLengthsRL@orbit];
act[[1]],
{t,0,tmax,π/360}];
{Max[Abs/@First/@acts],Max[Abs/@Second/@acts]}];

Clear@excenterMax;
excenterMax[a_]:=Module[{orbit,normals,sides,excenter,theX,coords},
(* FindMaximum[] pukes *)
coords=Table[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
getExcenters[orbit,normals][[1]],
{t,0,2π,2π/360}];
{Max[First/@coords],Max[Take[#,2]&/@coords]}
];

Clear@drawX88complex;
drawX88complex[a_,orbit_,normals_,notables_,lgt_]:=Module[{x88,n88},
x88="x88"/.notables;
n88=norm@ellGrad[a,Sequence@@x88];
(*ray[#2,-#3,lgt*.33]]&,*)
{PointSize@Large,
{(*drawOneNotable["x88"/.ptClrs,x88,"(Subscript[X, 88])",0,-1.5,16],*)
drawOneNotable["sym"/.ptClrs,"sym"/.notables,"(Subscript[X, 6])",0,-1.5,16],
("x88"/.ptClrs),Point@x88,Text[Style["(Subscript[X, 88])",16],ray[x88,-n88,lgt*.5]]},
Module[{inc,incInv,q,nq,incInvIsogConj},
inc="inc"/.notables;
{incInv,q}=ellInversion[a,inc];
nq=norm@ellGrad[a,Sequence@@q];
incInvIsogConj=isogonalConjugate[incInv,orbit,normals];
{{drawOneNotable["inc"/.ptClrs,inc,"(Subscript[X, 1])",0,-1.5,16],
drawOneNotable["inc"/.ptClrs,incInv,"(Subscript[X, 44])",0,-1.5,16],
(* "T" is point formerly known as tabachnikov's point ? *)
{Red,Point@q,Dashed,Line[{{0,0},incInv}],Text[Style["T",16],ray[q,-nq,.5lgt]]}}
(*,{Magenta,Point@incInvIsogConj}*)
}]}];

Module[{a=1.5,tDeg=30.,o,n,s,notables,lgt=.33},
{o,n,s}=orbitNormals[a,toRad@tDeg];
notables=getNotables[o,n];
drawX88complex[a,o,n,notables,lgt]
]//Graphics

adjExcName[name_]:=StringDrop[name,1]//ToLowerCase;

*** Main Viz Code

opts4drawSimT={
(* reference orbit *)
"orbit",
"ommitbilliard",
"loci",
"normals",
"caustic",

(*pts basic*)
"incenter" (*X1*),
"baricenter"(*X2*),
"circumcenter"(*X3*),
"orthocenter"(*X4*),
"ninepointcenter"(*X5*),
"symmedianpoint",
"gergonne"(*X7*),
"nagel"(*X8*),
"mittenpunkt"(*X9*),
(*"spieker" --X10--,*)
"feuerbach"(*X11*),

(*pts advanced*)
"bevanpt"(*X40*),
"x88",
"x100"(*anticompl of feuerbach x11*),
"x101",
"x142",
"darbouxpt"(*X144=anticompl of X7*),
"x168",
"x190",(*steiner meets billiard*)

(*pt groups*)
"basicnotables",
"notables",
"exnotables",
"mosesptsto1k",
"mosesptsto4k",
"mosesptsabove4k",
"trilinpts",(*all form X1~X100*)
"exctrilinpts",
"acttrilinpts",

(*lines*)
"notablelines",
"eulerline",
"exnotablelines",
"feuerbachline",
"mittenfeet",
"darbouxlines",
"incenterlines",
"mittengergonneline",
"darbouxgergonneline",
"mittenx142line",
"x88antifeuerline",
"interfeuerline",
"nagelincenterline",(* not used  *)
"tangentstoinccircumell",

(*circles*)
"incircle",
"circumcircle",
"ninepointcircle",
"excircles",
"cosinecircle",

(*triads*)
"medians",
"intouchpts",
"extouchpts",
"exfeuerbach",

(*triangles*)
"orthictriangle",
"intouchtri",
"extouchtri",
"outernapoleon",
"hexyltriangle",
"morleytriangle",

(*excentral*)
"exbaricenter",
(*"excentralcircumb",*)
"exbisectors",(* not used *)
"exnpc", (* not used *)

(*anticompl tri*)
"anticompl",
"anticomplcircumb",
"anticomplnpc",
"anticomplincirc",
"anticomplcontact",

(*medial tri*)
"medial",
"medialcircumb",
"medialnpc",
"medialincirc",
"medialcontact",

(*excentral tri*)
"excentral",
"excentralcircumb",
"excentralnpc",
"excentralincirc",
"excentralcontact",

(*orthic tri*)
"orthic",
"orthiccircumb",
"orthicnpc",
"orthicincirc",
"orthiccontact",

(*axes*)
"antiorthicaxis",
"isotomicaxis",

(*circumconics*)
"steinercircumell",
"steinerinell",
"inccircumell",
"hypx100"(*jerabek hyp of excentral*),
"hypfeuerbach",

(*quadrangles*)
"quadcirx100",
"quadactpsx100",

(*misc*)
"experimental",
"x88complex", (* not used *)
"extouchptlabels", (* not used *)
"refequi",
"coscirequi"
};

opts4Exps=<|
"manual"->{},
"all"->opts4drawSimT,
"none"->{},
"basic loci"->{"loci","incenter","baricenter","circumcenter","orthocenter","ninepointcenter","eulerline"},
"mitten"->{"medians","excentral","mittenpunkt","mittenfeet","excircles"},
"caustic"->{"medians","excentral","excircles","extouchpts","intouchpts","incircle","ninepointcircle","feuerbach","feuerbachline","exfeuerbach"},
"exfeuer"->{"ninepointcircle","excentral","excircles","extouchpts","exfeuerbach","feuerbach","incircle"},
"touchpts"->{"medians","incircle","intouchpts","excentral","excircles","extouchpts"},
"antifeuer"->{"ninepointcircle","incircle","feuerbach","baricenter","x100"},
"feuerall"->{"medians","incircle","caustic" ,"excentral","excircles","extouchpts","ninepointcircle","feuerbach","baricenter","x100","exfeuerbach","interfeuerline","exfeuerbach","extouchptlabels"},
"nonell"->{"medians","intouchpts" ,"medians","exfeuerbach","incircle","ninepointcircle","excircles"},
"orthicinc"->{"orthictriangle"},
"anticompl"->{"caustic","baricenter","feuerbach","x100","incircle","ninepointcircle","excircles","extouchpts","anticompl","mittenpunkt"},
"anticomplGergonne"->{"caustic","baricenter","mittenpunkt","anticompl","anticomplcircumb","anticomplincirc","darbouxgergonneline","darbouxpt","darbouxlines","feuerbach","x100","extouchpts"},
"darboux"->{"caustic","baricenter","anticompl","extouchpts","extouchtri","anticomplincirc","darbouxpt","darbouxlines","feuerbach","x100"},
"medial"->{"caustic","baricenter","mittenpunkt","feuerbach","x100","incircle","intouchpts","darbouxgergonneline","darbouxpt","anticompl","anticomplcircumb","anticomplincirc","medial","medialcircumb"},
"medialSimple"->{"caustic","baricenter","mittenpunkt","feuerbach","x100","incircle","intouchpts","mittenx142line","medial","medialcircumb"},
"anticomplSimple"->{"caustic","baricenter","mittenpunkt","feuerbach","x100","anticompl","anticomplincirc","anticomplcircumb","mittengergonneline"},
"x88"->{"incircle","mittenpunkt","x88","anticomplcontact","x100","x88antifeuerline","excentral","antiorthicaxis"},
"inccircum"->{"circumcircle","steinercircumell","inccircumell","x100","x190","mittenpunkt"},
"cyclicquads"->{"circumcircle","quadcirx100","quadactpsx100","anticomplincirc","x100"},
"hypx100"->{"baricenter","darbouxpt","x142","hypx100","gergonne","darbouxgergonneline","x88","x88antifeuerline","bevanpt"},
"hypfeux100"->{"gergonne","nagel","bevanpt","hypfeuerbach","hypx100","darbouxgergonneline","darbouxpt"},
"exccircumb"->{"excentralcircumb","excentral","hypx100","bevanpt"},
"antiorthic"->{"mittenpunkt","incenter","darbouxpt",(*"darbouxlines","incenterlines",*)"excentral","anticompl","antiorthicaxis","isotomicaxis","anticomplcontact"},
"inccircumell"->{"circumcircle","inccircumell","x100"},
"steinercircumell"->{"steinercircumell","steinerinell","x190"}
|>;

Clear@drTriDataOpts;
Options@drTriDataOpts=Join[{sameClr->False,"anticompl"->False,"medial"->False,"excentral"->False,"orthic"->False,incSymbol->OverBar["I"],mitSymbol->OverBar["9"]},(#->False)&/@opts4drawSimT];
drTriDataOpts[a_,triData_,triStr_,clr_,opts:OptionsPattern[]]:=Module[{tri,npc,inc,tps,npcClr,incClr,lgt=.33},
tri=triData["tri"];
npc=triData["npc"];
inc=triData["inc"];
tps=triData["tps"];
npcClr=If[OptionValue@sameClr,clr,"npc"/.ptClrs];
incClr=If[OptionValue@sameClr,clr,"inc"/.ptClrs];
{FaceForm@None,PointSize@Large,
If[OptionValue@triStr,
{clr,
EdgeForm@{Thick,clr},Polygon@tri,Point@tri},{}],
If[OptionValue[triStr<>"npc"],
{npcClr,
{Point@npc,drawOneNotable[npcClr,npc,OptionValue@mitSymbol,0,-1.5,16]},
{Thick,Circle[npc,triData["npcR"]]}}
,{}],
If[OptionValue[triStr<> "incirc"],
{incClr,
{Point@inc,drawOneNotable[incClr,inc,OptionValue@incSymbol,0,-1.5,16],Point@tps},
{Dashed,Line[{inc,#}]&/@tps},
{Thick,Circle[inc,triData["incR"]]}},{}],
If[OptionValue[triStr<>"contact"],Module[{ns},
ns=norm/@(ellGrad[a,Sequence@@#]&/@tps);
{incClr,EdgeForm@{incClr,Dashed},Point@tps,Polygon@tps,
MapThread[Text[Style[#1,16],#2-.5*lgt*#3]&,{{"(Subscript[C, 1])","(Subscript[C, 2])","(Subscript[C, 3])"},tps,ns}]}],{}]}];

Clear@drawSimTopts;
(* precompute loci *)
Options@drawSimTopts=Join[{ImageSize->800,labExtra->""},(#->False)&/@opts4drawSimT];
drawSimTopts[a_,t_,ellPlot_,causticPlot_,loci_,opt:OptionsPattern[]]:=Module[{incPlot,ellP,orbitData,orbit,normals,notables,exc,npc,
excNormals,excNotables,excCircleData,excOrtFeet,medians,excTps,orthic,
sides,pl,actData,medData,excData,orthicData,
x40,x88,x101,x144 (*darboux*),x168,x190,
x142,mosesPts,hasMoses,
toShowNeedsGr,toShowGr,lgt=.33},
ellP=N@{a Cos@t,Sin@t};
orbitData=getOrbitData[a,ellP[[1]],posY->(ellP[[2]]>0)];
{orbit,normals,sides}={"orbit","normals","sides"}/.orbitData;
notables=getNotables[orbit,normals];
exc="exc"/.notables;
medians="medians"/.notables;
npc="npc" /.notables;
excNormals=getTriBisectors@@exc;
excNotables=getNotables[exc,excNormals];
excOrtFeet=getAltBases@@exc;
excCircleData=getExcircleData[orbit,exc(*12,23,31*),npc];
excTps="tps"/.excCircleData;
orthic=getOrthicData@orbit;
actData=getAnticomplData[orbit,sides];
medData=getMedialData[orbit,sides];
excData=getSubtriData@exc;
orthicData=getSubtriData[getAltBases@@orbit];
(* bar + (bar-mitten)/2 = (3 bar - mitten)/2 *)
x142=(3("bar"/.notables)-("mitten"/.excCircleData))/2;
x144=getX144Trilin[orbit,sides];
x40=getBevanTrilin[orbit,sides];
x88=getX88Trilin[orbit,sides];
x168=getX168Trilin[orbit,sides];
x190=getX190Trilin[orbit,sides];
x101=getX101Trilin[orbit,sides];
hasMoses=Or[OptionValue@"mosesptsto1k",OptionValue@"mosesptsto4k",OptionValue@"mosesptsabove4k"];
mosesPts=If[hasMoses,getMosesCartesians[orbit,sides],{}];
pl=OptionValue@labExtra<>"a="<>nf@a<>"; t="<>nf0@toDeg[t]<>"°";
toShowGr={
If[OptionValue@"ommitbilliard",Graphics@{},ellPlot],
If[OptionValue@"orbit",drawOrbit[orbitData,"lgt"->(1.5*lgt),drNormals->OptionValue@"normals"],{}],
(*Graphics@If[OptionValue@"orbittri",{Thick,EdgeForm@Black,FaceForm@{Black,Opacity@.1},Polygon@orbit},{}],*)
If[OptionValue@"caustic",causticPlot,{}],
If[OptionValue@"loci",loci,{}],
If[OptionValue@"notablelines",drawNotableLines@notables,{}],
If[OptionValue@"basicnotables",drawBasicNotables@notables,{}],
If[OptionValue@"notables",drawNotables@notables,{}],
If[OptionValue@"exnotablelines",drawNotableLines@excNotables,{}],If[OptionValue@"exnotables",drawNotables[excNotables,"x"],{}],If[OptionValue@"anticomplcircumb",drawCircumMit[actData["tri"],ctrLab->Subscript["X", 7],ps->("anticompl"/.ptClrs)],{}],If[OptionValue@"medialcircumb",drawCircumMit[medData["tri"],ctrLab->Subscript["X", 142],ps->("med"/.ptClrs)],{}],If[OptionValue@"excentralcircumb",drawCircumMit[exc,ctrLab->Subscript["X", 168],ps->("exc"/.ptClrs)],{}],
If[OptionValue@"orthiccircumb",drawCircumMit[orthicData["tri"],ctrLab->Subscript["X", "?"],ps->("ort"/.ptClrs)],{}],

If[OptionValue@"steinercircumell",drawCircumBar[orbit,ctrLab->Subscript["X", 2],ps->{"steiner"/.ptClrs,Thick}],{}],
If[OptionValue@"steinerinell",drawSteinerInellipse[orbit,ctrLab->Subscript["X", 2],ps->{"steinerinell"/.ptClrs,Thick}],{}],If[OptionValue@"inccircumell",drawCircumInc[orbit,ctrLab->Subscript["X", 1],ps->{Darker@("inc"/.ptClrs),Thick}],{}],
(* LINE BELOW FOR DEBUGGING *)
(* showHyp5vizapp[1.5,10.,getHypX100,useSinCos->False,ps->{Thick,Brown},psAxes->{Dashed,Brown,Thick},lgt->.2,ctrLab->"(Subscript[X, 100])",showFoci->True,showExc->True] *)
If[OptionValue@"hypx100",showHyp5vizapp[a,toDeg@t,getHypX100,(Symbol@"lgt")->.1,ps->{Darker@("inc"/.ptClrs)}],{}],If[OptionValue@"hypfeuerbach",showHyp5vizapp[a,toDeg@t,getHypFeuerbach,(Symbol@"lgt")->.1,ps->{("feu"/.ptClrs)}],{}],If[OptionValue@"trilinpts",drawNewCenters[orbit,sides],{}],
If[OptionValue@"exctrilinpts",drawNewCenters[exc,excData["sides"],Darker@("inc"/.ptClrs)],{}],
If[OptionValue@"acttrilinpts",drawNewCenters[actData["tri"],actData["sides"],"anticompl"/.ptClrs],{}]};
toShowNeedsGr={
(*circles*)
If[OptionValue@"incircle",{"inc"/.ptClrs,PointSize@Large,Point["inc"/.notables],{Thick,Circle["inc"/.notables,"incRadius"/.notables]},drawOneNotable["inc"/.ptClrs,"inc"/.notables,"(Subscript[X, 1])",-1.5,-1.5,16]},{}],If[OptionValue@"circumcircle",{"cir"/.ptClrs,PointSize@Large,Point["cir"/.notables],{Thick,Circle["cir"/.notables,"cirRadius"/.notables]},drawOneNotable["cir"/.ptClrs,"cir"/.notables,"(Subscript[X, 3])",-1.5,-1.5,16]},{}],If[OptionValue@"excircles",{"exc"/.ptClrs,{PointSize@Large,Point@exc},{Thick,MapThread[Circle[#1,#2]&,{exc,"radii"/.excCircleData}]}},{}],
If[OptionValue@"ninepointcircle",{"npc"/.ptClrs,PointSize@Large,Point["npc"/.notables],{Thick,Circle["npc"/.notables,"npcRadius"/.notables]},drawOneNotable["npc"/.ptClrs,"npc"/.notables,"(Subscript[X, 5])",-1.5,-1.5,16]},{}],
If[OptionValue@"cosinecircle",{Red,Thick,Circle["mit"/.notables,cosineCircleRadiusRonaldo[a,1]]},{}],
(* lines *)
If[OptionValue@"eulerline",{Dashed,Darker@Gray,Line[{"ort","cir"}/.notables]},{}],
If[OptionValue@"interfeuerline",{Dashed,Gray,Line[{"antifeu","feu"}/.notables]},{}],If[OptionValue@"feuerbachline",{Black,Dashed,Line[{"feu"/.notables,"npc"/.notables}]},{}],
If[OptionValue@"darbouxgergonneline",{"bar"/.ptClrs,Thick,Line[{"ger"/.notables,x144}]},{}],If[OptionValue@"mittengergonneline",{"bar"/.ptClrs,Thick,Line[{"ger"/.notables,"mit"/.notables}]},{}],If[OptionValue@"mittenx142line",{"bar"/.ptClrs,Thick,Line[{"mit"/.notables,x142}]},{}],If[OptionValue@"x88antifeuerline",{Dashed,Darker@Cyan,Line[{"antifeu","x88"}/.notables]},{}],
If[OptionValue@"nagelincenterline",{"nag"/.ptClrs,Line[{"nagel"/.excCircleData,"inc"/.notables}]},{}],If[OptionValue@"darbouxlines",{Dashed,PointSize@Large,Red,
MapThread[Line[{#1,#2}]&,{actData["tri"],actData["tps"]}]},{}],
If[OptionValue@"incenterlines",{Dashed,PointSize@Large,"inc"/.ptClrs,
MapThread[Line[{#1,#2}]&,{orbit,RotateLeft@exc}]},{}],
If[OptionValue@"antiorthicaxis",drawAntiOrthicAxis[orbit,RotateLeft@exc,"drConstr"->True],{}],If[OptionValue@"isotomicaxis",drawIsotomicAxis[orbit,sides,actData,"drConstr"->True],{}],If[OptionValue@"exbisectors",{("exc"/.ptClrs),FaceForm[None],Arrowheads[Medium],MapThread[Arrow[{#1,ray[#1,#2,.5]}]&,{exc,excNormals}]},{}],If[OptionValue@"exfeuerbach",{PointSize@Large,("feu"/.ptClrs),Point["feus"/.excCircleData]},{}],If[OptionValue@"exbaricenter",{PointSize@Large,drawOneNotable["bar"/.ptClrs,"bar"/.excNotables,"xB"]},{}],If[OptionValue@"exnpc",{("npc"/.ptClrs),Thick,Circle[npc,"npcRadius"/.excNotables]},{}],

(*triangles*)
drTriDataOpts[a,actData,"anticompl","anticompl"/.ptClrs,FilterRules[{opt,sameClr->True,incSymbol->"(Subscript[X, 8])",mitSymbol->"(Subscript[X, 7])"},Options@drTriDataOpts]],drTriDataOpts[a,medData,"medial","med"/.ptClrs,FilterRules[{opt,sameClr->True},Options@drTriDataOpts]],
drTriDataOpts[a,excData,"excentral","exc"/.ptClrs,FilterRules[{opt,sameClr->True},Options@drTriDataOpts]],
drTriDataOpts[a,orthicData,"orthic","ort"/.ptClrs,FilterRules[{opt,sameClr->True},Options@drTriDataOpts]],

If[OptionValue@"intouchtri",{FaceForm@None,EdgeForm@{Thick,"inc"/.ptClrs},Polygon["tps"/.notables],PointSize@Large,"inc"/.ptClrs,Point["tps"/.notables]},{}],
If[OptionValue@"extouchtri",{FaceForm@None,EdgeForm@{Thick,"exc"/.ptClrs},Polygon@excTps},{}],If[OptionValue@"excentral",{FaceForm[None],EdgeForm[{Thick,("exc"/.ptClrs)}],Polygon@exc,("exc"/.ptClrs),PointSize@Large,Point@exc},{}],If[OptionValue@"hexyltriangle",Module[{hex},hex=hexylTriangle[orbit,sides];
{FaceForm@None,EdgeForm["hex"/.ptClrs],Polygon@hex,PointSize@Medium,"hex"/.ptClrs,Point@hex}],{}],If[OptionValue@"outernapoleon",Module[{nap},nap=outerNapoleonTriangle[orbit,sides];
{FaceForm@None,EdgeForm["nap"/.ptClrs],Polygon@nap,PointSize@Medium,"nap"/.ptClrs,Point@nap}],{}],If[OptionValue@"morleytriangle",Module[{morley,c1},morley=firstMorleyTriangle[orbit,sides];
c1=getFirstMorleyTrilin[orbit,sides];
{FaceForm@None,EdgeForm["nap"/.ptClrs],Polygon@morley,PointSize@Medium,"nap"/.ptClrs,Point@morley,Black,Point@c1}],{}],If[OptionValue@"orthictriangle",{{EdgeForm@Black,FaceForm[{"ort"/.ptClrs,Opacity@.3}],Polygon["feet"/.orthic]},{EdgeForm["inc"/.ptClrs],FaceForm[{Lighter@Green,Opacity@.3}],Polygon["intouch"/.orthic],Gray,Circle["inc"/.orthic,"inradius"/.orthic]},{FaceForm@None,EdgeForm@Red,Polygon["intouchOrt"/.orthic],Red,Point["intouchOrtInc"/.orthic]},{PointSize@Medium,"ort"/.ptClrs,Point["feet"/.orthic],PointSize@Large,Point["ort"/.notables](*,drawOneNotable["ort"/.ptClrs,"ort"/.notables,"O"]*)},(*{Dashed,Gray,MapThread[Line[{#1,#2}]&,{orbit,ortFeet}]},*){Dashed,Gray,Line[{#,"ort"/.notables}]&/@orbit},{PointSize@Large,"inc"/.ptClrs,Point["inc"/.orthic]}},{}],

If[OptionValue@"experimental",
Module[{cir="cir"/.notables,rad,equi,xfeus,xfeusCir,xtpsCir,cirClr,medsCir},cirClr="cir"/.ptClrs;
rad="cirRadius"/.notables;
xfeus=("feus"/.excCircleData);
equi=(cir+#)&/@(rad getEquilateral[0.]);
xfeusCir=getCircumcenter@@xfeus;
xtpsCir=getCircumcenter@@excTps;
medsCir=getCircumcenter@@medians;
{FaceForm@None,PointSize@Large,{cirClr,EdgeForm@cirClr,Polygon@equi,Polygon[flipX/@equi]},{"exc"/.ptClrs,Point@xtpsCir,Dashed,Thick,Circle[xtpsCir,magn[excTps[[1]]-xtpsCir]]}}],{}],
If[OptionValue@"refequi",Module[{v1,vs,a2=a^2,v2,vs2},
v1={2 Sqrt[3.] a2,1-3 a2}/(1+3 a2);
vs={{0,1},flipX@v1,v1};
v2=a{-1+3/ a2,-2 Sqrt[3.]/ a2}/(1+3 /a2);
vs2={{-a,0},flipY@v2,v2};
(*Print["v1:",triLengths@vs];
Print["v2:",triLengths@vs2];*)
{FaceForm@None,PointSize@Large,Purple,Point@vs,EdgeForm@Purple,Polygon@vs,EdgeForm@{Dashed,Purple},Polygon@vs2,Point@vs2}],{}
],

(*quadrangles*)
If[OptionValue@"quadcirx100",Module[{vtx,malts},vtx=orderVertices[Prepend[orbit,"antifeu"/.notables],"mit"/.notables];
malts=getMaltitudes[vtx];
{FaceForm@{"cir"/.ptClrs,Opacity@.1},EdgeForm@{Thick,"cir"/.ptClrs},Polygon@vtx,{Dashed,"cir"/.ptClrs,Line/@malts["lines"]}}],{}],If[OptionValue@"quadactpsx100",Module[{vtx,malts},vtx=orderVertices[Prepend[actData["tps"],"antifeu"/.notables],actData["inc"]];
malts=getMaltitudes[vtx];
{FaceForm@{"anticompl"/.ptClrs,Opacity@.1},EdgeForm@{Thick,"anticompl"/.ptClrs},Polygon@vtx,{Dashed,"anticompl"/.ptClrs,Line/@malts["lines"]}}],{}],

(*points*)
If[OptionValue@"incenter",{PointSize@Large,drawOneNotable["inc"/.ptClrs,"inc"/.notables,Subscript["X","1"],-1.5,-1.5,16]},{}],If[OptionValue@"baricenter",{PointSize@Large,drawOneNotable["bar"/.ptClrs,"bar"/.notables,Subscript["X","2"],-1.5,-1.5,16]},{}],If[OptionValue@"circumcenter",{PointSize@Large,drawOneNotable["cir"/.ptClrs,"cir"/.notables,Subscript["X","3"],-1.5,-1.5,16]},{}],If[OptionValue@"orthocenter",{PointSize@Large,drawOneNotable["ort"/.ptClrs,"ort"/.notables,Subscript["X","4"],-1.5,-1.5,16]},{}],
If[OptionValue@"ninepointcenter",{PointSize@Large,drawOneNotable["npc"/.ptClrs,"npc"/.notables,Subscript["X","5"],-1.5,-1.5,16]},{}],
If[OptionValue@"symmedianpoint",{PointSize@Large,drawOneNotable["sym"/.ptClrs,"sym"/.notables,Subscript["X", "6"],-1.5,-1.5,16]},{}],
If[OptionValue@"gergonne",{PointSize@Large,drawOneNotable["ger"/.ptClrs,"ger"/.notables,Subscript["X", "7"],-1.5,-1.5,16]},{}],
If[OptionValue@"nagel",{PointSize@Large,drawOneNotable["nag"/.ptClrs,"nag"/.notables,Subscript["X","8"],-1.5,-1.5,16]},{}],
If[OptionValue@"feuerbach",{PointSize@Large,drawOneNotable["feu"/.ptClrs,"feu"/.notables,Subscript["X","11"],-1.5,-1.5,16]},{}],If[OptionValue@"mittenpunkt",{("mit"/.ptClrs),PointSize@Large,Point["mitten"/.excCircleData],drawOneNotable["mit"/.ptClrs,"mitten"/.excCircleData,Subscript["X","9"],-1.5,-1.5,16]},{}],If[OptionValue@"intouchpts",{PointSize@Large,"inc"/.ptClrs,Point["tps"/.notables]},{}],If[OptionValue@"medians",{"med"/.ptClrs,PointSize@Large,Point@medians},{}],If[OptionValue@"bevanpt",{PointSize@Large,drawOneNotable["bev"/.ptClrs,x40,Subscript["X","40"],0,-1.5,16]},{}],If[OptionValue@"x142",{PointSize@Large,drawOneNotable["dar"/.ptClrs,x142,Subscript["X","142"],0,-1.5,16]},{}],If[OptionValue@"x168",{PointSize@Large,drawOneNotable["x88"/.ptClrs,x168,Subscript["X","168"],0,-1.5,16]},{}],If[OptionValue@"x88",{PointSize@Large,"x88"/.ptClrs,Point@x88,ellLabelTxt[a,x88,Style[Subscript["X","88"],16],.1]},{}],
If[OptionValue@"x190",{PointSize@Large,Black,"steiner"/.ptClrs,Point@x190,ellLabelTxt[a,x190,Style[Subscript["X","190"],16],.1]},{}],
If[OptionValue@"x101",{PointSize@Large,Black,Point@x101,ellLabelTxt[a,x101,Style[Subscript["X","101"],16],.1]},{}],
If[OptionValue@"x100",Module[{antifeu},antifeu="antifeu"/.notables;
{PointSize@Large,"cir"/.ptClrs,Point@antifeu,ellLabelTxt[a,antifeu,Style[Subscript["X","100"],16],.1]}],{}],

(*not on interface *)
If[OptionValue@"x88complex",drawX88complex[a,orbit,normals,notables,lgt],{}],
If[OptionValue@"extouchptlabels",MapThread[drawOneNotable[("exc"/.ptClrs),#1,#2]&,{excTps,Subscript["t",#]&/@{"12","23","31"}}],{}],

If[OptionValue@"extouchpts"&&OptionValue@"excircles",{("exc"/.ptClrs),Dashed,Thick,MapThread[Line@{#1,#2}&,{exc,excTps}]},{}],
If[OptionValue@"mittenfeet",{("mit"/.ptClrs),Thickness@Medium,Dashed,MapThread[Line[{#1,#2}]&,{exc,"mittenFeet"/.excCircleData}]},{}],
If[OptionValue@"extouchpts",{("exc"/.ptClrs),PointSize@Large,Point@excTps},{}],If[OptionValue@"darbouxpt",{Dashed,PointSize@Large,"dar"/.ptClrs,drawOneNotable[Red,x144,"(Subscript[X, 144])",0,-1.5,16]},{}],
If[hasMoses,{PointSize@Large,
showMosesPts[a,mosesPts,labelDist->.1,
drPeterMoses1k->OptionValue@"mosesptsto1k",
drPeterMosesAbove1k->OptionValue@"mosesptsto4k",
drPeterMosesAbove4k->OptionValue@"mosesptsabove4k"]},{}]
};
Show[{toShowGr,Graphics/@Select[toShowNeedsGr,Length@#>0&]},
AspectRatio->Automatic,Frame->True,Axes->True,
AxesStyle->Directive[RGBColor[.66,.66,.66]],
PlotLabel->Style[pl,{Black,20}],FilterRules[{opt},Options@Plot]]];

Clear@movieFrameOpts;
Options@movieFrameOpts=Options@drawSimTopts;
movieFrameOpts[a_,t_,ellPlot_,causticPlot_,loci_,excenterLims_,clip_,opts:OptionsPattern[]]:=Module[{prX,prY,maxX,maxY,maxYort,actMax},
maxX=Round[excenterLims[[1]]+.1,.1];
maxYort=Round[orthocenterMaxY[a,π/1.2]+.1,.1];
maxY=Round[excenterLims[[2]]+.1,.1];
(*Print[FilterRules[{opts},Options@Show]];*)
actMax=anticomplMax[a,π];
prX=Switch[clip,
"ellHalf",{-.5,.5},
"ort",1.25{-maxX,maxX},
"anticompl",{-actMax[[1]],actMax[[1]]},
"anticompl2",{-actMax[[1]],actMax[[1]]},
"antiorthic",3{-actMax[[2]],actMax[[2]]},
"antiorthic2",2{-actMax[[2]],actMax[[2]]},
"antiorthic3",3{-actMax[[2]],actMax[[2]]},
"antiorthic4",4{-actMax[[2]],actMax[[2]]},
"antiorthic8",4{-actMax[[2]],actMax[[2]]},
_,{-maxX,maxX}];
prY=Switch[clip,
"ellHalf",{-.5,.5},
"ell",{-1.1,1.1},
"ort",{-maxYort,maxYort},
"ortHalf",.5{-(1.1+maxYort),(1.1+maxYort)},
"excHalf",{-maxY,maxY}*.5,
"anticompl",{-actMax[[2]],actMax[[2]]},
"anticompl2",1.5{-actMax[[2]],actMax[[2]]},
"antiorthic",1.5{-actMax[[2]],actMax[[2]]},
"antiorthic2",2{-actMax[[2]],actMax[[2]]},
"antiorthic3",3{-actMax[[2]],actMax[[2]]},
"antiorthic4",4{-actMax[[2]],actMax[[2]]},
"antiorthic8",4{-actMax[[2]],actMax[[2]]},
_,{-maxY,maxY}];
Show[drawSimTopts[a,t,ellPlot,causticPlot,loci,opts],
PlotRange->{prX,prY},
FilterRules[{opts},Options@Plot]]];

Clear@makeMainVizCache;
makeMainVizCache[a_]:=<|
"ellPlot"->(plotEll[a,{Thick,Black}]),
"causticPlot"->(plotEllb[Sequence@@getTriCausticParams[a],{Thick,Brown}]),
"loci"->(precompLoci[a]),
"lociBasic"->(precompLociBasic[a]),
"lociNonEll"->(precompLociNonEll[a]),
"excenterLims"->(excenterMax[a])
|>;

mainVizCache=makeMainVizCache[1.5];

*** Main Viz Manipulate App

DynamicModule[{a=1.5,optsList,optsListEval,lastExp="manual"},
Manipulate[
optsList=
{(*reference orbit*){"orbit",Hold@drOrbit},{"ommitbilliard",Hold[!drBilliard]},{"loci",Hold@drLoci},{"normals",Hold@drNormals},{"caustic",Hold@drCaustic},(*pts basic*){"incenter",Hold@drIncenter},{"baricenter",Hold@drBaricenter},{"circumcenter",Hold@drCircumcenter},{"orthocenter",Hold@drOrthocenter},{"ninepointcenter",Hold@drNinepointcenter},{"symmedianpoint",Hold@drSymmedianpoint},{"gergonne",Hold@drGergonne},{"nagel",Hold@drNagel},{"mittenpunkt",Hold@drMitten},(*"spieker"--X10--,*){"feuerbach",Hold@drFeuerbach},(*pts advanced*){"bevanpt",Hold@drBevan},{"x88",Hold@drX88},{"x100",Hold@drAntiFeuerbach},{"x101",Hold@drX101},{"x142",Hold@drX142},{"darbouxpt",Hold@drDarbouxPt},{"x168",Hold@drX168},{"x190",Hold@drX190},(*pt groups*){"basicnotables",Hold@drBasicNotables},{"notables",Hold@drNotables},{"exnotables",Hold@drExcNotables},{"mosesptsto1k",Hold@drMosesPtsTo1k},{"mosesptsto4k",Hold@drMosesPtsTo4k},{"mosesptsabove4k",Hold@drMosesPtsAbove4k},{"trilinpts",Hold@drTrilinPts},{"exctrilinpts",Hold@drExcTrilinPts},{"acttrilinpts",Hold@drActTrilinPts},(*lines*){"notablelines",Hold@drNotableLines},{"eulerline",Hold@drEulerLine},{"exnotablelines",Hold@drExcNotableLines},{"feuerbachline",Hold@drFeuerLine},{"mittenfeet",Hold@drMittenFeet},{"darbouxlines",Hold@drDarbouxLine},{"incenterlines",Hold@drIncenterLine},{"mittengergonneline",Hold@drMittenGergonneLine},{"darbouxgergonneline",Hold@drDarbouxGergonneLine},{"mittenx142line",Hold@drMittenX142Line},{"x88antifeuerline",Hold@drX88AntiFeuerLine},{"interfeuerline",Hold@drInterFeuerLine},(*circles*){"incircle",Hold@drIncircle},{"circumcircle",Hold@drCircumcircle},{"ninepointcircle",Hold@drNpc},{"excircles",Hold@drExcircles},{"cosinecircle",Hold@drCosineCircle},(*triads*){"medians",Hold@drMedians},{"intouchpts",Hold@drIntouchpts},
{"extouchpts",Hold@drExtouchpts},{"exfeuerbach",Hold@drExcFeuer},
(*triangles*){"orthictriangle",Hold@drOrthicTri},
{"intouchtri",Hold@drIntouchTri},
{"extouchtri",Hold@drExtouchTri},
{"outernapoleon",Hold@drOuterNapoleonTri},{"hexyltriangle",Hold@drHexylTri},{"morleytriangle",Hold@drMorleyTri},(*excentral*){"exbaricenter",Hold@drExcBar},
(*anticompl tri*)
{"anticompl",Hold@drAntiComplTri},{"anticomplcircumb",Hold@drAntiComplCircumb},{"anticomplnpc",Hold@drAntiComplNpc},{"anticomplincirc",Hold@drAntiComplIncirc},{"anticomplcontact",Hold@drAntiComplContact},
(*medial tri*)
{"medial",Hold@drMedial},{"medialcircumb",Hold@drMedialCircumb},{"medialnpc",Hold@drMedialNpc},{"medialincirc",Hold@drMedialIncirc},{"medialcontact",Hold@drMedialContact},
(* excentral tri*)
{"excentral",Hold@drExcentral},{"excentralcircumb",Hold@drExcentralCircumb},{"excentralnpc",Hold@drExcentralNpc},{"excentralincirc",Hold@drExcentralIncirc},{"excentralcontact",Hold@drExcentralContact},
(* orthic tri*)
{"orthic",Hold@drOrthic},{"orthiccircumb",Hold@drOrthicCircumb},{"orthicnpc",Hold@drOrthicNpc},{"orthicincirc",Hold@drOrthicIncirc},{"orthiccontact",Hold@drOrthicContact},
(*axes*)
{"antiorthicaxis",Hold@drAntiorthicAxis},{"isotomicaxis",Hold@drIsotomicAxis},(*circumconics*){"steinercircumell",Hold@drSteinerCircumEll},{"steinerinell",Hold@drSteinerInell},{"inccircumell",Hold@drIncCircumEll},{"hypx100",Hold@drHypX100},{"hypfeuerbach",Hold@drHypFeuerbach},(*quadrangles*){"quadcirx100",Hold@drQuadCirX100},{"quadactpsx100",Hold@drQuadAnticomplTpsX100},(*misc*){"experimental",Hold@drExperimental},{"refequi",Hold@drRefEqui}};
(* main call *)
Dynamic[
If[exp≠"manual"&&exp≠lastExp,
Module[{expItems,assignments},
lastExp=exp;
expItems=AssociationMap[True&,Prepend[opts4Exps[exp],"orbit"]];
assignments=KeyExistsQ[expItems,First@#]&/@optsList;
MapThread[assign1[Unevaluated@@(Second@#1),#2]&,{optsList,assignments}]]];
optsListEval=Rule[First@#,ReleaseHold[Second@#]]&/@optsList;
movieFrameOpts[a,toRad@tDeg,
mainVizCache["ellPlot"],
mainVizCache["causticPlot"],
mainVizCache["lociBasic"],
mainVizCache["excenterLims"],
clip,Sequence@@optsListEval,
ImageSize->imgSize]]
,
(* how can I control animation step here! *)
Style["Triangular Orbits in Elliptic Billiards\n© 2019 Dan S. Reznik -- dreznik@gmail.com",16,{Bold,Black}],
Delimiter,
Grid[
{{Control[{{tDeg,30.,"θ"},-360,360,1.,AnimationRate->1,Appearance->"Open"}],"viewport",Control[{{clip,"ort",""},{"ellHalf","ell","ort","ortHalf","excHalf","exc","anticompl","anticompl2",
"antiorthic","antiorthic2","antiorthic3","antiorthic4","antiorthic8"}}]},
{(*SpanFromAbove*)Control[{{imgSize,800,"image size"},{600,800,1600,2400,3200}}](*Control[{{a,1.5,"a"},1.1,3,.1,Appearance->"Labeled"}]*),"experiment",Control[{{exp,"manual",""},Keys@opts4Exps}]}},Alignment->{Center}],
Grid[(makeCtrlCol/@{
{"basic",
Control[{{drBilliard,True, "billiard"},{False,True}}],
Control[{{drOrbit,True, "orbit"},{False,True}}],
Control[{{drNormals,False,"normals"},{False,True}}],
Control[{{drLoci,False, "loci"},{False,True}}],
Control[{{drCaustic,False, "caustic"},{False,True}}],
Control[{{drIncenter,False,"incenter (Subscript[X, 1])"},{False,True}}],
Control[{{drBaricenter,False,"baricenter (Subscript[X, 2])"},{False,True}}],
Control[{{drCircumcenter,False,"circumcenter (Subscript[X, 3])"},{False,True}}],
Control[{{drOrthocenter,False,"orthocenter (Subscript[X, 4])"},{False,True}}],
Control[{{drNinepointcenter,False,"nine-point center (Subscript[X, 5])"},{False,True}}],
Control[{{drSymmedianpoint,False,"symmedian point (Subscript[X, 6])"},{False,True}}],
Control[{{drGergonne,False,"gergonne (Subscript[X, 7])"},{False,True}}],
Control[{{drNagel,False,"nagel (Subscript[X, 8])"},{False,True}}],
Control[{{drMitten,False,"mittenpunkt (Subscript[X, 9])"},{False,True}}],
Control[{{drFeuerbach,False,"feuerbach (Subscript[X, 11])"},{False,True}}]
},
{"points",
Control[{{drBasicNotables,False,"basic"},{False,True}}],
Control[{{drNotables,False,"notables"},{False,True}}],
Control[{{drExcNotables,False,"exnotables"},{False,True}}],
Control[{{drBevan,False,"bevan (Subscript[X, 40])"},{False,True}}],
Control[{{drX88,False,"(Subscript[X, 88])"},{False,True}}],
Control[{{drAntiFeuerbach,False,"anti-feuer (Subscript[X, 100])"},{False,True}}],
Control[{{drX101,False,"focus of Yff parabola (Subscript[X, 101])"},{False,True}}],
Control[{{drX142,False,"tabachnikov (Subscript[X, 142])"},{False,True}}],
Control[{{drDarbouxPt,False,"darboux (Subscript[X, 144])"},{False,True}}],
Control[{{drX168,False,"excentral mitten (Subscript[X, 168])"},{False,True}}],
Control[{{drX190,False,"steiner (Subscript[X, 190])"},{False,True}}]
},
{"lines",
Control[{{drNotableLines,False,"notables"},{False,True}}],
Control[{{drEulerLine,False,"euler"},{False,True}}],
Control[{{drFeuerLine,False,"feuerbach"},{False,True}}],
Control[{{drExcNotableLines,False,"exnotable"},{False,True}}],Control[{{drMittenGergonneLine,False,"mitten-gergonne"},{False,True}}],
Control[{{drMittenX142Line,False,"mitten-(Subscript[X, 142])"},{False,True}}],
Control[{{drDarbouxGergonneLine,False,"darboux-gergonne"},{False,True}}],
Control[{{drIncenterLine,False,"incenter"},{False,True}}],
Control[{{drDarbouxLine,False,"darboux"},{False,True}}],
Control[{{drX88AntiFeuerLine,False,"x88-antifeuerbach"},{False,True}}],
Control[{{drInterFeuerLine,False,"feuer-antifeuer"},{False,True}}],
Control[{{drMittenFeet,False,"mittenfeet"},{False,True}}]
},
{"circles",
Control[{{drIncircle,False,"incircle"},{False,True}}],
Control[{{drCircumcircle,False,"circumcircle"},{False,True}}],
Control[{{drNpc,False,"nine point"},{False,True}}],
Control[{{drExcircles,False,"excircles"},{False,True}}],
Control[{{drCosineCircle,False,"cosine"},{False,True}}],
"",
Style["conics",{Black,Bold,Medium}],
Control[{{drHypFeuerbach,False,"Feuerbach hyperbola"},{False,True}}],
Control[{{drHypX100,False,"(Subscript[X, 100]) hyperbola"},{False,True}}],
Control[{{drSteinerCircumEll,False,"Steiner Circumell"},{False,True}}],
Control[{{drSteinerInell,False,"Steiner Inellipse"},{False,True}}],
Control[{{drIncCircumEll,False,"Incenter Circumell"},{False,True}}],
Control[{{drAntiorthicAxis,False,"isogonal axis"},{False,True}}],
Control[{{drIsotomicAxis,False,"isotomic axis"},{False,True}}]
},
{Style["anticompl","anticompl"/.ptClrs],
Control[{{drAntiComplTri,False,"tri"},{False,True}}],
Control[{{drAntiComplIncirc,False,"incirc (Subscript[X, 8])"},{False,True}}],
Control[{{drAntiComplNpc,False,"nine point"},{False,True}}],
Control[{{drAntiComplCircumb,False,"circumb (Subscript[X, 7])"},{False,True}}],
Control[{{drAntiComplContact,False,"contact"},{False,True}}]
},
{Style["medial","med"/.ptClrs],
Control[{{drMedial,False,"tri"},{False,True}}],
Control[{{drMedialIncirc,False,"incirc"},{False,True}}],
Control[{{drMedialNpc,False,"nine point"},{False,True}}],
Control[{{drMedialCircumb,False,"circumb (Subscript[X, 142])"},{False,True}}],
Control[{{drMedialContact,False,"contact"},{False,True}}]
},
{Style["excentral","exc"/.ptClrs],
Control[{{drExcentral,False,"tri"},{False,True}}],
Control[{{drExcentralIncirc,False,"incirc"},{False,True}}],
Control[{{drExcentralNpc,False,"nine point"},{False,True}}],
Control[{{drExcentralCircumb,False,"circumb (Subscript[X, 168])"},{False,True}}],
Control[{{drExcentralContact,False,"contact"},{False,True}}]
},
{Style["orthic","ort"/.ptClrs],
Control[{{drOrthic,False,"tri"},{False,True}}],
Control[{{drOrthicIncirc,False,"incirc"},{False,True}}],
Control[{{drOrthicNpc,False,"nine point"},{False,True}}],
Control[{{drOrthicCircumb,False,"circumb (Subscript[X, ?])"},{False,True}}],
Control[{{drOrthicContact,False,"contact"},{False,True}}]
},
{"triads",
Control[{{drMedians,False,"medians"},{False,True}}],
Control[{{drIntouchpts,False,"intouch"},{False,True}}],
Control[{{drExtouchpts,False,"extouch"},{False,True}}],
Control[{{drExcFeuer,False,"exfeuer"},{False,True}}]
},
{"tris",
Control[{{drOrthicTri,False,"orthic"},{False,True}}],
Control[{{drMorleyTri,False,"morley"},{False,True}}],
Control[{{drIntouchTri,False,"intouch"},{False,True}}],
Control[{{drExtouchTri,False,"extouch"},{False,True}}],
Control[{{drOuterNapoleonTri,False,"napoleon"},{False,True}}],
Control[{{drHexylTri,False,"hexyl"},{False,True}}]
},
{"research",
Control[{{drMosesPtsTo1k,False,"moses (Subscript[X, 9])(<1k)"},{False,True}}],
Control[{{drMosesPtsTo4k,False,"moses (Subscript[X, 9])(<4k)"},{False,True}}],
Control[{{drMosesPtsAbove4k,False,"moses (Subscript[X, 9])(>4k)"},{False,True}}],
Control[{{drTrilinPts,False,"trilins (Subscript[X, 1])~(Subscript[X, 100])"},{False,True}}],
Control[{{drExcTrilinPts,False,"exc trilins (Subscript[X, 1])~(Subscript[X, 100])"},{False,True}}],
Control[{{drActTrilinPts,False,"anticompl trilins (Subscript[X, 1])~(Subscript[X, 100])"},{False,True}}]
},
{"misc",
Control[{{drExperimental,False,"experimental"},{False,True}}],
Control[{{drRefEqui,False,"ref. equilateral"},{False,True}}],
Control[{{drExcBar,False,"exbaricenter"},{False,True}}],
Control[{{drQuadCirX100,False,"quad cir-(Subscript[X, 100])"},{False,True}}],
Control[{{drQuadAnticomplTpsX100,False,"quad actTps-(Subscript[X, 100])"},{False,True}}]}
})//Partition[#,4]&,Spacings->{1,1},Alignment->Right,Frame->All,FrameStyle->Lighter@Gray],
SaveDefinitions->True, ControlPlacement->Left,Alignment->Left, FrameMargins->None]]

(*DeleteFile[mainViz];*)

(*mainViz=CloudDeploy[%,"triangle in elliptic billiard v2",Permissions->"Public"]*)

[new] Excircles Side Touchpoints

Clear@getExcircleSideTouchpoints;
getExcircleSideTouchpoints[o_,s_]:=Module[{exc,ext,excRs,gr,sideTps1,sideTps2,hex,conic},
exc=excentralTriangle[o,s];
ext=extouchTriangle[o,s];
excRs=MapThread[magn[#1-#2]&,{exc,ext}];
sideTps1=MapThread[closestPerp[#1,#2,#3]&,{exc,o,RotateLeft@o}];
sideTps2=MapThread[closestPerp[#1,#2,#3]&,{exc,o,RotateRight@o}];
hex=Riffle[sideTps1,sideTps2];
conic=getConicCoeffs[Most@hex];
<|"orbit"->o,"exc"->exc,"ext"->ext,"excRs"->excRs,"sideTps1"->sideTps1,"sideTps2"->sideTps2,
"hex"->hex,"area1"->signedArea[sideTps1],"area2"->signedArea[sideTps2],"areaHex"->signedArea[hex],
"perHex"->triPer@hex,"conic"->conic|>]

getExcircleSideTouchpoints[Sequence@@Part[orbitNormals[1.5,toRad@10.],{1,3}]]

Clear@drawExcircleSideTouchpoints;
Options@drawExcircleSideTouchpoints={drSubtris->True,drExt->True,drHexVtxCircs->{},hexCircRad->.1,drHexConic->False};
drawExcircleSideTouchpoints[sideTps_,OptionsPattern[]]:=
Graphics[{FaceForm@None,PointSize@Large,
{Purple,Dashed,MapThread[Line@{#1,#2}&,{sideTps["hex"],RotateLeft[sideTps["hex"],3]}]},
MapThread[drawPoly[sideTps[#1],#2]&,{{"orbit","exc"},{Blue,Darker@Green}}],
If[OptionValue@drExt,drawPoly[sideTps["ext"],Brown],{}],
{Darker@Green,MapThread[{Thick,Circle[#1,#2]}&,{sideTps["exc"],sideTps["excRs"]}]},
If[OptionValue@drHexConic,List@@drawConic[sideTps["conic"],maxX->4,maxY->4,ps->Directive[AbsoluteThickness@3,Orange],psAxes->Directive[Dashed,Thick,Orange]],{}],
If[OptionValue@drSubtris,{drawPoly[sideTps["sideTps1"],Directive[Dashed,Thick,Orange]],drawPoly[sideTps["sideTps2"],Directive[Dashed,Red]]},{}],
{drawPoly[sideTps["hex"],Directive[Purple]],If[Length[OptionValue@drHexVtxCircs]>0,{Purple,Circle[sideTps["hex"][[#]],OptionValue@hexCircRad]&/@OptionValue@drHexVtxCircs},{}]}}];

getExcenterAxes[1.5]

What is the locus of vertices of the side touchpoints?

Module[{a=1.5,pp12,pp13,pp14,pp15,ell,ellC,dy=.05},
ellC=plotEllbAxes[Sequence@@getCausticAxes[a,1],{Thick,Brown}];
ellC=Graphics[Translate[List@@ellC,{0,dy}]];
ell=plotEllAxes[a,{Thick,Black}];
pp12=getEnvelopeLocus[a,getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,getExcircleSideTouchpoints[#1,#2]["hex"][[2]]&,Purple];
pp13=getEnvelopeLocus[a,getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,getExcircleSideTouchpoints[#1,#2]["hex"][[3]]&,Directive[Dashed,Purple]];
pp14=getEnvelopeLocus[a,getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,getExcircleSideTouchpoints[#1,#2]["hex"][[4]]&,Directive[Lighter@Blue]];
(*pp15=getEnvelopeLocus[a,getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,getExcircleSideTouchpoints[#1,#2]["hex"][[5]]&,Orange]*);
Show[{ell,ellC,pp12,pp13,pp14(*,pp15*)}]]

Envelope of [hex1, hex4] is trivially the caustic as it passes thru one of the sides.
The envelope of [hex1, hex2] is an ellipse similar to biiliard!

Module[{a=1.618,locus,ons,ellPars},
(* locus of single center *)
locus=Table[getEnvelope[a,tDeg,
getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,
getExcircleSideTouchpoints[#1,#2]["hex"][[2]]&],{tDeg,0,360,1}];
ellPars=findEllParams[a,-1,locus,"n/a"];
Print@Graphics[{FaceForm@None,Purple,Line@locus}];
ellPars]

sideTpsLocusPre[a_]:= Module[{ell,ellC,tps,sideTpsLocus1,sideTpsLocus2,ons,excLocus,env12Locus},
ell=plotEllAxes[a,{Thick,Black}];
ellC=plotEllbAxes[Sequence@@getCausticAxes[a,1],{Thick,Brown}];
sideTpsLocus1=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@tDeg2];
tps=getExcircleSideTouchpoints[ons[[1]],ons[[3]]];
tps["sideTps1"][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Red]];
sideTpsLocus2=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@tDeg2];
tps=getExcircleSideTouchpoints[ons[[1]],ons[[3]]];
tps["sideTps2"][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Red]];
excLocus=Graphics@{Darker@Green,Dashed,Thick,Circle[{0,0},getExcenterAxes[a]]};
env12Locus=getEnvelopeLocus[a,getExcircleSideTouchpoints[#1,#2]["hex"][[1]]&,getExcircleSideTouchpoints[#1,#2]["hex"][[2]]&,Directive[Thick,Dashed,Purple]];
<|"ell"->ell,"ellCaustic"->ellC,"loci"->{sideTpsLocus1,sideTpsLocus2},"excLocus"->excLocus,"env12Locus"->env12Locus|>
];

DynamicModule[{a=1.5,sideTpsData,ons,slackX=2,slackY=4,pre,pr,pl,conicA,conicB,conicK},
Manipulate[
pr={{-a-slackX,a+slackX},{-1-slackY,1+slackY}};
pre=sideTpsLocusPre[a];
Dynamic[
ons=orbitNormals[a,toRad@tDeg];
sideTpsData=getExcircleSideTouchpoints[ons[[1]],ons[[3]]];
conicA=sideTpsData["conic"]["a"];
conicB=sideTpsData["conic"]["b"];
conicK=1/(1/conicA+1/conicB);
pl="a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°"<>"\n (Subscript[L, hex])="<>nfn[sideTpsData["perHex"],2]<> ", (Subscript[A, hex])="<>nfn[Abs@sideTpsData["areaHex"],2]<>"\n"<>"cA="<>nfn[conicA,3]<>", cB="<>nfn[conicB,3];
Show[{pre["ell"],pre["ellCaustic"],pre["excLocus"],pre["env12Locus"],If[showLoci,pre["loci"],{}],
drawExcircleSideTouchpoints[sideTpsData,drSubtris->showSubtris,drExt->False,drHexVtxCircs->{1,2},drHexConic->drHexConic0]},PlotLabel->Style[pl,{Black,16}],PlotRange->pr,ImageSize->800]],
{{tDeg,10.},-180,180,.1,Appearance->"Labeled"},
{{showLoci,False},{True,False}},
{{showSubtris,False},{True,False}},
{{drHexConic0,True,"hex conic"},{True,False}},ControlPlacement->Right]]

Properties of the Mittenpunkt

http://www.journal-1.eu/2016-2/Grozdev-Dekov-Mittenpunkt-pp.9-13.pdf

Theorem 2.2.The Mittenpunkt is the
(1) Centroid of the Triangle of the Symmedian Points of the Anticevian Corner
Triangles of the Incenter
(2) Orthocenter of the Triangle of the Centroids of the Anticevian Corner Triangles of the Incenter.
(3) Orthocenter of the First Brocard Triangle of the Hexyl Triangle.
(4) Symmedian Point of the Intouch Triangle of the Medial Triangle.
(5) Symmedian Point of the Half - Cevian Triangle of the Nagel Point.
(6) Symmedian Point of the Inner Grebe Triangle of the Excentral Triangle.
(7) Symmedian Point of the Outer Grebe Triangle of the Excentral Triangle.
(8) Symmedian Point of the Fourth Brocard Triangle of the Excentral Triangle.
(9) Gergonne Point of the Medial Triangle. [ http://mathworld.wolfram.com/MedialTriangle.html ]
(10) Gergonne Point of the Half - Median Triangle of the Antimedial Triangle.
(11) Gergonne Point of the Half - Anticevian Triangle of the Centroid.
(12) Gergonne Point of the Tangential Triangle of the Excentral Triangle.
(13) Gergonne Point of the Triangle of the Centroids of the Triangulation Triangles of the Mittenpunkt.
(14) Retrocenter of the Circum - Anticevian Triangle of the Incenter.
(15) Retrocenter of the Medial Triangle of the Excentral Triangle.
(16) Steiner Point of the First Brocard Triangle of the Excentral Triangle.
(17) Center of the Brocard Circle of the Antimedial Triangle of the Hexyl Triangle.
(18) Second Rigby Point of the Lucas Central Triangle of the Excentral Triangle.

Cosine Circle is STATIONARY! (And Equilaterals)

(* http://mathworld.wolfram.com/BrocardAngle.html *)
tanBrocardAngle[{a_,b_,c_}]:=Module[{area,tanOmega},
area=triAreaHeron[{a,b,c}];
tanOmega=4*area/(a^2+b^2+c^2);
tanOmega];

(* http://mathworld.wolfram.com/TuckerCircles.html *)tuckerCircleRadius[R_,lambda_,tanOmega_]:=R*Sqrt[lambda^2+((1-lambda) tanOmega)^2]

Clear@getExcentralTuckerCircleRadius;
getExcentralTuckerCircleRadius[a_,t_,lambda_]:=Module[{o,n,s,exc,excSides,tanOmega,excR},
{o,n,s}=orbitNormals[a,t];
exc=excentralTriangle[o,s];
excSides=triLengthsRL@exc;
tanOmega=tanBrocardAngle@excSides;
excR=getCircumradius[excSides];
tuckerCircleRadius[excR,lambda,tanOmega]];

It does not work for the 1st lemoine circle (λ = .5)

Table[getExcentralTuckerCircleRadius[1.5,toRad@t,.5],{t,0,360,10}]

It does not work for the circumcircle (λ = 1)

Table[getExcentralTuckerCircleRadius[1.5,toRad@t,1],{t,0,360,10}]

It ***works*** for the cosine circle (λ = 0)

Table[getExcentralTuckerCircleRadius[1.5,toRad@t,0],{t,0,360,10}]

Ronaldo Gave closed - form eqn for Cosine Circle Radius

cosineCircleRadiusRonaldo[a_,b_]:=(1/3)*Sqrt[3*a^2+3*b^2+6*Sqrt[a^4-a^2*b^2+b^4]]

Table[{a,getExcentralTuckerCircleRadius[a,0,0],cosineCircleRadiusRonaldo[a,1]},{a,1.1,3,.1}]//Prepend[#,{"a","R*tan[ω]","ronaldo"}]&//Grid[#,Frame->All]&

ParametricPlot[{a,cosineCircleRadiusRonaldo[a,1]},{a,1.01,3},Epilog->{Dashed,Line@{{1,1},{3,3}}},Frame->True,FrameLabel->(Style[#,{Large,Black}]&/@{"a/b","(SuperStar[r])"}),FrameStyle->{Black,Medium},PlotLabel->Style["(SuperStar[r]) vs a/b",{Black,Large}]]

Plot[cosineCircleRadiusRonaldo[a,1]/a,{a,1.001,3},Frame->True,FrameLabel->(Style[#,{Large,Black}]&/@{"a/b","(SuperStar[r])/(a/b)"}),FrameStyle->{Black,Medium},ImageSize->Large,PlotLabel->Style["(SuperStar[r])/(a/b) vs a/b",{Black,Large}]]

Two lines PQ and RS are said to be antiparallel with respect to the sides of an angle A if they make the same angle in the opposite senses with the bisector of that angle.
The tangent to a triangle's circumcircle at a vertex is antiparallel to the opposite side.

Clear@drawCosineCircle
Options@drawCosineCircle={"drHex"->False,"drHexNonSI"->False,"hexStats"->False,"drMedTri"->False,"drBisTri"->False,"drExcTri"->False,"drAntiParallels"->False};
drawCosineCircle[a_,tDeg_,opts:OptionsPattern[]]:=Module[{ell,orbit,normals,sides,
mit,
exc,excSides,excCir,excCirTangs,excR,tuckerRadius,
antiparallels,inter1a,inter2a,inter3a,inter1b,inter2b,inter3b,
polyHex,perHex,areaHex,
polyHexNonSI,perHexNonSI,areaHexNonSI,
medTri,medTriOnExcCir,
bisTri,bisTriOnExcCir,
excTriOnExcCir,
gr,rayL=1,lgt=.25,lab},
ell=plotEll[a];
{orbit,normals,sides}=orbitNormals[a,toRad@tDeg];
(*notables=getNotables[orbit,normals];*)
exc=excentralTriangle[orbit,sides];
excSides=triLengthsRL@exc;
excR=getCircumradius@excSides;
(* for cosine circle, lambda=0 *)
tuckerRadius=tuckerCircleRadius[excR,0,tanBrocardAngle@excSides];
excCir=getCircumcenter@@exc;
mit=getMittenTrilin[orbit,sides];
excCirTangs=perp[#-excCir]&/@exc;
antiparallels=ray[mit,#,rayL]&/@excCirTangs;
inter1a=interRays[mit,antiparallels[[1]]-mit,exc[[1]],exc[[2]]-exc[[1]]];
inter2a=interRays[mit,antiparallels[[2]]-mit,exc[[2]],exc[[3]]-exc[[2]]];
inter3a=interRays[mit,antiparallels[[3]]-mit,exc[[3]],exc[[1]]-exc[[3]]];

inter1b=interRays[mit,antiparallels[[1]]-mit,exc[[3]],exc[[1]]-exc[[3]]];
inter2b=interRays[mit,antiparallels[[2]]-mit,exc[[1]],exc[[2]]-exc[[1]]];
inter3b=interRays[mit,antiparallels[[3]]-mit,exc[[2]],exc[[3]]-exc[[2]]];

polyHex = {inter1a,inter1b,inter2a,inter2b,inter3a,inter3b};
perHex=Total[MapThread[magn[#1-#2]&,{polyHex,RotateLeft@polyHex}]];
areaHex=signedArea@polyHex;
medTri={inter1b+inter2a,inter2b+inter3a,inter3b+inter1a}/2;
medTriOnExcCir=tuckerRadius*(norm/@medTri);
excTriOnExcCir=tuckerRadius*(norm/@exc);
bisTri={
getBisector[mit,inter1b,inter2a],
getBisector[mit,inter2b,inter3a],
getBisector[mit,inter3b,inter1a]};
bisTriOnExcCir=tuckerRadius*bisTri;(*they are unit*)
polyHexNonSI = {inter1a,inter2b,inter3a,inter1b,inter2a,inter3b};
perHexNonSI=Total[MapThread[magn[#1-#2]&,{polyHexNonSI,RotateLeft@polyHexNonSI}]];
areaHexNonSI=signedArea@polyHexNonSI;

lab="a="<>nf@a<>"; t="<>nfn[tDeg,1]<>"; (Subscript[r, cos])="<>nfn[tuckerRadius,3]<>If[OptionValue@"drHex"&&OptionValue@"hexStats","\nperHex="<>nfn[perHex,3]<>"; areaHex="<>nfn[areaHex,3],""]<>
If[OptionValue@"drHexNonSI"&&OptionValue@"hexStats","\nperHexNonSI="<>nfn[perHexNonSI,3]<>"; areaHexNonSI="<>nfn[areaHexNonSI,3],""]
;
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{"inc"/.ptClrs,Thick},Polygon@exc},
{"inc"/.ptClrs,Dashed,Circle[excCir,excR],Point@exc,Point@excCir,Text[Style["(Subscript[X, 40])",16],excCir,{-1.25,-1.25}]},
(*{Arrowheads@Medium,Red,MapThread[Arrow@{#1,#1+norm@#2}&,{exc,excCirTangs}]},*)
{EdgeForm@{Thick,Blue},FaceForm@{Blue,Opacity@.2},Polygon@orbit,PointSize@Medium,Blue,Point[getMedians@@orbit]},
{Red,Point@mit,Text[Style["(Subscript[X, 9])",16],mit,{-1.25,-1.25}]},
{Red,Dashed,Line@{2mit-#,#}&/@antiparallels},
If[OptionValue@"drAntiParallels",{Darker@Green,Thick,MapThread[Line@{#1-.5rayL #2,#1+.5rayL#2}&,{exc,excCirTangs}]},{}],
{Red,Thick,Circle[mit,tuckerRadius]},
{Red,PointSize@Large,Point@polyHex(*,MapIndexed[Text[Style[First@#2,16],#1,{-1.5,-1.5}]&,polyHex]*)},
If[OptionValue@"drHex",{EdgeForm@{Red},FaceForm@{Red,Opacity@.1},Polygon@polyHex},{}],
If[OptionValue@"drHexNonSI",{EdgeForm@{Purple},FaceForm@{Purple,Opacity@.1},Polygon@polyHexNonSI},{}],
If[OptionValue@"drMedTri",{PointSize@Medium,Red,Point@medTri,EdgeForm@{Thick,Red,Dashed},Polygon@medTriOnExcCir,Point@medTriOnExcCir,Point[getBaricenter@@medTriOnExcCir]}],
If[OptionValue@"drBisTri",{PointSize@Medium,Orange,EdgeForm@{Orange},Line@{mit,#}&/@bisTriOnExcCir,EdgeForm@{Thick,Orange,Dashed},Polygon@bisTriOnExcCir,Point@bisTriOnExcCir,Point[getBaricenter@@bisTriOnExcCir]}],
If[OptionValue@"drExcTri",{PointSize@Medium,Purple,EdgeForm@{Purple},Line@{mit,#}&/@exc,EdgeForm@{Thick,Purple,Dashed},Polygon@excTriOnExcCir,Purple,Point@excTriOnExcCir,Point[Total[excTriOnExcCir]/3]}]}];
Show[{ell,gr},ImageSize->Large,AspectRatio->Automatic,
PlotRange->{{-3,3},{-3,3}},Frame->True,FrameStyle->{Black,Medium},GridLines->Automatic,
PlotLabel->Style[lab,{Black,20}]]];

Manipulate[
drawCosineCircle[a,tDeg,"drHex"->drHex0,"drHexNonSI"->drHexNonSI0,"hexStats"->hexStats0,
"drMedTri"->drMedTri0,"drBisTri"->drBisTri0,"drExcTri"->drExcTri0,"drAntiParallels"->drAntiParallels0],
{{a,1.5},1.01,3,.1,Appearance->"Open"},
{{tDeg,30},-360,360,.2,Appearance->"Open",AnimationRate->1},
{{drHex0,True,"hex self-inter"},{True,False}},
{{drMedTri0,False,"hex med tri"},{True,False}},
{{drBisTri0,False,"hex bis tri"},{True,False}},
{{drExcTri0,False,"hex exc tri"},{True,False}},
{{drAntiParallels0,False,"antiparallels"},{True,False}},
{{drHexNonSI0,False,"hex non-self-inter"},{True,False}},
{{hexStats0,False,"hex perimeter & area"},{True,False}}]

(*DeleteFile[cosineCircleApp];*)

(*cosineCircleApp=CloudDeploy[%,"cosine circle of excentral triangle is stationary v1",Permissions->"Public"]*)

Clear@drawAntiTangent;
Options@drawAntiTangent={"drCosCircleConstr"->False,"drCircle"->False,"drAllTangs"->False,"drOrbitRefl"->False,"drExcRefl"->False,
"drExcPerps"->False,"drCircum"->False,"drExcCircum"->False,"drMedial"->False,"drMedialCircle"->False,"drFirstIsodynamicPedal"->False,"drFirstIsodynamicExcPedal"->False,"drFirstIsodynamicMedialPedal"->False,"drFirstIsodynamicAnticomplPedal"->False,"maxX"->3,"minY"->-3,"maxY"->3,"drLemoine"->False,"drCtrs100"->False,"drCtrsExc100"->False,"drCtrsMedial100"->False,"drCevianEquilateral"->False,"drAnticompl"->False,"drPerimeterTrisector"->False,"drPerimeterTrisectorExc"->False,"drFrame"->True,"drLabel"->True,"drOrthicParallels"->False};
drawAntiTangent[a_,tDeg_,opts:OptionsPattern[]]:=Module[{ell,
orbit,normals,sides,mit,exc,excSides,orbitRefl,
inter1a,inter1b,inter2a,inter2b,inter3a,inter3b,excRefl,excPerps,
tuckerRadius,cir,cirR,excCir,excCirR,
medial,medialSides,medialIntouch,(*medialIntouchSym,*)medialIntouchRefl,medialIntouchInter1a,medialIntouchCircleR,
anticompl,anticomplSides,firstIsodynAnticompl,firstIsodynAnticomplPedals,firstIsodynAnticomplPedalsCtr,
lemoine1a,lemoine1b,lemoine2a,lemoine2b,lemoine3a,lemoine3b,lemoineCtr,lemoineRad,
firstIsodyn,firstIsodynPedals,firstIsodynPedalsCtr,
firstIsodynExc,firstIsodynExcPedals,firstIsodynExcPedalsCtr,
firstIsodynMedial,firstIsodynMedialPedals,firstIsodynMedialPedalsCtr,
cevianEquiCevianCtr,cevianEquiCtr,cevianEqui,
ctrs100,ctrs100exc,ctrs100medial,
gr,rayL=1,lgt=.25,lab},
ell=plotEll[a,{Thick,Black}];
{orbit,normals,sides}=orbitNormals[a,toRad@tDeg];
cir=getCircumcenter@@orbit;
cirR=getCircumradius@sides;
(*notables=getNotables[orbit,normals];*)
exc=excentralTriangle[orbit,sides];
excPerps=MapThread[closestPerp[#1,#2,#3]&,{exc,RotateRight@orbit,RotateLeft@orbit}];
excSides=triLengthsRL@exc;
excCir=getCircumcenter@@exc;
excCirR=getCircumradius@excSides;
mit=getMittenTrilin[orbit,sides];
excRefl=(mit-#)&/@exc;
orbitRefl=-#&/@orbit;
inter1a=interRays[orbitRefl[[1]],exc[[3]]-exc[[2]],exc[[1]],exc[[2]]-exc[[1]]];
inter1b=interRays[orbitRefl[[1]],exc[[3]]-exc[[2]],exc[[1]],exc[[3]]-exc[[1]]];
inter2a=interRays[orbitRefl[[2]],exc[[1]]-exc[[3]],exc[[2]],exc[[1]]-exc[[2]]];
inter2b=interRays[orbitRefl[[2]],exc[[1]]-exc[[3]],exc[[2]],exc[[3]]-exc[[2]]];
inter3a=interRays[orbitRefl[[3]],exc[[2]]-exc[[1]],exc[[3]],exc[[1]]-exc[[3]]];
inter3b=interRays[orbitRefl[[3]],exc[[2]]-exc[[1]],exc[[3]],exc[[2]]-exc[[3]]];
tuckerRadius=magn[inter1a-mit];
(* anticompl *)
anticompl=anticomplementaryTriangle[orbit,sides];
anticomplSides=triLengthsRL@anticompl;
(* medial *)
medial=medialTriangle[orbit,sides];
medialSides=triLengthsRL@medial;
medialIntouch=intouchTriangle[medial,medialSides];
(* should be equal to mit *)
(*medialIntouchSym=getSymmedianTrilin[medialIntouch,triLengthsRL@medialIntouch];*)
medialIntouchRefl=(mit-#)&/@medialIntouch;
medialIntouchInter1a=interRays[
medialIntouch[[1]],medialIntouch[[2]]-medialIntouch[[1]],
medialIntouchRefl[[2]],medialIntouchRefl[[3]]-medialIntouchRefl[[2]]];
medialIntouchCircleR=magn[medialIntouchInter1a-mit];
(* lemoine: parallels to exc which pass through Symmedial of excentral = mit *)
lemoine1a=interRays[mit,exc[[2]]-exc[[1]],exc[[2]],exc[[3]]-exc[[2]]];
lemoine1b=interRays[mit,exc[[2]]-exc[[1]],exc[[1]],exc[[3]]-exc[[1]]];
lemoine2a=interRays[mit,exc[[3]]-exc[[2]],exc[[3]],exc[[1]]-exc[[3]]];
lemoine2b=interRays[mit,exc[[3]]-exc[[2]],exc[[2]],exc[[1]]-exc[[2]]];
lemoine3a=interRays[mit,exc[[1]]-exc[[3]],exc[[1]],exc[[2]]-exc[[1]]];
lemoine3b=interRays[mit,exc[[1]]-exc[[3]],exc[[3]],exc[[2]]-exc[[3]]];
lemoineCtr=.5(excCir+mit);(* X182: midpoint between circumcenter and symmedian of excentral *)
lemoineRad=magn[lemoine1a-lemoineCtr];(* all concyclic *)
(* isodyn *)
firstIsodyn=getFirstIsodynamicTrilin[orbit,sides];
firstIsodynPedals=MapThread[closestPerp[firstIsodyn,#1,#2]&,{orbit,RotateLeft@orbit}];
firstIsodynPedalsCtr=getBaricenter@@firstIsodynPedals;
firstIsodynExc=getFirstIsodynamicTrilin[exc,excSides];
firstIsodynExcPedals=MapThread[closestPerp[firstIsodynExc,#1,#2]&,{exc,RotateLeft@exc}];
firstIsodynExcPedalsCtr=getBaricenter@@firstIsodynExcPedals;
firstIsodynMedial=getFirstIsodynamicTrilin[medial,medialSides];
firstIsodynMedialPedals=MapThread[closestPerp[firstIsodynMedial,#1,#2]&,{medial,RotateLeft@medial}];
firstIsodynMedialPedalsCtr=getBaricenter@@firstIsodynMedialPedals;
firstIsodynAnticompl=getFirstIsodynamicTrilin[anticompl,anticomplSides];
firstIsodynAnticomplPedals=MapThread[closestPerp[firstIsodynAnticompl,#1,#2]&,{anticompl,RotateLeft@anticompl}];
firstIsodynAnticomplPedalsCtr=getBaricenter@@firstIsodynAnticomplPedals;
(* cevian equi *)
If[OptionValue@"drCevianEquilateral",
cevianEquiCevianCtr=equilateralCevianCenter[orbit,sides];
cevianEqui=MapThread[interRays[#1,cevianEquiCevianCtr-#1,#2,#3-#2]&,{orbit,RotateLeft@orbit,RotateRight@orbit}];
cevianEquiCtr=getBaricenter@@cevianEqui;
];
(* ctrs *)
ctrs100=If[OptionValue@"drCtrs100",getNewCenters[orbit,sides],{}];
ctrs100exc=If[OptionValue@"drCtrsExc100",getNewCenters[exc,excSides],{}];
ctrs100medial=If[OptionValue@"drCtrsMedial100",getNewCenters[medial,medialSides],{}];
(* ({{"X(1)", "INCENTER", {0.5217231210053024`,0.16957685185968183`}}}) *)

lab="a="<>nf@a<>"; t="<>nfn[tDeg,1]<>"; (Subscript[r, cos])="<>nfn[tuckerRadius,3]<>"; (Subscript[r, cos])/(Subscript[r, med])="<>nfn[tuckerRadius/medialIntouchCircleR,2];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{"inc"/.ptClrs,Thick},Polygon@exc},
If[OptionValue@"drExcRefl",{EdgeForm@{"inc"/.ptClrs,Dashed,Thick},Polygon@excRefl,"inc"/.ptClrs,Red,Point@{inter1a,inter1b,inter2a,inter2b,inter3a,inter3b}},{}],
{EdgeForm@{Thick,Blue},Polygon@orbit},
If[OptionValue@"drOrbitRefl",{EdgeForm@{Dashed,Blue},Polygon@orbitRefl},{}],
If[OptionValue@"drCircle",{Red,Thick,Circle[mit,tuckerRadius]},{}],
If[OptionValue@"drExcPerps",{Black,Point@excPerps,Dashed,MapThread[Line@{#1,#2}&,{exc,excPerps}]},{}],
If[OptionValue@"drCircum",{Blue,Point@cir,Dashed,Circle[cir,cirR]},{}],
If[OptionValue@"drExcCircum",{"inc"/.ptClrs,Point@excCir,Dashed,Circle[excCir,excCirR]},{}],
If[OptionValue@"drCosCircleConstr",{
Point@{orbit[[1]],orbitRefl[[1]]},
ellLabelTxt[a,orbit[[1]],Style["P",{16}],.15],
ellLabelTxt[a,orbitRefl[[1]],Style["P'",{16}],.15],
{Red,Dashed,Line@{inter1a,inter1b},Point@{inter1a,inter1b},
ellLabelPoints[a,{inter1a,inter1b},"Q",16,.15]},
Dashed,Line@{orbit[[1]],orbitRefl[[1]]}},{}],
If[OptionValue@"drAllTangs",
{Red,MapThread[{{Blue,Point@{#1,#2}},Dashed,Line@{#3,#4},Point@{#3,#4}}&,{Rest@orbit,Rest@orbitRefl,{inter2a,inter3a},{inter2b,inter3b}}]},{}],
If[OptionValue@"drOrthicParallels",{Thick,Dashed,Blue,
(*MapThread[Text[#1,#2,{-1.5,-1.5}]&,{{"1a","1b","2a","2b","3a","3b"},
{inter1a,inter1b,inter2a,inter2b,inter3a,inter3b}}],*)
Line@{inter1a,inter3b},
Line@{inter1b,inter2b},
Line@{inter2a,inter3a},Red,Point@{inter1a,inter3b},Point@{inter1b,inter2b},Point@{inter2a,inter3a}},{}],
If[OptionValue@"drMedial",{EdgeForm@{Darker@Red,Thick},Polygon@medial},{}],
If[OptionValue@"drAnticompl",{EdgeForm@{Dashed,Blue,Thick},Polygon@anticompl},{}],
If[OptionValue@"drMedialCircle",{EdgeForm@Purple,Polygon@medialIntouch,EdgeForm@{Purple,Dashed},Polygon@medialIntouchRefl,Purple,PointSize@Medium,Point@medialIntouchInter1a,Circle[mit,medialIntouchCircleR]},{}],
If[OptionValue@"drLemoine",{Darker@Cyan,Thick,
Line@{lemoine1a,lemoine3a},Point@{lemoine1a,lemoine1b},
Line@{lemoine2a,lemoine2b},Point@{lemoine2a,lemoine2b},
Line@{lemoine3a,lemoine3b},Point@{lemoine3a,lemoine3b},
Circle[lemoineCtr,lemoineRad],Point@lemoineCtr,
Text[Style["(Subscript[X, 182])",16],lemoineCtr,{-1.25,-1.25}]},{}],
If[OptionValue@"drFirstIsodynamicPedal",{PointSize@Large,Black,Point@firstIsodyn,Text[Style["(Subscript[X, 15])",16],firstIsodyn,{0,-1.25}],Point@firstIsodynPedals,Line[{firstIsodyn,#}]&/@firstIsodynPedals,EdgeForm@{Black,Thick},FaceForm@{Black,Opacity@.1},Polygon@firstIsodynPedals,PointSize@Medium,Point@firstIsodynPedalsCtr},{}],
If[OptionValue@"drFirstIsodynamicExcPedal",{PointSize@Large,Darker@Green,Point@firstIsodynExc,Text[Style["(Subscript[X, 1277])",16],firstIsodynExc,{0,-1.25}],Point@firstIsodynExcPedals,Line[{firstIsodynExc,#}]&/@firstIsodynExcPedals,EdgeForm@{Darker@Green,Thick},FaceForm@{Darker@Green,Opacity@.1},Polygon@firstIsodynExcPedals,PointSize@Medium,Point@firstIsodynExcPedalsCtr},{}],
If[OptionValue@"drFirstIsodynamicMedialPedal",{PointSize@Large,Darker@Red,Point@firstIsodynMedial,Text[Style["(Subscript[X, 623])",16],firstIsodynMedial,{0,-1.25}],Point@firstIsodynMedialPedals,Line[{firstIsodynMedial,#}]&/@firstIsodynMedialPedals,EdgeForm@{Darker@Red,Thick},FaceForm@{Darker@Red,Opacity@.1},Polygon@firstIsodynMedialPedals,PointSize@Medium,Point@firstIsodynMedialPedalsCtr},{}],
If[OptionValue@"drFirstIsodynamicAnticomplPedal",{PointSize@Large,Blue,Point@firstIsodynAnticompl,Text[Style["(Subscript[X, 621])",16],firstIsodynAnticompl,{0,-1.25}],Point@firstIsodynAnticomplPedals,Line[{firstIsodynAnticompl,#}]&/@firstIsodynAnticomplPedals,EdgeForm@{Blue,Thick},FaceForm@{Blue,Opacity@.1},Polygon@firstIsodynAnticomplPedals,PointSize@Medium,Point@firstIsodynAnticomplPedalsCtr},{}],

If[OptionValue@"drCevianEquilateral",{PointSize@Large,Darker@Cyan,Point@cevianEquiCevianCtr,Text[Style["(Subscript[X, 370])",16],cevianEquiCevianCtr,{0,-1.25}],
Point@cevianEqui,MapThread[Line@{#1,#2}&,{orbit,cevianEqui}],EdgeForm@{Darker@Cyan,Thick},FaceForm@{Darker@Cyan,Opacity@.1},Polygon@cevianEqui,PointSize@Medium,Point@cevianEquiCtr},{}],
If[OptionValue@"drPerimeterTrisector",Module[{trisectCtr,trisectTri},
{trisectCtr,trisectTri}=getPerimeterTrisector[orbit,sides];
{PointSize@Large,Darker@Pink,Point@trisectCtr,Text[Style["(Subscript[X, 369])",16],trisectCtr,{0,-1.25}],
Point@trisectTri,MapThread[Line@{#1,#2}&,{orbit,trisectTri}],EdgeForm@{Darker@Pink,Thick},FaceForm@{Darker@Pink,Opacity@.1},Polygon@trisectTri}],{}],
If[OptionValue@"drPerimeterTrisectorExc",Module[{trisectCtr,trisectTri},
{trisectCtr,trisectTri}=getPerimeterTrisector[exc,excSides];
{PointSize@Large,Darker@Green,Point@trisectCtr,Text[Style["(Subscript[X, 369 | exc])",16],trisectCtr,{0,-1.25}],
Point@trisectTri,MapThread[Line@{#1,#2}&,{orbit,trisectTri}],EdgeForm@{Darker@Green,Thick},FaceForm@{Darker@Green,Opacity@.1},Polygon@trisectTri}],{}],


If[OptionValue@"drCtrs100",{PointSize@Medium,Lighter@Blue,Point[Third/@ctrs100]},{}],
If[OptionValue@"drCtrsExc100",{PointSize@Medium,Darker@Green,Point[Third/@ctrs100exc]},{}],
If[OptionValue@"drCtrsMedial100",{PointSize@Medium,Darker@Red,Point[Third/@ctrs100medial]},{}],
{Red,Point@mit,Text[Style["(Subscript[X, 9])",16],mit,{-1.25,1.5}]}
}];
Show[{ell,gr},ImageSize->Large,AspectRatio->Automatic,
PlotRange->{{-OptionValue@"maxX",OptionValue@"maxX"},{OptionValue@"minY",OptionValue@"maxY"}},Frame->(OptionValue@"drFrame"),AxesStyle->Directive[RGBColor[.66,.66,.66]],
PlotLabel->If[OptionValue@"drLabel",Style[lab,{Black,20}],None]]];

Manipulate[
drawAntiTangent[a,tDeg,"drCosCircleConstr"->drCosCircleConstr0,"drCircle"->drCircle0,"drAllTangs"->drAllTangs0,"drOrbitRefl"->drOrbitRefl0,"drExcRefl"->drExcRefl0,"drExcPerps"->drExcPerps0,"drCircum"->drCircum0,"drExcCircum"->drExcCircum0,"drMedial"->drMedial0,"drLemoine"->drLemoine0,"drFirstIsodynamicPedal"->drFirstIsodynamicPedal0,"drFirstIsodynamicExcPedal"->drFirstIsodynamicExcPedal0,"drFirstIsodynamicMedialPedal"->drFirstIsodynamicMedialPedal0,"drCtrs100"->drCtrs0,"drCtrsExc100"->drCtrsExc0,"drCtrsMedial100"->drCtrsMedial0,"drMedialCircle"->drMedialCircle0,"drCevianEquilateral"->drCevianEqui0,"drAnticompl"->drAnticompl0,"drFirstIsodynamicAnticomplPedal"->drFirstIsodynamicAnticomplPedal0,
"drPerimeterTrisector"->drPerTrisect0,"drPerimeterTrisectorExc"->drPerTrisectExc0,"maxX"->maxX0,"maxY"->maxY0,"minY"->minY0,"drLabel"->drLabel0,"drFrame"->drFrame0,"drOrthicParallels"->drOrthicParallels0],
{{maxX0,3,"max x"},{2,3,3.5,4,5}},
{{minY0,-3,"min y"},{-2.5,-3,-3.5,-4,-5}},
{{maxY0,3,"max y"},{2,3,3.5,4,5}},
{{a,1.5},1.01,3,.1,Appearance->"Open"},
{{tDeg,30},-360,360,1,Appearance->"Open"},
{{drLabel0,True,"show label"},{True,False}},
{{drFrame0,True,"show frame"},{True,False}},
{{drCosCircleConstr0,True,"cosine circle constr"},{True,False}},
{{drCircle0,True,"cosine circle"},{True,False}},
{{drAllTangs0,False,"all tangs"},{True,False}},
{{drExcRefl0,False,"reflected excentral"},{True,False}},
{{drExcPerps0,False,"excentral perps"},{True,False}},
{{drOrbitRefl0,False,"reflected orbit"},{True,False}},
{{drCircum0,False,"orbit circumcircle"},{True,False}},
{{drExcCircum0,False,"excentral circumcircle"},{True,False}},
{{drOrthicParallels0,False,"orthic parallels"},{True,False}},
Delimiter,
{{drLemoine0,False,"lemoine"},{True,False}},
{{drMedial0,False,"medial"},{True,False}},
{{drAnticompl0,False,"anticompl"},{True,False}},
{{drMedialCircle0,False,"medial cosine circle"},{True,False}},
Delimiter,
{{drCevianEqui0,False,"cevian equilateral"},{True,False}},
{{drPerTrisect0,False,"perimeter trisector"},{True,False}},
{{drPerTrisectExc0,False,"perimeter trisector exc"},{True,False}},
{{drFirstIsodynamicPedal0,False,"1st isodynamic pedal"},{True,False}},
{{drFirstIsodynamicExcPedal0,False,"excentral 1st isodynamic pedal"},{True,False}},
{{drFirstIsodynamicMedialPedal0,False,"medial 1st isodynamic pedal"},{True,False}},
{{drFirstIsodynamicAnticomplPedal0,False,"anticompl 1st isodynamic pedal"},{True,False}},
Delimiter,
{{drCtrs0,False,"orbit: (Subscript[X, 1]) to (Subscript[X, 100])"},{True,False}},
{{drCtrsExc0,False,"excentral: (Subscript[X, 1]) to (Subscript[X, 100])"},{True,False}},
{{drCtrsMedial0,False,"medial: (Subscript[X, 1]) to (Subscript[X, 100])"},{True,False}}
]

cosCirclePlot=drawAntiTangent[1.5,30,"drCosCircleConstr"->False,"drCircle"->True,"maxX"->3,"maxY"->3.5,"minY"->-2.5,"drLabel"->False,"drFrame"->False,"drOrthicParallels"->True]

export3["0110_cosine_circle_locus_antiparallels",cosCirclePlot]

Show[drawCosineCircle[1.5,30,"drHex"->True,"drAntiParallels"->True],Frame->False,GridLines->None,PlotLabel->None,PlotRange->{{-3.7,3},{-2.5,3.5}}]

(*DeleteFile[antiTangApp];*)

(*antiTangApp=CloudDeploy[%,"intersection of excentral triangle with its reflection about the symmedian yields six points on stationary circle v1",Permissions->"Public"]*)

Ideal Ellipses: Ellliptic: X(1),X(5),X(8),X(10),X(40), Non-Elliptic: X(6)

Clear@xError;
xError[a_,a0_,b0_,fnTrilin_]:=Module[{o,n,s,x1s,b=1,ell1,t,gr,ell,errs,degStep=1},
x1s=Table[t=toRad@tDeg;{o,n,s}=orbitNormals[a,t];
fnTrilin[o,s],{tDeg,0,360-degStep,degStep}];
ell1=Table[t=toRad@tDeg;{a0 Cos@t,b0 Sin@t},{tDeg,0,360-degStep,degStep}];
gr=Graphics[{
{Darker@Green,Line@ell1},
{Red,Line@x1s}}];
ell=plotEll[a];
errs=Abs[ellError[a0,b0,#]]&/@x1s;
Print@getStats[errs];
Show[{ell,gr}]];

Clear@xErrorAbs;
xErrorAbs[a_,a0_,b0_,fnTrilin_]:=Module[{o,n,s,x1s,b=1,ell1,t,gr,ell,errs,degStep=1},
x1s=Table[t=toRad@tDeg;{o,n,s}=orbitNormals[a,t];
fnTrilin[o,s],{tDeg,0,360-degStep,degStep}];
ell1=Table[t=toRad@tDeg;{a0 Cos@t,b0 Sin@t},{tDeg,0,360-degStep,degStep}];
gr=Graphics[{
{Darker@Green,Line@ell1},
{Red,Line@x1s}}];
ell=plotEll[a];
errs=Abs[ellError[a0,b0,#]]&/@x1s;
getStats[errs]];

Clear@x1Error;
x1Error[a_]:=Module[{b=1,a1,b1,δ},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
a1=((-(b^2)+δ)/a); 
b1=(((a^2)-δ)/b);
xError[a,a1,b1,getIncenterTrilin]];

x1Error[1.5]

x5Error[a_]:=Module[{b=1,a5,b5,δ},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
a5=(-a^4-3a^2b^2+3δ a^2+δ b^2)/(4a(a^2-b^2));
b5=(-b^4-3a^2b^2+3δ b^2+δ a^2)/(4b(a^2-b^2));
xError[a,a5,b5,getNinepointCenterTrilin]];

x5Error[1.5]

x6Error[a_]:=Module[{b=1,a6,b6,δ,denom},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
denom=(a^4)+(b^4)+2(δ^2);
a6=(-(a^2)-(b^4)+δ(3 (a^2)- (b^2)))a/denom;
b6=((a^4)+(a^2)(b^2)+δ((a^2)-3 (b^2)))b/denom;
xError[a,a6,b6,getSymmedianTrilin]];

x6Error[1.5]

x6ErrorAbs[a_]:=Module[{b=1,a6,b6,δ,denom},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
denom=(a^4)+(b^4)+2(δ^2);
a6=(-(a^2)-(b^4)+δ(3 (a^2)- (b^2)))a/denom;
b6=((a^4)+(a^2)(b^2)+δ((a^2)-3 (b^2)))b/denom;
xErrorAbs[a,a6,b6,getSymmedianTrilin]["mean"]];

x6ErrorAbs[15]

ListLinePlot[Table[x6ErrorAbs[a],{a,1.01,15,1}]]

x8Error[a_]:=Module[{b=1,a8,b8,δ},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
a8=-(-a^4+a^2 b^2-2b^4+2δ b^2)/(a(a^2-b^2));
b8=(-2a^4+a^2*b^2-b^4+2δ a^2)/(b(a^2-b^2));
xError[a,a8,b8,getNagelTrilin]];

x8Error[1.5]

x10Error[a_]:=Module[{b=1,a10,b10,δ},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);
a10=((((a^2)+(b^2)) δ-(a^4)-(b^4))/(2 ((a^2)-(b^2)) a));
b10=((((a^2)+(b^2)) δ-(a^4)-(b^4))/(2 ((a^2)-(b^2)) b));
xError[a,a10,b10,getSpiekerTrilin]];

x10Error[1.5]

x12Error[a_]:=Module[{b=1,a12,b12,δ},
δ=(Sqrt[(a^4)-(a^2) (b^2)+(b^4)]);a12=(-b^2*(15*a^6+12*a^4*b^2+3*a^2*b^4+2*b^6)+(7*a^6+12*a^4*b^2+11*a^2*b^4+2*b^6)δ)/(a(7*a^6+11*a^4*b^2-11*a^2*b^4-7*b^6));b12=(-2*a^8-3*b^2*a^6-12*a^4*b^4-15*b^6*a^2+(2*a^6+11*a^4*b^2+12*a^2*b^4+7*b^6)δ)/(b(7*a^6+11*a^4*b^2-11*a^2*b^4-7*b^6));
xError[a,a12,b12,getX12Trilin]];

x12Error[1.5]

x40Error[a_]:=Module[{b=1,a40,b40},
a40=(a^2-b^2)/a;(*c^2/a*)
b40=(a^2-b^2)/b;(*c^2/b*)
xError[a,a40,b40,getBevanTrilin]];

x40Error[1.5]

Loci w/ Convex Combinations

convexPts[p_,q_,t_]:=(1-t)p+t q;

Convex Comb of edges

Clear@convVtx;
convVtx[a_,u_,tDeg_]:=Module[{lgt=.2,o1,ps,gr,o,n,s,ell,locus},
ell=plotEll[a];
o1=orbitNormals[a,toRad@tDeg][[1]];
ps=MapThread[convexPts[#1,#2,u]&,{o1,RotateLeft@o1}];
locus=Quiet@ParametricPlot[
{o,n,s}=orbitNormals[a,t];
convexPts[o[[1]],o[[2]],u],
{t,0,2π},PlotStyle->Red];
gr=Graphics[{FaceForm@None,PointSize@Large,Blue,Point@ps,EdgeForm@{Thick,Blue},Polygon@o1}];
Show[{ell,gr,locus}]];

Manipulate[convVtx[1.5,u,tDeg],{{u,.5},0,1,.01},{{tDeg,120},-180,180,1}]

trilineares: f(a,b,c) = 1/a.

f(a,b,c) = f(a,c,b)
f(a,b,c) = sin(A)*cos(B)*cos(C)

tril = [ f(a,b,c) : f(b,c,a) : f(c,a,b) ]
BARICENTRO : 1/a , 1/b, 1/c

Clear@convCevian;
convCevian[a_,p_,tDeg_]:=Module[{lgt=.2,o1,s1,cevs1,peds1,gr,cevs,peds,o,n,s,ell,locus,locusPedal,trils,trils1},
ell=plotEll[a,{Thick,Black}];
{o1,s1}=Part[orbitNormals[a,toRad@tDeg],{1,3}];
trils1=trilinearCoords[o1,p];
cevs1=cevianTriangle[o1,s1,trils1];
peds1=pedalTriangle[o1,s1,trils1];
(*locus=Quiet@ParametricPlot[
{o,n,s}=orbitNormals[a,t];
trils=trilinearCoords[o,p];
cevs=cevianTriangle[o,s,trils];
cevs[[1]],
{t,0,2π},PlotStyle->Red];
locusPedal=Quiet@ParametricPlot[
{o,n,s}=orbitNormals[a,t];
trils=trilinearCoords[o,p];
peds=pedalTriangle[o,s,trils];
peds[[1]],
{t,0,2π},PlotStyle->Darker@Green];*)
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@o1},
{Brown,Point@getBarycenterTrilin[o1,s1]},
{Lighter@Red,EdgeForm@Lighter@Red,Polygon@cevs1,Dashed,Point@cevs1,MapThread[Line@{#1,#2}&,{o1,cevs1}]},
{Green,EdgeForm@Green,Polygon@peds1,Dashed,Point@peds1,Line@{p,#}&/@peds1}}];
Show[{ell,gr(*,locus,locusPedal*)},ImageSize->Large]];

Locating point and calculate its trilinears with respect to a triangle (blue below) this won' t work because trilinears are *functions* of sidelengths or angles, e.g.: f(a,b,c)= k + a1 a + a2 a^2 + a3 a^3 +b1b + b2 b^2 + b3 b^3 + c1 c + c2 c^2 + c3 c^3.

Manipulate[convCevian[1.5,p,30],{{p,{0,0}},Locator}]

Incenter with First Intouch Point

Clear@getConvexIntouchLocus;
getConvexIntouchLocus[a_,tmax_,s_,(* 0 = incenter, 1 = intouch *)
ps_:("inc"/.ptClrs)]:=Module[{orbit,normals,sides,tps,inc},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
tps=intouchTriangle[orbit,sides];
inc=getIncenterTrilin[orbit,sides];
convexPts[inc,tps[[1]],s],
{t,0,tmax},PlotStyle->ps]
];

TO DO: which ρ makes the convex combo ((Subscript[X, 1]), (Subscript[I, 1]))=0 for isosceles in terms of (a, b), and calculate the ρ which makes (1 - ρ) X1 + ρ I1 = 0

getConvexIntouchLocus[1.5,2π,.56]

Options@convIncTps={drFrame->True};
convIncTps[a_,s_,OptionsPattern[]]:=Module[{lgt=.2,},
Legended[Show[{
plotEll[a],
incenterLocus[a,π,{"exc"/.ptClrs}],
getConvexIntouchLocus[a,2π,s,{Dashed,"inc"/.ptClrs}]},
ImageSize->Large,Frame->OptionValue@drFrame,AxesStyle->Lighter@Gray,PlotLabel->If[OptionValue@drFrame,
Style["s = "<>nf[s],20],""]],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell",(*"feu",*)"inc","inc"},
{{},(*{},*){},Dashed}}],
{"billiard",(*"caustic",*)"incenter","incenter-to-pedal"}]]]//Quiet

Show[convIncTps[1.5,.25,drFrame->False],ImageSize->Large]

Options@convIncTpsNoLegend={drFrame->True};
convIncTpsNoLegend[a_,s_,OptionsPattern[]]:=Module[{lgt=.2,thick=.0065},
Show[{
plotEll[a,{Thick,Black}],
Graphics@{Thick,Gray,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
incenterLocus[a,π,{"exc"/.ptClrs,Thickness@thick}],
getConvexIntouchLocus[a,2π,s,{Thickness@thick,Pink}]},
ImageSize->Large,Frame->OptionValue@drFrame,AxesStyle->Lighter@Gray,PlotLabel->If[OptionValue@drFrame,
Style["s = "<>nf[s],20],""]]//Quiet]

convIncPedalPlot=Module[{a=1.5,rhos={1,.8,5/9.,.25}},
Grid[Partition[MapThread[Show[convIncTpsNoLegend[a,#,drFrame->False],ImageSize->Large,PlotLabel->Style["ρ="<>nfn[#1,#2],{Black,20}]]&,{rhos,{1,1,4,1}}],2],Spacings->0,Frame->All]]

export3["1090_conv_inc_pedal",convIncPedalPlot];

Baricenter with First Median

Clear@getConvexMedianLocus;
getConvexMedianLocus[a_,tmax_,s_,(* 0 = baricenter, 1 = median *)
ps_:("bar"/.ptClrs)]:=Module[{orbit,normals,sides,meds,bar},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
meds=getMedians@@orbit;
bar=getBaricenter@@orbit;
convexPts[bar,meds[[1]],s],
{t,0,tmax},PlotStyle->ps]
];

convBariMed[a_,s_]:=Module[{lgt=.2},
Legended[Show[{
plotEll[a],
baricenterLocus[a,π/1.2,{"bar"/.ptClrs}],
getConvexMedianLocus[a,2π,s,{Dashed,"bar"/.ptClrs}]},
ImageSize->Large,Frame->True,AxesStyle->Lighter@Gray,
PlotLabel->Style["s = "<>nf[s],20]],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell",(*"feu",*)"bar","bar"},
{{},(*{},*){},Dashed}}],
{"billiard",(*"caustic",*)"baricenter","baricenter-to-median"}]]]//Quiet

Show[convBariMed[1.5,0.85],ImageSize->800,PlotRange->{{-1.5,1.5},{-.5,.5}}]

Clear@combineConvexBarInc;combineConvexBarInc[a_,s_,imgSize_:800]:=Row[{convBariMed[a,s],convIncTps[a,s]}];

combineConvexBarInc[1.5,.25,800]

First Excenter with First Extouch

Clear@getConvexExtouchLocus;
getConvexExtouchLocus[a_,tmax_,s_,(* 0 = excenter, 1 = extouch *)
ps_:("exc"/.ptClrs)]:=Module[{orbit,normals,sides,exc,tps},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
(*&&&*)
exc=getExcenters[orbit,normals];
tps=getExtouchPoints[orbit,exc];
convexPts[exc[[1]],tps[[1]],s],
{t,0,tmax},PlotStyle->ps]
];

convExcTps[a_,s_]:=Module[{lgt=.2},
Legended[Show[{
plotEll[a],
excenterLocus[a,2π,{"exc"/.ptClrs}],
getConvexExtouchLocus[a,2π,s,{Dashed,"exc"/.ptClrs}]},
ImageSize->Large,Frame->True,AxesStyle->Lighter@Gray,PlotRange->All,
PlotLabel->Style["s = "<>nf[s],20]],
Placed[LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell",(*"feu",*)"exc","exc"},
{{},(*{},*){},Dashed}}],
{"billiard",(*"caustic",*)"excenter","exc-to-extouch"}],Below]]]//Quiet

convExcTps[1.5,1]

Orthocenter to First Foot

Clear@getConvexOrtLocus;
getConvexOrtLocus[a_,tmax_,s_,(* 0 = orthocenter, 1 = foot *)
ps_:("ort"/.ptClrs)]:=Module[{orbit,normals,sides,ort,feet},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
ort=getOrthocenter@@orbit;
feet=getAltBases@@orbit;
convexPts[ort,feet[[1]],s],
{t,0,tmax},PlotStyle->ps]
];

convOrtFoot[a_,s_]:=Module[{lgt=.2},
Legended[Show[{
plotEll[a],
orthocenterLocus[a,π/1.2,{"ort"/.ptClrs}],
getConvexOrtLocus[a,2π,s,{Dashed,"ort"/.ptClrs}]},
ImageSize->Large,Frame->True,AxesStyle->Lighter@Gray,PlotRange->All,
PlotLabel->Style["s = "<>nf[s],20]],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell",(*"feu",*)"ort","ort"},
{{},(*{},*){},Dashed}}],
{"billiard",(*"caustic",*)"orthocenter","ort-to-foot"}]]]//Quiet

convOrtFoot[1.5,1]

Circumcenter to First Vertex

Clear@getConvexCirLocus;
getConvexCirLocus[a_,tmax_,s_,(* 0 = circumcenter, 1 = vertex *)
ps_:("cir"/.ptClrs)]:=Module[{orbit,normals,sides,cir},
ParametricPlot[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
(*&&&*)
cir=getCircumcenter@@orbit;
convexPts[cir,orbit[[1]],s],
{t,0,tmax},PlotStyle->ps]
];

convCirVtx[a_,s_]:=Module[{lgt=.2},
Legended[Show[{
plotEll[a],
circumcenterLocus[a,π/1.2,{"cir"/.ptClrs}],
getConvexCirLocus[a,2π,s,{Dashed,"cir"/.ptClrs}]},
ImageSize->Large,Frame->True,AxesStyle->Lighter@Gray,PlotRange->All,
PlotLabel->Style["s = "<>nf[s],20]],
LineLegend[MapThread[
Directive[{Thickness@Large,#2,#1/.ptClrs}]&,
{{"ell",(*"feu",*)"cir","cir"},
{{},(*{},*){},Dashed}}],
{"billiard",(*"caustic",*)"circumcenter","circ-to-vertex"}]]]//Quiet

convCirVtx[1.5,.585]

Clear@combineConvexOrtCir;combineConvexOrtCir[a_,s_,imgSize_:800]:=
Grid[{{},
{convOrtFoot[a,s],convCirVtx[a,s]}}
];

combineConvexOrtCir[1.5,.5]

Which Trilinears Lie on Hyperbola

Clear@sortHypPts;
sortHypPts[hyp_]:=Module[{ctr,hypA,hypB,xhat,yhat,ctrs},
ctr=hyp["ctr"];
ctrs=MapIndexed[Append[#1,First@#2]&,getNewCenters[hyp["orbit"],hyp["sides"]]]//Drop[#,{30,30}]&;
{hypA,hypB}={hyp["a"],hyp["b"]};
xhat={Cos[hyp["phi"]],-Sin[hyp["phi"]]};
yhat=perp@xhat;
{#[[1]],#[[2]],Abs@hypErr[hypA,hypB,{xhat.(#[[3]]-ctr),yhat.(#[[3]]-ctr)}],#[[4]]}&/@ctrs//Sort[#,#1[[3]]<#2[[3]]&]&//Select[#,#[[3]]<.001&]&//Sort[#,#1[[4]]<#2[[4]]&]&];

Clear@showHypLoci;
showHypLoci[hyp_]:=Module[{loci,ellA,ell,fs,ll,gr},
ellA=hyp["ellA"];
ell=plotEll[ellA,{Dashed,Gray}];
fs=getFoci[ellA];
ll=ListLinePlot[Legended[loci15t[[#[[4]]]],#[[1]]<>": "<>#[[2]]]&/@sortHypPts[hyp]];
gr=Graphics[{PointSize@Medium,Black,Point@fs}];
Show[{ell,ll,gr},Epilog->{Sequence@@drawHyp5b[hyp]},PlotRange->All,ImageSize->400,Frame->True]];(*{{-ellA,ellA},{-1.1,1.1}}]];*)

Which lie on the X100 hyperbola: only X(40) does

Module[{a=1.5,tDeg=33.,hyp},
hyp=getHypX100[a,tDeg];
(* remove euler infinity point *)
sortHypPts[hyp]//TableForm
]

showHypLoci[getHypX100[1.5,33.]]

Which lie on the Feuerbach X11 hyperbola

Module[{a=1.5,tDeg=33.,hyp},
hyp=getHypFeuerbach[a,tDeg];
sortHypPts[hyp]//TableForm
]

showHypLoci[getHypFeuerbach[1.5,33.]]

Miquel Point (on Extouchpoints) Locus

Clear@getMiquelPoint;
getMiquelPoint[a_,t_]:=Module[{o,n,s,ext,c1,r1,c2,r2,c3,r3,miquel1,miquel2,miquel,bevan},
{o,n,s}=orbitNormals[a,t];
bevan=getBevanTrilin[o,s];
ext=extouchTriangle[o,s];
c1=getCircumcenter[o[[1]],ext[[2]],ext[[3]]];r1=magn[c1-o[[1]]];
c2=getCircumcenter[o[[2]],ext[[3]],ext[[1]]];r2=magn[c2-o[[2]]];
c3=getCircumcenter[o[[3]],ext[[1]],ext[[2]]];r3=magn[c3-o[[3]]];
miquel1=circleInter[c1,r1,c2,r2];
miquel2=circleInter[c1,r1,c3,r3];
(* return the one common point of intersection *)
miquel=First@Intersection[miquel1,miquel2,SameTest->(negl@magn2[#1-#2]&)];
<|"o"->o,"ext"->ext,"cs"->{c1,c2,c3},"rs"->{r1,r2,r3},"bevan"->bevan,"miquel"->miquel|>];

Clear@getMiquelPointExc;
getMiquelPointExc[a_,t_]:=Module[{o,n,s,exc,c1,r1,c2,r2,c3,r3,miquel1,miquel2,miquel,inc},
{o,n,s}=orbitNormals[a,t];
inc=getIncenterTrilin[o,s];
exc=excentralTriangle[o,s];
c1=getCircumcenter[exc[[1]],o[[2]],o[[3]]];r1=magn[c1-exc[[1]]];
c2=getCircumcenter[exc[[2]],o[[3]],o[[1]]];r2=magn[c2-exc[[2]]];
c3=getCircumcenter[exc[[3]],o[[1]],o[[2]]];r3=magn[c3-exc[[3]]];
miquel1=circleInter[c1,r1,c2,r2];
miquel2=circleInter[c1,r1,c3,r3];
(* return the one common point of intersection *)
miquel=First@Intersection[miquel1,miquel2,SameTest->(negl@magn2[#1-#2]&)];
<|"o"->o,"exc"->exc,"inc"->inc,"cs"->{c1,c2,c3},"rs"->{r1,r2,r3},"miquel"->miquel|>];

Clear@miquelOfExtouchPoints;
miquelOfExtouchPoints[a_,t_,objs_]:=Module[{miquelData,gr},
miquelData=getMiquelPoint[a,t];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@miquelData["o"],Blue,Point@miquelData["o"],ellLabelPoints[a,miquelData["o"],"P",16,.15]},
{(*EdgeForm@Darker@Green,Polygon@ext,*)Darker@Green,Point@miquelData["ext"],ellLabelPoints[a,miquelData["ext"],"P'",16,.15]},
{Red,MapThread[Circle[#1,#2]&,{miquelData["cs"],miquelData["rs"]}],Point@miquelData["miquel"]},
{Darker@Cyan,Point@miquelData["cs"],EdgeForm@{Thick,Darker@Cyan},Polygon@miquelData["cs"]},
{Purple,Thick,Circle[miquelData["bevan"],.05]}
}];
Show[{objs["ell"],objs["caustic"],gr,objs["locus"],objs["locusCtrs"]},PlotRange->{{-2,2},{-1.75,1.75}},Frame->True,ImageSize->Large]];

DynamicModule[{cachedObjs},
Manipulate[
cachedObjs=<|
"ell"->plotEll[a,{Black,Thick}],
"caustic"->(plotEllb[Sequence@@getTriCausticParams[a],{Thick,"feu"/.ptClrs}]),
"locusCtrs"->Quiet@ParametricPlot[getMiquelPoint[a,t]["cs"][[1]],{t,0,2π},PlotStyle->{Darker@Cyan,Dashed,Thick}],
(*"ortlocus"->orthocenterLocus[a,π/1.2],*)
"locus"->Quiet@ParametricPlot[getMiquelPoint[a,t]["miquel"],{t,0,π/1.2},PlotStyle->{Red,Dashed,Thick}]|>;
Dynamic@miquelOfExtouchPoints[a,toRad@tDeg,cachedObjs],
{{a,1.5},1.01,2,.01},
{{tDeg,30},-180,180,.1,Appearance->"Open"}]]

Clear@miquelOfExcentral;
miquelOfExcentral[a_,t_,objs_]:=Module[{miquelData,gr},
miquelData=getMiquelPointExc[a,t];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@miquelData["o"],Blue,Point@miquelData["o"],ellLabelPoints[a,miquelData["o"],"P",16,.15]},
{EdgeForm@{Thick,Darker@Green},Polygon@miquelData["exc"],Darker@Green,Point@miquelData["exc"],ellLabelPoints[a,miquelData["exc"],"P'",16,.15]},
{Red,MapThread[Circle[#1,#2]&,{miquelData["cs"],miquelData["rs"]}],Point@miquelData["miquel"],Darker@Cyan,Point@miquelData["cs"],EdgeForm@{Thick,Darker@Cyan},Polygon@miquelData["cs"]},
{Darker@Green,Thick,Circle[miquelData["inc"],.075]}
}];
Show[{objs["ell"],gr,objs["locus"],objs["locusCtrs"]},PlotRange->{{-2.5,2.5},{-3.75,3.75}},Frame->True,ImageSize->Large]];

DynamicModule[{cachedObjs},
Manipulate[
cachedObjs=<|
"ell"->plotEll[a,{Black,Thick}],
"locusCtrs"->Quiet@ParametricPlot[getMiquelPointExc[a,t]["cs"][[1]],{t,0,2π},PlotStyle->{Darker@Cyan,Dashed,Thick}],
(*"ortlocus"->orthocenterLocus[a,π/1.2],*)
"locus"->Quiet@ParametricPlot[getMiquelPointExc[a,t]["miquel"],{t,0,π/1.305},PlotStyle->{Red,Dashed,Thick}]|>;
Dynamic@miquelOfExcentral[a,toRad@tDeg,cachedObjs],
{{a,1.5},1.01,2,.01},
{{tDeg,30},-180,180,.1,Appearance->"Open"}]]

Taylor Circle

http://mathworld.wolfram.com/TaylorCircle.html

Place radicand in terms of cosines only

Expand[(1-ca^2)(1-cb^2)(1-cc^2)+ca^2cb^2cc^2]

Clear@getTaylorRadius;getTaylorRadius[a_,tDeg_]:=Module[{o,n,s,ca,cb,cc,radicand,R},
{o,n,s}=orbitNormals[a,toRad@tDeg];
{ca,cb,cc}=getTriCosines[o];
radicand=1-(ca^2)-(cb^2)-(cc^2)+(ca^2) (cb^2)+(ca^2) (cc^2)+(cb^2) (cc^2);
R=getCircumradius@s;
R*Sqrt@radicand
];

Plot[getTaylorRadius[1.5,tDeg],{tDeg,0,360}]

Clear@getTaylorRadiusExc;getTaylorRadiusExc[a_,tDeg_]:=Module[{o,n,s,exc,excSides,ca,cb,cc,radicand,R},
{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
{ca,cb,cc}=getTriCosines[exc];
radicand=1-(ca^2)-(cb^2)-(cc^2)+(ca^2) (cb^2)+(ca^2) (cc^2)+(cb^2) (cc^2);
R=getCircumradius[triLengthsRL@exc];
R*Sqrt@radicand
];

getTaylorRadiusExc[1.5,0]

Plot[getTaylorRadiusExc[1.5,tDeg],{tDeg,0,360}]

Hunt for Equilaterals II: X370 [Needs for Cosine Circle Sim]

X369 : perimeter trisector

(*,as follows:x=bc(r-c+a)(r-a+b).Here x(a,c,b)≠x(a,b,c),so that y and z are not obtained from x by cyclically permutating a,b,c.At the geometry conference held at Miami University of Ohio,October 2,2004,Yff,proved that X(369) is also given by x1:y1:z1 where y1:z1 are given by cyclic permutations of a,b,c,in x1,where*)

(*x1=bc[r2-(2c+a)r+(-a2+b2+2c2+2bc+3ca+2ab].*)

Clear@getPerimeterTrisector;getPerimeterTrisector[tri_,{a_,b_,c_}]:=Module[{a2,b2,c2,r,r2,x1,y1,z1,x369,x369tri},
a2=a*a;b2=b*b;c2=c*c;
r=t/.First@Solve[2t^3-3(a+b+c)t^2+(a2+b2+c2+8b c+8c a+8a b)t-(c b2+a c2+b a2+5b c2+5c a2+5a b2+9a b c)==0,t,Reals];
r2=r*r;
x1=b c(r2-(2c+a)r+(-a2+b2+2c2+2b c+3c a+2a b));
y1=c a(r2-(2a+b)r+(-b2+c2+2a2+2c a+3a b+2b c));
z1=a b(r2-(2b+c)r+(-c2+a2+2b2+2a b+3b c+2c a));
x369=trilinearToCartesian[tri,{a,b,c},{x1,y1,z1}];
x369tri=cevianTriangle[tri,{a,b,c},{x1,y1,z1}];
{x369,x369tri}];

getPerimeterTrisector@@Part[orbitNormals[1.5,0],{1,3}]

Module[{a=1.5,t=0,trisectCtr,trisectTri,trisectSides,inc,bar},
{trisectCtr,trisectTri}=getPerimeterTrisector@@Part[orbitNormals[a,t],{1,3}];
trisectSides=triLengthsRL@trisectTri;
inc=getIncenterTrilin[trisectTri,trisectSides];
bar=getBarycenterTrilin[trisectTri,trisectSides];
{inc,bar}]

Simpler construction : single point of intersection of anti-tangent and excentral: X370

equilateralCevianCenter[tri_,{a_,b_,c_}]:=Module[{SA,SB,SC,a2=a^2,b2=b^2,c2=c^2,area,F,sols,solsSelBary,solsSelTrilin},
SA=(b2+c2-a2)/2;
SB=(c2+a2-b2)/2;
SC=(a2+b2-c2)/2;
area=triAreaHeron[{a,b,c}];
F=(2 area)/Sqrt@3;
sols={x,y,z}/.NSolve[{
y(1-y)SB+z(1-z)SC==x(1+x)F,
z(1-z)SC+x(1-x)SA==y(1+y)F,
x(1-x)SA+y(1-y)SB==z(1+z)F},{x,y,z}];
solsSelBary=First@Select[sols,(#[[1]]∈Reals)&&(#[[2]]∈Reals&&#[[3]]∈Reals)&&!negl@magn2@#&];
solsSelTrilin=MapThread[#1/#2&,{solsSelBary,{a,b,c}}];
trilinearToCartesian[tri,{a,b,c},solsSelTrilin]
]

Module[{o,n,s},
{o,n,s}=orbitNormals[1.5,toRad@33.];
equilateralCevianCenter[o,s]]

Yff Parabola and Mandart Circle

Mandart Circumcircle

getMandartCircumradiusOverInradius[a_,tDeg_]:=Module[{ons,ext,extSides},
ons=orbitNormals[a,toRad@tDeg];
ext=extouchTriangle[ons[[1]],ons[[3]]];
extSides=triLengthsRL@ext;
getCircumradius[extSides]/getInradius[extSides]
]

getMandartCircumradius[a_,tDeg_]:=Module[{ons,ext,extSides},
ons=orbitNormals[a,toRad@tDeg];
ext=extouchTriangle[ons[[1]],ons[[3]]];
extSides=triLengthsRL@ext;
getCircumradius[extSides]
]

getStats[Table[getMandartCircumradiusOverInradius[1.5,tDeg],{tDeg,0,359}]]

getStats[Table[getMandartCircumradius[1.5,tDeg],{tDeg,0,359}]]

Yff Circumcircle

YffVtx[a_?NumberQ,tDeg_?NumberQ]:=Module[{ons,x4,x9,x101,dirFoot,yff,focalDist,xhat,yhat,crossP,vtx},
ons=orbitNormals[a,toRad@tDeg];
{x4,x9,x101}=#[ons[[1]],ons[[3]]]&/@{getOrthocenterTrilin,getMittenTrilin,getX101Trilin};
dirFoot=closestPerp[x101,x4,x9];
yff=yffTriangle[ons[[1]],ons[[3]]];
focalDist=magn[x101-dirFoot]/2;
(* y = x^2/(4f) *)
crossP=crossProduct[x101-x9,x4-x101];
xhat=norm[x4-x9];
yhat=If[crossP<0,perp@xhat,perpNeg@xhat];
vtx=dirFoot+focalDist yhat;
vtx]

YffDirFoot[a_?NumberQ,tDeg_?NumberQ]:=Module[{ons,x4,x9,x101,dirFoot},
ons=orbitNormals[a,toRad@tDeg];
{x4,x9,x101}=#[ons[[1]],ons[[3]]]&/@{getOrthocenterTrilin,getMittenTrilin,getX101Trilin};
dirFoot=closestPerp[x101,x4,x9];
dirFoot]

Clear@drYffTri
drYffTri[a_,tDeg_]:=Module[{ons,yff,yffSides,ell,gr,x4,x9,x101,x190,dirFoot,lab,focalDist,yffArea,orbArea,par,xhat,yhat,crossP,vtx,vtx3234,dirLgt=a},
ell=plotEll[a,{Thick,Black}];
ons=orbitNormals[a,toRad@tDeg];
{x4,x9,x101,x190}=#[ons[[1]],ons[[3]]]&/@{getOrthocenterTrilin,getMittenTrilin,getX101Trilin,getX190Trilin};
dirFoot=closestPerp[x101,x4,x9];
yff=yffTriangle[ons[[1]],ons[[3]]];
focalDist=magn[x101-dirFoot]/2;
yffArea=signedArea[yff];
orbArea=-signedArea[ons[[1]]];
(* y = x^2/(4f) *)
crossP=crossProduct[x101-x9,x4-x101];
xhat=norm[x4-x9];
yhat=If[crossP<0,perp@xhat,perpNeg@xhat];
vtx=dirFoot+focalDist yhat;
vtx3234=getX3234Trilin[ons[[1]],ons[[3]]];
par=Quiet@ParametricPlot[(dirFoot+focalDist yhat+xhat x+yhat  x^2/(4focalDist)),{x,-2a,2a},PlotStyle->Darker@Green,PerformanceGoal->"Speed"];
lab="θ="<>nfn[tDeg,1]<>"°, f="<>nfn[focalDist,2]<>", (Subscript[A, orb])="<>nfn[orbArea,2]<>", (Subscript[A, yff])="<>nfn[yffArea,2]<>", (Subscript[A, yff])/(Subscript[A, orb])="<>nfn[yffArea/orbArea,2];
gr=Graphics[{FaceForm@None,Thick,PointSize@Large,
{Gray,Thickness@Medium,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{EdgeForm@{Thick,Darker@Red},Polygon@yff,Darker@Red,Point@yff},
{MapThread[{Point@#1,Text[Style[Subscript["X",ToString@#2],16],#1,{0,-1.5}]}&,{{x4,x9,x101,x190},{4,9,101,190}}]},
(* directrix of yff parabola passes through X9 and X4 *)
{Thickness@Medium,Line@{x4,x9},Line@{x4,x4+xhat*dirLgt},Line@{x9,x9-xhat*dirLgt},Line@{x101,dirFoot}},
{Purple,PointSize@Medium,Point@dirFoot,Text[Style["F",16],dirFoot,{1.5,-.5}]},
{Darker@Green,Dashed,Thickness@Small,MapThread[Line@{#1,#2}&,{ons[[1]],yff}]},
{Blue,Dashed,Thickness@Small,MapThread[Line@{#1,#2}&,{ons[[1]],RotateLeft@yff}]},
{Purple,Point@vtx,Text[Style["V",16],vtx,{0,-1.5}],Circle[vtx3234,.025],Text[Style["(Subscript[X, 3234])",16],vtx3234,{0,1.25}]}}];
Show[{ell,par,gr},PlotLabel->Style[lab,{Black,16}]]
]

DynamicModule[{a=1.5,max=3.5,vtxLocus,,dirFootLocus,eps=.01},
Manipulate[
vtxLocus=Quiet@ParametricPlot[YffVtx[a,tDeg+eps],{tDeg,0,180},
PlotStyle->{Orange},Axes->None,PerformanceGoal->"Speed"];
dirFootLocus=Quiet@ParametricPlot[YffDirFoot[a,tDeg+eps],{tDeg,0,140},
PlotStyle->{Purple},Axes->None,PerformanceGoal->"Quality"];
Dynamic@Show[{If[showLoci,{vtxLocus,dirFootLocus},{}],drYffTri[a,tDeg+eps]},
ImageSize->800,PlotRange->{{-max,max},{-max,max}}],{{tDeg,10.},-179,179,.1},{{showLoci,True},{False,True}},SaveDefinitions->True]
]

getYffCircumradiusOverInradius[a_,tDeg_]:=Module[{ons,yff,yffSides},
ons=orbitNormals[a,toRad@tDeg];
yff=yffTriangle[ons[[1]],ons[[3]]];
yffSides=triLengthsRL@yff;
getCircumradius[yffSides]/getInradius[yffSides]
]

getYffCircumradius[a_,tDeg_]:=Module[{ons,yff,yffSides},
ons=orbitNormals[a,toRad@tDeg];
yff=yffTriangle[ons[[1]],ons[[3]]];
yffSides=triLengthsRL@yff;
getCircumradius[yffSides]
]

getYffCircumradius[1.5,.3]

getStats[Table[getYffCircumradius[1.5,tDeg+.001],{tDeg,0,359}]]

X1 and X9 Cevian Triangles

showCevians[a_,tDeg_]:=Module[{ons,x9,gr,ell,cevianX9,x1,cevianX1,s1,s2,s3,lab},
ell=plotEll[a,{Thick,Black}];
ons=orbitNormals[a,toRad@tDeg];
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
x9=getMittenTrilin[ons[[1]],ons[[3]]];
{s1,s2,s3}=ons[[3]];
cevianX9=cevianTriangle[ons[[1]],ons[[3]],{s2+s3-s1,s3+s1-s2,s1+s2-s3}];
cevianX1=cevianTriangle[ons[[1]],ons[[3]],{1,1,1}];
lab="a="<>nfn[a,2]<>", (Subscript[L, 1])="<>nfn[triPer[cevianX1],3]<>", (Subscript[A, 1])="<>nfn[signedArea[cevianX1],3]<>", (Subscript[L, 9])="<>nfn[triPer[cevianX9],3]<>", (Subscript[A, 9])="<>nfn[signedArea[cevianX9],3];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{Darker@Red,Point@x9,EdgeForm@{Darker@Red,Thick},Polygon@cevianX9,Point@cevianX9,MapThread[Line@{#1,#2}&,{ons[[1]],cevianX9}]},{Darker@Green,Point@x1,EdgeForm@{Darker@Green,Thick},Polygon@cevianX1,Point@cevianX1,MapThread[Line@{#1,#2}&,{ons[[1]],cevianX1}]}}];
Show[{ell,gr},PlotLabel->lab]]

Manipulate[showCevians[1.5,tDeg],{{tDeg,10.},-180,180}]

X88: always on billiard, and collinear with X1 and X100

Plot[toDeg@getBilliardAngleTrilin[2,t,getX88Trilin],{t,180-25,180+25},ImageSize->Large,PlotRange->{All,{-10,10}}]

P1=(a cos t, sint) 
dado (x,y), qual o t: (tan^(-1))(y/a x)
t’ =  a (y’ x - x’ y)/(a^2 x^2 + y^2)
θ’ = (y' x - x' y)/(x^2 + y^2)

Module[{a=1.5,ts,xy,x,y,xdot,ydot,thdot,tdot,thlim=150,tstep=.1},
ts=Range[0,thlim,tstep];
xy=getTrilinXY[a,#,getX88Trilin]&/@ts;
x=First/@xy;
y=Second/@xy;
xdot=Differences[x]/toRad@tstep;
ydot=Differences[y]/toRad@tstep;
thdot=(ydot*Rest@x-xdot*Rest@y)/(Rest[x^2+y^2]);
tdot=a(ydot*Rest@x-xdot*Rest@y)/(Rest[a x^2+y^2]);
ListLinePlot[{Transpose@{ts,x},Transpose@{ts,y},Transpose@{Rest@ts,thdot/10},Transpose@{Rest@ts,tdot/10}},PlotStyle->{Red,Green,Blue,Purple},ImageSize->Large,AxesLabel->{"t",""},PlotRange->All,
PlotLabel->Style["(Subscript[X, 88]) motion, a="<>nfn[a,2],20],PlotLegends->(Style[#,20]&/@{"(Subscript[x, 88])","(Subscript[y, 88])","θ(Subscript[', 88])/10","t(Subscript[', 88])/10"})]]

Find Billiard Aspect Ratio for which X88 is on one vertex and X4 on another (right triangle)

Clear@x88err;
x88err[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,x88},
{o,n,s}=orbitNormals[a,toRad@tDeg];
x88=getX88Trilin[o,s];
magn2[o[[1]]-x88]]

FindMinimum[{x88err[1.5,tDeg]},{tDeg,20.5}]

Plot[x88err[1.5,tDeg],{tDeg,18,22}]

(* for the x88 on vertex and right tri *)
Clear@x88errRect;
x88errRect[a_?NumericQ,tDeg_?NumericQ]:=Module[{o1,n1,s1,x88,x4,},
{o1,n1,s1}=orbitNormals[a,toRad@tDeg];
x88=getX88Trilin[o1,s1];
x4=getOrthocenterTrilin[o1,s1];
magn2[o1[[1]]-x88]+magn2[o1[[2]]-x4]];

FindMinimum[{x88errRect[a,tDeg],a>1.3&&a<1.5&&tDeg>23&&tDeg<24},{{a,1.4},{tDeg,23.5}}]

Ronaldo : X88 e X100, ponto medio, locus

Clear@getX88objs;
getX88objs[a_?NumericQ,t_?NumericQ]:=Module[{o,n,s,x1,x88,x100,mid},
{o,n,s}=orbitNormals[a,t];
x1=getIncenterTrilin[o,s];
x88=getX88Trilin[o,s];
x100=getX100Trilin[o,s];
mid=(x88+x100)/2;
{x1,x88,x100,mid}];

(* not sure how to add colors to list *)

Clear@showMid88to100;
showMid88to100[a_]:=
ListLinePlot[Transpose@Table[getX88objs[a,th],{th,0,2π,π/1000}]//Evaluate,
PlotLegends->{"x1","x88","x100","(x88+x100)/2"},AspectRatio->Automatic,Frame->True,FrameStyle->Medium,PlotRange->All,PlotLabel->Style["a="<>nfn[a,2],16]]

showMid88to100[1.35]

showMid88to100[3.]

X59 four loops

X1, X100, X59, X88 are aligned

lawOfCosines[a,b,c]

Module[{cosA,cosB,cosC,sinA,sinB,sinC,x59t1,x59t2,x59t3,a=1},
{cosA,cosB,cosC}={lawOfCosinesSymbol[a,b,c],lawOfCosinesSymbol[b,a,c],lawOfCosinesSymbol[c,a,b]};
{sinA,sinB,sinC}=getSinSymbol/@{cosA,cosB,cosC};
x59t1=FullSimplify[1/(1-cosB cosC-sinB sinC ),a>0&&b>a&&c>a];
x59t2=FullSimplify[1/(1-cosC cosA-sinC sinA ),a>0&&b>a&&c>a];
x59t3=FullSimplify[1/(1-cosA cosB-sinA sinB ),a>0&&b>a&&c>a];
Factor@FullSimplify[Det[{{1,1,1},
{1/(b-c),1/(c-a),1/(a-b)},
{x59t1,x59t2,x59t3}}]==0,b>0&&c>0]]

plotX59Yerror[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,x59},
{o,n,s}=orbitNormals[a,toRad@tDeg];
x59=getX59Trilin[o,s];
x59[[1]]^2]

FindMinimum[{plotX59Yerror[1.3,tDeg]},{tDeg,29.}]

FindMinimum[{plotX59Yerror[1.5,tDeg]},{tDeg,23.5}]

plotX59[1.5,deg1->29.085,drX4->True]

sols59=Table[FindMinimum[{plotX59Yerror[a,tDeg],tDeg>27&&tDeg<35},{tDeg,28.}],{a,1.2,1.5,.05}]

MapThread[plotX59[#1,deg1->#2]&,{Range[1.2,1.5,.05],(tDeg/.Second@#)&/@sols59}]

ListLinePlot[Transpose@{Range[1.2,2.0,.05],(tDeg/.Second@#)&/@sols59}]

plotX59YerrorRightTriangle[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,x59,x4},
{o,n,s}=orbitNormals[a,toRad@tDeg];
x59=getX59Trilin[o,s];
x4=getOrthocenterTrilin[o,s];
x59[[1]]^2+magn2[x4-o[[2]]]]

FindMinimum[{plotX59YerrorRightTriangle[a,tDeg],a>1.5&&a<2.},{{a,1.51},{tDeg,23.5}}]

plotX59[1.58005,deg1->27.9211,drX4->True]

X4: show locus

Clear@showOrt;
Options@showOrt={p1Dist->.125,drOrthic->False,drP1->True,drOrthicLocus->False,orthicLocusThickness->.0125,x4displ->{1.25,-1.25},drAlts->False,fontSize->20,drAngle->False};
showOrt[a_,tDeg_,OptionsPattern[]]:=Module[{ons,o1,n1,s1,ort1,degStep=.5,degs,poly1,ell,gr,grads1,clr={Blue,Thick},lgt=.33,orts,clrs,orthic,orthicLocus,ortFeet},
degs=Range[0,360-degStep,degStep];
ell=plotEll[a,{Thick,Black}];
ons=orbitNormals[a,toRad@#]&/@degs;
orthicLocus=If[OptionValue@drOrthicLocus,(orthic=orthicTriangle[#[[1]],#[[3]]]; getIncenterTrilin[orthic,triLengthsRL@orthic])&/@ons,{}];
{o1,n1,s1}=orbitNormals[a,toRad@tDeg];
ort1=getOrthocenterTrilin[o1,s1];
ortFeet=orthicTriangle[o1,s1];
orts=MapThread[getOrthocenterTrilin[#1,#2]&,{First/@ons,Third/@ons}];
orthic=orthicTriangle[o1,s1];
grads1=ellGrad[a,Sequence@@#]&/@poly1;
clrs=#/.ptClrs&/@{"ort"};
gr=Graphics[{clr,FaceForm@None,PointSize@Large,
{Dashed,Gray,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}},Point@{0,0}},
MapThread[{#1,Thick,Line@#2}&,{clrs,{orts}}],
MapThread[{#1,Point@#2,Text[Style[Subscript["X",#3],OptionValue@fontSize],#2,#4]}&,
{clrs,{ort1},{4},
{OptionValue@x4displ}}],
If[OptionValue@drP1,{Black,ellLabelTxt[a,o1[[1]],Style["(Subscript[P, 1])(t)",OptionValue@fontSize],OptionValue@p1Dist]},{}],
If[OptionValue@drOrthic,{EdgeForm@{Thick,Purple},Polygon@orthic,Purple,Point@orthic}],
If[OptionValue@drOrthicLocus,{Thickness@OptionValue@orthicLocusThickness,Purple,Line@orthicLocus}],
If[OptionValue@drAlts,{Thick,PointSize@Medium,Point@ortFeet,Dashed,Blue,MapThread[Line@{#1,#2}&,{o1,RotateLeft@ortFeet}],Orange,Line@{#,ort1}&/@o1},{}],
{EdgeForm@clr,Polygon@o1,Point@o1}
}];
Show[{ell,gr},PlotLabel->Style["a/b="<>nfn[a,3]<>If[OptionValue@drAngle,", θ="<>nfn[tDeg,3],""],20]]]

X26: explodes when orbit is right triangle

Clear@plotX26;
Options@plotX26={xdispl->{0,-1.5},lgt->.22,degStep->.1,degMax->180.};plotX26[a_,tDeg_,OptionsPattern[]]:=Module[{ons,o1,n1,s1,x26,x26locus,deg0=0.1,x3,tangTri,degs,poly1,ell,gr,clr={Blue,Thick},xclr="hex"/.ptClrs,fontSize=20},
degs=.01+Range[0,OptionValue@degMax-OptionValue@degStep,OptionValue@degStep];
ell=plotEll[a,{Thick,Black}];
ons=orbitNormals[a,toRad@#]&/@degs;
{o1,n1,s1}=orbitNormals[a,toRad@tDeg];
x26=getX26Trilin[o1,s1];
x3=getCircumcenterTrilin[o1,s1];
x26locus=MapThread[getX26Trilin[#1,#2]&,{First/@ons,Third/@ons}];
tangTri=tangentialTriangle[o1,s1];
gr=Graphics[{clr,FaceForm@None,PointSize@Large,
{EdgeForm@clr,Polygon@o1,Point@o1,ellLabelPoints[a,o1,"P",fontSize,OptionValue@lgt]},
(*{Dashed,pclr,Thick,Line@{#,p1}&/@o1},*)
{Dashed,Black,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}},Point@{0,0}},
{xclr,Thick,Line@x26locus},
{xclr,Point@x26,Text[Style["(Subscript[X, 26])",fontSize],x26,OptionValue@xdispl],{EdgeForm@{Dashed,Thick,Darker@Green},Polygon@tangTri,Darker@Green,Point@tangTri},{Darker@Green,Thick,Circle[x26,magn[x26-tangTri[[1]]]]}},{"cir"/.ptClrs,Thick,Circle[x3,magn[x3-o1[[1]]]],Point@x3,Text[Style["(Subscript[X, 3])",fontSize],x3,OptionValue@xdispl]}
}];
Show[{ell,gr},PlotLabel->Style["a="<>nfn[a,2]<>", t="<>nfn[tDeg,1]<>"°",20]]];

Manipulate[Show[plotX26[1.25,tDeg,xdispl->{-1.5,0}],PlotRange->{{-2,6},{-4.25,5}}],{{tDeg,5},-180,180}]

Clear@showX26;
Options@showX26={"proj"->"none"};
showX26[a_,OptionsPattern[]]:=Module[{o,n,s,p},
Quiet@ParametricPlot[
{o,n,s}=orbitNormals[a,t];
p=getX26Trilin[o,s];
p=Switch[OptionValue@"proj","stereo",Take[stereographicProj@@p,2],"spherical",sphereProj@@p,"spherical2",sphereProj2@@p,"spherical3",sphereProj3@@p,"logProj",logProj@@p,_,p];
p,{t,0,2π},Frame->True,FrameStyle->Medium,PlotRange->All,PlotLabel->Style["a/b="<>nfn[a,2],16]]]

Partition[showX26/@Range[1.1,1.35,.05],3]//Grid

Partition[showX26[#,"proj"->"stereo"]&/@Range[1.1,1.5,.05],3]//Grid

Partition[Show[showX26[#,"proj"->"spherical2"],AspectRatio->1]&/@Range[1.1,1.5,.05],3]//Grid

Partition[Show[showX26[#,"proj"->"spherical3"],AspectRatio->1]&/@Range[1.1,1.5,.05],3]//Grid

Partition[Show[showX26[#,"proj"->"logProj"],AspectRatio->1]&/@Range[1.1,1.5,.05],3]//Grid

X40: golden billiard @ a/b=ϕ

getNextGoldenBevan[x40_,upright_:True]:=Module[{o,s,phi=(1+Sqrt@5)/2},
If[upright,
{o,s}={"orbit","sides"}/.getOrbitData[phi,x40[[2]],posY->(x40[[1]]<0)];
o=perp/@o,
{o,s}={"orbit","sides"}/.getOrbitData[phi,x40[[1]],posY->(x40[[2]]>0)]];
getBevanTrilin[o,s]];
Clear@plotX40;
Options@plotX40={p1Dist->.125,drP1->True,degStep->.5,inward0->False,locusThickness->.0125,lgt->.1,fontSize->20,clr->Purple,shortLabel->False,topBotVtx->False,ellStyle->{Thick,Black},drOrbit2->False};
plotX40[a_,tDeg_,OptionsPattern[]]:=Module[{ell,degs,ons,locus,o1,n1,s1,p1,gr,a40,b40,r,R,exc,excR,o2,s2,p1b,p1c,p1bs,lab},
ell=plotEll[a,OptionValue@ellStyle];
degs=Range[0,360-OptionValue@degStep,OptionValue@degStep];
{o1,n1,s1}=orbitNormals[a,toRad@tDeg];
a40=(a*a-1)/a;b40=(a*a-1);
p1=getBevanTrilin[o1,s1];
exc=excentralTriangle[o1,s1];
excR=magn[exc[[1]]-p1];
r=getInradius[s1];
R=getCircumradius[s1];

{o2,s2}={"orbit","sides"}/.getOrbitData[b40/a40,p1[[2]]/a40,posY->(p1[[1]]<0)];
o2=(a40*#)&/@o2;
s2=(a40*#)&/@s2;
o2=perp/@o2;
(*p1b=getBevanTrilin[o2,s2];*)
(* implement get next bevan *)
p1b=getNextGoldenBevan[p1];
p1c=getNextGoldenBevan[p1b,False];
p1bs=Second/@NestList[{#[[2]]+1,getNextGoldenBevan[#[[2]],!EvenQ[#[[1]]]]}&,{1,p1},3];

lab=Style["a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,2]<>"°"<>If[OptionValue@shortLabel,"",", excR="<>nfn[excR,3]<>", r/R="<>nfn[r/R,3]],{Black,20}];
gr=Graphics[{FaceForm@None,PointSize@Large,
{Dashed,Gray,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{"cir"/.ptClrs,Point@p1,
(* &&& nao ta funcionando *)
ellLabelTxtb[a40,b40,p1,Style["(Subscript[X, 40])",OptionValue@fontSize],OptionValue@lgt,inward->(OptionValue@inward0)],
(*Text[Style["(Subscript[X, 40])",OptionValue@fontSize],p1,OptionValue@displ]*),
Thick,Circle[{0,0},{a40,b40}]},
{{EdgeForm@{Thick,Darker@Green},Polygon@exc},If[OptionValue@drOrbit2,{EdgeForm@{Thick,Dashed,Purple},Polygon@o2,Black,Point@p1b,Orange,Point@p1c},{}] ,Dashed,Darker@Green,Thick,Circle[p1,excR],Point@exc},
If[OptionValue@topBotVtx,{"cir"/.ptClrs,Point@{0,b40},Point@{0,-b40}},{}],
{EdgeForm@{Thick,Blue},Polygon@o1,Blue,Point@o1}
}];
Show[{ell,gr},PlotRange->{{-5,5},{-5,5}},PlotLabel->lab]]

Manipulate[Show[plotX40[a,tDeg,lgt->.5,shortLabel->True,drOrbit2->True],ImageSize->Large],{{a,(1.+Sqrt@5.)/2},1.001,2,.01},{{tDeg,0},-180,180,.05}]

Which right triangle is produced by the Golden Billiard?

Clear@x4err;
x4err[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,x4},
{o,n,s}=orbitNormals[a,toRad@tDeg];
x4=getOrthocenterTrilin[o,s];
ellError[a,1,x4]^2]

(1) we get a right triangle when the aspect ratio = a4, and a vertex is at the top

Module[{a4=Sqrt[2Sqrt[2]-1.]},
x4err[a4,90.]]

tDeg0phi=Module[{phi=(1+Sqrt@5)/2.},
FindMinimum[{x4err[phi,tDeg]},{tDeg,45}]]

Module[{tDeg0=tDeg/.tDeg0phi[[2,1]],phi=(1+Sqrt@5)/2.,o,n,s},
{o,n,s}=orbitNormals[phi,toRad@tDeg0];
Print["sidelengths: ",s];
Print["s2/s3=",s[[2]]/s[[3]]];
showOrt[phi,tDeg0,drAngle->True]]

Incentral Triangle

Module[{a=1.5,o,n,s,tri},
Quiet@ParametricPlot[
{o,n,s}=orbitNormals[a,t];
tri=incentralTriangle[o,s];
tri[[1]],{t,0,2π}]]

Ellipticity via Trilinears

getEllTrils[a_,t_]:=Module[{cosA,cosB,cosC,sinA,sinB,sinC,sinBC, cosBC,cosBmC,xell,xnonell},
{cosA,cosB,cosC}=getOrbitCosines[a,t];
{sinA,sinB,sinC}=getSin/@{cosA,cosB,cosC};
cosBC=cosB  cosC;
sinBC=sinB sinC;
cosBmC=cosBC+sinBC;
xell={
{2,cosA+cosBmC},
{3,cosA},
{4,cosA-cosBmC},
{5,cosBmC},
{7,1/(1+cosA)},
{20,cosA - cosBC}};
(*X(8):1/(1-cosA)
X(10):(cosB+cosC)/(1-cosA)
X(11):1-cos(B-C)
X(12):1+cos(B-C)
X(20):cosA-cosB cosC
X(21):1/(cosB+cosC)
X(35):1+2 cosA
X(36):1-2 cosA
X(40):cosB+cosC-cosA-1*)
xnonell={
{6,sinA},
{30,cosA-2 cosB cosC}
};
(*X(6):sinA[cosseno "fora de fase"]
X(13):1/cos(A-π/6)
X(14):1/cos(A+π/6)
X(15):cos(A-π/6)
X(16):cos(A+π/6)
X(17):1/cos(A-π/3)
X(18):1/cos(A+π/3)
X(19):tanA[ou:sin(2B)+sin(2C)-sin(2A)]
X(22):a(b^4+c^4-a^4)[quartica]
X(23):a(b^4+c^4-a^4-b^2 c^2)
X(24):cos2A/cosA
X(25):sinA tanA[ou:cosA-secA]
X(26):a[b^2 cos2B+c^2 cos2C-a^2 cos2A]
X(27):(secA)/(b+c)
X(28):(tanA)/(b+c)
X(29):(secA)/(cosB+cosC)
X(30):cosA-2 cosB cosC
X(31):1-cos2A
X(32):sin(A-ω)[ou:a^3]
X(33):1+1/cosA
X(34):1-1/cosA
X(37):b+c[angle form possible?]
X(38):sin(A+ω)/sinA
X(39):sin(A+ω)*)<|"xell"->xell,"xnonell"->xnonell|>];

Module[{xs,xells,xnonells,plells,plnonells},
xs=Table[getEllTrils[1.5,toRad@tDeg],{tDeg,-90,90}];
xells=#["xell"]&/@xs;
xnonells=#["xnonell"]&/@xs;
plells=First/@Table[First/@Transpose[xells][[i]],{i,Length@Transpose@xells}];
plnonells=First/@Table[First/@Transpose[xnonells][[i]],{i,Length@Transpose@xnonells}];
Print@plells;
Grid[{
{ListLinePlot[Table[Second/@Transpose[xells][[i]],{i,Length@Transpose@xells}],PlotLegends->plells, Frame->True,ImageSize->Large]},
{ListLinePlot[Table[Second/@Transpose[xnonells][[i]],{i,Length@Transpose@xnonells}],PlotLegends->plnonells,Frame->True,ImageSize->Large]}}]
]

Irrational Centers by Clark Kimberling, are they all non - elliptic?

1) Non-Elliptic Rational :
    
X(6) = a ::
X(19) = 1/(b^2 + c^2 - a^2) ::
X(22) = a(b^4 + c^4 - a^4) ::
X(23)= a(b^4 + c^4 - a^4 - b^2 c^2)
X(24)= a (a^4 + b^4 + c^4 - 2 a^2 b^2 - 2 a^2 c^2)/(a^2 - b^2 - c^2) ::
X(25)=a/(b2 + c2 - a2) 
X(26)=a (a^8 - 2 a^6 (b^2 + c^2) + 2 a^2 (b^6 + c^6) - (b^2 - c^2)^2 (b^4 + c^4))

X(27)=
X(28)=
X(29)=
X(30)=
X(31)=
X(32)=
X(33)=
X(34)=

2) Non-Elliptic Irrational (Conway’s S = ab sinA = 2Δ = irrational). Jair’s comment: Heron’s formula Sqrt[(a+b+c)....]

Sa,Sb,Sc, Area(ABC)

X(13) = sec(A - π/6) ::
X(14) = sec(A + π/6) ::
X(15) = cos(A - π/6) :: = a^2*(Sqrt[3]*(a^2 - b^2 - c^2) - 2*S) ::
X(16) = cos(A + π/6) ::
X(17) = sec(A - π/3) ::
X(18) = sec(A + π/3) ::

====
X(168) = X(9) of Excentral

===

Jair: vamos fazer uma 2a verao do applet q aceite formula algebrica em a,b,c,S,Sa,Sb,Sc
 
X(364) = b^1/2 + c^1/2 - a^1/2 ::
X(365) = a^1/2 ::
X(366) = a^-1/2 ::

Good question: can any member in these families of T.C. produce elliptic loci?

- irrationals
- cubics
- quintics?
- etc.

Poncelet Triangles & Central Circles

What is the radius of a circle centered on (x, y) in an ellipse which permits a poncelet N = 3 polygon to be formed?

Clear@rPonceletCtrEqn;
rPonceletCtrEqn[a_,b_]=Module[{P,eqn1,eqn1coeffs,discr,cos2Alpha,tanAlpha,t0,Q,reqn,sa,tangs,ca},
P={0,b}+t{Sin@α,-Cos@α};
eqn1=P.P-r^2;
eqn1coeffs=FullSimplify@CoefficientList[eqn1,t];
discr=eqn1coeffs[[2]]^2-4eqn1coeffs[[3]]eqn1coeffs[[1]];
cos2Alpha=First[ca2/.Solve[(discr/.(Cos@α)^2->ca2)==0,ca2]];
ca=Sqrt[cos2Alpha];sa=Sqrt[1-cos2Alpha];
tanAlpha=Sqrt[(1-cos2Alpha)/cos2Alpha];
Q={(b+r)tanAlpha,-r};
reqn=FullSimplify[(Q[[1]]/a)^2+(Q[[2]]/b)^2==1,r>0&&a>0&&b>0];
(r/.Solve[reqn,r])
]

Clear@TangsToCircTopEqn;
TangsToCircTopEqn[y_,r_]=Module[{P,eqn1,eqn1coeffs,discr,cos2Alpha,tanAlpha,t0,Q,reqn,sa,tangs,ca},
P={0,y}+t{Sin@α,-Cos@α};
eqn1=P.P-r^2;
eqn1coeffs=FullSimplify@CoefficientList[eqn1,t];
discr=eqn1coeffs[[2]]^2-4eqn1coeffs[[3]]eqn1coeffs[[1]];
cos2Alpha=First[ca2/.Solve[(discr/.(Cos@α)^2->ca2)==0,ca2]];
ca=Sqrt[cos2Alpha];sa=Sqrt[1-cos2Alpha];
t0=y*ca;
tangs=FullSimplify[{{0,y}+t0{sa,-ca},{0,y}+t0{-sa,-ca}},y>0&&r>0];
tangs
]

PonceletCtrRadius[a_,b_]:=(a*b)/(a+b);

(* from point (0,y) *)
Clear@TangsToCircTop;
TangsToCircTop[y_,r_]:=Module[{tang1,tang2},
tang1=(r/y){(Sqrt[(y-r) (y+r)]),r};
tang2=flipX@tang1;
{tang1,tang2}];

PonceletCtrRadius[1.5,1]

TangsToCircTop[1,PonceletCtrRadius[1.5,1]]

Clear@TangsToCircAnyEqn;
TangsToCircAnyEqn[x_,y_,r_]:=Module[{b,tangs,yhat,xhat,rotInv},
b=magn[{x,y}];
yhat={x,y}/b;
xhat=perpNeg[yhat];
rotInv=Transpose@{xhat,yhat};
tangs=TangsToCircTop[b,r];
(rotInv.#)&/@tangs
]

Module[{u=π/2},
TangsToCircAnyEqn[1.5 Cos@u,Sin@u,PonceletCtrRadius[1.5,1]]]

N=3 externo elipse (a,b), interno circulo r = ab/(a+b)

getTriInfo[tri_,tangsU_,feetU_]:=Module[{sides,feu,bar,x100,coss,sins},
sides=triLengthsRL@tri;
feu=getFeuerbachTrilin[tri,sides];
bar=getBarycenterTrilin[tri,sides];
x100=bar+2(bar-feu);
coss=getTriCosines[tri];
sins=Sqrt[1-#]&/@coss;
<|"tri"->tri,
"sides"->sides,
"exc"->excentralTriangle[tri,sides],
"orthic"->orthicTriangle[tri,sides],
"act"->anticomplementaryTriangle[tri,sides],
"coss"->coss,
"cosSum"->Total@coss,
"sinSum"->Total@sins,
"sinProd"->Apply[Times,sins],
"cosProd"->Apply[Times,coss],
"tangs"->tangsU,
"feet"->feetU,
"per"->Total@sides,
"per2"->Total[sides^2],
"area"->Abs@signedArea@tri,
"r"-> getInradius@sides,
"R"->getCircumradius@sides,
"inc"->getIncenterTrilin[tri,sides],
"bar"->bar,
"cir"->getCircumcenterTrilin[tri,sides],
"ort"->getOrthocenterTrilin[tri,sides],
"npc"->getNinepointCenterTrilin[tri,sides],
"sym"->getSymmedianTrilin[tri,sides],
"ger"->getGergonneTrilin[tri,sides],
"nag"->getNagelTrilin[tri,sides],
"mit"->getMittenTrilin[tri,sides],
"spi"->getSpiekerTrilin[tri,sides],
"feu"->feu,
"x100"->x100
(*"x100t"->x100t,*)
|>];

Clear@getPoncU;
getPoncU[a_,u_]:=Module[{r,P1,tangsU,feetU,triPonc},
r = a/(a+1);
P1={a Cos@u,Sin@u};
tangsU=TangsToCircAnyEqn[Sequence@@P1,r];
feetU=ellInterRayUnprot[a,P1,#-P1][[2]]&/@tangsU;
triPonc={P1,Sequence@@feetU};
getTriInfo[triPonc,tangsU,feetU]];

getPoncU[1.4,.1]

Which are circular: X1,X3,X11

PonceletCircularity[a_,degStep_]:=Module[{ctrs,locs},
ctrs={"inc","bar","cir","ort","npc","sym","ger","nag","mit","spi","feu","x100"};
locs=Transpose@Table[magn[getPoncU[a,toRad@(v+.001)][#]]&/@ctrs,{v,0,360,degStep}];
Pick[ctrs,negl[#["z"]]&/@getStats/@locs]]

PonceletCircularity[1.5,1]

Clear@drawPonceletCtr;
Options@drawPonceletCtr={drRefTri->False,drLabels->False,drLoci->False,drCircs->False,degStep->1.,drExc->False};
drawPonceletCtr[a_,u_,OptionsPattern[]]:=Module[{ell,r,gr,fs,c2a,ta,Q,tri,triPonc,lab,tangs,
locX2,locX3,locX4,locX5,locX9,locX11,locX100,clrs,ctrs,locis,lociExc},
clrs={Brown,Purple,Orange,Pink,Darker@Red,Gray,Gray};
ctrs={"bar","cir","ort","npc","mit","feu","x100"};
locis={True,True,True,True,True,False,False};
ell=plotEll[a,{Thick,Black}];
fs=getFoci[a];
r=PonceletCtrRadius[a,1];
c2a=(1-r)(1+r);
ta=Sqrt[(1-c2a)/c2a];
Q={(1+r)ta,-r};
tri={{0,1},Q,flipX@Q};
tangs=TangsToCircTop[1,r];
triPonc=getPoncU[a,u];
lociExc=If[OptionValue@drLoci,Table[getPoncU[a,toRad@(v+.001)]["exc"][[1]],{v,0,360,OptionValue@degStep}],{}];
If[OptionValue@drLoci,{locX2,locX3,locX4,locX5,locX9,locX11,locX100}=Transpose@Table[getPoncU[a,toRad@(v+.001)][#]&/@ctrs,{v,0,110,OptionValue@degStep}]];
gr=Graphics[{PointSize@Large,FaceForm@None,Thick,
{PointSize@Medium,Black,Point@fs,Darker@Green,Point@{0,0}},
{EdgeForm@{Thick,Darker@Green},FaceForm@{Darker@Green,Opacity@.1},Disk[{0,0},r]},
If[OptionValue@drRefTri,
{Blue,Point@tri,EdgeForm@{Thick,Blue},Polygon@tri(*,Blue,Point@tangs*)},{}],
{Blue,Point@triPonc["tri"][[1]],(*Point@triPonc["tangs"],*)Line@{triPonc["tri"][[1]],#}&/@triPonc["feet"],Point@triPonc["feet"],(*Dashed,*)Line@triPonc["feet"]},
If[OptionValue@drExc,{EdgeForm@{Thick,Darker@Green},Polygon@triPonc["exc"]},{}],
If[OptionValue@drCircs,
{{Purple,Circle[triPonc["cir"],triPonc["R"]]},
{Pink,Circle[triPonc["npc"],triPonc["R"]/2]}},{}],
If[OptionValue@drLoci,
{MapThread[{#1,If[#3,Line@#2,{}]}&,{clrs,{locX2,locX3,locX4,locX5,locX9,locX11,locX100},locis}]},{}],
If[OptionValue@drLoci,{Thick,Darker@Green,Line@lociExc},{}],
If[OptionValue@drLabels,
MapThread[{#1,Text[Style[Subscript["X",#2],14],triPonc[#3],{0,-1.5}],Point@triPonc[#3]}&,
{clrs,
{2,3,4,5,9,11,100},
ctrs}],{}]
}];
lab="a="<>nfn[a,2]<>", r="<>nfn[r,3]<>" ,R="<>nfn[triPonc["R"],3](*<>"\nL="<>nfn[triPonc["per"],3]<>", A="<>nfn[triPonc["area"],3]*);
Show[{ell,gr},PlotLabel->Style[lab,{16,Black}],ImageSize->400,PlotRange->{1.1{-3,3},1.1{-3,3}}]];

Manipulate[drawPonceletCtr[a,toRad@tDeg,
drCircs->drCircs0,
drExc->drExc0,
drLoci->drLoci0,
drLabels->drLabels0],
{{a,2.},1.01,3},
{{tDeg,30},-180,180,1},
{{drExc0,False},{False,True}},
{{drCircs0,False},{False,True}},
{{drLoci0,False},{False,True}},
{{drLabels0,False},{False,True}}]

Module[{a=2.,tDeg=-30},Grid[{Show[#,PlotRange->{1.1{-a,a},{1.1,-2}},
PlotLabel->None]&/@
{drawPonceletCtr[a,toRad@tDeg,drCircs->False,drLoci->False],
drawPonceletCtr[a,toRad@tDeg,drCircs->True,drLoci->False],
drawPonceletCtr[a,toRad@tDeg,drCircs->True,drLoci->True,drLabels->True]}}]]

Clear@drOnePoncCirc;
drOnePoncCirc[a_,tDeg_]:=Show[drawPonceletCtr[a,toRad@tDeg,drCircs->True,drLoci->True,drLabels->True],
PlotRange->{1.1{-a,a},{a,-a}},
ImageSize->800,
PlotLabel->None];

drOnePoncCirc[3.,30.]

N=3: externo circulo r=(a+b), interno elipse (a,b)

Clear@getPoncOuterU;
getPoncOuterU[a_,u_]:=Module[{r=a+1,Pinner,Pouter,ellTang,P1,tangsU,feetU,triPonc},
Pinner={a Cos@u,Sin@u};
ellTang=perp[ellGrad[a,Sequence@@Pinner]];
P1=ellInterRaybUnprot[r,r,Pinner,ellTang][[1]];
(*P1=r{Cos@u,Sin@u};*)
tangsU=ellTangents[a,P1];
(* should be inter w circ *)
feetU=(ellInterRaybUnprot[r,r,P1,#-P1][[2]])&/@tangsU;
triPonc={P1,Sequence@@feetU};
getTriInfo[triPonc,tangsU,feetU]];

getPoncOuterU[1.5,0.1]

Clear@drawPonceletOuterCtr;
Options@drawPonceletOuterCtr={drLabels->False,drLoci->False,drCircs->False,degStep->1.,drExc->False};
drawPonceletOuterCtr[a_,u_,OptionsPattern[]]:=Module[{ell,r,gr,fs,triPonc,lab,
locX1,locX2,locX4,locX5,locX9,locX11,locX100,clrs,ctrs,locis,lociExc},
clrs={Darker@Green,Brown,Orange,Pink,Darker@Red,Gray,Gray};
ctrs={"inc","bar","ort","npc","mit","feu","x100"};
locis={True,True,True,True,True,False,False};
ell=plotEll[a,{Thick,Black}];
fs=getFoci[a];
r=a+1;
triPonc=getPoncOuterU[a,u];
lociExc=If[OptionValue@drLoci,Table[getPoncOuterU[a,toRad@(v+.001)]["exc"][[1]],{v,0,360,OptionValue@degStep}],{}];
If[OptionValue@drLoci,{locX1,locX2,locX4,locX5,locX9,locX11,locX100}=Transpose@Table[getPoncOuterU[a,toRad@(v+.001)][#]&/@ctrs,{v,0,150,OptionValue@degStep}],{}];
gr=Graphics[{PointSize@Large,FaceForm@None,Thick,Dashed,
{PointSize@Medium,Black,Point@fs,Purple,Point@{0,0}},
{Purple,Circle[{0,0},r]},
{Blue,Point@triPonc["tri"][[1]],(*Point@triPonc["tangs"],*)Line@{triPonc["tri"][[1]],#}&/@triPonc["feet"],Point@triPonc["feet"],(*Dashed,*)Line@triPonc["feet"]},
If[OptionValue@drExc,{EdgeForm@{Thick,Darker@Green},Polygon@triPonc["exc"]},{}],
If[OptionValue@drCircs,
{{Darker@Green,Circle[triPonc["inc"],triPonc["r"]]},
{Pink,Circle[triPonc["npc"],triPonc["R"]/2]}},{}],
If[OptionValue@drLoci,{Thick,Darker@Green,Line@lociExc},{}],
If[OptionValue@drLoci,
{MapThread[{#1,If[#3,Line@#2,{}]}&,{clrs,{locX1,locX2,locX4,locX5,locX9,locX11,locX100},locis}]},{}],
If[OptionValue@drLabels,
MapThread[{#1,Text[Style[Subscript["X",#2],14],triPonc[#3],{0,-1.5}],Point@triPonc[#3]}&,
{clrs,
{1,2,4,5,9,11,100},
ctrs}],{}]
}];
lab="a="<>nfn[a,2]<>", r="<>nfn[triPonc["r"],3]<>", ∏cos="<>nfn[triPonc["cosProd"],4]<>"\nL="<>nfn[triPonc["per"],3]<>", A="<>nfn[triPonc["area"],3];
Show[{ell,gr},PlotLabel->Style[lab,{16,Black}],ImageSize->400,PlotRange->{1.1{-6,6},1.1{-6,6}}]];

Manipulate[drawPonceletOuterCtr[a,toRad@tDeg,
drCircs->drCircs0,
drExc->drExc0,
drLoci->drLoci0,
drLabels->drLabels0],
{{a,2.},1.01,3},
{{tDeg,30},-180,180,1},
{{drExc0,False},{False,True}},
{{drCircs0,False},{False,True}},
{{drLoci0,False},{False,True}},
{{drLabels0,False},{False,True}}]

Clear@drOnePoncCircOuter;
drOnePoncCircOuter[a_,tDeg_]:=Module[{r=a+1},
Show[drawPonceletOuterCtr[a,toRad@tDeg,drCircs->True,drLoci->True,drLabels->True],
PlotRange->{1.1{-r,r},1.1{r,-r}},
ImageSize->800,
PlotLabel->None]];

drOnePoncCircOuter[3,30.]

getPoncAreaRatio[a_,tDeg_]:=Module[{out,in,tRad},
tRad=toRad@tDeg;
out=getPoncOuterU[a,tRad]["area"];
in=getPoncU[a,tRad]["area"];
out/in];

getStats@Table[getPoncAreaRatio[3,tDeg+.001],{tDeg,0,360}]

Which are circular: X1,X3,X11

PonceletOuterCircularity[a_,degStep_]:=Module[{ctrs,locs},
ctrs={"inc","bar","cir","ort","npc","sym","ger","nag","mit","spi","feu","x100"};
locs=Transpose@Table[magn[getPoncOuterU[a,toRad@(v+.001)][#]]&/@ctrs,{v,0,360,degStep}];
Pick[ctrs,negl[#["z"]]&/@getStats/@locs]]

PonceletOuterCircularity[1.5,1]

Clear@showPoncInvariants;
Options@showPoncInvariants={drLoci->False,drCircs->False,drIntExc->False,drExtExc->False,showR0->0,drLabels->False};
showPoncInvariants[a_,tDeg_,opts:OptionsPattern[]]:=Module[{rint,rext,cosProdExt,cosSumInt,u,lab,showR,poncInt,cosProdIntExc},
rext=a+1;
rint=a/(a+1);
showR=If[OptionValue@showR0==0,rext,OptionValue@showR0];
u=toRad@tDeg;
poncInt=getPoncU[a,u];
cosSumInt=poncInt["cosSum"];
cosProdIntExc=Apply[Times,getTriCosines@poncInt["exc"]];
cosProdExt=getPoncOuterU[a,u]["cosProd"];
lab="a="<>nfn[a,2]<>", (Subscript[r, int])="<>nfn[rint,3]<>", (Subscript[r, ext])="<>nfn[rext,3]<>"\n∑(Subscript[cos, int])="<>nfn[cosSumInt,3]<>", ∏(Subscript[cos, ext])="<>nfn[cosProdExt,3]<>"\n∏(Subscript[cos, int, exc])="<>nfn[cosProdIntExc,3];
Show[{
drawPonceletCtr[a,u,FilterRules[{opts},Options@drawPonceletCtr],drExc->OptionValue@drIntExc],
drawPonceletOuterCtr[a,u,FilterRules[{opts},Options@drawPonceletCtr],drExc->OptionValue@drExtExc]},
PlotLabel->Style[lab,{Black,16}],PlotRange->{1.1{-showR,showR},1.1{-showR,showR}}]];

Novas Invariantes para familias de poncelet N=3:
1) caustica interna é circulo: conserva circumraio. como r é constante, conserva r/R ou ∑(Subscript[cos, int]) ; corolario: ∏(Subscript[cos, exc,int]) é conservado
2) caustica interna é elipse, circumelipse é circulo. conserva produto de cossenos ∏(Subscript[cos, ext]).
3) bonus do ronaldo: ∏(Subscript[cos, ext])=∏(Subscript[cos, exc,int])

Manipulate[showPoncInvariants[a,tDeg,drCircs->drCircs0,drIntExc->drExc0],
{{a,1.5},1.1,3,.05},
{{tDeg,30.},-180,180,.1},
{{drCircs0,False},{True,False}},
{{drExc0,False},{True,False}}]

Grid[{showPoncInvariants[#,30.,False,4]&/@{1.5,2,3}}]

Clear@getPoncInvariants;
getPoncInvariants[a_,tDeg_]:=Module[{r,cosProdExt,cosSumInt,u},
r=a+1;
u=toRad@tDeg;
cosSumInt=getPoncU[a,u]["cosSum"];
cosProdExt=getPoncOuterU[a,u]["cosProd"];
{cosSumInt,cosProdExt}];

ListLinePlot[Transpose@Table[({{a,#[[1]]},{a,10#[[2]]},{a,10#[[2]]/#[[1]]}}&@getPoncInvariants[a,30.]),{a,1.01,10,.1}],PlotLegends->{"∑(Subscript[cos, int])","10 ∏(Subscript[cos, ext])","10 ∑(Subscript[cos, int])/∏(Subscript[cos, ext])"},FrameStyle->Medium,Frame->True,FrameLabel->{Style["a",{Black,16}],None}]

N = 3 external ellipse (a, b), internal ellipse (a0, b0), st a0/a + b0/b = 1, a0=a-b0(a/b), b0 ∈ (0,1)

Clear@getPoncPencil;
getPoncPencil[a_,a0_,b0_,u_]:=Module[{Pouter,tangs,feet,triPonc},
Pouter={a Cos@u,Sin@u};
tangs=ellTangentsb[a0,b0,Pouter];
feet=(ellInterRayUnprot[a,Pouter,#-Pouter][[2]])&/@tangs;
triPonc={Pouter,Sequence@@feet};
getTriInfo[triPonc,tangs,feet]];

getPoncPencil[1.5,.5,1.,.1]

ptClrs

Clear@drawPonceletPencil;
Options@drawPonceletPencil={drLabels->False,drLoci->False,drExc->False,drOrthic->False,drAct->False,drCircs->False,degStep->1.,degMax->360};
drawPonceletPencil[a_,b0_,u_,OptionsPattern[]]:=Module[{a0,ell,ellInt,gr,fs,tri,lab,
locs,ctrs,lociExc},
ctrs={"inc","bar","cir","ort","npc","sym","ger","nag","mit","spi","feu","x100"};
ell=plotEll[a,{Thick,Black}];
a0=a(1-b0);(* Cayley *)
ellInt=plotEllb[a0,b0,{Thick,Gray}];
fs=getFoci[a];
tri=getPoncPencil[a,a0,b0,u];
lociExc=If[OptionValue@drLoci&&OptionValue@drExc,Table[getPoncPencil[a,a0,b0,toRad@(v+.001)]["exc"][[1]],{v,0,OptionValue@degMax,OptionValue@degStep}],{}];
If[OptionValue@drLoci,locs=Transpose@Table[getPoncPencil[a,a0,b0,toRad@(v+.001)][#]&/@ctrs,{v,0,OptionValue@degMax,OptionValue@degStep}]];
gr=Graphics[{PointSize@Large,FaceForm@None,Thick,
{PointSize@Medium,Black,Point@fs,Gray,Point@{0,0}},
{Blue,Point@tri["tri"][[1]],(*Point@tri["tangs"],*)Line@{tri["tri"][[1]],#}&/@tri["feet"],Point@tri["feet"],(*Dashed,*)Line@tri["feet"]},
If[OptionValue@drExc,{EdgeForm@{Thick,Darker@Green},Polygon@tri["exc"]},{}],
If[OptionValue@drAct,{EdgeForm@{Thick,Lighter@Blue},Polygon@tri["act"],Lighter@Blue,Point[getCircumcenter@@tri["act"]]},{}],
If[OptionValue@drOrthic,{EdgeForm@{Thick,Orange},Polygon@tri["orthic"],Red,Point@tri["orthic"][[1]],Point@tri["tri"][[1]]},{}],
If[OptionValue@drCircs,
{{Purple,Circle[tri["cir"],tri["R"]]},
{Pink,Circle[tri["npc"],tri["R"]/2]}},{}],
If[OptionValue@drLoci,
{MapThread[{#1/.ptClrs,Line@#2}&,{ctrs,locs}]},{}],
If[OptionValue@drLoci&&OptionValue@drExc,{Thick,Darker@Green,Line@lociExc},{}],
If[OptionValue@drLabels,
MapThread[{#2/.ptClrs,Text[Style[Subscript["X",#1],14],tri[#2],{0,-1.5}],Point@tri[#2]}&,
{{1,2,3,4,5,6,7,8,9,10,11,100},ctrs}],
{}]
}];
lab="a="<>nfn[a,2]<>", ((Subscript[a, 0,])(Subscript[b, 0]))=("<>nfn[a0,3]<>","<>nfn[b0,3]<>")"<>", r="<>nfn[tri["r"],3]<>", R="<>nfn[tri["R"],3]<>", L="<>nfn[tri["per"],3]<>", A="<>nfn[tri["area"],3]<>", r*R="<>nfn[tri["r"]*tri["R"],3]<>"\n∑cos="<>nfn[tri["cosSum"],3]<>", ∏cos="<>nfn[tri["cosProd"],3]<>", ∑sin="<>nfn[tri["sinSum"],3]<>", ∏sin="<>nfn[tri["sinProd"],3]<>", ∑l^2="<>nfn[tri["per2"],3];
If[OptionValue@drExc,Module[{s,re,Re,Ae},
s=triLengths@tri["exc"];
re=getInradius[s];
Re=getCircumradius[s];
Ae=signedArea[tri["exc"]];
lab=lab<>"\n(Subscript[L, e])="<>nfn[Total@s,3]<>", (Subscript[A, e])="<>nfn[Ae,3]<>", (Subscript[r, e])="<>nfn[re,3]<>", (Subscript[R, e])="<>nfn[Re,3]<>", (Subscript[r, e])/(Subscript[R, e])="<>nfn[re/Re,3]]];
If[OptionValue@drOrthic,Module[{s,rh,Rh,Ah,altSum,altSumInv,altProd,Aratio},
s=triLengths@tri["orthic"];
rh=getInradius[s];
Rh=getCircumradius[s];
Ah=signedArea[tri["orthic"]];
Aratio=tri["area"]/Ah;
altSum=Total@MapThread[magn[#1-#2]&,{tri["tri"],tri["orthic"]}];
altProd=Apply[Times,MapThread[magn[#1-#2]&,{tri["tri"],tri["orthic"]}]];
altSumInv=Total@MapThread[1/magn[#1-#2]&,{tri["tri"],tri["orthic"]}];
lab=lab<>"\n(Subscript[L, h])="<>nfn[Total@s,3]<>", (Subscript[A, h])="<>nfn[Ah,3]<>", (Subscript[r, h])="<>nfn[rh,3]<>", (Subscript[R, h])="<>nfn[Rh,3]<>", (Subscript[r, h])/(Subscript[R, h])="<>nfn[rh/Rh,3]<>", ∑alts="<>nfn[altSum,3]<>", ∏alts="<>nfn[altProd,3]<>", A/(Subscript[A, h])="<>nfn[Aratio,3]]];
If[OptionValue@drAct,Module[{s,ra,Ra,Aa},
s=triLengths@tri["act"];
ra=getInradius[s];
Ra=getCircumradius[s];
Aa=signedArea[tri["act"]];
lab=lab<>"\n(Subscript[L, act])="<>nfn[Total@s,3]<>", (Subscript[A, act])="<>nfn[Aa,3]<>", (Subscript[r, act])="<>nfn[ra,3]<>", (Subscript[R, a])="<>nfn[Ra,3]<>", (Subscript[r, act])/(Subscript[R, act])="<>nfn[ra/Ra,3]]];
Show[{ell,ellInt,gr},PlotLabel->Style[lab,{16,Black}],ImageSize->800,
PlotRange->{1.1{-a,a},1.1{-1,1}}]];

a0/a + b0 == 1 (1)
a^2 - 1 = c^2 = a0^2 - b0^2

a0^2= b0^2 + a^2 -1
Sqrt[b0^2 + a^2 -1] + a b0 == a

b0^2 == a0^2 - a^2 + 1

a0/a + Sqrt[a0^2 - a^2 + 1] = 1

confocalN3b0dsr[a_]=1/(a^2+(Sqrt[1-(a^2)+(a^4)]));

confocalN3b0dsr[2.]

confocalN3b0[a_]=b0/.Solve[Sqrt[b0^2+a^2-1]+a b0==a,b0][[1]]

confocalN3b0[1.5]

confocalN3a0[a_]=a0/.Solve[a0/a + Sqrt[a0^2 - a^2 + 1] ==1,a0][[2]]

Manipulate[
b0=If[inner=="billiard",N@confocalN3b0[a],b0];
b0=If[inner=="circle",a/(a+1),b0];
b0=N@b0;
drawPonceletPencil[N@a,N@b0,toRad@(tDeg+10^-5),
drCircs->drCircs0,
drExc->drExc0,drOrthic->drOrthic0,drAct->drAct0,
drLoci->drLoci0,
drLabels->drLabels0,
degStep->.5,
degMax->150.],
{{inner,"none"},{"none","billiard","circle"}},
{{a,2},1.01,3},
{{b0,.25},0.05,.95,.01},
{{tDeg,30},-180,180,1},
{{drCircs0,False},{False,True}},
{{drLoci0,False},{False,True}},
{{drLabels0,False},{False,True}},
{{drExc0,False},{False,True}},
{{drAct0,False},{False,True}},
{{drOrthic0,False},{False,True}}]

X4 is point: Prof. Arseniy: when circumellipse and inellipse w/ center at orthocenter are dual, so it does not depend on triangles
Check that a0*a = b0*b

a0*a = b0*b => a0=b0*(b/a)
with a0/a+b0/b=1 => b0/a^2+b0=b => b0(1/a^2+1)=b =>b0=b(a^2+1)

b0forX4point[a_,b_]=b0/.First@Solve[{(b0(b/a))/a+b0/b==1},b0]

b0forX4point[a,1]

N@b0forX4point[2.,1]

drawPonceletPencil[N@2,N@b0forX4point[2.,1.],toRad@30,
drLoci->True,
drLabels->True,
degStep->.5,
degMax->150.]

Next steps :
- Analisar loci dos pontos onde (a0, b0) é fixo, e variamos a elipse externa.
- Já sabemos que quando a=b=(a0+b0), X3 fica estacionário.
- Será q outros pontos ficam estacionários neste sub-espaço?

Clear@getPoncPencilOuter;
getPoncPencilOuter[a_,a1_,b1_,u_]:=Module[{Pouter,tangs,feet,triPonc},
Pouter={a1 Cos@u,b1 Sin@u};
tangs=ellTangents[a,Pouter];
feet=(ellInterRaybUnprot[a1,b1,Pouter,#-Pouter][[2]])&/@tangs;
triPonc={Pouter,Sequence@@feet};
getTriInfo[triPonc,tangs,feet]];

when: external (a,1), internal (a0,b0): a0/a+b0/b=1

here internal (a,1). external = (a1,b1) => a/a1+1/b1=1=> a + a1 / b1 = a1 => a1(1-1/b1)=a =>a1 = a b1 /(b1-1)

Clear@drawPonceletPencilOuter;
Options@drawPonceletPencilOuter={drLabels->False,drLoci->False,drExc->False,drOrthic->False,drAct->False,drCircs->False,degStep->1.,degMax->360,drFeu->True};
drawPonceletPencilOuter[a_,b1_,u_,OptionsPattern[]]:=Module[{a1,ell,ellOut,gr,fs,tri,lab,
locs,ctrs,lociExc},
ctrs=If[OptionValue@drFeu,
{"inc","bar","cir","ort","npc","sym","ger","nag","mit","spi","feu","x100"},
{"inc","bar","cir","ort","npc","sym","ger","nag","mit","spi"}];
ell=plotEll[a,{Thick,Black}];
a1=a b1/(b1-1);(* Cayley *)
ellOut=plotEllb[a1,b1,{Thick,Gray}];
fs=getFoci[a];
tri=getPoncPencilOuter[a,a1,b1,u];
lociExc=If[OptionValue@drLoci&&OptionValue@drExc,Table[getPoncPencilOuter[a,a1,b1,toRad@(v+.001)]["exc"][[1]],{v,0,OptionValue@degMax,OptionValue@degStep}],{}];
If[OptionValue@drLoci,locs=Transpose@Table[getPoncPencilOuter[a,a1,b1,toRad@(v+.001)][#]&/@ctrs,{v,0,OptionValue@degMax,OptionValue@degStep}]];
gr=Graphics[{PointSize@Large,FaceForm@None,Thick,
{PointSize@Medium,Black,Point@fs,Gray,Point@{0,0}},
{Blue,Point@tri["tri"][[1]],(*Point@tri["tangs"],*)Line@{tri["tri"][[1]],#}&/@tri["feet"],Point@tri["feet"],(*Dashed,*)Line@tri["feet"]},
If[OptionValue@drExc,{EdgeForm@{Thick,Darker@Green},Polygon@tri["exc"]},{}],
If[OptionValue@drAct,{EdgeForm@{Thick,Lighter@Blue},Polygon@tri["act"],Lighter@Blue,Point[getCircumcenter@@tri["act"]]},{}],
If[OptionValue@drOrthic,{EdgeForm@{Thick,Orange},Polygon@tri["orthic"],Red,Point@tri["orthic"][[1]],Point@tri["tri"][[1]]},{}],
If[OptionValue@drCircs,
{{Purple,Circle[tri["cir"],tri["R"]]},
{Pink,Circle[tri["npc"],tri["R"]/2]},
{Darker@Green,Circle[tri["inc"],tri["r"]]}},{}],
If[OptionValue@drLoci,
{MapThread[{#1/.ptClrs,Line@#2}&,{ctrs,locs}]},{}],
If[OptionValue@drLoci&&OptionValue@drExc,{Thick,Darker@Green,Line@lociExc},{}],
If[OptionValue@drLabels,
MapThread[{#2/.ptClrs,Text[Style[Subscript["X",#1],14],tri[#2],{0,-1.5}],Point@tri[#2]}&,
{If[OptionValue@drFeu,{1,2,3,4,5,6,7,8,9,10,11,100},{1,2,3,4,5,6,7,8,9,10}],ctrs}],
{}]
}];
lab="a="<>nfn[a,2]<>", ((Subscript[a, 1,])(Subscript[b, 1]))=("<>nfn[a1,3]<>","<>nfn[b1,3]<>")"<>", r="<>nfn[tri["r"],3]<>", R="<>nfn[tri["R"],3]<>", L="<>nfn[tri["per"],3]<>", A="<>nfn[tri["area"],3]<>", A/L="<>nfn[tri["area"]/tri["per"],3]<>"\n∑cos="<>nfn[tri["cosSum"],3]<>", ∏cos="<>nfn[tri["cosProd"],3]<>", ∑sin="<>nfn[tri["sinSum"],3]<>", ∏sin="<>nfn[tri["sinProd"],3]<>", ∑l^2="<>nfn[tri["per2"],3];
If[OptionValue@drExc,Module[{s,re,Re,Ae},
s=triLengths@tri["exc"];
re=getInradius[s];
Re=getCircumradius[s];
Ae=signedArea[tri["exc"]];
lab=lab<>"\n(Subscript[L, e])="<>nfn[Total@s,3]<>", (Subscript[A, e])="<>nfn[Ae,3]<>", (Subscript[r, e])="<>nfn[re,3]<>", (Subscript[R, e])="<>nfn[Re,3]<>", (Subscript[r, e])/(Subscript[R, e])="<>nfn[re/Re,3]]];
If[OptionValue@drOrthic,Module[{s,rh,Rh,Ah,altSum,altSumInv,altProd,Aratio},
s=triLengths@tri["orthic"];
rh=getInradius[s];
Rh=getCircumradius[s];
Ah=signedArea[tri["orthic"]];
Aratio=tri["area"]/Ah;
altSum=Total@MapThread[magn[#1-#2]&,{tri["tri"],tri["orthic"]}];
altProd=Apply[Times,MapThread[magn[#1-#2]&,{tri["tri"],tri["orthic"]}]];
altSumInv=Total@MapThread[1/magn[#1-#2]&,{tri["tri"],tri["orthic"]}];
lab=lab<>"\n(Subscript[L, h])="<>nfn[Total@s,3]<>", (Subscript[A, h])="<>nfn[Ah,3]<>", (Subscript[r, h])="<>nfn[rh,3]<>", (Subscript[R, h])="<>nfn[Rh,3]<>", (Subscript[r, h])/(Subscript[R, h])="<>nfn[rh/Rh,3]<>", ∑alts="<>nfn[altSum,3]<>", ∏alts="<>nfn[altProd,3]<>", A/(Subscript[A, h])="<>nfn[Aratio,3]]];
If[OptionValue@drAct,Module[{s,ra,Ra,Aa},
s=triLengths@tri["act"];
ra=getInradius[s];
Ra=getCircumradius[s];
Aa=signedArea[tri["act"]];
lab=lab<>"\n(Subscript[L, act])="<>nfn[Total@s,3]<>", (Subscript[A, act])="<>nfn[Aa,3]<>", (Subscript[r, act])="<>nfn[ra,3]<>", (Subscript[R, a])="<>nfn[Ra,3]<>", (Subscript[r, act])/(Subscript[R, act])="<>nfn[ra/Ra,3]]];
Show[{ell,ellOut,gr},PlotLabel->Style[lab,{16,Black}],ImageSize->800,
PlotRange->{1.1{-2a,2a},1.1{-b1,b1}}]];

a/a1 + 1/b0 == 1 (1)
a^2 - 1 = c^2 = a1^2 - b1^2

a1 = Sqrt[ b1^2 + a^2 - 1]

a/Sqrt[b1^2 + a^2 - 1] + 1/ b1 == 1
b1 a/Sqrt[b1^2 + a^2 - 1] + 1 == b1
b1 a  = (b1-1)Sqrt[b1^2 + a^2 - 1] 
b1^2 a^2 == (b1-1)^2 (b1^2 + a^2 - 1)

Manipulate[
(*b1=If[inner=="billiard",N@confocalN3b1[a],b1];*)
b1=If[inner=="circle",(a+1),b1];
b1=N@b1;
drawPonceletPencilOuter[N@a,N@b1,toRad@(tDeg+10^-5),
drCircs->drCircs0,
drExc->drExc0,drOrthic->drOrthic0,
drAct->drAct0,
drLoci->drLoci0,
drLabels->drLabels0,
drFeu->drFeu0,
degStep->2.5,
degMax->150.],
{{inner,"none"},{"none","billiard","circle"}},
{{a,2},1.01,3},
{{b1,2},1.05,5,.01,AnimationRate->10},
{{tDeg,30},-180,180,1},
{{drCircs0,False},{False,True}},
{{drFeu0,True},{False,True}},
{{drLoci0,False},{False,True}},
{{drLabels0,False},{False,True}},
{{drExc0,False},{False,True}},
{{drAct0,False},{False,True}},
{{drOrthic0,False},{False,True}}]

Scan for Point Loci

Clear@getPoncPencilb;
getPoncPencilb[a_,b_,a0_,b0_,u_]:=Module[{Pouter,tangs,feet,triPonc},
Pouter={a Cos@u,b Sin@u};
tangs=ellTangentsb[a0,b0,Pouter];
feet=(ellInterRaybUnprot[a,b,Pouter,#-Pouter][[2]])&/@tangs;
triPonc={Pouter,Sequence@@feet};
getTriInfo[triPonc,tangs,feet]];

a0/a + b0/b == 1 => a0 = a - b0 (a/b) = a(1-b0/b)

Clear@getOnePoncLow;
getOnePoncLow[a_,b_,b0_,t_]:=Module[{a0,tri},
a0=a(1-b0/b);
tri=getPoncPencilb[a,b,a0,b0,t];
tri];

Module[{p,eps=10^-9,a=4},
Quiet@Plot[
Evaluate[p=getOnePoncLow[a,1,b0forX4point[a,1],t+eps];
{p["R"],p["r"]}],{t,0,2π},AspectRatio->1,PlotLegends->{"R","r"}]]

rRplot=Module[{p,eps=10^-9,a=3},
Quiet@ParametricPlot[
p=getOnePoncLow[a,1,b0forX4point[a,1],t+eps];
{p["r"],p["R"]},{t,0,π},PerformanceGoal->"Quality",PlotStyle->{Thick,Blue},AspectRatio->1,AxesLabel->(Style[#,20]&/@{"r","R"})]]

Module[{p,a=3,eps=10^-6,rR,fit,fitPlot,rMin,rMax,rRplot},
rR=Table[p=getOnePoncLow[a,1,b0forX4point[a,1],t+eps];
{p["r"],p["R"]},{t,0,π,π/50}];
rMin=Min[First/@rR];
rMax=Max[First/@rR];
fit=LinearModelFit[rR,{1,x,x^2},x];
Print[fit[{"RSquared"}]];
rRplot=Quiet@Graphics[{Thick,Blue,
Line@Table[p=getOnePoncLow[a,1,b0forX4point[a,1],t+eps];
{p["r"],p["R"]},{t,π/2,π-eps,π/100}]}];
fitPlot=Plot[fit,{x,rMin,rMax},PlotStyle->Red];
Show[{rRplot,fitPlot,Graphics[{Darker@Green,PointSize@Large,Point@rR}]},PlotRange->All,AspectRatio->1,AxesLabel->(Style[#,20]&/@{"r","R"})]
]

Clear@getOnePonc;
getOnePonc[a_,b_,b0_,t_]:=Module[{a0,tri},
a0=a(1-b0/b);
tri=getPoncPencilb[a,b,a0,b0,t];
{tri["tri"],tri["sides"]}];

getOnePonc[2,1,.8,.1]

Clear@getPoncRads;getPoncRads[a_,b_,b0_]:=Module[{o,n,s,tri,kimbs,names,xys,rads0,rads90},
{o,s}=getOnePonc[a,b,b0,π/4.];
{kimbs,names,xys}=Transpose@getNewCenters[o,s];
rads0=magn2/@xys;
{o,s}=getOnePonc[a,b,b0,π/4+π/2.];
{kimbs,names,xys}=Transpose@getNewCenters[o,s];
rads90=magn2/@xys;
<|"rads0"->rads0,"rads90"->rads90,"radsSum"->rads0+rads90|>];

Clear@getPoncAxes;getPoncAxes[a_,b_]:=Module[{xs,ys},
ListLinePlot[Table[getPoncRads[a,b,b0]["radsSum"],{b0,.1,b-.1,.1}],PlotLegends->centerNames,ImageSize->Large]]

getPoncAxes[2,1]

Clear@getPoncRadsOne;getPoncRadsOne[a_,b_,b0_,kimb_]:=Module[{o,s,xys,rads0,rads90},
{o,s}=getOnePonc[a,b,b0,π/1000.];
xys=First@(Transpose@getNewCenters[o,s,{kimb}])[[3]];
rads0=magn2@xys;
{o,s}=getOnePonc[a,b,b0,π/1000+π/2.];
xys=First@(Transpose@getNewCenters[o,s,{kimb}])[[3]];
rads90=magn2@xys;
<|"rads0"->rads0,"rads90"->rads90,"radsSum"->rads0+rads90|>];

Plot radius sum

Plot[{
getPoncRadsOne[2,1,b0,1]["radsSum"],
getPoncRadsOne[2,1,b0,2]["radsSum"],
getPoncRadsOne[2,1,b0,4]["radsSum"],
getPoncRadsOne[2,1,b0,6]["radsSum"],
getPoncRadsOne[2,1,b0,9]["radsSum"]},{b0,.05,.95},
PlotLegends->{"(Subscript[X, 1])","(Subscript[X, 2])","(Subscript[X, 4])","(Subscript[X, 6])","(Subscript[X, 9])"}]

Jair: Excentral-to-Orbit Area Ratio is Constant, and Quad/Tri Spatial Integral

Clear@getAreaRatio;
getAreaRatio[a_,tDeg_]:=Module[{o,n,s,exc,excSides},
{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
excSides=triLengthsRL@exc;
triAreaHeron@excSides/triAreaHeron@s
];

getAreaRatio[2.5,50]

getSumProdCosines[2.5,0]

2/(1.15203-1)

getRadiusRatio[2.5,0]

Plot[{Legended[getAreaRatio[a,0],"A'/A"],Legended[.1+2/getRadiusRatio[a,0],"2R/r + ϵ"]},{a,1.01,2},PlotLabel->Style["N=3: A'/\!\(\*SubscriptBox[\(A\), \(\\ \)]\)= 2R/r",{Black,16}],GridLines->Automatic,AxesLabel->{"a/b","ratio"},AxesStyle->{{Black,Medium},{Black,Medium}}]

Clear@getAreaRatioOneSubtri;
Options@getAreaRatioOneSubtri={drGr->False};
getAreaRatioOneSubtri[a_,tDeg_,OptionsPattern[]]:=Module[{o,n,s,exc,ptri,pquad,atri,aquad},
{o,n,s}=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[o,s];
ptri={{0,0},o[[1]],o[[2]]};
atri=signedArea@ptri;
pquad={{0,0},o[[1]],exc[[3]],o[[2]]};
aquad=signedArea@pquad;
If[OptionValue@drGr,
Module[{ell,gr},
ell=plotEll[a,{Thick,Black}];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@Blue,Polygon@o,Blue,,Point@ptri,FaceForm@{Opacity@.2,Blue},Polygon@ptri},
{EdgeForm@Darker@Green,Polygon@exc,FaceForm@{Opacity@.2,Green},Polygon@pquad,Darker@Green,Point@exc[[3]]},
{Black,MapThread[Text[Style[#2,16],#1,{-1.5,-1.5}]&,{pquad,{"O","(Subscript[P, 1])","Q","(Subscript[P, 2])"}}]}}];
Print[Show[{ell,gr}]]]];
aquad/atri
];

getAreaRatioOneSubtri[1.5,20,drGr->True];

Module[{ratioAvgs,quadAvgs,as,epsilon=.1},
as=Range[1.1,2,.1];
quadAvgs={#,epsilon+Mean@Table[getAreaRatioOneSubtri[#,tDeg],{tDeg,0,359,1}]}&/@as;
ratioAvgs={#,getAreaRatio[#,0]}&/@as;
ListLinePlot[{Legended[quadAvgs,"MEAN A((Subscript[OP, 1])(Subscript[QP, 2]))/A((Subscript[OP, 1])(Subscript[P, 2])) + ϵ"],Legended[ratioAvgs,"A((Subscript[P, 1])'(Subscript[P, 2])'(Subscript[P, 3])')/A((Subscript[P, 1])(Subscript[P, 2])(Subscript[P, 3]))"]},
Frame->True,FrameStyle->{{Black,16},{Black,16}},FrameLabel->(Style[#,{Black,16}]&/@{"a","ratio avg"})]]

Plot[{
Legended[getAreaRatioOneSubtri[1.5,tDeg],"A((Subscript[OP, 1])(Subscript[QP, 2]))/A((Subscript[OP, 1])(Subscript[P, 2]))"],
Legended[getAreaRatio[1.5,tDeg],"A((Subscript[P, 1])'(Subscript[P, 2])'(Subscript[P, 3])')/A((Subscript[P, 1])(Subscript[P, 2])(Subscript[P, 3]))"]
},{tDeg,0,359},PlotRange->All,AxesLabel->{"θ","area"}]

Hunting for Equilaterals I

Start with Orbit

Clear@getTwoOrbits;getTwoOrbits[a_,t_,t2_]:=Module[{o,n,s,o2,n2,s2,inters,exc,exc2,intersExc,intersExcSides,act,act2},
{o,n,s}=orbitNormals[a,t];
exc=excentralTriangle[o,s];
act=anticomplementaryTriangle[o,s];
{o2,n2,s2}=orbitNormals[a,t2];
exc2=excentralTriangle[o2,s2];
act2=anticomplementaryTriangle[o2,s2];
inters=MapThread[interRays[#1,#2-#1,#3,#4-#3]&,{o,RotateLeft@o,o2,RotateLeft@o2}];
intersExc=MapThread[interRays[#1,#2-#1,#3,#4-#3]&,{exc,RotateLeft@exc,exc2,RotateLeft@exc2}];
intersExcSides=triLengthsRL@intersExc;
<|"orbit"->o,"orbit2"->o2,"orbitSides"->s,"orbit2Sides"->s2,"inters"->inters,"exc"->exc,"exc2"->exc2,"intersExc"->intersExc,"intersExcSides"->intersExcSides,"act"->act,"act2"->act2|>];

drawTwoOrbits[a_,t_,t2_]:=Module[{to,ell,gr},
ell=plotEll[a];
to=getTwoOrbits[a,t,t2];
gr=Graphics[{FaceForm@None,PointSize@Medium,
{EdgeForm@Blue,Polygon@to["orbit"],{EdgeForm@{Blue,Dashed},Polygon@to["orbit2"]},EdgeForm@Blue,Polygon@to["inters"]},
{Blue,Point@to["inters"]}}];
Show[{ell,gr}]]

Manipulate[drawTwoOrbits[1.5,0,toRad@tDeg2],{{tDeg2,10},-180,180,1}]

RandomReal[{0,1},4]

samplePoly[poly_,n_]:=Module[{rs,polyR,vals},
rs=Range[0,1,1/(n-1)];
polyR=RotateLeft@poly;
vals=Table[((1-#) poly[[i]]+# polyR[[i]])&/@Most@rs,{i,1,Length@poly}];
vals];

samplePolyOutside[poly_,n_]:=Module[{rs,polyR,vals,valsNeg},
rs=Range[0,5,1/(n-1)];
polyR=RotateLeft@poly;
vals=Table[(polyR[[i]]+(#^2)(polyR[[i]]-poly[[i]]))&/@Most@rs,{i,1,Length@poly}];
valsNeg=Table[(poly[[i]]-(#^2)(polyR[[i]]-poly[[i]]))&/@Most@rs,{i,1,Length@poly}];
Join[vals,valsNeg]];

Clear@drawTwoOrbitsExc;
Options@drawTwoOrbitsExc={drOrbit2->False,drAct2->False,drMedians->False,drExc->False,drExc2->False,drAct->False,maxX->2,maxY->3,drIntersExcIncBar->False,drSamples->False,drInversion->False,drExcInv->False,drSamples,drActInv->False,drExcInvCont->False};
drawTwoOrbitsExc[a_,t_,t2_,OptionsPattern[]]:=Module[{to,ell,gr,oClr=Black,excClr=Darker@Green,actClr=Blue,excInvClr=Red,actInvClr=Brown,barExc,incExc,barInc,fs,excInv,actInvEll,actInv,excInvEll,meds,excCont,excContInv,excContInvEll,excContOut,excContOutInv,excContOutInvEll,excContSample5s,excContSample5sInv,excInvEllCtrs,excInvEllCtrsInv},
ell=plotEll[a,{Thick,Gray}];
to=getTwoOrbits[a,t,t2];
fs=getFoci[a];
barExc=getBaricenter@@(to["intersExc"]);
incExc=getIncenterTrilin[to["intersExc"],to["intersExcSides"]];
{excInv,excInvEll}=Transpose[ellInversion[a,#]&/@to["exc"]];
{actInv,actInvEll}=Transpose[ellInversion[a,#]&/@to["act"]];
excCont=samplePoly[to["exc"],100];
excContSample5s=samplePoly[to["exc"],8];
excContSample5sInv=Map[ellInversion[a,#][[1]]&,excContSample5s,{2}];
excInvEllCtrs=getEll5ctr[(#+10^-6RandomReal[])&/@Take[#,5]]&/@excContSample5sInv;
excInvEllCtrsInv=First[ellInversion[a,#]]&/@excInvEllCtrs;
{excContInv,excContInvEll}=Transpose[ellInversion[a,#]&/@Flatten[excCont,1]];
excContOut=samplePolyOutside[to["exc"],100];
excContOutInv=Map[ellInversion[a,#][[1]]&,excContOut,{2}];
meds=getMedians@@to["orbit"];
gr=Graphics[{FaceForm@None,PointSize@Medium,
{EdgeForm@{Thick,oClr},Polygon@to["orbit"]},
If[OptionValue@drOrbit2,{EdgeForm@{Dashed,oClr},Polygon@to["orbit2"],Point@to["orbit"][[1]],PointSize@Large,Point@to["inters"]},{}],
If[OptionValue@drExc,
{EdgeForm@{Thick,excClr},Polygon@to["exc"]},{}],
If[OptionValue@drExc2,{{EdgeForm@{Thick,excClr,Dashed},Polygon@to["exc2"]},
{EdgeForm@Black,FaceForm@{excClr,Opacity@.2},Polygon@to["intersExc"],excClr,Point@to["intersExc"]}},{}],
If[OptionValue@drExcInv,
{EdgeForm@{Thick,excInvClr},Polygon@excInv(*EdgeForm@{Thick,Dashed,excInvClr},Polygon@excInvEll,excInvClr,Point[getBaricenter@@excInvEll],Darker@Green,Point[getIncenterTrilin[excInvEll,triLengthsRL@excInvEll]]*)},{}],
If[OptionValue@drExcInvCont,{Blue,Thick,Line@excContInv,Dashed,Line/@excContOutInv,Point@excInvEllCtrs,Point@excInvEllCtrsInv,EdgeForm@{Dashed,Blue},Polygon@excInvEllCtrsInv},{}],
If[OptionValue@drSamples,{PointSize@Large,Darker@Green,Point/@excContSample5s,Blue,Point/@excContSample5sInv},{}],
If[OptionValue@drIntersExcIncBar,{excClr,Point@barExc,Red,Point@incExc},{}],
If[OptionValue@drAct,{EdgeForm@{Thick,actClr},Polygon@to["act"]},{}],
If[OptionValue@drAct2,{EdgeForm@{Thick,actClr,Dashed},Polygon@to["act2"]},{}],
If[OptionValue@drActInv,
{EdgeForm@{Thick,actInvClr},Polygon@actInv,EdgeForm@{Thick,Dashed,actInvClr},Polygon@actInvEll,actInvClr,Point[getBaricenter@@actInv],Darker@Green,Point[getIncenterTrilin[actInv,triLengthsRL@actInv]]},{}],
If[OptionValue@drMedians,{Red,PointSize@Large,Point@meds},{}]
}];
Show[{ell,gr},PlotRange->{{-OptionValue@maxX,OptionValue@maxX},{-OptionValue@maxY,OptionValue@maxY}},ImageSize->Large]]

Manipulate[drawTwoOrbitsExc[a,toRad@tDeg,toRad@(tDeg+tDeg2),drOrbit2->drOrbit20,drMedians->drMedians0,drExc->drExc0,drExc2->drExc20,drAct->drAct0,drActInv->drActInv0,drAct2->drAct20,drExcInv->drExcInv0,drIntersExcIncBar->drIntersExcIncBar0,drExcInvCont->drExcInvCont0,maxX->maxX0,maxY->maxY0],
{{drOrbit20,False,"2nd orbit"},{True,False}},
{{drExc0,True,"excentral"},{True,False}},
{{drExc20,False,"2nd excentral"},{True,False}},
{{drExcInv0,True,"inv excentral"},{True,False}},
{{drExcInvCont0,True,"inv excentral continuous"},{True,False}},
{{drMedians0,True,"medians"},{True,False}},
{{drAct0,False,"anticompl"},{True,False}},
{{drAct20,False,"2nd anticompl"},{True,False}},
{{drActInv0,False,"inv anticompl"},{True,False}},
{{drIntersExcIncBar0,False,"inters exc inc bar"},{True,False}},
{{a,1.5},1.01,2,.1,Appearance->"Labeled"},
{{tDeg,0},-180,180,1,Appearance->"Labeled"},
{{tDeg2,20},-180,180,1,Appearance->"Labeled"},
{{maxX0,3},{1,2,3,4,8}},
{{maxY0,3},{1,2,3,4,8}}
]

Check area of McBeath Circumconic vs Orthic Inconic

Cos[60°]

areaMcBeathEqui[a_]=FullSimplify[2π Sqrt[2] a^3 Sqrt[8] / (3a^2)^(3/2)*(a*a*Sqrt[3]/4),a>0]

circArea[r_]:=π*r^2

circArea[a Sqrt[3]/3]

areaOrthicInconic[a_]=FullSimplify[2π Sqrt[2] a^3 Sqrt[1/8] / (3a^2)^(3/2)*(a*a*Sqrt[3]/4),a>0]

circArea[a Sqrt[3]/6]

X100+X88+act intouchpoints+Peter Moses Triads?

Module[{a=1.5,tDeg=30.,o,n,s,mosesTab,mosesPts,tups,equis,x88,x100,act},
{o,n,s}=orbitNormals[a,toDeg@tDeg];
mosesTab=getMosesCartesians[o,s];
x100=getX100Trilin[o,s];
x88=getX88Trilin[o,s];
act=getAnticomplData[o,s];(* intouchpoints are on the billiard *)
mosesPts=Join[Third/@mosesTab,{x100,x88},act["tps"]];
Print["Obtained ",Length@mosesPts," points on elliptic boundary"];
tups=Subsets[Range[Length@mosesPts],{3}];
Print["Testing ",Length@tups," triples for equilaterality"];
equis=isEqui[Part[mosesPts,#]]&/@tups;
Position[equis,True]]

Module[{a=1.5,tDeg=30.,o,n,s,mosesTab,mosesPts,tups,equiErrs,x88,x100,ord,act,best,bestErrs,bestTriples},
{o,n,s}=orbitNormals[a,toDeg@tDeg];
mosesTab=getMosesCartesians[o,s];
x100=getX100Trilin[o,s];
x88=getX88Trilin[o,s];
act=getAnticomplData[o,s];(* intouchpoints are on the billiard *)
mosesPts=Join[Third/@mosesTab,{x100,x88},act["tps"]];
Print["Obtained ",Length@mosesPts," points on elliptic boundary"];
tups=Subsets[Range[Length@mosesPts],{3}];
Print["Testing ",Length@tups," triples for equilaterality"];
equiErrs=equiError[Part[mosesPts,#]]&/@tups;
ord=Ordering[equiErrs];
best=Part[tups,Take[ord,10]];
bestErrs=Part[equiErrs,Take[ord,10]];
bestTriples=Part[Join[Second/@mosesTab,{"x100","x88","actTps1","actTps2","actTps3"}],#]&/@best;
Print[Grid[MapThread[Join[{#3,#2},#1]&,{bestTriples,bestErrs,Take[ord,Length@bestErrs]}],Alignment ->Left]];
ListLinePlot@equiErrs[[ord]]]

Clear@reportBestTriples;
reportBestTriples[a_,tDeg_,topN_]:=Module[{o,n,s,mosesTab,mosesPts,tups,equiErrs,x88,x100,ord,act,best,bestErrs,bestTriples,exc,excInts,actInts},
{o,n,s}=orbitNormals[a,toDeg@tDeg];
exc=excentralTriangle[o,s];
excInts=ellInversion[a,#][[2]]&/@exc;
mosesTab=getMosesCartesians[o,s];
x100=getX100Trilin[o,s];
x88=getX88Trilin[o,s];
act=getAnticomplData[o,s];(* intouchpoints are on the billiard *)
actInts=ellInversion[a,#][[2]]&/@act["tri"];
mosesPts=Join[Third/@mosesTab,{x100,x88},act["tps"],excInts,actInts];
tups=Subsets[Range[Length@mosesPts],{3}];
equiErrs=equiError[Part[mosesPts,#]]&/@tups;
ord=Ordering[equiErrs];
best=Part[tups,Take[ord,topN]];
bestErrs=Part[equiErrs,Take[ord,topN]];
bestTriples=Part[Join[Second/@mosesTab,{"x100","x88","actTps1","actTps2","actTps3","excInt1","excInt2","excInt3","actInt1","actInt2","actInt3"}],#]&/@best;
Grid[MapThread[Join[{#3,#2},#1]&,{bestTriples,bestErrs,Take[ord,Length@bestErrs]}],Alignment ->Left]]

reportBestTriples[1.5,10.,10]

reportBestTriples[1.5,20.,20]

reportBestTriples[1.5,30.,5]

NumberQ@Infinity

validInter[{x_,y_}]:=NumberQ@x&&NumberQ@y&&!negl[x^2+y^2];

validInter[{0,0.1}]

Clear@reportBestTriplesTrilin;
reportBestTriplesTrilin[a_,tDeg_,topN_,maxPts_:20]:=Module[{o,n,s,exc,act,ctrs,ctrsExc,ctrsAct,ctrsAll,pts,tups,equiErrs,ord,best,bestErrs,excEll,actEll},
{o,n,s}=orbitNormals[a,toDeg@tDeg];
exc=excentralTriangle[o,s];
act=getAnticomplData[o,s];
ctrs=getNewCenters[o,s];
ctrsExc=getNewCenters[exc,triLengthsRL@exc];
ctrsAct=getNewCenters[act["tri"],act["sides"]];
ctrsAll=Third/@Join[ctrs,ctrsExc,ctrsAct];
excEll=Select[Flatten[Join@Table[ellInterRay[a,exc[[i]],#,exc[[i]]-#][[2]]&/@ctrsAll,{i,3}],1],validInter@#&];
actEll=Select[Flatten[Join@Table[ellInterRay[a,act["tri"][[i]],#,act["tri"][[i]]-#][[2]]&/@ctrsAll,{i,3}],1],validInter@#&];
pts=Join[excEll,actEll];
Print["Obtained ",Length@pts," points on elliptic boundary, reducing to ",maxPts];
pts=RandomSample[pts,maxPts];
tups=Subsets[Range[Length@pts],{3}];
Print["Testing ",Length@tups," triples for equilaterality"];
equiErrs=equiError[Part[pts,#]]&/@tups;
ord=Ordering[equiErrs];
best=Part[tups,Take[ord,topN]];
bestErrs=Part[equiErrs,Take[ord,topN]];
Grid[MapThread[Join[{#3,#2},#1]&,{best,bestErrs,Take[ord,Length@bestErrs]}],Alignment ->Left]]

(* dangerous*)
(*reportBestTriplesTrilin[1.5,10.,10]*)

Conservation of Angular Momentum

https://mobile.twitter.com/gregegansf/status/1037963743517261829

getMomentum[p1_,p2_]:=Module[{lgt,d},
lgt=magn[p2-p1];
d=magn[closestPerp[{0,0},p1,p2]];
(*d=magn[(p1+p2)/2];*)
{lgt,d}];
getMomentumTri[p1_,p2_,p3_]:=#[[1]]*#[[2]]&/@{getMomentum[p1,p2],getMomentum[p2,p3],getMomentum[p3,p1]};

{x1,y1,0}\[Cross]{x2,y2,0}

getMomentumFoci[f1_,f2_,p1_,p2_]:=Module[{edge,d1,d2},
edge=norm[p2-p1];
d1=crossProduct[edge,p1-f1];
d2=crossProduct[edge,p1-f2];
d1*d2];

Clear@getMomenta;
getMomenta[a_]:=Module[{orbit,normals,sides},
Table[{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
{t,getMomentum[orbit[[1]],orbit[[2]]]},{t,0,2.π,toRad[1.]}]
];

Clear@getMomentaFoci;
getMomentaFoci[a_]:=Module[{orbit,normals,sides,c,f1,f2},
c=focalDistance[a,1];
f1={c,0};
f2={-c,0};
Table[
{orbit,normals,sides}=Evaluate[orbitNormals[a,t]];
{t,{getMomentumFoci[f1,f2,orbit[[1]],orbit[[2]]],
getMomentumFoci[f1,f2,orbit[[2]],orbit[[3]]],
getMomentumFoci[f1,f2,orbit[[3]],orbit[[1]]]}},{t,0,2.π,toRad[1.]}]
];

Sum of products of distance is *not* conserved

Plot[Total@Module[{o,n,s},
{o,n,s}=orbitNormals[1.5,t];
getMomentumTri@@o],{t,0,2π}]

Module[{ms,ts,ls,ds,mults,sums,clrs={Blue,Red,Green,Orange}},
ms=getMomenta[1.5];
ts=First/@ms;
ls=First/@(Second/@ms);
ds=Second/@(Second/@ms);
mults=ls*ds;
sums=ls+ds;
Legended[ListLinePlot[Transpose/@{{ts,ls},{ts,ds},{ts,mults},{ts,sums}},PlotStyle->clrs],
LineLegend[clrs,{"length","dist","length*dist","length + dist"}]]]

Module[{ms,ts,v12,v23,v31,clrs={Blue,Red,Green}},
ms=getMomentaFoci[1.5];
ts=First/@ms;
v12=First/@(Second/@ms);
v23=Second/@(Second/@ms);
v31=Third/@(Second/@ms);
Legended[ListLinePlot[Transpose/@{{ts,v12},{ts,v23},{ts,v31}},PlotStyle->clrs],
LineLegend[clrs,{"v12","v23","v31"}]]]

Clear@showTangentToEllipse;showTangentToEllipse[a_,t_]:=Module[{c,f1,f2,cl1,cl2,d1,d2,m1,m2,p,gr,bisector,bisectorPerp,lab,lgt=.5,ell},
ell=plotEll[a,{Thick,Black}];
p={a Cos[t],Sin[t]};
c=focalDistance[a,1];
{f1,f2}={{-c,0},{c,0}};
bisector=norm[norm[p-f1]+norm[p-f2]];
bisectorPerp=perp[bisector];
cl1=closestPerp[f1,p,p+bisectorPerp];
cl2=closestPerp[f2,p,p+bisectorPerp];
m1=(f1+cl1)/2;
m2=(f2+cl2)/2;
d1=magn[cl1-f1];
d2=magn[cl2-f2];
lab=Style["(Subscript[d, 1])="<>nfn[d1,2]<>", (Subscript[d, 2])="<>nfn[d2,2]<>", (Subscript[d, 1])(Subscript[d, 2])="<>nfn[d1*d2,2],{Black,16}];
gr=Graphics[{PointSize@Large,Arrowheads@Medium,Thick,
{Gray,Line[{{-a,0},{a,0}}],Line[{{0,-1},{0,1}}]},
{Blue,Thick,Arrow[{p,p-bisector*lgt}]},
{Darker@Green,Thick,Line[{p,p+2bisectorPerp}],Line[{p,p-2bisectorPerp}]},
{Blue,Dashed,Point@p,Line[{f1,p}],Line[{f2,p}]},
{Dashed,Darker@Green,Line[{f1,cl1}],Line[{f2,cl2}],Point@cl1,Point@cl2},
{Black,Point@{f1,f2}},
MapThread[Text[Style[#1,20],#2,{-1.5,0}]&,{{"(Subscript[d, 1])","(Subscript[d, 2])"},{m1,m2}}],
MapThread[Text[Style[#1,20],#2,{0,1.5}]&,{{"(Subscript[F, 1])","(Subscript[F, 2])"},{f1,f2}}]}];
Show[{ell,gr},ImageSize->Large,PlotLabel->lab,Frame->True,PlotRange->{{-a-.5,a+.5},{-1.5,1.5}}]];

Manipulate[
showTangentToEllipse[a,toRad@t],
{{a,1.5},1.01,3,.1,Appearance->"Labeled"},
{{t,55.},-360,360,1,Appearance->"Labeled"}]

(*DeleteFile[tangentsApp]*)

(*tangentsApp=CloudDeploy[%,"tangent to ellipse and conservation of momenta",Permissions->"Public"]*)

Study Orbit, Excentral, Invariants

Perimeter invariants
1) orbit: P
2) excentral (r’/R’)P’ = P
3) orthic: P’’ = (r/R)*P:
	A=r*P/2=R*P’’/2
	P’’(R/r) = P [[only works for acute orbits]]

Clear@excPerimeterInvariants;
excPerimeterInvariants[a_,wiggle_:.1]:=Module[{darboux,orbit,normals,sides,per,orbitData,exc,excData,ort,ortData,ortPer,ratioExc,excPer,ratioOrtPer,ortExc,ortExcData,ortExcPer,ratioOrtPerPreImage,excessPerPreImage,ratioOrtPerPreImageAdj},
darboux=darbouxP[a];
Table[
{orbit,normals,sides}=orbitNormals[a,t];
orbitData=getTriData[orbit];
per="perimeter"/.orbitData;
exc=excentralTriangle[orbit,sides];
excData=getTriData[exc];
excPer="perimeter"/.excData;
ort=orthicTriangle[orbit,sides];
ortData=getTriData[ort];
ortPer="perimeter"/.ortData;
ortExc=excentralTriangle[ort,"sides"/.ortData];
(* acute pre image *)
ortExcData=getTriData[ortExc];
ortExcPer="perimeter"/.ortExcData;
ratioExc=excPer*("rOvR"/.excData);
ratioOrtPer=ortPer/("rOvR"/.orbitData);
ratioOrtPerPreImage=ortPer/("rOvR"/.ortExcData);
excessPerPreImage=ortExcPer-per;
ratioOrtPerPreImageAdj=ratioOrtPerPreImage-excessPerPreImage;
{t,
darboux, (* P (darboux) *)
ratioExc+wiggle, (* P'(r'/R') *)
ratioOrtPerPreImageAdj-wiggle, (* P''*((Subscript[R, acute])/(Subscript[r, acute])) - ((Subscript[P, acute])-P) *)
ratioOrtPer, (* P''*(R/r) *)
ratioOrtPerPreImage ,(* P''*((Subscript[R, acute])/(Subscript[r, acute])) *)
excessPerPreImage (* ((Subscript[P, acute])-P) *)
},{t,0,2π,π/100.}]];

Clear@showExcPerInvariants;
showExcPerInvariants[a_,wiggle_:.1]:=Module[{pers,tr,ts,clrs={Red,Green,Blue,Orange,Cyan,Purple}},
pers=excPerimeterInvariants[a,wiggle];
tr=Transpose[pers];
ts=tr[[1]];
Legended[
ListLinePlot[
(MapThread[Function[{l1,l2},{l1,l2}],{ts,#}])&/@Rest[tr]
,PlotStyle->clrs,Frame->True,FrameStyle->Medium,ImageSize->Large,FrameLabel->{"t","length"},PlotLabel->Style["a = "<>nfn[a,2],16],PlotRange->All],
LineLegend[Directive/@({#,Thick}&/@clrs),
Style[#,16]&/@{
"P",
"P'(r'/R')",
"P''*((Subscript[R, acute])/(Subscript[r, acute])) - ((Subscript[P, acute])-P)",
"P''*(R/r)",
"P''*((Subscript[R, acute])/(Subscript[r, acute]))",
"((Subscript[P, acute])-P)"
}]]];

showExcPerInvariants[2,.25]

Angular Invariants :
1) orbit : sum of cosines = 1 + r/R
2) excentral : product of cosines or - (sum of sines of double angles) = 1 + r/R
3) orthic : sum of sines of half angles = 1 + r/R [[only for acute orbits]]

Clear@excAngleInvariants;
excAngleInvariants[a_]:=Module[{normals,sides,rOvRp1,
orbit,orbitData,orbitCosines,orbitSum,
exc,excData,excCosines,excSum,excProd,
ort,ortData,ortCosines,ortSum},
Table[
{orbit,normals,sides}=orbitNormals[a,t];
orbitData=getTriData[orbit];
rOvRp1=(1+("rOvR"/.orbitData))*.99;
orbitCosines="cosines"/.orbitData;
exc=excentralTriangle[orbit,"sides"/.orbitData];
excData=getTriData[exc];
excCosines="cosines"/.excData;
ort=orthicTriangle[orbit,"sides"/.orbitData];
ortData=getTriData[ort];
ortCosines="cosines"/.ortData;
orbitSum=1.01*Total@orbitCosines;
(* hack: double angle works w/ sin or cos as arg *)
excSum=-.98*Total[cosDoubleAngle/@excCosines];
excProd=1+4*excCosines[[1]]*excCosines[[2]]*excCosines[[3]];
ortSum=Total[sinHalfAngle/@ortCosines];
{t,rOvRp1,orbitSum,excSum,excProd,ortSum},{t,0,2π,toRad[1.]}]];

Clear@showExcAngleInvariants;
showExcAngleInvariants[a_]:=Module[{pers,tr,ts,clrs={Red,Green,Blue,Orange,Pink}},
pers=excAngleInvariants[a];
tr=Transpose[pers];
ts=tr[[1]];
Legended[
ListLinePlot[
(MapThread[Function[{l1,l2},{l1,l2}],{ts,#}])&/@Rest[tr],
PlotStyle->clrs,Frame->True,FrameStyle->Medium,ImageSize->Large,FrameLabel->{"t","length"},PlotLabel->Style["a = "<>nfn[a,2],16],PlotRange->{All,{0,2}}],
LineLegend[Directive/@({#,Thick}&/@clrs),
Style[#,16]&/@{
"rOvRp1","orbitSum","excSum","excProd","ortSum"}]]]

showExcAngleInvariants[1.6]

So:
(a/a') = Sin[A/2]
(b/b') = Sin[B/2]
(b/c') = Sin[C/2]

Sin[θ/2]=Sqrt[(1-Cos[θ])/2]
Sin[θ/2]^2=(1-Cos[θ])/2

(a/a')^2+(b/b')^2+(c/c')^2=(1-Cos[A])/2+(1-Cos[B])/2+(1-Cos[C])/2=
(3-Cos[A]-Cos[B]-Cos[C])/2 =should be constant!

Since (proven below): cos[A] + cos[B]+ cos[C] = 1+r/R

(3-Cos[A]-Cos[B]-Cos[C])/2 = (3-1-r/R)/2 = 1-r/(2R)

Clear@showTriExc;showTriExc[a_,t_,test_:False]:=Module[{orbit,normals,sides,exc,excNormals,excNotables,excNpc,excCircleData,orbitSides,excSides,orbitMeds,excMeds,
txts,txtsExc,txtsSides,txtsSidesExc},
{orbit,normals,sides}=orbitNormals[a,t];
(* 23, 13, 12 *) orbitMeds=RotateRight[getMedians@@orbit];
(* 12, 23, 31 *) orbitSides=triSides@orbit;
exc=getExcenters[orbit,normals];
excNormals=getTriBisectors@@exc;
excNotables=getNotables[exc,excNormals];
excMeds="medians"/.excNotables;
excSides="sides"/.excNotables;
excNpc="npc"/.excNotables;
excCircleData=getExcircleData[orbit,exc,excNpc];
(*txts=MapThread[txtSubscript["P",#3,12,ray[#1,-norm@#2,.2]]&,{orbit,normals,{"1","2","3"}}];*)
txts=MapThread[Style[Text[#1,ray[#2,-#3,0.2]],16]&,{{"A","B","C"},orbit,normals}];
txtsExc=MapThread[Style[Text[#1,ray[#2,-#3,0.2]],16]&,{{"C'","A'","B'"},exc,excNormals}];
(*txtsExc=MapThread[txtSubscript["E",#3,12,ray[#1,-norm@#2,.2]]&,{exc,"xNormals"/.excData,{"1","2","3"}}];*)
txtsSides=MapThread[Style[Text[#1,ray[#2,norm[perpNeg[#3]],0.15]],14]&,{{"a","b","c"},orbitMeds,orbitSides}];
txtsSidesExc=MapThread[Style[Text[#1,ray[#2,norm[perpNeg[#3]],0.15]],14]&,{{"a'","b'","c'"},excMeds,RotateLeft@excSides}];
Show[{plotEll[a],
Graphics[{
FaceForm@None,PointSize@Medium,
{EdgeForm@Black,Polygon@orbit,Point@orbit,txts (*,txtsSides*)},
{EdgeForm["exc"/.ptClrs],"exc"/.ptClrs,Polygon@exc,Point@exc,
Point["medians"/.excNotables],Point["tps"/.excCircleData],txtsExc(*,txtsSidesExc*)},
{Point["mitten"/.excCircleData],Point@orbitMeds,Dashed,
MapThread[Line[{#1,#2}]&,{exc,"mittenFeet"/.excCircleData}]},
{Red,Point["mittenPedals"/.excCircleData],Line[{"mitten" /.excCircleData,#}]&/@("mittenPedals" /.excCircleData)},{Blue,Point["mittenFeet"/.excCircleData]},
(* verify if symmedian of extriangle A'B'C' is the same as mitten of ABC *)
{Red,Point["sym"/.excNotables]},
If[test,{Blue,Point["bar"/.excNotables],"mit"/.ptClrs,Point["mit"/.excNotables]},{}]}]},
PlotRange->{{-2,2},{-3,3}},AspectRatio->Automatic,Frame->False,Ticks->False,AxesStyle->Directive[{Dashed,GrayLevel[.7]}]]
];

Manipulate[showTriExc[1.5,t,test],
{{t,π/4},0,2π,toRad[.1]},
{{test,False},{True,False}},SaveDefinitions->True]

Adjust Trilinear to get real distances

getTrilinearK[a_,b_,c_]:=Module[{num,den},
num=2*triAreaHeron[{a,b,c}];
den={a,b,c}.{b+c-a,a+c-b,a+b-c};
num/den];

FullSimplify[(getTrilinearK[a,b,c]^2)(*/.c->P-b-a*),a>0&&b>0&&c>0&&P>0]

Soma dos comprimentos dos pedais do Mittenpunk é constante?

Clear@mittenPedalLengths;
mittenPedalLengths[a_,t_]:=Module[{orbit,triK,sideLengths,normals,exc,excNormals,excNotables,excNpc,excCircleData,mitten,mittenPedals},
{orbit,normals,sideLengths}=orbitNormals[a,t];
(*sideLengths=triLengths@orbit;*)
triK=getTrilinearK@@sideLengths;
exc=getExcenters[orbit,normals];
excNormals=getTriBisectors@@exc;
excNotables=getNotables[exc,excNormals];
excNpc="npc"/.excNotables;
excCircleData=getExcircleData[orbit,exc,excNpc];
mitten="mitten"/.excCircleData;
mittenPedals="mittenPedals"/.excCircleData;
triK*(magn[mitten-#]&/@mittenPedals)
];

Plot[Total@mittenPedalLengths[1.5,t],{t,0,2π}]

ListLinePlot@Module[{pl},
Table[{t,pl=mittenPedalLengths[1.5,t];(1/pl[[1]]+1/pl[[2]]+1/pl[[3]])},{t,0,2π,toRad[22.5]}]]

Sum of cos double angle of extriangle: cos(2A’)+cos(2B’)+cos(2C’) = -cos(A)-cos(B)-cos(C) = constant = 1 - r/R

Clear@excDoubleCos;excDoubleCos[a_,t_]:=Module[{orbit,normals,sides,exc,coss,sins},
{orbit,normals,sides}=orbitNormals[a,t];
coss=getTriCosines@orbit;
sins=Sqrt[1-#^2]&/@coss;
exc=getExcenters[orbit,normals];
{Total[coss],getTriDoubleCosineSum@exc,Total[sins],Apply[Times,sins]}
];

Plot[{excDoubleCos[3,t][[1]],excDoubleCos[3,t][[3]],excDoubleCos[3,t][[4]]},{t,0,2π},PlotStyle->Automatic,PlotLegends->{"∑cos((Subscript[θ, i]))","∑sin((Subscript[θ, i]))","∏sin((Subscript[θ, i]))"},Frame->True,FrameLabel->(Style[#,16]&/@{"t","∑"}),FrameStyle->Medium,PlotLabel->Style["N=3, a/b=1.5",{Black,20}]]

Table[excDoubleCos[3,t][[1]],{t,0,2π,toRad[1]}]//getStats

Table[excDoubleCos[3,t][[2]],{t,0,2π,toRad[1]}]//getStats

Table[excDoubleCos[1.5,t],{t,0,2π,toRad[1]}]//StandardDeviation//Chop

(a/a')^2 + (b/b')^2 + (c/c')^2 =(3 - Cos[A] - Cos[B] - Cos[C])/2 = 1-r/(2R) = constant!

Clear@triRatioSums;
triRatioSums[a_,t_]:=Module[{orbit,normals,sides,exc,p12,p23,p31,e12,e23,e31,notables,r,R,const},
{orbit,normals,sides}=orbitNormals[a,t];
exc=getExcenters[orbit,normals];
{p12,p23,p31}=triLengths[orbit];
{e12,e23,e31}=triLengths[exc];
notables=getNotables[orbit,normals];
r="incRadius"/.notables;
R="cirRadius"/.notables;
const=(2-r/R)/2;
{(p12/e23)^2+(p23/e31)^2+(p31/e12)^2,const}
];

Table[triRatioSums[1.5,t],{t,0,2π,2π/360}]//Mean

Table[triRatioSums[1.5,t],{t,0,2π,2π/360}]//StandardDeviation//Chop

Diagram of (u,v) arm constant r/R

rOvR2[a_]:=Module[{δ=Sqrt[a^4-a^2+1]},
2(δ-1)(a^2-δ)/(a^2-1)^2]

rOvR2[1.5]

a/.Solve[rOvR[a]==rOvR,a,Reals]

Plot Simple Triangle Arm For Constant r/R

armrOvRprod[u_,v_]:=Module[{tri},
tri={{0,0},{1,0},{u,v}};
Apply[Times,getTriCosines@tri]];

armrOvR[u_,v_]:=Module[{tri},
tri={{0,0},{1,0},{u,v}};
Total[getTriCosines@tri]-1];

Clear@showArm;
showArm[u_,v_,clr_:Blue]:=Module[{tri},
tri={{0,0},{1,0},{u,v}};
Graphics[{PointSize@Large,FaceForm@None,EdgeForm@{Thick,clr},Polygon@tri,clr,Point@tri}]]

showArm[2,1]

What is the largest r/R for when u = 1? (limit for non-obtuse)

Together@FullSimplify[armrOvR[1,v],v>0]

Maximize[(1+v)/Sqrt[1+v^2]-1,v]

This corresponds to the following ratio of axes

N@Solve[rOvR[a]==Sqrt[2]-1,a]

Transforms a triangle ABC into {{0, 0}, {1, 0}, {u, v}}

Clear@getTriUV;getTriUV[{p1_,p2_,p3_}]:=Module[{scale,p12hat,p3norm},
scale=magn[p2-p1];
p12hat=(p2-p1)/scale;
p3norm=(p3-p1)/scale;
{p3norm.p12hat,p3norm.perp@p12hat}];

getTriUVsameSign[vs_]:=Abs/@First@Select[Table[getTriUV@RotateLeft[vs,i],{i,3}],Sign[#[[1]]]==Sign[#[[2]]]&];

Clear@getArmAndExc;
getArmAndExc[a_,t_]:=Module[{o,n,s,exc,rOvR,excSides,excrOvR,uv,excUV},
{o,n,s}=orbitNormals[a,t];
(*uv=Chop@getTriUVsameSign[o];*)
uv=getTriUV[Reverse@o];
rOvR=getInradius[s]/getCircumradius[s];
exc=excentralTriangle[o,s];
(*excUV=Chop@getTriUVsameSign[exc];*)
excUV=getTriUV[Reverse@exc];
excSides=triLengthsRL@exc;
excrOvR=getInradius[excSides]/getCircumradius[excSides];
<|"rOvR"->rOvR,"excrOvR"->excrOvR,"orbit"->o,"exc"->exc,"orbitUV"->uv,"excUV"->excUV|>];

getArmAndExc[1.35,0]

getArmAndExc[1.5,π/2]/@{"rOvR","exc"}

Clear@showExcUVlocus;
Options@showExcUVlocus={minU->-.25,maxU->1.25,maxV->2,cosProd->False,labExtra->""};
showExcUVlocus[a_,OptionsPattern[]]:=Module[{cc,ccObt,ccUV,ccExcUV,arm,excArm,conservFn},
ccUV=Quiet@ParametricPlot[getArmAndExc[a,t]["orbitUV"],{t,0,2π},
PlotStyle->{Dashed,Darker@Blue}];
ccExcUV=Quiet@ParametricPlot[getArmAndExc[a,t]["excUV"],{t,0,2π},PlotStyle->{Dashed,Darker@Green}];
(*ccExcUV=Quiet@ParametricPlot[getArmAndExc[a,t]["excUV"],{t,0,2π},PlotStyle->{Dashed,Darker@Green}];*)
conservFn=If[OptionValue@cosProd,armrOvRprod,armrOvR];
cc=ContourPlot[conservFn[u,v],{u,OptionValue@minU,OptionValue@maxU},{v,0,OptionValue@maxV},ContourLabels->True,Contours->Table[x,{x,-1,5,.025}],ColorFunction->"LightTemperatureMap"];
arm=Graphics[showArm@@(getArmAndExc[a,toDeg@30.]["orbitUV"])];
excArm=Graphics[showArm[Sequence@@(getArmAndExc[a,toDeg@30.]["excUV"]),Darker@Green]];
(*ccObt=ContourPlot[armrOvR[u,v]==Sqrt[2]-1,{u,OptionValue@minU,OptionValue@maxU},{v,0,OptionValue@maxV},ContourLabels->True,Contours->{Sqrt[2]-1.},ContourStyle->{Dashed,Red}];*)
Show[{cc,(*ccObt,*)ccUV,ccExcUV(*,ccExcUV*),arm,excArm},PlotLabel->Style[OptionValue@labExtra<>"a/b="<>nfn[a,2],{Black,20}],PlotRange->{{OptionValue@minU,OptionValue@maxU},{0,OptionValue@maxV}},AspectRatio->Automatic]]

ColorData["Gradients"]

Grid[{Show[#,ImageSize->600]&/@{showExcUVlocus[1.5,labExtra->"∑cos(θ), "],showExcUVlocus[1.5,cosProd->True,labExtra->"∏cos(θ), "]}},ItemSize->Large]

Grid[{Show[#,ImageSize->600]&/@{showExcUVlocus[1.3522],showExcUVlocus[1.3522,cosProd->True]}},ItemSize->Large]

Grid[{Show[#,ImageSize->600]&/@{showExcUVlocus[2,minU->-1,maxU->2,maxV->3],showExcUVlocus[2,minU->-1,maxU->2,maxV->3,cosProd->True]}},ItemSize->Large]

Make Movie

Clear@showOrbitAndExc;
showOrbitAndExc[a_,tDeg_,ell_,lgt_:.4]:=Module[{orbitData,exc,gr},
orbitData=orbitDataT[a,toRad@tDeg];
exc=excentralTriangle@@({"orbit","sides"}/.orbitData);
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Darker@Green,Thick},Polygon@exc,Darker@Green,Point@exc},
{Black,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{PointSize@Large,Point@("orbit"/.orbitData)}
(*{Darker@Red,Point@{0,0}}*)}];
Show[{ell,drawOrbit[orbitData,"lgt"->lgt,"drNormals"->False,drVtxLabels->False],gr}]]

Clear@tableExcUVlocus;
Options@tableExcUVlocus={minU->-.5,maxU->1.5,maxV->2.25,labExtra->"",tDegStep->100,imgSz->600,tDegMax->360,plLabel->True};
tableExcUVlocus[a_,OptionsPattern[]]:=Module[{cc,ccProd,ccObt,ccUV,ccExcUV,arm,excArm,img,imgProd,ell,drOrbit,contours},
ccUV=Quiet@ParametricPlot[getArmAndExc[a,t]["orbitUV"],{t,0,π},
PlotStyle->{Dashed,Thick,Darker@Blue}];
ccExcUV=Quiet@ParametricPlot[getArmAndExc[a,t]["excUV"],{t,0,π},PlotStyle->{Dashed,Thick,Green}];
(*ccExcUV=Quiet@ParametricPlot[getArmAndExc[a,t]["excUV"],{t,0,2π},PlotStyle->{Dashed,Darker@Green}];*)
contours=Table[x,{x,-1,5,.025}];
cc=ContourPlot[armrOvR[u,v],{u,OptionValue@minU,OptionValue@maxU},{v,0,OptionValue@maxV},
ContourLabels->If[OptionValue@plLabel,contours,None],
Contours->contours,
ColorFunction->"LightTemperatureMap"];
ccProd=ContourPlot[armrOvRprod[u,v],{u,OptionValue@minU,OptionValue@maxU},{v,0,OptionValue@maxV},ContourLabels->If[OptionValue@plLabel,contours,None],
Contours->contours,ColorFunction->"LightTemperatureMap"];
ell=plotEll[a,{Thick,Black}];
Table[
drOrbit=Show[showOrbitAndExc[a,tDeg,ell],PlotRange->{{-2,2},{-4,4}},AspectRatio->Automatic,ImageSize->(OptionValue@imgSz)];
arm=Graphics[showArm@@(getArmAndExc[a,toRad@tDeg]["orbitUV"])];
excArm=Graphics[showArm[Sequence@@(getArmAndExc[a,toRad@tDeg]["excUV"]),Darker@Green]];
img=Show[{cc,(*ccObt,*)ccUV,ccExcUV(*,ccExcUV*),arm,excArm},
Frame->None,
PlotLabel->Style["∑cos(θ)"<>If[OptionValue@plLabel,", a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1],""],{Black,20}],PlotRange->{{OptionValue@minU,OptionValue@maxU},{0,OptionValue@maxV}},AspectRatio->Automatic,ImageSize->OptionValue@imgSz];
imgProd=Show[{ccProd,(*ccObt,*)ccUV,ccExcUV(*,ccExcUV*),arm,excArm},
Frame->None,
PlotLabel->Style["∏cos(θ)"<>If[OptionValue@plLabel,", a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1],""],{Black,20}],PlotRange->{{OptionValue@minU,OptionValue@maxU},{0,OptionValue@maxV}},AspectRatio->Automatic,ImageSize->OptionValue@imgSz];
Grid[{{drOrbit,img,imgProd}},Alignment->{Center,Center}],
{tDeg,0.01,OptionValue@tDegMax,OptionValue@tDegStep}]];

conservationPlot=Last@tableExcUVlocus[1.5,tDegStep->30.,imgSz->400,tDegMax->31,plLabel->False]

Export["0072_cosine_conservation.pdf",conservationPlot]

Study of Orthic

At which a/b will the orthic become obtuse?

Before we must ask, at which triangle height (say the base is = 1) does its orthic become obtuse?

baseCosOrt[d_]:=Module[{tri,ort,ortH,ortD,eqn,cosHalf},
tri={{-1/2,0},{1/2,0},{0,d}};
ort=getAltBases@@tri;
ortD=Sqrt[ort[[1]].ort[[1]]];
ortH=ort[[1,2]];
cosHalf=ortH/ortD;
cosDoubleAngle[cosHalf]
]

baseCosOrt[d]

Desenha órtico

Clear@drawOrthic;
drawOrthic[u_,v_,ymax_,op_,clrs_:{Blue,Red,Darker@Green}]:=Module[{tri,gr,xmax=2,sides,orthic,sidesOrt,excOrt,ort,tris},
tri={{-.5,0},{.5,0},{u,v}};
sides=triLengthsRL@tri;
ort=getOrthocenterTrilin[tri,sides];
orthic=orthicTriangle[tri,sides];
sidesOrt=triLengthsRL@orthic;
excOrt=excentralTriangle[orthic,sidesOrt];
tris={tri,orthic,excOrt};
gr=Graphics[{
MapThread[{
{Opacity@.15,FaceForm@#2,EdgeForm@#2,Thick,Polygon@#1},
{PointSize@Medium,#2,Point@#1}
}&,Reverse/@{tris,clrs}],
{Orange,PointSize@Large,Point@ort,Text[Style["(Subscript[X, 4])",16],ort,{-2,0}]}}];
Legended[Show[{gr,op},
ImageSize->Medium,Frame->False,FrameStyle->Medium,
PlotRange->{{-xmax,xmax},{-ymax,ymax}},AspectRatio->Automatic],LineLegend[Directive[Thick,#]&/@clrs,
Style[#,16]&/@{"reference","orthic","orthic's excentral"}]]];

Clear@ortPath;ortPath[xmin_,xmax_,y_,ps_:{Dashed,Orange}]:=Module[{tri,sides,ort},
Quiet@ParametricPlot[
tri={{-.5,0},{.5,0},{x,y}};
sides=triLengthsRL@tri;
ort=getOrthocenterTrilin[tri,sides],
{x,xmin,xmax},PerformanceGoal->"Speed",PlotStyle->ps,Epilog->{Black,Thick,Dashed,Line@{{xmin,y},{xmax,y}}},PlotRange->{Automatic,{Automatic,y+.1}}]
];

ortPath[-1.5,1.5,1]

DynamicModule[{op},
Manipulate[
op=ortPath[-1.5,1.5,1.2];
Dynamic@drawOrthic[x,1.2,1.5,If[drOrtPath,op,{}]],
{{x,.1},-2,2},
{{drOrtPath,True},{True,False}}]]

When is it obtuse

Um triangulo isoceles ABC, | AB | = 1, height = d, produz um ortico obtuso se (1) d < (Sqrt[2] - 1)/2 = .207 ou se (2) d > (Sqrt[2] + 1)/2 = 1.207
Ou seja, o cosseno da base do órtico é positivo

Plot[baseCosOrt[d],{d,0,3},AxesLabel->{"tri height (d)","cos base angle orthic"},AxesStyle->Medium,ImageSize->Large]

calcOrt[d_]:=Module[{tri,ort,ortW,eqn},
tri={{-1/2,0},{1/2,0},{0,d}};
ort=getAltBases@@tri;
ortW=2ort[[1,1]];
eqn=ortW^2==2ort[[1]].ort[[1]];
Select[d/.Solve[eqn,s],#>0&]
]

ortOpts=calcOrt[d]

ortOpts//N

Clear@showOrt;showOrt[d1_,d2_]:=Module[{tris,orts,gr},
tris={{-1/2,0},{1/2,0},{0,#}}&/@ortOpts;
orts=getAltBases@@#&/@tris;
orts[[2]]=(#+{0,0.0})&/@orts[[2]];(* perturb just to see *)
gr=Graphics[{FaceForm@None,PointSize@Medium,
{EdgeForm@Blue,Polygon/@tris,Blue,Point/@tris},
{EdgeForm@Red,Polygon/@orts,Red,Point/@orts}
}];
Show[gr,AspectRatio->Automatic,Frame->True,ImageSize->Small]
];

showOrt@@ortOpts

What a/b generates obtuse vertices?

Clear@minOrtAng;
minOrtAng[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,ort,ortCos},
{o,n,s}=orbitNormals[a,toRad@tDeg];
ort=orthicTriangle[o,s];
ortCos=getTriCosines[ort];
Min@ortCos];
Clear@maxOrtAng;
maxOrtAng[a_?NumericQ,tDeg_?NumericQ]:=Module[{o,n,s,ort,ortCos},
{o,n,s}=orbitNormals[a,toRad@tDeg];
ort=orthicTriangle[o,s];
ortCos=getTriCosines[ort];
Max@ortCos];

Clear@minOrtAngRange;
minOrtAngRange[a_?NumericQ,tDegMax_:90]:=Module[{o,n,s,ort,ortCos,gr={}},
FindMinimum[{minOrtAng[a,tDeg],0<tDeg<tDegMax},{tDeg,tDegMax/2}]];

Clear@maxOrtAngRange;
maxOrtAngRange[a_?NumericQ,tDegMax_:90]:=Module[{o,n,s,ort,ortCos,gr={}},
FindMaximum[{maxOrtAng[a,tDeg],-tDegMax<tDeg<tDegMax},{tDeg,tDegMax/2}]];

(* goes through segment orthic, one angle is 0, max cos is 1 *)

maxOrtAngRange[1.4,45]

orthic family can never be completely obtuse as orthic goes through segment when orbit is right triangle

{#,minOrtAngRange[#],maxOrtAngRange[#]}&/@Range[1.1,3,.1]//TableForm

Module[{as=Range[1.01,1.5,.025]},
Plot[Evaluate[minOrtAng[#,tDeg]&/@as],{tDeg,0,40},PlotLegends->(nfn[#,2]&/@as),Frame->True,FrameStyle->Medium,FrameLabel->Style[{"θ","min cos"},Medium],ImageSize->Large]]

Ronaldo Expressao para a/b que faz ortico da orbita deitada ser retangulo :

Solve[(97*a^8-52*a^6*b^2-122*a^4*b^4+12*a^2*b^6+b^8==0)/.b->1,a,Reals]

(97*a2^4-52*a2^3*b^2-122*a2^2*b^4+12*a2*b^6+b^8==0)/.b->1

Sqrt[a2/.NSolve[(97*a2^4-52*a2^3*b^2-122*a2^2*b^4+12*a2*b^6+b^8==0)/.b->1,a2,Reals]]

1/.383797

Clear@showOrtAng;
Options@showOrtAng={drScene->False,th1displ->{-2,0},th1hdispl->{-2,0},dashed->False,drText->True,ortClr->{Thick,Orange},drOrtOrt->False};
showOrtAng[a_?NumericQ,tDeg_?NumericQ,OptionsPattern[]]:=Module[{o,n,s,ort,ortCos,ortOrt,gr={}},
{o,n,s}=orbitNormals[a,toRad@tDeg];
ort=orthicTriangle[o,s];
ortCos=getTriCosines[ort];
ortOrt=getOrthocenterTrilin[ort,triLengthsRL@ort];
gr=If[OptionValue@drScene,Show[{plotEll[a,{Thick,Black,If[OptionValue@dashed,Dashed,{}]}],
Graphics[{FaceForm@None,PointSize@Large,
{Gray,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{EdgeForm@Join[{Thick,Blue},If[OptionValue@dashed,{Dashed},{}]],Polygon@o,Blue,Point@o,If[OptionValue@drText,Text[Style["(Subscript[θ, 1])",16,Background->White],o[[1]],OptionValue@th1displ],{}]},
If[OptionValue@drOrtOrt,{Purple,Point@ortOrt},{}],
{EdgeForm@Join[OptionValue@ortClr,If[OptionValue@dashed,{Dashed},{}]],Polygon@ort,Sequence@@OptionValue@ortClr,Point@ort,If[OptionValue@drText,Text[Style["(Subscript[θ, 1, h])",16,Background->White],ort[[1]],OptionValue@th1hdispl],{}]}}]},
PlotLabel->If[OptionValue@drText,Style["a/b="<>nfn[a,5]<>", (Subscript[cosθ, 1, h])="<>nfn[N@If[Abs@ortCos[[1]]<10^-5,0,ortCos[[1]]],3],{Black,16}],None],{}]];
If[OptionValue@drScene,gr,ortCos]];

showOrtAng[3,10,drScene->True,drText->True]

Manipulate[Show[showOrtAng[a,tDeg,drScene->True,drOrtOrt->True],PlotRange->{{-3,3},{-3,3}}],
{{a,1.5},1.001,4,.01},
{{tDeg,10},-180,180,1}]

Plot[showOrtAng[2.5,tDeg,drScene->False][[1]],{tDeg,0,180}]

ortRightTri=showOrtAng[1.17435,90,drScene->True,drText->True]

ortRightTriNoText=showOrtAng[1.17435,90,drScene->True,drText->False]

ortRightTriOuter=showOrtAng[2.605,90,drScene->True,th1displ->{0,-1.5},th1hdispl->{0,1.5}]

ortRightTriOuterNT=showOrtAng[2.605,90,drScene->True,th1displ->{0,-1.5},th1hdispl->{0,1.5},drText->False]

ortRightTriOuterDashed=showOrtAng[2.605,90,drScene->True,th1displ->{0,-1.5},th1hdispl->{0,1.5},dashed->True,drText->False]

ortRightTri=showOrtAng[1.17435,0,drScene->True]

ortRightTriNoText=showOrtAng[1.17435,0,drScene->True,drText->False]

Grid[{MapThread[Show[#1,ImageSize->400, AspectRatio->(#3+1.2)/(2#2),PlotRange->{{-#2,#2},{-1.2,#3}},Frame->True]&,{{ortRightTri,ortRightTriOuter},{1.4,2.75},{2,2}}]},Frame->All,Spacings->1]

orthicRightTriangle2cases=Show[{ortRightTriNoText,Graphics@Translate[List@@ortRightTriOuterNT,{4.5,0}]},ImageSize->400,AspectRatio->Automatic, PlotRange->All,Frame->False]

export3["0090_orthic_right_triangle",orthicRightTriangle2cases]

Plot[showOrtAng[a,0.][[1]],{a,1.0001,2}]

FindRoot[showOrtAng[a,0.][[1]],{a,1.2}]

Locus of Orthic Orthocenter

showOrtAng[1.4,80,drScene->True,drText->False]

getOrthicOrthocenter[a_?NumericQ,tDeg_?NumericQ]:=Module[{ons,ort,ortSides,eps=0},
ons=orbitNormals[a,toRad@(tDeg+eps)];
ort=orthicTriangle[ons[[1]],ons[[3]]];
ortSides=triLengthsRL@ort;
getOrthocenterTrilin[ort,ortSides]];

Clear@orthicOrthocenterLocus;
Options@orthicOrthocenterLocus={slackX->.1,slackY->.1,tDegMax->150.,perfGoal->"Speed",drPlotLabel->True};
orthicOrthocenterLocus[a_,OptionsPattern[]]:=Module[{ons,ort,ortSides,ortOrt,ortOrtSides,x,eps=10^-4,ppX4,ppOrtX4,ppOrtX1,ell,pl,pr,maxX,maxY},
ell=plotEllAxes[a,{Black,Thick}];
ppX4=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@(tDeg+eps)];
getOrthocenterTrilin[ons[[1]],ons[[3]]],
{tDeg,0,180},PlotStyle->{Thick,Orange},PerformanceGoal->(OptionValue@perfGoal)];
ppOrtX4=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@(tDeg+eps)];
ort=orthicTriangle[ons[[1]],ons[[3]]];
ortSides=triLengthsRL@ort;
getOrthocenterTrilin[ort,ortSides],
{tDeg,0,180},PlotStyle->{Blue},PerformanceGoal->(OptionValue@perfGoal),MaxRecursion->8];
maxX=Abs@getOrthicOrthocenter[a,0][[1]];
maxY=Abs@getOrthicOrthocenter[a,90][[2]];
ppOrtX1=Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@(tDeg+eps)];
ort=orthicTriangle[ons[[1]],ons[[3]]];
ortSides=triLengthsRL@ort;
ortOrt=orthicTriangle[ort,ortSides];
ortOrtSides=triLengthsRL@ortOrt;
getIncenterTrilin[ortOrt,ortOrtSides],
{tDeg,0,OptionValue@tDegMax},PlotStyle->{Thick,Dashed,Darker@Green},PerformanceGoal->(OptionValue@perfGoal)];
pl="a/b="<>nfn[a,3];
pr={{Min[-a,-maxX]-OptionValue@slackX,Max[a,maxX]+OptionValue@slackX},
{Min[-1,-maxY]-OptionValue@slackY,Max[1,maxY]+OptionValue@slackY}};
Show[{ell,ppX4,ppOrtX4,ppOrtX1},ImageSize->400,PlotRange->pr,If[OptionValue@drPlotLabel,PlotLabel->Style[pl,{Black,16}],{}]]
];

orthicOrthocenterLocus[5,perfGoal->"Quality",drPlotLabel->False]

At what a/b the orthic orthocenter touches the billiard?

getOrthicOrthocenter[1.3,90][[2]]

getOrtOrtDiffY[a_?NumericQ]:=getOrthicOrthocenter[a,90][[2]]-1;getOrtOrtDiffX[a_?NumericQ]:=getOrthicOrthocenter[a,0][[1]]+a;
getOrtOrtY[a_?NumericQ]:=getOrthicOrthocenter[a,90][[2]];

FindRoot[getOrtOrtDiffX[a],{a,1.33}]

FindRoot[getOrtOrtDiffY[a],{a,1.33}]

FindRoot[getOrtOrtY[a]+1,{a,3}]

FindRoot[getOrtOrtY[a],{a,2.6}]

(* parei aqui adicionar isto ao paper *)

orthicOrthicGrs=
Module[{as,tDegMaxs,grs,slackYs},as={
1.174,1.2,1.32514,
1.35219,1.618,2.57131,
2.605,2.97489,3.5};
tDegMaxs={
140,129,133,
135,143,160,
160,160,160};
slackYs=ReplacePart[ConstantArray[.1,Length@as],8->.2];
grs=MapThread[orthicOrthocenterLocus[#1,perfGoal->"Quality",tDegMax->#2,slackY->#3,drPlotLabel->False]&,
{as,tDegMaxs,slackYs}];
Transpose[{as,grs}]];

orthicOrthicPlot=Module[{as,grs,asPart,grsPart,leg,romans},
as=First/@orthicOrthicGrs;
grs=Second/@orthicOrthicGrs;
romans={"(i)","(ii)","(iii)","(iv)","(v)","(vi)","(vii)","(viii)","(ix)"};
asPart=Partition[MapIndexed[Style[romans[[First@#2]]<>" a/b="<>nfn[#,3],{Black,20}]&,as],3];
grsPart=Partition[grs,3];
leg=LineLegend[{Directive[AbsoluteThickness[3],Black],Directive[AbsoluteThickness[3],Orange],Directive[AbsoluteThickness[3],Blue],Directive[AbsoluteThickness[3],Dashed,Darker@Green]},Style[#,20]&/@{"EB","(Subscript[X, 4])","Orthic (Subscript[X, 4])","Orthic's Orthic (Subscript[X, 1])"},LegendLayout->"Row"];
Grid[Append[MapThread[{Grid[{#1,#2},Frame->All]}&,{asPart,grsPart}],{leg,SpanFromLeft}],Spacings->{0,1}]]

export3["1085_orthic_orthic",orthicOrthicPlot]

Do paper: (basic orbits)

1) When orbit is horizontal :

orbitW[a_]:=Sqrt[2 deltaA[a]-a^2+1]/(a^2-1);

orbitHeightHoriz[a_]:=a^3/(deltaA[a]+1);
(* a>1 *)
orbitBaseHoriz[a_]:=orbitW[a];

horizD[a_]=FullSimplify[orbitHeightHoriz[a]/orbitBaseHoriz[a],a>1]

posReal[x_]:=If[negl[Im[x]],(Re[x]>0),False];

(a/.Solve[horizD[a]==ortOpts[[1]],a])^2

posReal/@N@(a/.Solve[horizD[a]==ortOpts[[1]],a])

(a/.Solve[horizD[a]==ortOpts[[2]],a])^2

posReal/@N@(a/.Solve[horizD[a]==ortOpts[[2]],a])

{#,First@Select[N[a/.Solve[horizD[a]==#,a]],posReal]}&/@ortOpts//Prepend[#,{"critical d","a/b"}]&//Grid[#,Frame->All]&

Plot Orthic' s Orthocenter, and Orthic' s orthic' s Incenter.

nfn[1.2,3]

Module[{as={1.17,1.5},clrs={Red,Blue}},
Legended[
Show[MapThread[orthicsOrthicIncenterLocus[#1,π/1.2,π/1.2,#2]&,{as,clrs}]//Quiet,
ImageSize->Large,PlotRange->All],
LineLegend[Directive[{Thickness@Large,#}]&/@(Sequence@@{{Dashed,#},#}&/@clrs),
Flatten[{"a="<>nfn[#,3]<>", ortOrt","a="<>nfn[#,3]<>", ortOrtInc"}&/@as]]]]

(* FAZER VIDEO variando a *)

Module[{as={1.1,1.25,1.50,2.00,2.50,3,3.5},clrs={Darker@Gray,Red,Darker@Green,Blue,Pink,Orange,Cyan}},
Legended[
Show[MapThread[orthicsOrthicIncenterLocus[#1,π/1.1,π/1.9*Sqrt[#1],{Dashed,#2},#2]&,{as,clrs}]//Quiet,
ImageSize->800,PlotRange->All],
LineLegend[Directive[{Thickness@Large,#}]&/@(Sequence@@{{Dotted,#},#}&/@clrs),
Flatten[{"a="<>nf[#]<>", ortOrt","a="<>nf[#]<>", ortOrtInc"}&/@as]]]]

getOneOrthicOrtIncFrame[a_]:=Module[{styles={Darker@Gray,Orange,Green,Blue,Red},xmax=6.5,ymax=2.5},
Legended[Show[Quiet@{
plotEll[a,styles[[1]]],
orthocenterLocus[a,π,styles[[2]]],
orthicIncenterLocus[a,π,styles[[3]]],
orthicsOrthicIncenterLocus[a,π/1.1,2π,styles[[4]],styles[[5]]]
},
PlotLabel->Style["a/b = "<>nfn[a,2],16],
AspectRatio->Automatic,
AxesStyle->16,
ImageSize->800,
PlotRange->{{-xmax,xmax},{-ymax,ymax}}],
LineLegend[Directive/@styles,
{"billiard","orbit orthocenter","orthic incenter","orthic orthocenter","orthic orthic's incenter"}]]];

getOneOrthicOrtIncFrame[3.5]

2) When orbit is vertical (no real solutions!)

orbitHeightVert[a_]:=1+1/(a^2+deltaA[a]);
orbitBaseVert[a_]:=2*a^2orbitW[a];

horizW[a_]=FullSimplify[orbitHeightVert[a]/orbitBaseVert[a],a>1]

Select[N[a/.Solve[horizW[a]==#,a]],posReal]&/@ortOpts

Epitrochoid (should it be pedal curve?)

Clear@epitrochoid;
epitrochoid[r_,d_,th_]:=Module[{arg},
arg=th(1/r+1);
{(1+r)Cos[th]-d Cos[arg],(1+r)Sin[th]-d Sin[arg]}]

What (1, b) ellipse produces an ellipse whose eccentricity is the same as (1.5, 1)

Solve[eccentricity[1.5,1]==eccentricity[1,b],b]

eccentricity[1.5,1]

1./(2/3)

Manipulate[
ParametricPlot[epitrochoid[r,r*d,th],{th,0,ThMult*2π},PlotStyle->{Thick,Red},PerformanceGoal->"Quality",Frame->True],
{{r,.25},.01,3,.01,Appearance->"Labeled"},
{{d,2.5},0,5,Appearance->"Labeled"},
{{ThMult,2},1,10,1,Appearance->"Labeled"}]

Circumconic and Inconic and Axes and Areas

Clear@getConicArea;getConicArea[a_,t_,ctrTrilinFn_]:=Module[{o,n,s,ctr,circum,area},
{o,n,s}=orbitNormals[a,t];
ctr=ctrTrilinFn[o,s];
circum=getCircumAny[o,ctr];
area=circum["area"];
area];

Clear@getInconicArea;getInconicArea[a_,t_,ctrTrilinFn_,touchPtsFn_]:=Module[{o,n,s,ctr,circum,area,tps},
{o,n,s}=orbitNormals[a,t];
ctr=ctrTrilinFn[o,s];
tps=touchPtsFn@@o;
circum=getCircumAny[tps,ctr];
area=circum["area"];
area];

It is a known result the Steiner Ellipse has 4 x the area of the Steiner Inellipse

ListLinePlot[Transpose@Table[{
{tDeg,getConicArea[1.5,toRad@tDeg,getBarycenterTrilin]},
{tDeg,getInconicArea[1.5,toRad@tDeg,getBarycenterTrilin,getMedians]}},{tDeg,0,360,1}],PlotLegends->{"steiner circum","steiner inell"}]

Module[{a=1.5},
ListLinePlot[Table[
{tDeg,getConicArea[a,toRad@tDeg,getBarycenterTrilin]/getInconicArea[a,toRad@tDeg,getBarycenterTrilin,getMedians]},
{tDeg,0,360,1}]]]

The Areas of the X(1) and X(2) Circumconics is not stable

ListLinePlot[Transpose@Table[{
{tDeg,getConicArea[1.5,toRad@tDeg,getBarycenterTrilin]},
{tDeg,getConicArea[1.5,toRad@tDeg,getIncenterTrilin]}},{tDeg,0,360}]]

When plotting area (E1) vs area (E2), they fool the eye : very close to a straight line

ListLinePlot[Table[{
getConicArea[1.5,toRad@tDeg,getBarycenterTrilin],
getConicArea[1.5,toRad@tDeg,getIncenterTrilin]},{tDeg,0,360}],AxesLabel->(Style[#,Medium]&/@{"area (Subscript[E, 2])","area (Subscript[E, 1])"})]

The ratio of areas is not constant

ListLinePlot[Table[{tDeg,
getConicArea[1.5,toRad@tDeg,getIncenterTrilin]/getConicArea[1.5,toRad@tDeg,getBarycenterTrilin]},{tDeg,0,360}],AxesLabel->(Style[#,Medium]&/@{"t","area (Subscript[E, 1])/(Subscript[E, 2])"})]

Module[{a=1.5,lm,areaX1,areaX2},
areaX1=Table[getConicArea[a,toRad@tDeg,getIncenterTrilin],{tDeg,0,359}];
areaX2=Table[getConicArea[a,toRad@tDeg,getBarycenterTrilin],{tDeg,0,359}];
lm=LinearModelFit[Transpose@{areaX1,areaX2},x,x];
{Normal@lm,lm["RSquared"]}]

And their ratios are not stable either

Clear@getConicAxes;getConicAxes[a_,t_,ctrTrilinFn_]:=Module[{o,n,s,ctr,circum,lgts},
{o,n,s}=orbitNormals[a,t];
ctr=ctrTrilinFn[o,s];
circum=getCircumAny[o,ctr];
lgts=circum["lengths"];
lgts];

getConicAxesRatio[a_,tDeg_,ctrTrilinFn_]:=(#[[2]]/#[[1]])&@getConicAxes[a,toRad@tDeg,ctrTrilinFn];

getConicAxesRatio[1.5,10.,getIncenterTrilin]

getConicAxesRatio[2.,10.,getIncenterTrilin]

Ronaldo E1 axes ratio 20/01/2020

getE1AxesRatioRonaldo[a_,b_]:=Module[{delta=Sqrt[a^4-a^2b^2+b^4]},
Sqrt@(2delta^2+2(a^2-b^2)delta-a^2b^2)/(b^2)]

getE1AxesRatioPoristic[a_,b_]:=Module[{ρ},
ρ=rOvR[a/b];
(1+Sqrt[1-2ρ])/ρ-1];

getE1AxesRatioPoristic[2.,1]

getE1AxesRatioRonaldo[2.,1.]

Clear@getInconicAxes;getInconicAxes[a_,t_,ctrTrilinFn_,touchPtsFn_]:=Module[{o,n,s,ctr,circum,lgts,tps},
{o,n,s}=orbitNormals[a,t];
ctr=ctrTrilinFn[o,s];
tps=touchPtsFn@@o;
circum=getCircumAny[tps,ctr];
lgts=circum["lengths"];
lgts]

ListLinePlot[Transpose@Table[{tDeg,#}&/@getConicAxes[1.5,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}]]

The Steiner axes are linearly related!

Module[{axes125,axes15,axes175,axes20},
axes125=Table[{#[[1]],#[[2]]}&@getConicAxes[1.25,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}];
axes15=Table[{#[[1]],#[[2]]}&@getConicAxes[1.5,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}];
axes175=Table[{#[[1]],#[[2]]}&@getConicAxes[1.75,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}];
axes20=Table[{#[[1]],#[[2]]}&@getConicAxes[2.0,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}];
ListLinePlot[{axes125,axes15,axes175,axes20},PlotLegends->{1.25,1.5,1.75,2.0},ImageSize->Large,PlotStyle->Automatic,Frame->True,FrameStyle->Medium,FrameLabel->(Style[#,Medium]&/@{"(Subscript[η, 2])","(Subscript[η, 2])'"})]]

Table[{#[[1]],#[[2]]}&@getConicAxes[1.25,toRad@tDeg,getBarycenterTrilin],{tDeg,0,10}]

Clear@x;

getE2fit[a_]:=Module[{data,fit},
data=Table[{#[[1]],#[[2]]}&@getConicAxes[a,toRad@tDeg,getBarycenterTrilin],{tDeg,0,359}];
fit=LinearModelFit[data,x,x];
{a,fit//Normal,fit["RSquared"]}]

getE2fit[20.]

getE2fit/@Range[1.1,3,.1]//TableForm

steinerCircumellFits=Table[Normal@LinearModelFit[Table[{#[[1]],#[[2]]}&@getConicAxes[a,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}],x,x],{a,1.1,3,.1}];

steinerInellFits=Table[Normal@LinearModelFit[Table[{#[[1]],#[[2]]}&@getInconicAxes[a,toRad@tDeg,getBarycenterTrilin,getMedians],{tDeg,0,360}],x,x],{a,1.1,3,.1}];

Grid[Prepend[Transpose@{Range[1.1,3,.1],steinerCircumellFits,steinerInellFits},{"a/b","steiner circum","steiner inell"}],ItemStyle->Directive[Black,18,FontFamily->"Courier New"],Frame->All]

ListLinePlot[Table[{tDeg,#[[1]]+#[[2]]}&@getConicAxes[1.5,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}]]

ListLinePlot[Transpose@Table[{tDeg,#}&/@getConicAxes[1.5,toRad@tDeg,getIncenterTrilin],{tDeg,0,360}]]

The ratio of axes of the steiner circumellipse is not constant

ListLinePlot[Table[{tDeg,#[[2]]/#[[1]]}&@getConicAxes[1.5,toRad@tDeg,getBarycenterTrilin],{tDeg,0,360}]]

*** The ratio of axes of the incenter circumellipse is constant! ***

LinearModelFit[Table[{#[[2]],#[[1]]}&@getConicAxes[1.5,toRad@tDeg,getIncenterTrilin],{tDeg,0,360}],x,x]//Normal

ListLinePlot[Table[{#[[1]],#[[2]]}&@getConicAxes[1.5,toRad@tDeg,getIncenterTrilin],{tDeg,0,360}],PlotMarkers->{Automatic,Small}]

ListLinePlot[Table[{tDeg,#[[2]]/#[[1]]}&@getConicAxes[1.5,toRad@tDeg,getIncenterTrilin],{tDeg,0,360}]]

getStats@Table[Divide@@getConicAxes[1.5,toRad@tDeg,getIncenterTrilin],{tDeg,0,359,1}]

Module[{tDeg=40.},ListLinePlot[Table[{a,Divide@@getConicAxes[a,toRad@tDeg,getIncenterTrilin]},{a,1.01,2,.1}],PlotMarkers->Automatic,PlotLabel->Style["Ratio of Axes for the (Subscript[X, 1])-centered Circumellipse",{Medium,Black}],Frame->True,GridLines->Automatic,
FrameLabel->(Style[#,{Medium,Black}]&/@{"a","axis ratio"}),FrameStyle->{Medium,Black}]]

Ratio of axes for Steiner Inellipse is not constant

getStats@Table[Divide@@getInconicAxes[1.5,toRad@tDeg,getBarycenterTrilin,getMedians],{tDeg,0,359,1}]

Near Circularity of Some Loci

ListLinePlot[{lociMed15t[[37]]},AspectRatio->1,ImageSize->Small]

Clear@getMinCircularity;getMinCircularity[loci_]:=Module[{l,imin},
l=Select["zscore"/.Quiet@(getCircularity/@loci),NumberQ];
imin=First@First@Position[l,Min[l]];
{l[[imin]],centerNames[[imin]]}]

Clear@getMinCircularity2;getMinCircularity2[loci_,n_:2]:=Module[{l,best},
l=Select[Quiet@(getCircularity/@loci),(NumberQ["zscore"/.#])&];
best=Ordering[l,n,("zscore"/.#1)<("zscore"/.#2)&];
{{"zscore","mean"}/.l[[best]],best,centerNames[[best]]}]

Mittenpunkt of Exfeuerbach is the champ in circularity

getMinCircularity2[lociExfeuerbach15t,5]

Sort[MapThread[Prepend[getMinCircularity2[#1,5],#2]&,{{loci15t,lociExc15t,lociOrt15t,lociMed15t,lociIntouch15t,lociExtouch15t,lociAnticompl15t,lociExfeuerbach15t},
{"orbit","excentral","orthic","medial","intouch","extouch","anticompl","exfeuer"}}],#1[[2]]<#2[[2]]&]//TableForm

getCircularity[lociExfeuerbach15t[[9]]]

Show[{ListLinePlot[{lociExfeuerbach15t[[9]]},AspectRatio->1,ImageSize->Small],
Graphics[{Green,Circle[{0,0},.426511]}]},ImageSize->Small]

Clear@getDerivedTriPoint;getDerivedTriPoint[a_,t_,triFn_,pointFn_]:=Module[{o,n,s,tri,p},
{o,n,s}=orbitNormals[a,t];
tri= triFn[o,s];
p=pointFn[tri,triLengthsRL@tri];
p];

Clear@getDerivedTriCircularity;
getDerivedTriCircularity[a_,triFn_,pointFn_,stepDeg_:1]:=Module[{locus,circ},
locus=Table[getDerivedTriPoint[a,toRad@tDeg,triFn,pointFn],{tDeg,0,359,stepDeg}];
circ=getCircularity@locus;
circ];

Clear@getFeuerbachTriMitten;
getFeuerbachTriMitten[a_,t_]:=getDerivedTriPoint[a,t,feuerbachTriangle,getMittenTrilin];

Quiet@ParametricPlot[getFeuerbachTriMitten[1.01,t],{t,0,π},ImageSize->Small]

There' s a minimum of the circularity error for the mittenpunkt of the feuerbach triangle

getDerivedTriCircularity[2,feuerbachTriangle,getMittenTrilin]

(* not working ... *)

(* FindMinimum[{"zscore"/.getDerivedTriCircularity[a,feuerbachTriangle,getMittenTrilin],1.4<a<2},{a,1.4,1.5}]*)

Module[{as,circs},
as=Range[1.4,2,.025];
circs=getDerivedTriCircularity[#,feuerbachTriangle,getMittenTrilin]&/@as;
ListLinePlot[Transpose@MapThread[{{#1,"sd"/.#2},{#1,"zscore"/.#2}(*,{#1,"mean"}/.#2*)}&,{as,circs}],PlotLegends->{"sd","zscore"(*,"mean rad"*)},PlotLabel->"Locus of Mittenpunkt of Feuerbach Triangle:\nCircular Error vs. a/b",PlotMarkers->Automatic,Frame->True,FrameLabel->{"a/b","statistic"},FrameStyle->Medium]]

X(56) = EXSIMILICENTER(CIRCUMCIRCLE, INCIRCLE) = a/(b + c - a) : b/(c + a - b) : c/(a + b - c) 
NEARLY CIRCULAR

ListLinePlot[{lociExc15t[[56]]},AspectRatio->1,ImageSize->Small]

getCircularity[lociExc15t[[56]]]

ListLinePlot[magn/@lociExc15t[[56]],AxesOrigin->{0,0},AxesLabel->{"sample","radius"}]

Radii of Feuerbach or Symmedian Circumcircles (not constant but linearly related)

Clear@getExcData;getExcData[a_,t_]:=Module[{orbit,normals,sides,exc,npc,excCircleData,feus,exfSides},
{orbit,normals,sides}=orbitNormals[a,t];
exc=getExcenters[orbit,normals];(*12,23,31*)
npc=getNinepointcenter@@orbit;
excCircleData=getExcircleData[orbit,exc,npc];
excCircleData]

Centers of these circumcircles move along ellipses

ListLinePlot[Transpose@Table[{"feusCir","mittenFeetCir"}/.getExcData[1.5,toRad@tDeg],{tDeg,0,359}],AspectRatio->Automatic]

ListLinePlot[Table[{tDeg,"feusCirR"/.getExcData[1.5,toRad@tDeg]},{tDeg,0,359}]]

ListLinePlot[Table[{tDeg,"mittenFeetCirR"/.getExcData[1.5,toRad@tDeg]},{tDeg,0,359}]]

Module[{excData},
ListLinePlot[Table[excData=getExcData[1.5,toRad@tDeg];{"mittenFeetCirR","feusCirR"}/.excData,{tDeg,0,359}]]]

Module[{excData,a=1.5},
LinearModelFit[Table[excData=getExcData[a,toRad@tDeg];{"mittenFeetCirR","feusCirR"}/.excData,{tDeg,0,359}],x,x]//Normal]

Constant Perimeter Ratios?

perRatio[a_]:=Module[{b=1,a2,b2,c2,δ,ac,bc,perEll,perCaustic,perX1,aa1,bb1,aa5,bb5,perX5},
perEll=ellPerimeter[a,b];
a2=a*a;
b2=b*b;
c2=(a2-b2);
δ=Sqrt[a2^2-a2 b2+b2^2];
ac=a(δ-b2)/c2;bc=b(a2-δ)/c2;
perCaustic=ellPerimeter[ac,bc];
aa1=(δ-b2)/a;
bb1=(a2-δ)/b;(* use aan,bbn not to clash with an *)
perX1=ellPerimeter[aa1,bb1];
aa5=(-a2(a2+3b2)+δ(3a2+b2))/(4a c2);
bb5=(-b2(3a2+b2)+δ(a2+3b2))/(4b c2);
perX5=ellPerimeter[aa5,bb5];
Re/@<|"ell/Caustic"->{a,perEll/perCaustic},
"Caustic/X1"->{a,perCaustic/perX1},
"ell/X1"->{a,perEll/perX1},
"ell/X5"->{a,perEll/perX5},
"Caustic/X5"->{a,perCaustic/perX5}
|>
];

perRatio[1.5]

Module[{tab,keys},
tab=Table[perRatio[a],{a,1.001,5.0,.01}];
keys=Keys[tab[[1]]];
ListLinePlot[Transpose[Values[#]&/@tab],PlotStyle->ConstantArray[Thick,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,AxesLabel->(Style[#,16]& /@{"a/b","perimeter ratio"}),AspectRatio->1]]

ellPerimeter[1.5,1]

Iso-Contours : A, L, γ

showIsoEll[perExp_,areaExp_]:=Module[{lab},
lab=Style["L^"<>nfn[perExp,2]<>" * A^"<>nfn[areaExp,2],{Medium,Black}];
ContourPlot[(ellPerimeter[a,b]^perExp ellArea[a,b]^areaExp),{a,.1,2},{b,.1,2},ContourLabels->True,PlotLabel->lab,ColorFunction->"Temperature",PlotTheme->"Web"]]

iso10=Show[{showIsoEll[1,0],Graphics@{Darker@Green,Thick,Circle[{-.1,-.1},1.1]}}];
iso01=showIsoEll[0,1];
iso11=showIsoEll[1,1];
iso2m1=showIsoEll[2,-1];
iso15m05=showIsoEll[1.5,-.5];
iso15m025=showIsoEll[1.5,-.25];

Grid[Partition[Show[#,ImageSize->300]&/@{iso10,iso01,iso11,iso2m1,iso15m05,iso15m025},3]]

Sum of perimeter + area

ContourPlot[ellArea[a,b]+ellPerimeter[a,b],{a,.1,2},{b,.1,2},ContourLabels->True,PlotTheme->"Web"]

getGammaL[1.5,1]

Check if perimeter is correct :

orbitNormals[1.5,0.][[3]]//Total

ellIsoGamma=ContourPlot[getGammaLsym[a,b][[1]],{a,.1,2},{b,.1,2},ContourLabels->True,ColorFunction->"Temperature",
FrameStyle->Medium,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->Style["γ",{Black,Large}]];

ellIsoL=ContourPlot[getGammaLsym[a,b][[2]],{a,.1,2},{b,.1,2},ContourLabels->True,ColorFunction->"Temperature",
FrameStyle->Medium,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->Style["L",{Black,Large}]];

ellIsoGammaL=ContourPlot[Apply[Times,getGammaLsym[a,b]],{a,.1,2},{b,.1,2},ContourLabels->True,ColorFunction->"Temperature",
FrameStyle->Medium,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->Style["γ L",{Black,Large}]];

ellIsoGammaOvL=ContourPlot[getGammaLsym[a,b][[1]]/getGammaLsym[a,b][[2]],{a,.1,2},{b,.1,2},ContourLabels->True,ColorFunction->"Temperature",
FrameStyle->Medium,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->Style["γ/L",{Black,Large}]];

ellIsoLovGamma=ContourPlot[getGammaLsym[a,b][[2]]/getGammaLsym[a,b][[1]],{a,.1,2},{b,.1,2},ContourLabels->True,ColorFunction->"Temperature",
FrameStyle->Medium,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->Style["L/γ",{Black,Large}]];

Grid[Map[Show[#,ImageSize->400]&,{{ellIsoGamma,ellIsoL,ellIsoGammaL},{ellIsoGammaOvL,ellIsoLovGamma}},{2}],ItemSize->Full]

Draw Any Center (all loci!)

Clear@anyNewCenter;
anyNewCenter[o_,s_,n_]:=Module[{or,sr},
or=Reverse@o;
sr=Reverse@s;
Third/@getNewCenters[or,sr,n]];

Clear@anyNewCenterT;
anyNewCenterT[a_,t_,ns_:{1}]:=Module[{ons,or,sr},
ons=orbitNormals[a,t];
or=Reverse@ons[[1]];
sr=Reverse@ons[[3]];
Third/@getNewCenters[or,sr,ns]];

anyNewCenterT[1.5,0.1,Range@99]

Clear@plotXn;
Options@plotXn={drPoint->False,degPoint->10.,degStep->1.,displ->{0,-1.5},fontSize->20};
plotXn[a_,ns_,clrs_,OptionsPattern[]]:=Module[{ons,degs,ps,ell,gr,loci,eps=10^-6},
(*ons=orbitNormals[a,toRad@#]&/@degs;*)
ell=plotEll[a,{Thick,Black}];
loci=MapThread[Quiet@ParametricPlot[(
ons=orbitNormals[a,toRad@tDeg];
First@anyNewCenter[ons[[1]],ons[[3]],{#1}]),
{tDeg,0+eps,150-eps},PlotStyle->#2,PerformanceGoal->"Speed"]&,{ns,clrs}];
(*ps=MapThread[anyNewCenter[#1,#2,n]&,{First/@ons,Third/@ons}];*)
ps=(ons=orbitNormals[a,toRad@OptionValue@degPoint];anyNewCenter[ons[[1]],ons[[3]],ns]);
gr=Graphics[{FaceForm@None,PointSize@Large,
(*{EdgeForm@clr,Polygon@o1,Point@o1,ellLabelPoints[a,o1,"P",fontSize,OptionValue@lgt]},*)
{Dashed,Gray,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}(*,Point@{0,0}*)},
If[OptionValue@drPoint,
MapThread[{#1,Point@#2,Text[Style[Subscript["X",#3],OptionValue@fontSize],#2,OptionValue@displ]}&,{clrs,ps,ns}],{}]
(*If[OptionValue@drXn,{Purple,Point@xn,Text[Style[Subscript["X",n],fontSize],xn,{1,-1.25}]},{}]*)
}];
Show[{ell,loci,gr},PlotLabel->Style["a/b="<>nfn[a,2]]]];

Module[{pts,clrs},
pts={4,5,20,21,35,36,90};
clrs=ColorData[1,#]&/@Range[Length@pts];
Show[plotXn[1.5,pts,clrs,drPoint->True],Frame->True,GridLines->Automatic,ImageSize->Large]]

ellXn={1,2,3,4,5,7,8,10,12,20,21,35,36,40,46,55,56,57,63,65,72,78,79,80,84,90};

(* 63: b2+c2-a2 *)
(* 65: cos B + cos C *)

Module[{clrs},
clrs=ColorData[1,#]&/@Range[Length@ellXn];Show[plotXn[(1+Sqrt@5.)/2,ellXn,clrs,drPoint->True],PlotRange->{{-5,5},{-5,5}},ImageSize->800,Frame->True,GridLines->Automatic]]

Perimeter for any Kimberling Center

Clear@perimeterXn;
perimeterXn[a_,degStep_,n_(* FROM 1 TO 100 *)]:=Module[{ons,degs,ps,ds},
degs=.01+Range[0,360,degStep];
ons=orbitNormals[a,toRad@#]&/@degs;
ps=MapThread[First[anyNewCenter[#1,#2,{n}]]&,{First/@ons,Third/@ons}];
ds=MapThread[magn[#1-#2]&,{Most@ps,Rest@ps}];
Total[ds]/3.];

Perimeter of Billiard

ellPerimeter[1.5,1]

ellPerimeter[2.,1]

perimeterXn[1.5,.1,20]

Test Ronaldo' s Elliptic Axes via perimeter

ellXn={1,2,3,4,5,7,8,10,12,20,21,35,36,40,46,55,56,57,63,65,72,78,79,80,84,90};

(*this is slow*)
(*persRef15={#,perimeterXn[1.5,.05,#]}&/@ellXn;
Save["persRef15.m",persRef15];*)

persRef15=Get["persRef15.m"]

Clear@getEllPerArea;
Options@getEllPerArea={getAreas->False,noise->0,debug->False};
getEllPerArea[a_,OptionsPattern[]]:=Module[{eps=OptionValue@noise,b=1,a2,b2,c2,δ,a4,b4,measFn,
(* a, b, *) measEll,
(* caustic *)ac,bc,measC,
(* excenters *)ae,be,measE,
(* elliptic but not there: X11,X88,X100 = on billiard *)
measX1,measX2,measX3,measX4,measX5,
measX7,measX8,measX10,measX12,measX20,
measX21,measX35,measX36,measX40,measX46,
measX55,measX56,measX57,measX63,measX65,
measX72,measX78,measX79,measX80,measX84,
measX90
},
measFn=If[OptionValue@getAreas,ellArea,ellPerimeter];
(* init *)
a2=a*a;b2=b*b;a4=a2 a2;b4=b2 b2;
c2=(a2-b2);
δ=Sqrt[a2^2-a2 b2+b2^2];
(* ell *)
measEll=measFn[a,b];
(* caustic *)
ac=a(δ-b2)/c2;bc=b(a2-δ)/c2;
measC=measFn[ac,bc];
(* exc *)
ae=(b2+δ)/a;be=(a2+δ)/b;
measE=measFn[ae,be];
(* X1 *) Module[{aa=(δ-b2)/a,bb=(a2-δ)/b},
measX1=measFn[aa,bb]
];
(* X2 *)Module[{k2,aa,bb},
k2=(2δ-a2-b2)/(3c2);
aa=k2 a;bb=k2 b;
measX2=measFn[aa,bb];
];
(* X3 *)Module[{aa,bb},
aa=(a2-δ)/(2a);
bb=(δ-b2)/(2b);
measX3=measFn[aa,bb];
];
(* X4 *)Module[{k4=((a2+b2)δ-2a2 b2)/c2,aa,bb},
aa=k4/a;bb=k4/b;
measX4=measFn[aa,bb];
];
(* X5 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=x^2(x^2+3y^2);
wpp[x_,y_]:=3x^2+y^2;
w[x_,y_]:=4x(x^2-y^2);
aa=(-wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x5:",aa,bb}];
measX5=measFn[aa,bb];
];
(* X7 *)Module[{k7,aa,bb},
k7=(2δ-a2-b2)/c2;aa=k7 a;bb=k7 b;
measX7=measFn[aa,bb];
];
(* X8 *)Module[{aa,bb},
aa=(b2-δ)^2/(a c2);bb=(a2-δ)^2/(b c2);
measX8=measFn[aa,bb];
];
(* X10 *)Module[{k10,aa,bb},
k10= ((a2+b2)δ-a4-b4)/(2c2);aa=k10/a;bb=k10/b;
measX10=measFn[aa,bb];
];
(* X12 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(15x^6+12y^2 x^4+3x^2 y^4+2y^6);
wpp[x_,y_]:=7x^6+12y^2 x^4+11x^2 y^4+2y^6;
w[x_,y_]:=x(7 x^6+11 y^2 x^4 -11 x^2 y^4 -7y^6);
aa=(wpp[a,b]δ- wp[a,b])/ w[a,b];
bb=(wp[b,a]-wpp[b,a]δ)/ w[b,a];
measX12=measFn[aa,bb];
];
(* X20 *)Module[{aa,bb},
aa=-(-a2(a2-3b2)-2b2 δ)/(a c2);
bb=-(b2(3a2-b2)-2a2 δ)/(b c2);
measX20=measFn[aa,bb];
];
(* X21 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=x^4+x^2 y^2+2y^4;
wpp[x_,y_]:=2(x^2+y^2);
w[x_,y_]:=x(3x^2+5y^2);
aa=(-wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x21:",aa,bb}];
measX21=measFn[aa,bb];
];
(* X35 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(11x^4+4x^2 y^2+y^4);
wpp[x_,y_]:=(7x^2+y^2)(x^2+y^2);
w[x_,y_]:=x(7x^4+18x^2y^2+7y^4);
aa=(wpp[a,b]δ-wp[a,b])/w[a,b];
bb=(wpp[b,a]δ-wp[b,a])/w[b,a];
If[OptionValue@debug,Print@{"x35:",aa,bb}];
measX35=measFn[aa,bb];
];
(* X36 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(x^2+y^2);
wpp[x_,y_]:=3x^2-y^2;
w[x_,y_]:=3x(x^2-y^2);
aa=(wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(-wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x36:",aa,bb}];
measX36=measFn[aa,bb];
];
(* X40 *)Module[{aa,bb},
aa=c2/a;
bb=c2/b;
measX40=measFn[aa,bb];
];
(* X46 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(3x^2-y^2)(x^2-y^2);
wpp[x_,y_]:=(5x^2+y^2)(x^2-y^2);
w[x_,y_]:=x(5x^4-6x^2y^2+5y^4);
aa=(wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(-wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x46:",aa,bb}];
measX46=measFn[aa,bb];
];
(* X55 *)Module[{aa,bb},
aa=a(δ-b2)/(a2+b2);
bb=b(a2-δ)/(a2+b2);
measX55=measFn[aa,bb];
];
(* X56 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y ^2(x^4-x^2y^2+2y^4);
wpp[x_,y_]:=5x^4-5x^2y^2+2y^4;
w[x_,y_]:=x(5x^4-6x^2y^2+5y^4);
aa=(-wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x56:",aa,bb}];
measX56=measFn[aa,bb];
];
(* X57 *)Module[{k,aa,bb},
k=(c2/δ);aa=k a;bb=k b;
measX57=measFn[aa,bb];
];
(* X63 *)Module[{k,aa,bb},
k=c2/(a2+b2);aa=k a;bb=k b;
measX63=measFn[aa,bb];
];
(* X65 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=x^4y^2+x^2y^4+2y^6;
wpp[x_,y_]:=x^4-3x^2y^2-2y^4;
w[x_,y_]:=x(x^2-y^2)^2;
aa=(wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(-wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x65:",aa,bb}];
measX65=measFn[aa,bb];
];
(* X72 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=x^6+2x^2y^4+y^6;
wpp[x_,y_]:=y^2(3x^2+y^2);
w[x_,y_]:=x(x^2-y^2)^2;
aa=(wp[a,b]-wpp[a,b]δ)/w[a,b];
bb=(-wp[b,a]+wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x72:",aa,bb}];
measX72=measFn[aa,bb];
];
(* X78 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=5x^6-4x^4y^2+x^2y^4+2y^6;
wpp[x_,y_]:=2y^2(x^2+y^2);
w[x_,y_]:=x(5x^4-6x^2y ^2+5y^4);
aa=(wp[a,b]-wpp[a,b]δ)/w[a,b];
bb=(-wp[b,a]+wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x78:",aa,bb}];
measX78=measFn[aa,bb];
];
(* ~~~ X79 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(11x^4+4x^2y ^2+y^4);
wpp[x_,y_]:=3x^4+12x^2y^2+y^4;
w[x_,y_]:=x(x^2-y^2)(3x^2+5y^2);
aa=(-wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(wp[b,a]-wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x79:",aa,bb}];
measX79=measFn[aa,bb];
];
(* X80 *)Module[{k,aa,bb},
k=(a2+b2)/c2;aa=k(δ-b2)/a ;bb=k (a2-δ)/b;
measX80=measFn[aa,bb];
];
(* X84 *)Module[{aa,bb},
aa=c2(b2+δ)/a^3;bb=c2(a2+δ)/b^3;
measX84=measFn[aa,bb];
];
(* X90 *)Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=y^2(3x^2-y^2)(x^2-y^2);
wpp[x_,y_]:=x^4-y^4;
w[x_,y_]:=x(x^4+2x^2y^2-7y^4);
aa=(wp[a,b]+wpp[a,b]δ)/w[a,b];
bb=(wp[b,a]+wpp[b,a]δ)/w[b,a];
If[OptionValue@debug,Print@{"x90:",aa,bb}];
measX90=measFn[aa,bb];
];
(* Xnn *)(*Module[{w,wp,wpp,aa,bb},
wp[x_,y_]:=0;
wpp[x_,y_]:=0;
w[x_,y_]:=0;
aa=1;
bb=1;
If[OptionValue@debug,Print@{"xnn:",aa,bb}];
measXnn=measFn[aa,bb];
];*)
{a,(#+RandomReal[{-eps,eps}])}&/@Re/@<|
"ell"->measEll,
"caustic"->measC,
"exc"->measE,
"x1"->measX1,"x2"->measX2,"x3"->measX3,"x4"->measX4,"x5"->measX5,"x7"->measX7,"x8"->measX8,"x10"->measX10,
"x12"->measX12,"x20"->measX20,
"x21"->measX21,(*bad*)"x35"->measX35,(*bad*)
"x36"->measX36,(*bad*)
"x40"->measX40,"x46"->measX46,
"x55"->measX55,
"x56"->measX56,
"x57"->measX57,
"x63"->measX63,
"x65"->measX65,
"x72"->measX72,
"x78"->measX78,
"x79"->measX79,
"x80"->measX80,
"x84"->measX84,
"x90"->measX90
|>
];

symbolicPers15=getEllPerArea[1.5,getAreas->False,debug->True]//Transpose[{Keys[#],Second/@Values[#]}]&;

symbolicPers15Ref=Append[#,Abs[#[[2]]-#[[4]]]<10^-4]&/@MapThread[Join[#1,#2]&,{persRef15,Drop[symbolicPers15,3]}];
Grid[Prepend[symbolicPers15Ref,Style[#,Bold]&/@{"center","perNumeric","center","perSymb","matches"}],Alignment->Left,Background->{None,Prepend[If[#,White,RGBColor[1,.8,.8]]&/@Fifth/@symbolicPers15Ref,Lighter@Yellow]}]

Module[{tab,keys,trVals,labs,nrands},
tab=Table[getEllPerArea[a],{a,1.001,4.0,.01}];
keys=Keys[tab[[1]]];
trVals=Transpose[Values[#]&/@tab];
nrands=Table[RandomInteger[{1,Length@trVals[[1]]}],{Length@keys}];
labs=MapThread[Text[Style[#1,16,Background->White],#2[[#3]],{0,-1.5}]&,{keys,trVals,nrands}];
ListLinePlot[trVals,PlotStyle->ConstantArray[Thickness@.0075,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,PlotRange->{Automatic,{0,20}},AxesLabel->(Style[#,16]& /@{"a/b","perimeter"}),AspectRatio->1,
Epilog->labs]]

Module[{tab,keys},
tab=Table[getEllPerArea[a],{a,1.001,4.0,.01}];
keys=Keys[tab[[1]]];
ListLinePlot[Transpose[Values[#]&/@tab],PlotStyle->ConstantArray[Thick,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,PlotRange->{{2.,2.5},{5,10}},AxesLabel->(Style[#,16]& /@{"a/b","perimeter"}),AspectRatio->1]]

transfLog[{a_,b_}]:={a,Log[b]};

Module[{tab,keys,trVals,nrands,labs},
tab=Table[getEllPerArea[a,getAreas->True,noise->.01],{a,1.001,4.0,.01}];
keys=Keys[tab[[1]]];
trVals=Transpose[Values[#]&/@tab];
nrands=Table[RandomInteger[{1,Length@trVals[[1]]}],{Length@keys}];
labs=MapThread[Text[Style[#1,16,Background->White],transfLog[#2[[#3]]],{0,-1.}]&,{keys,trVals,nrands}];
ListLogPlot[trVals,PlotStyle->ConstantArray[Thickness@.005,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,Joined->True,AxesLabel->(Style[#,16]& /@{"a/b","area"}),AspectRatio->1,Epilog->labs]]

Module[{tab,keys,trVals,nrands,labs},
tab=Table[getEllPerArea[a,getAreas->True,noise->.01],{a,1.001,4.0,.01}];
keys=Keys[tab[[1]]];
trVals=Transpose[Values[#]&/@tab];
nrands=Table[RandomInteger[{1,Length@trVals[[1]]}],{Length@keys}];
labs=MapThread[Text[Style[#1,16,Background->White],#2[[#3]],{0,-1.}]&,{keys,trVals,nrands}];
ListPlot[trVals,PlotStyle->ConstantArray[Thickness@.005,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,Joined->True,AxesLabel->(Style[#,16]& /@{"a/b","area"}),AspectRatio->1,Epilog->labs]]

Module[{tab,keys,trVals,nrands,labs},
tab=Table[getEllPerArea[a,getAreas->True,noise->.0],{a,1.001,1.5,.01}];
keys={"x2","x3"};
trVals=Transpose[Values[#[[keys]]]&/@tab];
nrands=Table[RandomInteger[{1,Length@trVals[[1]]}],{Length@keys}];
labs=MapThread[Text[Style[#1,16,Background->White],#2[[#3]],{0,-1.}]&,{keys,trVals,nrands}];
ListPlot[trVals,PlotStyle->ConstantArray[Thickness@.005,Length@keys],PlotLegends->keys,ImageSize->Large,GridLines->Automatic,Joined->True,AxesLabel->(Style[#,16]& /@{"a/b","area"}),AspectRatio->1,Epilog->labs]]

Plot All Perimeters

perimeterXn[2.,.1,67]

perAll=Table[{i,perimeterXn[1.5,.5,i]},{i,100}]

Module[{ratio,a=1.5,ellper},
ellper=ellPerimeter[a,1];
ListPlot[(ratio=#[[2]]/ellper;Tooltip[{#[[1]],ratio},ToString@(#[[1]])<>","<>nfn[ratio,3]])&/@perAll,
FrameLabel->(Style[#,16]&/@{"X(N)","Per(N)/perEll(a="<>nfn[a,2]<>")"}),Prolog->{Red,Dashed,Thick,Line@{{1,1},{100,1}}},
GridLines->Automatic,Frame->True,ImageSize->Large]]

Clear@areaXn;areaXn[a_,degStep_,n_]:=Module[{ons,degs,ps},
degs=.01+Range[0,360,degStep];
ons=orbitNormals[a,toRad@#]&/@degs;
ps=MapThread[anyNewCenter[#1,#2,n]&,{First/@ons,Third/@ons}];
signedArea[ps]/3.];

areaAll=Table[{i,areaXn[1.5,.5,i]},{i,100}]

Area of Billiard

Module[{ratio,a=1.5,ellarea},
ellarea=ellArea[a,1];
ListPlot[(ratio=#[[2]]/ellarea;Tooltip[{#[[1]],ratio},ToString@(#[[1]])<>","<>nfn[ratio,3]])&/@areaAll,GridLines->Automatic,Frame->True,FrameLabel->(Style[#,16]&/@{"X(N)","Area(N)/Ell(a="<>nfn[a,2]<>")"}),PlotRange->{{1,100},{-3,3}},
Prolog->{Red,Dashed,Thick,Line@{{1,1},{100,1}},Line@{{1,-1},{100,-1}}}]]

Circumellipses E1 and E2

getClosestIntersection[ints1_,ints2_]:=Module[{interPairs},
interPairs=Append[#,magn2[#[[1]]-#[[2]]]]&/@{
{ints1[[1]],ints2[[1]]},
{ints1[[1]],ints2[[2]]},
{ints1[[2]],ints2[[1]]},
{ints1[[2]],ints2[[2]]}};
First@First@Sort[interPairs,#1[[3]]<#2[[3]]&]]

(* using trick: line x75x77 seem to intersect with E1 where E1 and E2 meet *)
(* so report intersection of x75x77 with E1 *)
Clear@getInterIncBarElls;
getInterIncBarElls[a_,t_]:=Module[{o,n,s,x75,x77,incCircum,inc,interInc,bar,barCircum,interBar},
{o,n,s}=orbitNormals[a,t];
{x75,x77}=Third/@getNewCenters[o,s,{75,77}];
inc=getIncenterTrilin[o,s];
incCircum=getCircumAny[o,inc];
interInc=ellInterRaybUnprotAny[Sequence@@incCircum["lengths"],incCircum["ctr"],Sequence@@incCircum["axes"],
x77,x75-x77];
bar=getBarycenterTrilin[o,s];
barCircum=getCircumAny[o,bar];
interBar=ellInterRaybUnprotAny[Sequence@@barCircum["lengths"],barCircum["ctr"],Sequence@@barCircum["axes"],
x77,x75-x77];
getClosestIntersection[interInc,interBar]];

Formula 2 (simpler, Ronaldo, 19/01/2020) : Sqrt[2 delta^2 + 2 (a^2 - b^2) delta - a^2 b^2] / b^2

axisRatioIncEllRonaldo[a_,b_]:=Module[{delta},
delta=Sqrt@(a^4-a^2*b^2+b^4);
Sqrt[b^4*(-a^2+2*b^2+2*delta)/((2*a^2-b^2+2*delta)*a^4)]];

axisRatioIncEllRonaldo2[a_,b_]:=Module[{delta},
delta=Sqrt@(a^4-a^2*b^2+b^4);
Sqrt[2 delta^2+2 (a^2-b^2) delta-a^2 b^2]/b^2];

axisRatioIncEllRonaldo2[1.5,1]

Plot[axisRatioIncEllRonaldo2[a,1],{a,1.1,3}]

measureIncAxisRatio[a_,t_]:=Module[{o,n,s,incCircum,inc,interInc,(*bar,barCircum,*)e1ratio,e1ratioRonaldo,e1ratioRonaldo2},
{o,n,s}=orbitNormals[a,t];
inc=getIncenterTrilin[o,s];
incCircum=getCircumAny[o,inc];
(*bar=getBarycenterTrilin[o,s];
barCircum=getCircumAny[o,bar];*)
e1ratio=incCircum["lengths"][[1]]/incCircum["lengths"][[2]];
e1ratioRonaldo=axisRatioIncEllRonaldo[a,1.];
e1ratioRonaldo2=axisRatioIncEllRonaldo[a,1.];
{e1ratio,e1ratioRonaldo,e1ratioRonaldo2}
];

measureIncAxisRatio[1.5,50]

(* get intersection between E1 and E2 *)
getInterIncBarElls[1.5,toRad@30.]

Clear@drawInterE1E2;
(* precompute loci *)
(*{"circumcircle","steinercircumell","inccircumell","x100","x190"}*)
Options@drawInterE1E2={"orbit"->True,"loci"->False,
"inccircumell" ->True,"steinercircumell"->True,"incircumell"->True,"npccircumell"->False,
"circumcircle"->False,"x100"->True,"x190"->True,"mittenpunkt"->False,"e1e9inter"->False,"x664"->True,"x663"->True,
labExtra->"","xmax"->2,"ymax"->1.5,"drInterLocus"->True,"e1e29interConstr"->True,"drAxes"->False,"lgt"->.33,"inward"->True,"drL29"->False,rayL->4};
drawInterE1E2[a_,tDeg_,ellPlot_,interLocus_,opt:OptionsPattern[]]:=Module[{
ellP,orbitData,orbit,normals,inc,mit,bar,cir,npc,sides,x75,x77,x190,x664,x663,
barCircum,incCircum,npcCircum,interE1E9,inter7577incEll,inter7577barEll,pl,notables,t,
toShowNeedsGr,toShowGr,incRatio,barRatio,a1,b1,a2,b2},
t=toRad@tDeg;
ellP=N@{a Cos@t,Sin@t};
orbitData=getOrbitData[a,ellP[[1]],posY->(ellP[[2]]>0)];
{orbit,normals,sides}={"orbit","normals","sides"}/.orbitData;
(* bar + (bar-mitten)/2 = (3 bar - mitten)/2 *)
notables=getNotables[orbit,normals];
{inc,bar,cir,npc,mit}={"inc","bar","cir","npc","mit"}/.notables;
x190=getX190Trilin[orbit,sides];
x663=getX663Trilin[orbit,sides];
x664=getX664Trilin[orbit,sides];
{x75,x77}=Third/@getNewCenters[orbit,sides,{75,77}];
incCircum=getCircumAny[orbit,inc];
barCircum=getCircumAny[orbit,bar];
npcCircum=getCircumAny[orbit,npc];
inter7577incEll=ellInterRaybUnprotAny[Sequence@@incCircum["lengths"],incCircum["ctr"],Sequence@@incCircum["axes"],
x77,x75-x77];
inter7577barEll=ellInterRaybUnprotAny[Sequence@@barCircum["lengths"],barCircum["ctr"],Sequence@@barCircum["axes"],
x77,x75-x77];
interE1E9=getClosestIntersection[inter7577incEll,inter7577barEll];
{a1,b1}=incCircum["lengths"];
{a2,b2}=barCircum["lengths"];
incRatio=incCircum["lengths"][[1]]/incCircum["lengths"][[2]];
barRatio=barCircum["lengths"][[1]]/barCircum["lengths"][[2]];
pl=OptionValue@labExtra<>"a="<>nf@a<>"; t="<>nf0@toDeg[t]<>"°\nratio((Subscript[E, 1]))="<>nfn[incRatio,3]<>"; ratio((Subscript[E, 2]))="<>nfn[barRatio,3];
toShowGr={
If[OptionValue@"loci",loci,{}],
If[OptionValue@"steinercircumell",drawCircumAnyLow[barCircum,orbit,ctrLab->Style["(Subscript[X, 2])",{"steiner"/.ptClrs,20}],ps->{"steiner"/.ptClrs,Thick}],{}],
(*If[OptionValue@"steinerinell",drawSteinerInellipse[orbit,ctrLab->Subscript["X", 2],ps->{"steinerinell"/.ptClrs,Thick}],{}],*)
If[OptionValue@"inccircumell",drawCircumAnyLow[incCircum,orbit,ctrLab->Style["(Subscript[X, 1])",{Darker@("inc"/.ptClrs),20}],ps->{Darker@("inc"/.ptClrs),Thick}],{}],
If[OptionValue@"npccircumell",drawCircumAnyLow[npcCircum,orbit,ctrLab->Style["(Subscript[X, 5])",{"npc"/.ptClrs,20}],ps->{Darker@("npc"/.ptClrs),Thick}],{}],
If[OptionValue@"orbit",Graphics@{FaceForm@None,EdgeForm@{Thick,Blue},Polygon@orbit,Blue,PointSize@Large,Point@orbit}(*drawOrbit[orbitData,"lgt"->(1.5*lgt),drNormals->False]*),{}]
(*Graphics@If[OptionValue@"orbittri",{Thick,EdgeForm@Black,FaceForm@{Black,Opacity@.1},Polygon@orbit},{}],*)
};
toShowNeedsGr={
If[OptionValue@"drAxes",{Thick,Dashed,Gray,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},{}],
(*circles*)
 If[OptionValue@"circumcircle",{"cir"/.ptClrs,PointSize@Large,Point@cir,{Dashed,Thick,Circle[cir,"cirRadius"/.notables]},drawOneNotable["cir"/.ptClrs,cir,"(Subscript[X, 3])",-1.5,-1.5,16]},{}],
(*points*)
If[OptionValue@"mittenpunkt",{("mit"/.ptClrs),PointSize@Large,Point@mit,drawOneNotable["mit"/.ptClrs,mit,Style["(Subscript[X, 9])",{"mit"/.ptClrs,20}],-1.5,-1.5,16]},{}],
 If[OptionValue@"x190",{PointSize@Large,Black,"steiner"/.ptClrs,Point@x190,ellLabelTxtb[a2,b2,x190,Style["(Subscript[X, 190])",16],OptionValue@"lgt"]},{}],
If[OptionValue@"x100",Module[{antifeu},antifeu="antifeu"/.notables;
{PointSize@Large,"cir"/.ptClrs,Point@antifeu,ellLabelTxtb[a1,b1,antifeu,Style["(Subscript[X, 100])",16],OptionValue@"lgt"]}],{}],
If[OptionValue@"x663",{PointSize@Large,"ort"/.ptClrs,Point@x663,ellLabelTxt[a,x663,Style["(Subscript[X, 663])",16],OptionValue@"lgt"]},{}],
If[OptionValue@"x664",{PointSize@Large,"cir"/.ptClrs,Point@x664,ellLabelTxt[a,x664,Style["(Subscript[X, 664])",16],OptionValue@"lgt",inward->True]},{}],
If[OptionValue@"drL29",{Dashed,Black,Line@{{0,0},ray[{0,0},norm[-bar],OptionValue@rayL]},Line@{bar,ray[bar,norm[bar],OptionValue@rayL]},Line@{{0,0},bar}},{}],
If[OptionValue@"e1e9inter",
{If[OptionValue@"e1e29interConstr",{PointSize@Medium,Black,
{MapThread[{Point@#1,Text[Subscript["X",#2],#1,{-1.5,-1.5}]}&,{{x75,x77},{75,77}}]},
{Dashed,Red,Line@{x77,x75},Line@{x75,interE1E9}}},{}],
{PointSize@Large,Red,Point@interE1E9,ellLabelTxt[a2,interE1E9,Style["(Subscript[P, 12])",16],OptionValue@"lgt",inward->(OptionValue@"inward")]}},{}]};
Show[{ellPlot,toShowGr,If[OptionValue@"drInterLocus",interLocus,{}],Graphics/@Select[toShowNeedsGr,Length@#>0&]},
AspectRatio->Automatic,Frame->True,Axes->True,
AxesStyle->Directive[RGBColor[.66,.66,.66]],
PlotLabel->Style[pl,{Black,20}],FilterRules[{opt},Options@Plot],
ImageSize->800,
PlotRange->{{-OptionValue@"xmax",OptionValue@"xmax"},{-OptionValue@"ymax",OptionValue@"ymax"}}]];

getX664TestTrilin[Sequence@@Part[orbitNormals[1.5,toRad@4.],{1,3}]]

(*newCentersFromFile=Get["data/x0001_0100.m"]; *)

DynamicModule[{imgs,ell,interLocus},
Manipulate[
ell=plotEllFill[a,{Yellow,Opacity@.05},{Thick,Black}];
ell=plotEll[a,{Thick,Black}];
interLocus=Quiet@ParametricPlot[getInterIncBarElls[a,toRad@tDeg],{tDeg,0,150},PlotStyle->{Thick,Red}];
Dynamic@drawInterE1E2[a,tDeg+.001,ell,interLocus,"drL29"->drL29,
"npccircumell"->npc,"circumcircle"->cir,"xmax"->xmax,"ymax"->ymax,"drInterLocus"->drInterLocus,"lgt"->.15,"inward"->False],
{{a,1.5},1.01,3,.1,Appearance->"Labeled"},
{{tDeg,30.},-180,180,1,AnimationRate->10,Appearance->"Labeled"},
{{drInterLocus,False,"draw inter locus"},{True,False}},
{{npc,False,"npc"},{True,False}},
{{cir,False},{True,False}},
{{drL29,False},{True,False}},
{{xmax,3},{.5,1,1.5,2,3,6}},
{{ymax,1.5},{.5,1,1.5,2,3,6}},ControlPlacement->Left]]

Options@drawInterE1E2

Clear@getOneE1E2Img;
getOneE1E2Img[a_,xmax_,ymax_,tDeg_]:=Module[{imgs,ell,interLocus={}},
ell=plotEll[a,{Thick,Black}];
(*interLocus=Quiet@ParametricPlot[getInterIncBarElls[a,toRad@tDeg],{tDeg,0,150},PlotStyle->{Thick,Red}];*)
drawInterE1E2[a,tDeg+.001,ell,interLocus,"npccircumell"->False,"circumcircle"->False,"xmax"->xmax,"ymax"->ymax,"e1e29interConstr"->False,"mittenpunkt"->True,"drAxes"->True,"x663"->False,"lgt"->.1,"inward"->False]];

e1e2plot=Show[getOneE1E2Img[1.5,3,3,22.],Axes->None,Frame->None,PlotLabel->None,PlotRange->All]

export3["0091_e1e2",e1e2plot]

(* for movies, many images *)
Clear@getOneE1E2Imgs;
getOneE1E2Imgs[a_,xmax_,ymax_,tDegStep_]:=Module[{imgs,ell,interLocus},
ell=plotEllFill[a,{Yellow,Opacity@.05},{Thick,Black}];
interLocus=Quiet@ParametricPlot[getInterIncBarElls[a,toRad@tDeg],{tDeg,0,150},PlotStyle->{Thick,Red}];
Table[drawInterE1E2[a,tDeg+.001,ell,interLocus,"npccircumell"->False,"circumcircle"->False,"xmax"->xmax,"ymax"->ymax],{tDeg,0,359,tDegStep}]];

Pythagorical Triples, [9:59 PM,1/20/2020] Prof Ronaldo Garcia

pythagoreanAB[m_,n_]:=Module[{a,b,p=Sqrt@(m^2+n^2)},
b=m*n*Sqrt@((m-n)Sqrt@(p^2+(-2*n-2*m)*p+2*m^2+2*n^2)+2*m^2-2*p*m+2*n^2-2*p*n+p^2)*Sqrt@((2*m^2-p*m+n(n-p))Sqrt@((-2*n-2*m)*p+3*m^2+3*n^2)-3*m^3+2*p*m^2+(-3*n^2+2*n*p)*m)*Sqrt@(2*m^3+(2*n-2*p)*m^2+(2*n^2-n*p)*m+2*n^2(n-p))/((m+n-p)Sqrt@((-2*n-2*m)*p+3*m^2+3*n^2)*Sqrt@(m^2+(n-p)*m+n(n-p))Sqrt@(m^2+(-n-p)*m+n(n-p))*Sqrt@(4*m^2-m*n+4*n^2));
a=m*n*Sqrt@((m-n)Sqrt@(p^2+(-2*n-2*m)*p+2*m^2+2*n^2)-2*m^2+2*p*m-2*n^2+2*p*n-p^2)*Sqrt@((2*m^2-p*m+n(n-p))Sqrt@((-2*n-2*m)*p+3*m^2+3*n^2)+3*m^3-2*p*m^2+(3*n^2-2*n*p)*m)*Sqrt@(2*m^3+(2*n-2*p)*m^2+(2*n^2-n*p)*m+2*n^2(n-p))/((m+n-p)Sqrt@((-2*n-2*m)*p+3*m^2+3*n^2)*Sqrt@(m^2+(n-p)*m+n(n-p))Sqrt@(m^2+(-n-p)*m+n(n-p))*Sqrt@(4*m^2-m*n+4*n^2));
{a,b}
];

pythagoreanABold[m_,n_]:=Module[{a,b,c=Sqrt@(m^2+n^2)},
a=Sqrt@(n^3*(2*c m^4+5*n^2*m^2*Sqrt@(m^2+n^2)+2*c*n^4+2*m^5+2*m^3*n^2+2*m^2*n^3+2*n^5)(n+m+Sqrt@(-2*c m-2*c*n+3*m^2+3*n^2)))/(4(4*m^2-m*n+4*n^2));
b=Sqrt@2Sqrt@((n+m-Sqrt@((-2*n-2*m)*c+3*m^2+3*n^2))*n^3((m^4+(5/2*(n^2))*m^2+n^4)*c+m^5+m^3*n^2+m^2*n^3+n^5))/(16*m^2-4*m*n+16*n^2);
{a,b}];

pythagoreanRatio[m_,n_]:=(#[[1]]/#[[2]])&@pythagoreanAB[m,n];

FullSimplify@pythagoreanAB[3,4]

FullSimplify@pythagoreanRatio[3,4]

N@pythagoreanAB[3,4]

N@pythagoreanRatio[3,4]

N@pythagoreanAB[5,12]

N@pythagoreanABold[5,12]

Simplify@pythagoreanRatio[5,12]

N@pythagoreanRatio[5,12]

pythagoreanRatio[8,15]

generateTriple[m_,n_]:=Module[{a,b,c},
a=m^2-n^2;
b=2 m n;
c=m^2+n^2;
{a,b,c}];

generateTriple[2,1]

generateTriple[3,2]

generateTriple[4,2]/4

generateTriple[4,3]

(* first arg > second arg, and args must be coprime *)
inputsToGenerateTriple=Select[Tuples[Range[200],2],(#[[1]]>#[[2]]&&CoprimeQ[#[[1]],#[[2]]])&];
sampleTriples=(generateTriple@@#)&/@inputsToGenerateTriple;
Print@Dimensions@sampleTriples;
(* slow *)
sampleABs=N@pythagoreanAB[#[[1]],#[[2]]]&/@sampleTriples;

Length@sampleABs

Are there different triangles with same perimeter

Tally[Second/@Tally[Total/@sampleTriples]]

10912+2*585+3*47+4*2

10912+585+47+4

There are 4 of perimeter 78540

Sort[Select[Tally[Total/@sampleTriples],#[[2]]>1&],#1[[2]]>#2[[2]]&]//Take[#,10]&

(* append perimeters *)
isoPerimeterTriples=Select[GroupBy[sampleTriples,Total],Length@#>1&];
Length@isoPerimeterTriples

Max[Length/@isoPerimeterTriples]

getIsoPers[repeats_]:=Module[{per4=Select[isoPerimeterTriples,Length@#==repeats&],keys,vals},
keys=Keys@per4;
vals=Values@per4;
(*MapThread[{Sequence@@#1,Sqrt[#1[[1]]^2+#1[[2]]^2],#2}&,{vals,keys}]*)
Flatten[MapThread[Map[Function[a,Prepend[Prepend[a,#2],Length@#1]],#1]&,{vals,keys}],1]];

TeXForm@Prepend[getIsoPers[4],Style[#,Bold]&/@{"reps","L","(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"}]

Grid[Prepend[getIsoPers[4],Style[#,Bold]&/@{"reps","L","(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"}],Alignment->Left,ItemStyle->Medium]

isoPersList=Flatten[getIsoPers/@{4,3,2},1];
Take[isoPersList,8]//Grid

Export["isoPerimeters.xls",Prepend[isoPersList,{"reps","L","s1","s2","s3"}]]

ContourPlot[a+b+Sqrt[a^2+b^2],{a,0,100},{b,0,100},ContourShading->None,
FrameLabel->(Style[#,Large]&/@{"(Subscript[s, 1])","(Subscript[s, 2])"}),
PlotLabel->Style["(Subscript[s, 1])+(Subscript[s, 2])+(Sqrt[((Subscript[s, 1])^2) + ((Subscript[s, 2])^2)]) = k",Large]]

Isoperimetric Right Triangles in (a,b) space

getGammaL[a,b]

fourTriplesPlot=Module[{ABs,cp,persSel,fixedLs,a4},
a4=Sqrt[2Sqrt[2]-1.];
persSel=Select[isoPersList,(#[[1]]==4)&];
fixedLs=DeleteDuplicates[Second/@persSel];
ABs=N@pythagoreanAB[#[[3]],#[[4]]]&/@persSel;
(*Print["fixedLs: ",fixedLs,", ABs: ",ABs];*)
ContourPlot[{getGammaLsym[a,b][[2]]},{a,0000,20000},{b,0000,20000},Exclusions ->{a==b},Contours->(fixedLs),
ContourStyle->(Directive[Thick,#]&/@{Red,Blue}),
ContourShading->None,
ContourLabels->(Text[Framed["L="<>ToString@#3],{#1-500,4000},Background->White]&),
Prolog->{Darker@Green,Thick,Dashed,Line@{{0,0},{a4,1}20000}},Epilog->{PointSize@Large,Point@ABs}, 
FrameLabel->(Style[#,{Black,Large}]&/@{"a","b"}),
FrameStyle->Directive[Black,16],
PlotLabel->(Style["(a,b) space. N="<>ToString@Length@sampleABs,{Black,Large}]),
ImageSize->Large]]

export3["0120_fourTriplesPlot",fourTriplesPlot]

fourTriplesAllPlot=Module[{ABs,cp,persSel,fixedLs,a4},
a4=Sqrt[2Sqrt[2]-1.];
persSel=Select[isoPersList,(#[[1]]==4||#[[1]]==3)&];
fixedLs=DeleteDuplicates[Second/@persSel];
ABs=N@pythagoreanAB[#[[3]],#[[4]]]&/@persSel;
(*Print["fixedLs: ",fixedLs,", ABs: ",ABs];*)
ContourPlot[{getGammaLsym[a,b][[2]]},{a,0000,20000},{b,0000,20000},Exclusions ->{a==b},Contours->(fixedLs),
ContourStyle->"Temperature",
FrameStyle->Directive[Black,16],ContourLabels->None,ContourShading->None,
Prolog->{Darker@Green,Thick,Dashed,Line@{{0,0},{a4,1}20000}},Epilog->{PointSize@Large,Point@ABs}, 
FrameLabel->(Style[#,{Black,Large}]&/@{"a","b"}),
PlotLabel->(Style["(a,b) space. N="<>ToString@Length@sampleABs,{Black,Large}]),
ImageSize->Large]]

export3["0121_fourTriplesAllPlot",fourTriplesAllPlot]

Are there Billiards whose own perimeter is equal to the N = 3 orbit?

Module[{a4,cpOrbitL,cpEllPer,maxA=100,cntrs},
cntrs=Rest@Range[0,maxA,maxA/10];
a4=Sqrt[2Sqrt[2]-1.];
(*Print["fixedLs: ",fixedLs,", ABs: ",ABs];*)
cpOrbitL=ContourPlot[getGammaLsym[a,b][[2]],{a,0,maxA},{b,0,maxA},Exclusions ->{a==b},
ContourStyle->{Directive[Thick,Blue]},
ContourLabels->All,ContourShading->None,
Contours->cntrs,
Prolog->{Darker@Green,Thick,Dashed,Line@{{0,0},{a4,1}maxA}},
PlotLegends->{"orbitPer"}];
cpEllPer=ContourPlot[ellPerimeter[a,b],{a,0,maxA},{b,0,maxA},
ContourStyle->Directive[Thick,Red],
ContourLabels->All,ContourShading->None,
Contours->cntrs,
Prolog->{Darker@Green,Thick,Dashed,Line@{{0,0},{a4,1}10maxA}},
PlotLegends->{"ellPer"}];
Show[{cpOrbitL,cpEllPer},
FrameStyle->Medium,
PlotRange->All,
FrameLabel->(Style[#,{Black,Medium}]&/@{"a","b"}),
PlotLabel->(Style["(a,b) space. N="<>ToString@Length@sampleABs,{Black,Medium}]),
ImageSize->Large]]

N@getGammaLsym[1,1][[2]]

3Sqrt[3.]

Module[{
ContourPlot[getGammaL[1.5,1][[2]]

Resrict to a single run of m

inputsToGenerateTripleRestricted=Select[inputsToGenerateTriple,#[[1]]==150&];
sampleTriplesRestricted=(generateTriple@@#)&/@inputsToGenerateTripleRestricted;
Print@Dimensions@sampleTriplesRestricted;
sampleABsRestricted=N@pythagoreanAB[#[[1]],#[[2]]]&/@sampleTriplesRestricted;

First@inputsToGenerateTripleRestricted

First@sampleTriplesRestricted

find the most isosceles

mostIsoscelesRestricted=First@Ordering[Abs@(#[[1]]/#[[2]]-1)&/@sampleTriplesRestricted,1]

sampleTriplesRestricted[[mostIsoscelesRestricted]]

sampleABsRestricted[[mostIsoscelesRestricted]]

Resrict to a single run of n

inputsToGenerateTripleRestrictedN=Select[inputsToGenerateTriple,#[[2]]==150&];
sampleTriplesRestrictedN=(generateTriple@@#)&/@inputsToGenerateTripleRestrictedN;
Print@Dimensions@sampleTriplesRestrictedN;
sampleABsRestrictedN=N@pythagoreanAB[#[[1]],#[[2]]]&/@sampleTriplesRestrictedN;

Module[{a4},
a4=Sqrt[2Sqrt[2]-1];Graphics[{Point@sampleABs,Red,PointSize@Large,Point@{800,800},Darker@Green,Point@{800,400},Blue,Point@{800,600},Thick,Line@{{0,0},{a4,1}1000}},PlotRange->{{0,200},{0,200}},AspectRatio->Automatic,Axes->True]]

pythagoreanPlot=Module[{a4,
mostIsoAB=sampleABsRestricted[[mostIsoscelesRestricted]],mostIsoTriple=sampleTriplesRestricted[[mostIsoscelesRestricted]],firstScaleneTriple=First@sampleTriplesRestricted,firstScaleneAB=First@sampleABsRestricted,
lastScaleneTriple=Last@sampleTriplesRestricted,lastScaleneAB=Last@sampleABsRestricted,
labIso,labFirstScalene,labLastScalene},
a4=Sqrt[2Sqrt[2]-1];
labIso=StringJoin@MapThread[#1<>"="<>ToString@#2<>"\n"&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},mostIsoTriple}];
labFirstScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},firstScaleneTriple,{False,True,False}}];
labLastScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple,{False,True,False}}];
Graphics[{PointSize@Small,Thickness@.005,
{Black,Point@sampleABs},
{Green,Line@{{0,0},{a4,1}20000}},
{Red,(*PointSize@Large,Point@sampleABsRestricted,*)Line@sampleABsRestricted},
{Blue,(*PointSize@Large,Point@sampleABsRestrictedN,*)Line@sampleABsRestrictedN},
{Red,PointSize@.015,Point@mostIsoAB,Text[Style[labIso,16],mostIsoAB,{1,-.6}]},
{Red,PointSize@.015,Point@firstScaleneAB,Text[Style[labFirstScalene,16],firstScaleneAB,{0,1.5}]},
{Red,PointSize@.015,Point@lastScaleneAB,Text[Style[labLastScalene,16],lastScaleneAB,{0,1.25}]}
},PlotRange->{Automatic,{-3000,20000}},AspectRatio->Automatic,Frame->True,FrameStyle->16,FrameLabel->(Style[#,{Black,20}]&/@{"a","b"}),ImageSize->800,
PlotLabel->(Style["(a,b) space. N="<>ToString@Length@sampleABs,{Black,Large}])]]

export3["0101_pythagorean_billards",pythagoreanPlot]

pythagoreanLegPlot=Module[{a4,
mostIsoTriple=sampleTriplesRestricted[[mostIsoscelesRestricted]],
firstScaleneTriple=First@sampleTriplesRestricted,
lastScaleneTriple=Last@sampleTriplesRestricted,
labIso,labFirstScalene,labLastScalene,isoPers=10,arg2,range2,showIsoPers=False},
a4=Sqrt[2Sqrt[2]-1];
labIso=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>"\n"&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},mostIsoTriple}];
labFirstScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},firstScaleneTriple,{False,False,False}}];
labLastScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple,{False,False,False}}];
(*labLastScalene=StringJoin@MapThread[#1<>"="<>ToString@#2<>"\n"&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple}];*)(*StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple,{False,True,False}}];*)arg2=Map[Take[#,2]&,RandomChoice[Values@isoPerimeterTriples,isoPers],{2}];
range2=(Range[isoPers]-1)/isoPers;
Graphics[{PointSize@Small,Thickness@.005,
{Black,Point@Select[Take[#,2]&/@sampleTriples,#[[2]]<48000&]},
{Green,Line@{{0,0},{1,1}33000}},
{Red,Line[Take[#,2]&/@sampleTriplesRestricted]},
{Blue,Line[Take[#,2]&/@sampleABsRestrictedN]},
{Red,PointSize@.015,Point@Take[mostIsoTriple,2],Text[Style[Framed@labIso,16,Background->Directive[White]],Take[mostIsoTriple,2],{-1.25,-1}]},
{Red,PointSize@.015,Point@Take[firstScaleneTriple,2],Text[Style[Framed@labFirstScalene,16,Background->Directive[White]],Take[firstScaleneTriple,2],{1.1,-.75}]},
{Red,PointSize@.015,Point@Take[lastScaleneTriple,2],Text[Style[Framed@labLastScalene,16, Background->Directive[White]],Take[lastScaleneTriple,2],{-1.1,-1}]},
If[showIsoPers,{PointSize@Large,Thick,MapThread[{Hue[#1],Point/@#2,Line@#2}&,{range2,arg2}]},{}]
},PlotRange->All,AspectRatio->.5,Frame->True,FrameStyle->16,FrameLabel->(Style[#,{Black,20}]&/@{"(Subscript[s, 1])","(Subscript[s, 2])"}),ImageSize->800,PlotLabel->(Style["((Subscript[s, 1]),(Subscript[s, 2])) space. N="<>ToString@Length@sampleABs,{Black,Large}])]]

export3["0101_pythagorean_leg_billards",pythagoreanLegPlot]

bothPythagoreanPlots=Grid[{{pythagoreanLegPlot},{pythagoreanPlot}}]

export3["0101_pythagorean_legs_ab",bothPythagoreanPlots]

Module[{a4,
mostIsoTriple=sampleTriplesRestricted[[mostIsoscelesRestricted]],
firstScaleneTriple=First@sampleTriplesRestricted,
lastScaleneTriple=Last@sampleTriplesRestricted,
labIso,labFirstScalene,labLastScalene,isoPers=10,arg2,range2,showIsoPers=False},
a4=Sqrt[2Sqrt[2]-1];
labIso=StringJoin@MapThread[#1<>"="<>ToString@#2<>"\n"&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},mostIsoTriple}];
labFirstScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},firstScaleneTriple,{False,False,False}}];
labLastScalene=StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple,{False,False,False}}];
(*labLastScalene=StringJoin@MapThread[#1<>"="<>ToString@#2<>"\n"&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple}];*)(*StringDrop[#,-2]&@StringJoin@MapThread[#1<>"="<>ToString@#2<>If[#3,"\n",", "]&,{{"(Subscript[s, 1])","(Subscript[s, 2])","(Subscript[s, 3])"},lastScaleneTriple,{False,True,False}}];*)arg2=Map[Take[#,2]&,RandomChoice[Values@isoPerimeterTriples,isoPers],{2}];
range2=(Range[isoPers]-1)/isoPers;
Graphics[{PointSize@Small,Thickness@.005,
{Black,Point@Select[Take[#,2]&/@sampleTriples,#[[2]]<100000&]},
{Green,Line@{{0,0},{1,1}33000}},
{Red,Line[Take[#,2]&/@sampleTriplesRestricted]},
{Blue,Line[Take[#,2]&/@sampleABsRestrictedN]},
{Red,PointSize@.015,Point@Take[mostIsoTriple,2],Text[Style[labIso,16,Background->Directive[White]],Take[mostIsoTriple,2],{-1.25,-.6}]},
{Red,PointSize@.015,Point@Take[firstScaleneTriple,2],Text[Style[labFirstScalene,16,Background->Directive[White]],Take[firstScaleneTriple,2],{1.1,-1.33}]},
{Red,PointSize@.015,Point@Take[lastScaleneTriple,2],Text[Style[labLastScalene,16, Background->Directive[White]],Take[lastScaleneTriple,2],{-1.1,-1.5}]},
If[showIsoPers,{PointSize@Large,Thick,MapThread[{Hue[#1],Point/@#2,Line@#2}&,{range2,arg2}]},{}]
},PlotRange->All,AspectRatio->Automatic,Frame->True,FrameStyle->16,FrameLabel->(Style[#,{Black,20}]&/@{"(Subscript[s, 1])","(Subscript[s, 2])"}),ImageSize->800,PlotLabel->(Style["((Subscript[s, 1]),(Subscript[s, 2])) space. N="<>ToString@Length@sampleABs,{Black,Large}])]]

Histogram[#[[1]]/#[[2]]&/@Take[sampleABs,10000]]

Histogram[#[[1]]/#[[2]]&/@sampleABs]

Graphics[{Blue,PointSize@Medium,Point[{#[[1]]/#[[2]],1}&/@Take[sampleABs,100]]},Frame->True,PlotRange->All]

logABs[{a_,b_}]:={Log@a,Log@b};

Module[{a4},
a4=Sqrt[2Sqrt[2]-1];
Graphics[{PointSize@Small,Thick,
{Black,Point@(logABs/@sampleABs)},
{Red,PointSize@Large,Point@(logABs/@sampleABsRestricted),Line@(logABs/@sampleABsRestricted)},
{Blue,PointSize@Large,Point@(logABs/@sampleABsRestrictedN),Line@(logABs/@sampleABsRestrictedN)}
},AspectRatio->Automatic,Frame->True,FrameStyle->16,FrameLabel->(Style[#,{Black,20}]&/@{"Log[a]","Log[b]"}),ImageSize->800,PlotLabel->(Style["N="<>ToString@Length@sampleABs,{Black,Large}])]]

Is any ratio rational? (* very slow *) -- need to computed ABs symbolically and see if simplification generates rational.

sampleABs[[1]]

(*sampleABsSymbol=FullSimplify[pythagoreanRatio[#[[1]],#[[2]]]]&/@Take[sampleTriples,1000];*)

(*Export["sampleABs.pdf",sampleABsSymbol//TableForm]*)

Histogram[Third/@sampleTriples]

Min[Third@sampleTriples]

Max[Third/@sampleTriples]

N@Mean[Third/@sampleTriples]

Module[{cs,cmax,cmin,cmean,nearMean},
cs=Third/@sampleTriples;
cmin=N@Min[cs];
cmax=N@Max[cs];
cmean=N@Mean[cs];
(*nearMean=(Abs[#[[3]]-cmean]<200)&/@sampleTriples;*)
Graphics[{PointSize@Small,MapThread[{Hue[(#1-cmin)/(cmax-cmin)],Point@#2}&,{cs,sampleABs}],Black(*,Point@Pick[sampleABs,nearMean]*)},AspectRatio->Automatic,Frame->True,FrameStyle->Large,ImageSize->800]]

Graphics[{PointSize@Small,Point@sampleABs},AspectRatio->Automatic,Frame->True,ImageSize->Large]

N@pythagoreanRatio[8,15]

Clear@elementaryCBpyth;
Options@elementaryCBpyth={minX->-2,maxX->5,minY->-2,maxY->5};
elementaryCBpyth[m_,n_,OptionsPattern[]]:=Module[{cp,tri,gr,mit},
tri={{0,0},{m,0},{m,n}};
mit=getMittenTrilin[tri,{n,Sqrt@(m^2+n^2),m}];
gr=Graphics@{PointSize@Large,FaceForm@None,
{EdgeForm@{Thick,Blue},Polygon@tri,Blue,Point@tri},
{Darker@Red,Point@mit}};
cp=ContourPlot[-(-Sqrt@(m^2+n^2)+m+n)*x*y/n+m*y^2/n-m*x+(-Sqrt@(m^2+n^2)+m)*m*y/n+x^2==0,{x,OptionValue@minX,OptionValue@maxX},{y,OptionValue@minY,OptionValue@maxY},ContourStyle->Black];
Show[{cp,gr},AspectRatio->Automatic]];

elementaryCBpyth[3,4]

pythagoreanAB[5,12]

elementaryCBpyth[5,12,maxY->13,maxX->8]

Circumphenomena pictures

{excCircumPlot,medCircumPlot,actCircumPlot,actMedCircumPlot}=MapThread[Show[#1 ,PlotLabel->None,PlotRange->{#2,#3},Axes->False,Frame->False,ImageSize->#4]&,{
{makeExperimentFrame[1.5,25.,"antiorthic3","exccircumb"],
makeExperimentFrame[1.5,25.,"ell","medialSimple"],
makeExperimentFrame[1.5,25.,"ell","anticomplSimple"],
makeExperimentFrame[1.5,25.,"ell","medial"]},
{{-3.25,2.75},{-2.5,2.},{-2.5,2.},{-2.5,2.}},{{-3,4},{-1.15,1.15},{-2.,1.75},{-2.,1.75}},{800,400,400,800}}]

export3["0110_excCircum",excCircumPlot];

medActCircumSimplePlot=Grid[Reverse@{{Show[medCircumPlot,ImageSize->1200]},{Show[actCircumPlot,ImageSize->800]}},Spacings->0]

export3["0111_medActCircumSimple",medActCircumSimplePlot];

export3["0112_actMedCircumAll",actMedCircumPlot]

Convex Combination of X1 and Intouch makes lobes touch

isoscelesP2[1.5,1]

isoscelesIntouch[a_,b_]:=Module[{iso,int},
iso=isoscelesP2[a,b];
FullSimplify[{0,iso[[2,2]]},a>b>0]]

isoscelesInc[a_,b_]:=Module[{iso,inc,sides},
iso=isoscelesP2[a,b];
sides=triLengthsRL@iso;
inc=getIncenterTrilinUnsafe[iso,sides];
FullSimplify[inc,a>b>0]]

Module[{ell,a=1.5,gr,orbit,intouch,inc,ρ,Y},
ell=plotEll[a,{Thick,Black}];
orbit=isoscelesP2[a,1];
intouch={0,orbit[[2,2]]};
inc=isoscelesInc[a,1];
(*Y=(1-ρ)(Subscript[inc, y])+ ρ (Subscript[int, y]) = 0; (Subscript[inc, y])+ρ((Subscript[int, y])-(Subscript[inc, y]))=0 => ρ = (Subscript[inc, y])/((Subscript[inc, y])-(Subscript[int, y])) *)
ρ=inc[[2]]/(inc[[2]]-intouch[[2]]);
Y=Chop[(1-ρ)inc+ρ intouch];
gr=Graphics[{FaceForm@None,PointSize@Large,
{Gray,Dashed,Line@{{0,-1},{0,1}},Line@{{-a,0},{a,0}}},
{EdgeForm@{Thick,Blue},Polygon@orbit},
{Brown,Point@intouch,Darker@Green,Point@inc,Darker@Red,Point@Y}}];
Show[{ell,gr},PlotLabel->"ρ="<>nfn[ρ,2]<>", Y="<>ToString@Y,ImageSize->Small]]

intAB=isoscelesIntouch[a,b]/.{Sqrt[a^4-a^2 b^2+b^4]->δ,a^2-b^2->c2}

incAB=FullSimplify[isoscelesInc[a,b]/.{Sqrt[a^4-a^2 b^2+b^4]->δ,a^2-b^2->c2},c2>0]

incAB/.{a->1.5,b->1,δ->getDelta[1.5,1]}

(*Y=(1-ρ)(Subscript[inc, y])+ (Subscript[ρint, y])=0; (Subscript[inc, y])+ρ((Subscript[int, y])-(Subscript[inc, y]))=0 => ρ=(Subscript[inc, y])/((Subscript[inc, y])-(Subscript[int, y])) *)

rhoLobeTouch=Module[{ρ},
ρ=incAB[[2]]/(incAB[[2]]-intAB[[2]]);
FullSimplify[ρ/.{c2->c^2},a>b>0&&c>0&&δ>0]]

rhoLobeTouchSimple=FullSimplify[rhoLobeTouch/.{b->1},a>0&&(1-a^2-2δ<0)]

Clear@rhoLobeTouchAB;rhoLobeTouchAB[a_,b_,c_,δ_,d2_,d1_]=FullSimplify[rhoLobeTouch/.{ (Sqrt[2 (a^4)+(b^4)-(a^2) ((b^2)+2 δ)])->d1}/.{2 (a^4)+(b^4)-(a^2) ((b^2)+2 δ)->(a^4)+δ(δ-2((a )^2))}/.{-(a^4)-2 (b^4)+2 (b^2) d1+(a^2) ((b^2)+2 δ)->-b^4+2b^2d1+δ(2a^2-δ)}/.((a^2)+(b^2)-2 δ)->d2,δ>0&&a>b>0&&d2<0]/.{(a^4)+2 (b^4)-(a^2) ((b^2)+2 δ)->b^4+δ(δ-2a^2 )}/.{(a^4)+δ+2 (a^2) δ->a^4+δ(2a^2+δ)}/.{-(a^4)-2 (b^4)+(a^2) ((b^2)+2 δ)->-b^4+δ(2a^2-δ)}

rhoLobeTouchAB2[a_,b_,c_,δ_]=FullSimplify[FullSimplify[rhoLobeTouchAB[a,b,c,δ,((a^2)+(b^2)-2 δ),(Sqrt[ (a^4)+δ(δ-2((a )^2))])],a>b>0&&δ>0]/.{a^2-b^2->c^2},a>b>0&&δ>0&&c>0]

Module[{a=1.5,b=1,d1a,d1b,δ},
δ=getDelta[a,b];
d1a=2 (a^4)+(b^4)-(a^2) ((b^2)+2 δ);
d1b=(a^4)+(δ^2)-2((a )^2)δ;
{d1a,d1b}]

rhoLobeTouchAB2[a,b,c,δ]//CForm

Clear@getRhoLobeTouch;getRhoLobeTouch[a_,b_]:=Module[{c,δ,d2,d1},
c=Sqrt[a^2-b^2];
δ=getDelta[a,b];
rhoLobeTouchAB2[a,b,c,δ]]

FullSimplify@getRhoLobeTouch[3/2,1]

FullSimplify@getRhoLobeTouch[2,1]

getConvexIntouchLocus[2,2π,3/4]

getConvexIntouchLocus[1.5,2π,5/9]

Cubics: Thomson, etc.

Thomson Cubic: sum x(s3^2 y^2-s2^2 z^2)

thomsonCyclic[{bx_,by_,bz_},{a2_,b2_,c2_}]:=bx(c2 by^2-b2 bz^2);

thomsonCubicErr[p_,tri_,sides_]:=Module[{bars,sides2},
bars=getBarycentrics[p,tri];
sides2=sides *sides;(* a2,b2,c2 *)
thomsonCyclic[bars,sides2]+
thomsonCyclic[RotateLeft@bars,RotateLeft@sides2]+
thomsonCyclic[RotateLeft[bars,2],RotateLeft[sides2,2]]
(*bx(c^2 by^2-b^2 bz^2)+by(a^2 bz^2-c^2 bx^2)+bz(b^2 bx^2-a^2 by^2)];*)
]

thomsonCubicErrTrils[p_,tri_,{a_,b_,c_}]:=Module[{bars,α,β,γ},
bars=getBarycentrics[p,tri];
{α,β,γ}=bars/{a,b,c};
b c α(β^2-γ^2)+c a β(γ^2-α^2)+a b γ(α^2-β^2)
]

Hunting for invariants in the triangle of intersections with E9, or if any known tri centers lie at the origin. FAIL

Module[{a=1.5,ell,gr,slack=.2,lab,
ons,tmin,pmin,tri,cp,inc,cir,ctrs,
onsUp,tminUp,pminUp,triUp,cpUp,incUp,ctrsUp},
ons=orbitNormals[a,0.];
tmin=t/.FindRoot[thomsonCubicErrTrils[{a Cos@t,Sin@t},ons[[1]],ons[[3]]],{t,π/2}];
pmin={a Cos@tmin,Sin@tmin};
tri={{-a,0},flipY@pmin,pmin};
inc=getIncenterTrilin[ons[[1]],ons[[3]]];
cir=getCircumcenterTrilin[ons[[1]],ons[[3]]];

onsUp=orbitNormals[a,π/2];
tminUp=t/.FindRoot[thomsonCubicErrTrils[{a Cos@t,Sin@t},onsUp[[1]],onsUp[[3]]],{t,π/4}];
pminUp={a Cos@tminUp,Sin@tminUp};
triUp={{0,-1},pminUp,flipX@pminUp};
incUp=getIncenterTrilin[onsUp[[1]],onsUp[[3]]];

lab="a="<>nfn[a,2]<>", A="<>nfn[signedArea[ons[[1]]],3]<>", (Subscript[A, up])="<>nfn[signedArea[onsUp[[1]]],3]<>"\n"<>"(Subscript[A, tri])="<>nfn[signedArea[tri],3]<>", (Subscript[A, tri, up])="<>nfn[signedArea[triUp],3]<>"\n"<>"(Subscript[A, tri])/A="<>nfn[signedArea[tri]/signedArea[ons[[1]]],3]<>", (Subscript[A, tri, up])/(Subscript[A, up])="<>nfn[signedArea[triUp]/signedArea[onsUp[[1]]],3]<>"\n"<>"r="<>nfn[getInradius@triLengths@tri,3]<>", R="<>nfn[getCircumradius@triLengths@tri,3]<>", (Subscript[r, up])="<>nfn[getInradius@triLengths@triUp,3]<>", (Subscript[R, up])="<>nfn[getCircumradius@triLengths@triUp,3]<>"\n"<>"r+R="<>nfn[getInradius@triLengths@tri+getCircumradius@triLengths@tri,3]<>", (Subscript[r, up])+(Subscript[R, up])="<>nfn[getInradius@triLengths@triUp+getCircumradius@triLengths@triUp,3]<>"\n"<>"R-r="<>nfn[-getInradius@triLengths@tri+getCircumradius@triLengths@tri,3]<>", (Subscript[R, up])-(Subscript[r, up])="<>nfn[-getInradius@triLengths@triUp+getCircumradius@triLengths@triUp,3]<>"\n"<>"per="<>nfn[triPer@tri,3]<>", (Subscript[per, up])="<>nfn[triPer@triUp,3];

ctrs=Quiet@getNewCenters[tri,triLengthsRL@tri,Range[100]];
Print["ctrs: ",Select[ctrs,magn2[Third@#]<10^-6&]];
ctrsUp=Quiet@getNewCenters[triUp,triLengthsRL@triUp,Range[100]];
Print["ctrsUp: ",Select[ctrsUp,magn2[Third@#]<10^-6&]];

ell=plotEllAxes[a,{Thick,Black}];
cp=ContourPlot[thomsonCubicErr[{x,y},ons[[1]],ons[[3]]]==0,{x,-a-slack,a+slack},{y,-1-slack,1+slack},ContourStyle->{Thick,Darker@Red},PerformanceGoal->"Quality"];
cpUp=ContourPlot[thomsonCubicErr[{x,y},onsUp[[1]],onsUp[[3]]]==0,{x,-a-slack,a+slack},{y,-1-slack,1+slack},ContourStyle->{Thick,Dashed,Darker@Red},PerformanceGoal->"Quality"];
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],EdgeForm@{Thick,Dashed,Blue},Polygon@onsUp[[1]]},
{Darker@Green,Point@pmin,EdgeForm@{Darker@Green,Thick},Polygon@tri},
{Darker@Green,Point@pminUp,EdgeForm@{Darker@Green,Dashed,Thick},Polygon@triUp},
{Blue,Point@inc,Circle[inc,getInradius[ons[[3]]]],Dashed,Point@incUp,Circle[incUp,getInradius[onsUp[[3]]]]}(*,
{Purple,Circle[cir,getCircumradius[ons[[3]]]]}*)}];
Show[{ell,cp,cpUp,gr},ImageSize->800,PlotRange->{{-a-slack,a+slack},{-1-slack,1+slack}}(*,PlotLabel->Style[lab,{Black,16}]*)]]

1.203*.594

1.22*.598

Clear@showThomsonCubic;
Options@showThomsonCubic={excSlack->.25,fontSize->16};
showThomsonCubic[a_,tDeg_,OptionsPattern[]]:=Module[{ons,ell,gr,ps,lab,cp,exc,excMinX,excMinY,excMaxX,excMaxY,med},
ell=plotEllAxes[a,{Thick,Black}];
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
med=medialTriangle[ons[[1]],ons[[3]]];
excMinX=Min[First/@exc];excMaxX=Max[First/@exc];
excMinY=Min[Second/@exc];excMaxY=Max[Second/@exc];
ps=#[ons[[1]],ons[[3]]]&/@{getIncenterTrilin,getBarycenterTrilin,getCircumcenterTrilin,getOrthocenterTrilin,getSymmedianTrilin,getMittenTrilin};
cp=ContourPlot[thomsonCubicErr[{x,y},ons[[1]],ons[[3]]]==0,{x,excMinX-OptionValue@excSlack,excMaxX+OptionValue@excSlack},{y,excMinY-OptionValue@excSlack,excMaxY+OptionValue@excSlack},ContourStyle->{Thick,Darker@Red},PerformanceGoal->"Quality"];
lab="a="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°";
gr=Graphics[{FaceForm@None,PointSize@Large,
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{EdgeForm@{Thick,Darker@Green},Polygon@exc,Darker@Green,Point@exc},
{EdgeForm@{Thick,Dashed,Blue},Polygon@med(*,Blue,Point@med*)},
{Black,Point@ps,MapThread[Text[Style[Subscript["X",#1],OptionValue@fontSize],#2,{-1.25,-1.25}]&,{{1,2,3,4,6,9},ps}]}}];
Show[{ell,cp,gr},PlotLabel->Style[lab,{Black,16}],PlotRange->{{-2.5,2.5},{-4.5,4.5}},Frame->True,ImageSize->800]]

Manipulate[showThomsonCubic[1.5,tDeg],{{tDeg,10.},-180,180,.1}]

Grid[{{showThomsonCubic[1.5,0.],showThomsonCubic[1.5,90.]}}]

P1(t) e Extouchponts Synchronized?

Clear@getP1andExt;
getP1andExt[a_,tDeg_]:=Module[{ons,ext,b=1,causticA,causticB},
ons=orbitNormals[a,toRad@tDeg];
ext=extouchTriangle[ons[[1]],ons[[3]]];
{causticA,causticB}=getCausticAxes[a,b];
{(a/b)(ons[[1,1,2]]/ons[[1,1,1]]),(causticA/causticB )(ext[[1,2]]/ext[[1,1]])}]

ListPlot[Table[getP1andExt[1.5,tDeg+10^-5],{tDeg,0,180,1}],ImageSize->Medium,AspectRatio->1,PlotStyle->Blue,Frame->True,FrameStyle->Medium,FrameLabel->(Style[#,{Black,16}]&/@{"tan[(Subscript[P, 1])(t)]=(a/b)(p1y/p1x)","tan[(Subscript[e, 1])(t)]=((Subscript[a, c])/(Subscript[b, c]))(e1y/e1x)"})]

The Reznikpunkt: Mitten of Extouch Tri?

Clear@showMittenExtouch;
Options@showMittenExtouch={drPts->True};
showMittenExtouch[a_,tDeg_,OptionsPattern[]]:=Module[{ons,ext,extSides,gr,ell,lines,medial,extMedial,linesExtMedial,linesMitt,rayL=3,pr,exc,slack=1,ellC,ca,cb,extXs,extX9locus},
{ca,cb}=getCausticAxes[a,1];
ell=plotEll[a,{Thick,Black}];
ellC=plotEllb[ca,cb,{Thick,Brown}];
extX9locus=If[OptionValue@drPts,Quiet@ParametricPlot[
ons=orbitNormals[a,toRad@(tDeg2+.0001)];
ext=extouchTriangle[ons[[1]],ons[[3]]];
extSides=triLengthsRL@ext;
getMittenTrilin[ext,extSides],{tDeg2,0,180},
PerformanceGoal->"Speed",PlotStyle->Red],{}];
ons=orbitNormals[a,toRad@tDeg];
ext=extouchTriangle[ons[[1]],ons[[3]]];
extSides=triLengthsRL@ext;
medial=medialTriangle[ons[[1]],ons[[3]]];
extXs=If[OptionValue@drPts,getNewCenters[ext,extSides],{}];
exc=excentralTriangle[ons[[1]],ons[[3]]];
extMedial=medialTriangle[ext,extSides];
lines=MapThread[{#1,#2}&,{ons[[1]],ext}];
linesExtMedial=MapThread[{#1,ray[#1,#2-#1,rayL]}&,{ons[[1]],extMedial}];
linesMitt=MapThread[{#1,ray[#1,#2-#1,rayL]}&,{exc,medial}];
gr=Graphics[{FaceForm@None,PointSize@Large,Thick,
{EdgeForm@{Thick,Darker@Green},Polygon@exc,Darker@Green,Point@exc},
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{EdgeForm@{Thick,Brown},Polygon@ext},
(*{Gray,Thickness@Small,Thickness@Small,Line/@lines},*)
{Thickness@Small,Dashed,Blue,Line/@linesExtMedial,Brown,Point@extMedial},
{Darker@Red,Point@{0,0},Text[Style["(Subscript[X, 9])",16],{0,0},{-1.25,-1.25}]},
If[OptionValue@drPts,{
{Darker@Green,Point@medial,Thickness@Small,Dashed,Line/@linesMitt},
{PointSize@Medium,Point[Third/@extXs],Red,Point@extXs[[9,3]]}},{}]}];
pr={{-a-slack,a+slack},{-1-slack,1+slack}};
Show[{ell,ellC,extX9locus,gr},PlotRange->pr,ImageSize->Large]];

Manipulate[showMittenExtouch[Sqrt@2,tDeg,drPts->False],{{tDeg,10.},-180,180,.1}]

The Swan Dance of X88 and X162

ColorData[3,"ColorList"]

plotX126vel[a_,clr_]:=Module[{ons,onsN,eps=10^-5,x,xn,v},
Plot[
ons=orbitNormals[a,toRad@tDeg];
onsN=orbitNormals[a,toRad@(tDeg+eps)];
x=getX162Trilin[ons[[1]],ons[[3]]];
xn=getX162Trilin[onsN[[1]],onsN[[3]]];
v=Sign[crossProduct[xn,x]]magn[x-xn]/eps;
v,{tDeg,10,40},PlotStyle->clr]]

Module[{as,clrs,min},
as=Range[1.15,1.18,.01];
clrs=Rest@ColorData[1,"ColorList"];
min=Min[Length/@{as,clrs}];
Show[Legended[
MapThread[plotX126vel[#1,{Thick,#2}]&,Take[#,min]&/@{as,clrs}],
Placed[LineLegend[Directive[AbsoluteThickness[3],#]&/@Take[clrs,min],
Style["a="<>nfn[#,2],20]&/@Take[as,min],
LegendLayout->{"Column",1}],Right]],
Axes->True,PlotRange->All,AxesLabel->(Style[#,{Black,20}]&/@{"t (deg)","(Subscript[vel, 162])"}),AxesStyle->Medium,ImageSize->Large,GridLines->Automatic]]

alpha162=a/.FindRoot[5*a^8+3*a^6-32*a^4+52*a^2-36==0,{a,1.16}]

allnumlists[nl_]:=AllTrue[nl,allnum];

Clear@getX162prot;getX162prot[ons_?allnumlists,sides_?allnum]:=getX162Trilin[ons,sides];

getSwanDance[a_,tDeg_]:=Module[{ons,x88,x162},
ons=orbitNormals[a,toRad@tDeg];
x88=getX88Trilin[ons[[1]],ons[[3]]];
x162=getX162Trilin[ons[[1]],ons[[3]]];
{x88,x162}];

ArcTanSigned[x_,y_]:=Module[{at=ArcTan[x,y]},
If[at<0,at+2π,at]];

ArcTanSigned2[x_,y_]:=ArcTanSigned[x,y];

getP1P2P3AngsDeg[a_,tDeg_]:=Module[{ons},
ons=orbitNormals[a,toRad@tDeg];
{tDeg,toDeg@#}&/@(ArcTanSigned2[#[[1]],a#[[2]]]&/@ons[[1]])];

getSwanDanceAngs[a_,tDeg_]:=Module[{ons,x88,x162},
{x88,x162}=getSwanDance[a,tDeg];
{ArcTanSigned[x88[[1]],a x88[[2]]],
ArcTanSigned[x162[[1]],a x162[[2]]]}];

getSwanDanceAngsDeg[a_,tDeg_]:=Module[{ons,x88,x162},
{x88,x162}=getSwanDance[a,tDeg];
{{tDeg,toDeg@ArcTanSigned[x88[[1]],a x88[[2]]]},
{tDeg,toDeg@ArcTanSigned[x162[[1]],a x162[[2]]]}}];

Clear@partitionJumps;
partitionJumps[vs_,jumpThresh_]:=Module[{diffs,largeJumps,largeJumpsAugm},
diffs=Differences[vs];
largeJumps=First/@Position[diffs,x_/;x>jumpThresh];
largeJumpsAugm={0,Sequence@@largeJumps,Length@vs};
(*Print@largeJumpsAugm;*)
MapThread[Take[vs,{#1+1,#2}]&,{Most@largeJumpsAugm,(Rest@largeJumpsAugm)}]
];

Clear@partitionJumps2;
partitionJumps2[vs_,jumpThresh_]:=Module[{diffs,largeJumps,largeJumpsAugm},
diffs=Abs@Differences[Second/@vs];
largeJumps=First/@Position[diffs,x_/;x>jumpThresh];
largeJumpsAugm={0,Sequence@@largeJumps,Length@vs};
(*Print@largeJumpsAugm;*)
MapThread[Take[vs,{#1+1,#2}]&,{Most@largeJumpsAugm,(Rest@largeJumpsAugm)}]
];

correct180[v_]:=If[v>180,360-v,v];

Clear@getBilliardDist;getBilliardDist[a_?NumericQ,tDeg_?NumericQ,trilinFn1_,trilinFn2_]:=Module[{ons,p1,p2,t1,t2},
ons=orbitNormals[a,toRad@tDeg];
{p1,p2}=#[ons[[1]],ons[[3]]]&/@{trilinFn1,trilinFn2};
t1=ArcTan[p1[[1]],a p1[[2]]];
t2=ArcTan[p2[[1]],a p2[[2]]];
Abs[t1-t2]];

Clear@getBilliardDistSqr;getBilliardDistSqr[a_?NumericQ,tDeg_?NumericQ,trilinFn1_,trilinFn2_]:=Module[{ons,p1,p2,t1,t2},
ons=orbitNormals[a,toRad@tDeg];
{p1,p2}=#[ons[[1]],ons[[3]]]&/@{trilinFn1,trilinFn2};
t1=ArcTan[p1[[1]],a p1[[2]]];
t2=ArcTan[p2[[1]],a p2[[2]]];
(t1-t2)^2];

getBilliardDist[2,10.,getX88Trilin,getX162Trilin]

FindMinimum[getBilliardDistSqr[2.,tDeg,getX88Trilin,getX162Trilin],{tDeg,90}]

Plot[getBilliardDist[2.,tDeg,getX88Trilin,getX162Trilin],{tDeg,30,60}]

Clear@showEKGX88X162;
Options@showEKGX88X162={degMin->0,degMax->360,degStep->.1,drDiff->False,drDiffMin->False,ar->.25,imgSize->800,abdigs->1,eps->0,minCircRad->5};showEKGX88X162[a_,OptionsPattern[]]:=Module[{x88,x162,tDegs,lp88,lp162,v1,lpv1,lpv2,lpv3,diffs,lpDiffs,diffMin,gr,diffLow,diffHigh,p1,p2,p3,minLine,tMin},
tDegs=OptionValue@eps+Range[OptionValue@degMin,OptionValue@degMax,OptionValue@degStep];
{x88,x162}=Transpose[getSwanDanceAngsDeg[a,#]&/@tDegs];
(*v1=Transpose@{tDegs,toRad/@tDegs-π};*)
{p1,p2,p3}=Transpose[getP1P2P3AngsDeg[a,#]&/@tDegs];
(*lpv1=ListLinePlot[partitionJumps2[v1,π/4],PlotStyle->{{Thick,Blue}}];*)
lpv1=ListLinePlot[partitionJumps2[p1,20.],PlotStyle->{{Thick,Blue}}];
lpv2=ListLinePlot[partitionJumps2[p2,20.],PlotStyle->{{Thick,Dashed,Blue}}];
lpv3=ListLinePlot[partitionJumps2[p3,20.],PlotStyle->{{Thick,Dashed,Blue}}];
lp88=ListLinePlot[partitionJumps2[x88,20.],PlotStyle->{{Thick,Red}}];
lp162=ListLinePlot[partitionJumps2[x162,20.],PlotStyle->{{Thick,Darker@Green}}];
diffs=Transpose[{tDegs,correct180/@Abs[Second/@x88-Second/@x162]}];
diffMin=First@Ordering[Abs[Second/@diffs],1];
lpDiffs=ListLinePlot[partitionJumps2[diffs,20.],PlotStyle->{{Thick,Black}}];
diffLow=Min[x88[[diffMin,2]],x162[[diffMin,2]]];
diffHigh=Max[x88[[diffMin,2]],x162[[diffMin,2]]];
tMin=tDegMin/.Second@FindMinimum[getBilliardDistSqr[a,tDegMin,getX88Trilin,getX162Trilin],{tDegMin,90}];
Print@tMin;
minLine=Graphics[{Black,Dashed,Thick,
Line@{{OptionValue@degMin,diffs[[diffMin,2]]},{OptionValue@degMax,diffs[[diffMin,2]]}},
Line@{{OptionValue@degMin,180.},{OptionValue@degMax,180.}},
PointSize@Large,Point@{tMin,diffs[[diffMin,2]]},Circle[{tMin,diffs[[diffMin,2]]},OptionValue@minCircRad{1,.5/OptionValue@ar}]}
];
gr=Graphics[{PointSize@Large,Thick,
If[OptionValue@drDiffMin,
{Black,
(*Line@{{tDegs[[diffMin]],diffLow},{tDegs[[diffMin]],diffHigh}},*)
Line@{{tDegs[[diffMin]],0},{tDegs[[diffMin]],360}},
(*Point@{tDegs[[diffMin]],diffLow},Point@{tDegs[[diffMin]],diffHigh},*)
{Red,Point@{tDegs[[diffMin]],x88[[diffMin,2]]},
Darker@Green,Point@{tDegs[[diffMin]],x162[[diffMin,2]]}}(*,Text[Style[diffs[[diffMin]],16],{tDegs[[diffMin]],diffHigh},{-1.25,-1.5}]*)},{}]
}];
Grid[{
{Show[Legended[{lpv1,lpv2,lpv3,lp88,lp162,gr},
Placed[LineLegend[Directive[AbsoluteThickness[3],#]&/@
{Blue,{Dashed,Blue},{Dashed,Blue},Red,Darker@Green,Black},
(Style[#,20]&/@{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])","(Subscript[X, 88])","(Subscript[X, 162])"}),
LegendLayout->{"Column",1}],Right]],
PlotLabel->Style["a/b="<>nfn[a,OptionValue@abdigs],{Black,20}],PlotRange->All,
Frame->True,FrameStyle->16,GridLines->Automatic,ImageSize->OptionValue@imgSize,AspectRatio->OptionValue@ar,FrameLabel->(Style[#,{Black,20}]&/@{"t (deg)","t' (deg)"})]},
{Show[{lpDiffs,minLine},
PlotRange->All,
Frame->True,FrameStyle->16,GridLines->Automatic,ImageSize->OptionValue@imgSize,AspectRatio->OptionValue@ar,FrameLabel->(Style[#,{Black,20}]&/@{"","|(Subscript[X, 88])-(Subscript[X, 162])| (deg)"})]}},Alignment->Left,Spacings->0]
];

flatTorusPlot=showEKGX88X162[2.,degMin->-180,degMax->180,
degStep->.1,(* .01 for high quality *)
ar->.25,eps->.00005,abdigs->1,drDiffMin->False,drDiff->False,imgSize->800]

export4["1220_flat_torus_x88_x126",flatTorusPlot]

showEKGX88X162[2.,degMin->30,degMax->50,degStep->.01,drDiff->True,drDiffMin->True,ar->.5,imgSize->800]

showEKGX88X162[2.5,degMin->175,degMax->185,degStep->.01,drDiff->True,drDiffMin->True,ar->Automatic,imgSize->800]

showEKGX88X162[5,degMin->178,degMax->182,degStep->.001,drDiff->True,drDiffMin->True,ar->.5,imgSize->800]

showEKGX88X162[2,abdigs->1,degMin->177,degMax->183,degStep->.01,drDiff->True,drDiffMin->True,ar->.5,imgSize->800]

showEKGX88X162[2,abdigs->1,degMin->-3,degMax->3,degStep->.01,drDiff->True,drDiffMin->True,ar->.5,imgSize->800]

getSwanDanceAngs90[a_,tDeg_]:=Module[{ons,x88,x162},
{x88,x162}=getSwanDance[a,tDeg];
{ArcTan[-a x162[[2]],x88[[1]]],ArcTan[-a x162[[2]],x162[[1]]]}];

getSwanDanceAngsX[a_,tDeg_]:=Module[{ons,x88,x162},
{x88,x162}=getSwanDance[a,tDeg];
{x88[[1]],x162[[1]]}];

getSwanDanceAngsY[a_,tDeg_]:=Module[{ons,x88,x162},
{x88,x162}=getSwanDance[a,tDeg];
{x88[[2]],x162[[2]]}];

Clear@getSwanDanceGraph;
getSwanDanceGraph[a_,drLabel_:True]:=Module[{pl,pp},
pl="a/b="<>nfn[a,2];
pp=Quiet@ParametricPlot[getSwanDanceAngs90[a,tDeg+10^-5],{tDeg,0,180},Exclusions->{tDeg<48},ImageSize->Medium,AspectRatio->1,PlotStyle->Purple,PlotRange->All,Frame->True,FrameStyle->Medium,PerformanceGoal->"Quality",MaxRecursion->8, FrameLabel->(Style[#,{Black,20}]&/@{"(Subscript[θ, 88])(t)","(Subscript[θ, 162])(t)"}),
PlotLabel->If[drLabel,Style[pl,{Black,16}],None]];
pp];

Clear@getSwanDanceGraphX;
getSwanDanceGraphX[a_,drLabel_:True]:=Module[{pl,pp},
pl="a/b="<>nfn[a,2];
pp=Quiet@ParametricPlot[getSwanDanceAngsX[a,tDeg+10^-5],{tDeg,0,180},Exclusions->{tDeg<48},ImageSize->Medium,AspectRatio->1,PlotStyle->Purple,PlotRange->All,Frame->True,FrameStyle->Medium,PerformanceGoal->"Quality",MaxRecursion->8, FrameLabel->(Style[#,{Black,20}]&/@{"(Subscript[x, 88])(t)","(Subscript[x, 162])(t)"}),
PlotLabel->If[drLabel,Style[pl,{Black,16}],None]];
pp];
Clear@getSwanDanceGraphY;
getSwanDanceGraphY[a_,drLabel_:True]:=Module[{pl,pp},
pl="a/b="<>nfn[a,2];
pp=Quiet@ParametricPlot[getSwanDanceAngsY[a,tDeg+10^-5],{tDeg,0,180},Exclusions->{tDeg<48},ImageSize->Medium,AspectRatio->1,PlotStyle->Purple,PlotRange->All,Frame->True,FrameStyle->Medium,PerformanceGoal->"Quality",MaxRecursion->8, FrameLabel->(Style[#,{Black,20}]&/@{"(Subscript[y, 88])(t)","(Subscript[y, 162])(t)"}),
PlotLabel->If[drLabel,Style[pl,{Black,16}],None]];
pp];

Clear@getSwanDanceGrid;
Options@getSwanDanceGrid={drX4->True,drLine->True,drPp->True};
getSwanDanceGrid[a_,tDeg_,pp_,pcurr_,OptionsPattern[]]:=Module[{ons,gr,x88,x162,ell,slack=.3,pr,pl,x4,a4,b4,linePs,pp1},
ell=plotEllAxes[a,{Thick,Black}];
ons=orbitNormals[a,toRad@tDeg];
x88=getX88Trilin[ons[[1]],ons[[3]]];
x162=getX162Trilin[ons[[1]],ons[[3]]];
x4=getOrthocenterTrilin[ons[[1]],ons[[3]]];
{a4,b4}=getOrthocenterAxes[a,1];
gr=Graphics[{PointSize@Large,FaceForm@None,
{EdgeForm@{Thick,Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
{Point@{0,0},Text[Style["(Subscript[X, 9])",20],{0,0},{-1,-1}]},
(* ellLabelTxt[a,#1,Style[#2,fontSize],.16] *)
MapThread[{#3,Point@#1,ellLabelTxt[a,#1,Style[Subscript["X",#2],Directive[20,#3]],.15]}&,{{x88,x162},{88,162},{Red,Darker@Green}}],
If[OptionValue@drX4,{Orange,ellLabelTxtb[a4,b4,x4,Style["(Subscript[X, 4])",20],.125],Point@x4},{}]}];
pr={{-a-slack,a+slack},{-1-slack,1+slack}};
pl="a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°";
linePs={{pcurr[[1,1]],1},{pcurr[[1,1]],-3.5}};
pp1=Show[{ell,gr},PlotRange->pr,ImageSize->600,PlotLabel->Style[pl,{Black,16}]];
If[!OptionValue@drPp,
pp1,
Grid[{{pp1,
Show[Legended[{Graphics@@pp,Graphics[{Black,Line@linePs,PointSize@Medium,Point@linePs}]},
Placed[LineLegend[Directive[{Thickness@Large,#}]&/@{Red,Darker@Green,{Dashed,Red},{Dashed,Darker@Green}},
Style[#,14]&/@{"(Subscript[X, 88])","(Subscript[X, 126])","(Subscript[X, 88])-1","(Subscript[X, 126])+1"},LegendLayout->{"Column",4}],Below]], 
PlotLabel->Style["Perimeter Progress",{Black,16}],ImageSize->400(*AspectRatio->1/a*),
ImagePadding->{{Automatic,Automatic},{Automatic,Scaled[.05]}}]}},
Spacings->0,Alignment->Top]]];

tProgressOnEll[a_,b_,{x_,y_}]:=Module[{cosT,sinT,tanT},
cosT=x/a;
sinT=y/b;
tanT=sinT/cosT;
(a b)/(cosT^2(a^2+b^2 tanT^2))]

getSuccDists[ps_]:=MapThread[Sign@crossProduct[#1,#2]magn[#1-#2]&,{Most@ps,Rest@ps}];

Clear@getSwanMetricArcTan;
getSwanMetricArcTan[a_,degStep_]:=Module[{x88,x162,tDegs,eps=10^-5,acc88,acc162,per,accsNorm},
tDegs=Range[0,360,degStep];
{x88,x162}=Transpose[getSwanDance[a,#+eps]&/@tDegs];
(* x88 starts on the left vertex *)
acc88=ArcTan[#[[1]],a#[[2]]]&/@x88;
acc162=ArcTan[#[[1]],a#[[2]]]&/@x162;
{MapThread[{#1,#2}&,{tDegs,acc88}],
MapThread[{#1,#2}&,{tDegs,acc162}]}];

getSwanMetric[a_,degStep_]:=Module[{x88,x162,tDegs,eps=10^-5,acc88,acc162,per,accsNorm},
tDegs=Range[0,360,degStep];
{x88,x162}=Transpose[getSwanDance[a,#+eps]&/@tDegs];
per=ellPerimeter[a,1];
(* x88 starts on the left vertex *)
acc88=Prepend[Accumulate[getSuccDists@x88]/per-1/2,-1/2];
acc162=Prepend[Accumulate[getSuccDists@x162]/per,0];
{MapThread[{#1,#2}&,{tDegs,acc88}],
MapThread[{#1,#2}&,{tDegs,acc162}],
MapThread[{#1,#2-1}&,{tDegs,acc88}],
MapThread[{#1,#2+1}&,{tDegs,acc162}]}];

Clear@torusPoint;torusPoint[t_,u_,r_]:={Cos[t] (r+Cos[u]),Sin[t] (r+Cos[u]),Sin[u]};

getTorusPoint[a_,t_,trilinFn_,r_,k_:1]:=Module[{ons,p,cu,su},
ons=orbitNormals[a,t];
p=trilinFn[ons[[1]],ons[[3]]];
cu=p[[1]]/a;su=p[[2]];
{k cu(r+Cos[t]),k su(r+Cos[t]),k Sin[t]}];

torusOptions=//Options;

showX88X162torus[a_]:=Module[{torus,pathXs,ons,xi,ct,st,r=3.5,tmax=2π,k=1.0,tMin,pMin},
torus=ParametricPlot3D[torusPoint[t,u,r],{t,0, tmax},{u,0, 2Pi},Axes->False,Boxed->False,Mesh->None,PlotStyle->Directive[Opacity@.66,White],PerformanceGoal->"Quality",MaxRecursion->12];
tMin=tDegMin/.Second@FindMinimum[getBilliardDistSqr[a,tDegMin,getX88Trilin,getX162Trilin],{tDegMin,90}];
pMin={a Cos@toRad@tMin,Sin@toRad@tMin};
pathXs=ParametricPlot3D[
{(* t = 0 *) getTorusPoint[a,u,Function[{o,s},{a,0}],r,k],
(* t = tMin *) getTorusPoint[a,u,Function[{o,s},pMin],r,k],
(* p1 *) getTorusPoint[a,u,Function[{o,s},o[[1]]],r,k],
(* x88 *) getTorusPoint[a,u,getX88Trilin,r,k],
(* x162 *) getTorusPoint[a,u,getX162Trilin,r,k]
},{u,0,2π},PlotStyle->({AbsoluteThickness[3],#}&/@{Black,{Dashed,Black},Blue,Red,Darker@Green}),
PerformanceGoal->"Quality",
MaxRecursion->12,Method->{"ShrinkWrap"->True},PlotRangePadding->0];
Grid[{{Show[{torus,pathXs},ImageSize->800,Background->White,torusOptions,PlotRangePadding->0],
LineLegend[Directive[#,AbsoluteThickness[3]]&/@{Black,{Dashed,Black},Blue,Red,Darker@Green},
Style[#,Large]&/@{"t=0","t=(Subscript[t, min])","(Subscript[P, 1])(t)","(Subscript[X, 88])","(Subscript[X, 162])"}]}}]]

torusX88X162Plot=showX88X162torus[2]

export3["1210_pics_torus_x88_x126",torusX88X162Plot]

getSwanMetricPlot[a_,degStep_]:=ListLinePlot[getSwanMetric[a,degStep],Frame->True,PlotStyle->{{Thick,Red},{Thick,Darker@Green},{Thick,Dashed,Red},{Thick,Dashed,Darker@Green}},FrameStyle->Directive[Black,16],GridLines->Automatic,FrameLabel->(Style[#,16]&/@{"t (degrees)",""}),PlotLegends->(Style[#,16]&/@{"(Subscript[X, 88])","(Subscript[X, 126])","(Subscript[X, 88])-1","(Subscript[X, 126])+1"}),ImageSize->Large];

getSwanMetricPlot[1.8,.1]

myEllRaster[a_]:=Module[{ps},
ps=Table[{a Cos[toRad@tDeg],Sin[toRad@tDeg]},{tDeg,0,360,1}];
Polygon[ps,VertexTextureCoordinates->Rescale[ps]]];

ellInnerArrow[a_,p_,arrowL_,lgt_]:=Module[{grad,ctr,halfArrow},
grad=norm[ellGrad[a,Sequence@@p]];
ctr=p+grad*lgt;
halfArrow=arrowL*perp@grad;
{ctr-halfArrow,ctr+halfArrow}];

ellInnerArrow2[a_,p_,pnext_,arrowL_,lgt_]:=Module[{grad,ctr,halfArrow},
grad=norm[ellGrad[a,Sequence@@p]];
ctr=p+grad*lgt;
halfArrow=Sign[crossProduct[pnext,p]]arrowL*perp@grad;
{ctr-halfArrow,ctr+halfArrow}];

Clear@ellInnerCurvedArrow;
ellInnerCurvedArrow[a_,{px_,py_},axisFactor_,arrowTheta_]:=Module[{(*tan0,*)th2,t0,arc},
th2=toRad@(arrowTheta/2);
(*tan0=(a/1)(py/px);*)
t0=ArcTan[px,a py];
arc=Table[axisFactor{a Cos[t],Sin[t]},{t,t0-th2,t0+th2,th2/20}];
arc]

Clear@makeOneSwanFrame;
Options@makeOneSwanFrame={lgtP1->.1,arrowL->.1,drP1dir->False};
makeOneSwanFrame[a_,tDeg_,{swanImg_,swanImgBlack_},OptionsPattern[]]:=Module[{ons,ons2,
p1,p1n,
x88,x88n,x88d,
x162,x162n,x162d,
grad88,grad162,
gr,lgt=.175,eps=.001},
ons=orbitNormals[a,toRad@tDeg];
p1=ons[[1,1]];
x88=getX88Trilin[ons[[1]],ons[[3]]];
grad88=-norm[ellGrad[a,Sequence@@x88]];
x162=getX162Trilin[ons[[1]],ons[[3]]];
grad162=-norm[ellGrad[a,Sequence@@x162]];
ons2=orbitNormals[a,toRad@(tDeg+eps)];
p1n=ons2[[1,1]];
x88n=getX88Trilin[ons2[[1]],ons2[[3]]];
x162n=getX162Trilin[ons2[[1]],ons2[[3]]];
x88d=Sign[crossProduct[x88n,x88]];
x162d=Sign[crossProduct[x162n,x162]];
gr=Graphics[{AbsolutePointSize[8],FaceForm@None,Arrowheads@Large,
{Gray,Dashed,Line@{{-a,0},{a,0}},Line@{{0,-1},{0,1}}},
{EdgeForm@{AbsoluteThickness[3],Blue},Polygon@ons[[1]],Blue,Point@ons[[1]]},
Inset[swanImg,x88+lgt*grad88,{Center,Center},.3,{x88d perp@grad88,grad88}],
Inset[swanImg,x162+lgt*grad162,{Center,Center},.3,{x162d perp@grad162,grad162}],
Inset[swanImgBlack,{.025,.025},{Left,Bottom},.3,Background->None],
If[OptionValue@drP1dir,{Blue,Thick,Arrow@ellInnerArrow2[a,p1,p1n,OptionValue@arrowL,.07]},{}],
{Red,Thick,Arrow@ellInnerArrow2[a,x88,x88n,OptionValue@arrowL,.07]},
{Darker@Green,Thick,Arrow@ellInnerArrow2[a,x162,x162n,OptionValue@arrowL,.07]},
{Gray,AbsolutePointSize[8],Point@{0,0},Text[Style["9",{White,16}],{.18,.115}]},
(* ellLabelTxt[a_,p_,txt_,lgt_, *)
{Blue,AbsolutePointSize[8],Point@p1,ellLabelTxt[a,p1,Style["(Subscript[P, 1])",20],OptionValue@lgtP1]},
{Red,AbsolutePointSize[8],Point@x88,Text[Style["88",16],x88+.7lgt*grad88,{Center,Center},{-perp@grad88,grad88}]},
{Darker@Green,AbsolutePointSize[8],Point@x162,Text[Style["162",16],x162+.7lgt*grad162,{Center,Center},{-perp@grad162,grad162}]}},Background->None];
gr];

Clear@makeWaves;
Options@makeWaves={xmax->1,ymax->1,dt->0};
makeWaves[cycles_,clr_,OptionsPattern[]]:=Module[{fn,x0,y0,x,y},
fn=Function[{t},{t-Sin[t],1+Cos[t]}];
x0=cycles*2π;
y0=2;
ParametricPlot[
Evaluate[{x,y}=
fn[t];{(x+OptionValue@dt)OptionValue@xmax/x0,y(OptionValue@ymax/y0)}],{t,0,2π cycles},PlotStyle->clr]];

Show[
MapThread[makeWaves[12,#1,dt->#2,xmax->5,ymax->.5]&,{{Red,Blue},{0,π}}]]

SameQ[Head[None],RGBColor]

Clear@MakeSwanFrameProps;
Options@MakeSwanFrameProps={ellFill->None,waveClr->RGBColor[.7,.7,1]};
MakeSwanFrameProps[a_,OptionsPattern[]]:=Module[{i,swanImg,swanImgBlack,waves,waves90,waveScaled,ell,rp},
swanImg=Import["pics/swan-no-alpha.png"];
swanImgBlack=Import["pics/swan-gray.png"];
waves=makeWaves[16,OptionValue@waveClr,xmax->2.2a,ymax->.1];
waves90=makeWaves[16,OptionValue@waveClr,xmax->2.2a,ymax->.1,dt->π];
waveScaled=Graphics[i=0;Table[Translate[List@@If[EvenQ[i++],waves,waves90],{-1.1a,y}],{y,-1.25,1,.25}]];
ell=If[SameQ[OptionValue@ellFill,None],
plotEll[a,{AbsoluteThickness[3],Black}],
plotEllFill[a,OptionValue@ellFill,{AbsoluteThickness[3],Black}]];
rp=RegionPlot[(x/a)^2+y^2>1,{x,-2a,2a},{y,-2,2},BoundaryStyle->None,PlotStyle->White];
<|"waveScaled"->waveScaled,"rp"->rp,"ell"->ell,"swanImg"->swanImg,"swanImgBlack"->swanImgBlack|>
];

Clear@MakeOneSwanFrameWithProps;
Options@MakeOneSwanFrameWithProps=Join[
{slackX->.3,slackY->.3,drWaves->True,labPrefix->"",slackXleft->0,slackYbot->0,imgSize->800},Options@makeOneSwanFrame];
MakeOneSwanFrameWithProps[a_,tDeg_,props_,opts:OptionsPattern[]]:=Module[{pl,gr,pr},
(*props=MakeSwanFrameProps[a,False];*)
pl=OptionValue@labPrefix<>"a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°";
gr=makeOneSwanFrame[a,tDeg,{props["swanImg"],props["swanImgBlack"]},FilterRules[{opts},Options@makeOneSwanFrame]];
pr={{-a-OptionValue@slackX+OptionValue@slackXleft,a+OptionValue@slackX},{-1-OptionValue@slackY+OptionValue@slackYbot,1+OptionValue@slackY}};
Show[{Sequence@@If[OptionValue@drWaves,{props["waveScaled"],props["rp"]},{}],props["ell"],gr},
PlotLabel->Style[pl,{Black,24}],ImageSize->OptionValue@imgSize,PlotRange->pr]];

DynamicModule[{a=2.5,props},
Manipulate[
props=MakeSwanFrameProps[a,ellFill->None];
Dynamic@MakeOneSwanFrameWithProps[a,tDeg,props,lgtP1->.133,arrowL->.15],{{tDeg,45.},-180,180,.2}]]

ptClrs

swanPlot=Module[{a=2.5,props,imgs,tDegs},
props=MakeSwanFrameProps[a,ellFill->Directive["sym"/.ptClrs,Opacity@.1]];
tDegs={24.8,30,31,48.5,49,57};
imgs=MapThread[
MakeOneSwanFrameWithProps[a,#1,props,drP1dir->True,slackY->.1,slackX->.4,slackXleft->2.75,slackYbot->.5,drWaves->True,labPrefix->#2<>" "]&,
{tDegs,{"(i)","(ii)","(iii)","(iv)","(v)","(vi)"}}];
Grid[Partition[imgs,2],Frame->All,Spacings->{0.1,0}]]

Export["pics/1200_swan_frames.png",swanPlot]

(*Module[{a=2.5,props,img,i,tDegs},
props=MakeSwanFrameProps[a,ellFill->False];
tDegs=Range[0,360,30];
For[i=1,i<=Length@tDegs,i++,
If[Mod[i-1,100]==0,Print@i];
 img=MakeOneSwanFrameWithProps[a,tDegs[[i]],props];
Export["pics_swan/swan_"<>padZ[i,4]<>".png",img];
Export["pics_swan_eps/swan_"<>padZ[i,4]<>".eps",img];]];*)

With Jair: Trilinears for Circumconics And Inconics

Darboux Line: Kimberling [2,7]:
 a (b - c) (b + c - a) α + b (c - a) (c + a - b) β + c (a - b) (a + b - c) γ = 0

Clear@x;Clear@y;Clear@z;

(* x4 *)circumcenterTrilin={a(b^2+c^2-a^2),b(c^2+a^2-b^2),c(a^2+b^2-c^2)};

(* x4 *)orthocenterTrilin={b c /(b^2+c^2-a^2),c a/(c^2+a^2-b^2),a b/(a^2+b^2-c^2)};

(* x9 *)mittenTrilin={b+c-a,a+c-b,a+b-c};

(* x8 *) nagelTrilin={b c (b+c-a),c a(c+a-b),a b(a+b-c)};

(* x7 *) gergonneTrilin={b c/(b+c-a),c a /(c+a-b),
a b/(a+b-c)};

x85Trilin={b^2c^2/(b+c-a),c^2a^2/(c+a-b),a^2 b^2/(a+b-c)};
(* isotomic conj of X(9) *)x57Trilin=1/{b+c-a,c+a-b,a+b-c};

x88Trilin=1/{b+c-2a,c+a-2b,a+b-2c};
x100Trilin=1/{b-c,c-a,a-b};

x162Trilin=1/{(b^2-c^2)(b^2+c^2-a^2),(c^2-a^2)(c^2+a^2-b^2),(a^2-b^2)(a^2+b^2-c^2)};

(* isog conj of X7 *)x55Trilin={a(b+c-a),b(c+a-b),c(a+b-c)};

feuerbachTrilin={b c(b+c-a)(b-c)^2,c a(c+a-b)(c-a)^2,a b(a+b-c)(a-b)^2};

http : // www.maths.gla.ac.uk/wws/cabripages/triangle/conics.htm
If C (P), P=p:q:r, then center = { p (q + r - p) : q (r + p - q) : r (p + q - r) }

Given a triangle with vertices A, B, C and sides a, b, c. circumconic is the locus of [x : y : z] st:

u y z + v z x + w x y = 0   ---  where: [u : v : w] is the “perspector”
( divide all by xyz => u/x + v/y + w/z = 0 )

Center is at: [ u(-a u+b v+c w) : v(a u-b v+c w) : w(a u+b v-c w) ]
Note: if [u:v:w]=[1:1:1], center is X9 = b+c-a ::

circumTrilin[{u_,v_,w_},{x_,y_,z_}]:=u y z+v z x+w x y; (* == 0 *)

circumCenterTrilin[{u_,v_,w_},{a_,b_,c_}]:={u(-a u+b v+c w),v(a u-b v+c w),w(a u+b v-c w)};

Isotomic of [u : v : w] = 1/(u a^2) ::

Verify that with perspector u : w : v = X (1) = 1:1:1, get trilinears for X (9)

circumCenterTrilin[{1,1,1},{a,b,c}]

Equation for E9 = X(9)-centered circumconic (note: also xy + xz + yz = 0, or 1/z+1/y+1/x=0)
Isotomic of [x:y:z] = [x’:y’:z’] = [1/(x a^2): 1/(y b^2) : 1/(z c^2)] they will obey
L(31): x’ a^2 + y’ b^2 + z’ c^2 = 1/x+1/y+1/z = 0
nota: X(31) = [a^2 : b^2 : c^2]

Se estou na L(31): a^2 x + b^2 y + c^2 z = 0
Pergunta: qual a circumconica correspondente under isotomic?
Isotomic of [x:y:z] = [x’:y’:z’] = [1/(x a^2): 1/(y b^2) : 1/(z c^2)]
Circumconica generica (quadrica): u y z + v z x + w x y = 0
outra forma: u/x + v/y + w/z = 0

Antiorthic: Isogonal of [x:y:z] ] = [1/x,1/y,1/z]
L(1) = x + y + z = 0
X(1) = [1:1:1]

We want L(1)⋂L(31) = X(661)
x a^2 + y b^2 + z c^2 =  x + y + z
b^2-c^2 : c^2-a^2 : a^2-b^2
X(661) = b^2 - c^2

circumTrilin[{1,1,1},{x,y,z}]==0

Factor[circumTrilin[{1,1,1},circumcenterTrilin]==0]

Factor@circumTrilin[{1,1,1},orthocenterTrilin]

((a^3)-(a^2) b-a (b^2)+(b^3)-(a^2) c-(b^2) c-a (c^2)-b (c^2)+(c^3))/.{a->3,b->4,c->5}

circumTrilin[{1,1,1},{x,y,z}]==0

Factor@circumTrilin[{1,1,1},1/{cA,cB,cC}]==0

Numerator@Factor@circumTrilin[{1,1,1},orthocenterTrilin]

((a^3)-(a^2) b-a (b^2)+(b^3)-(a^2) c-(b^2) c-a (c^2)-b (c^2)+(c^3))/.{a->3,b->4,c->5}

FullSimplify[Numerator@Factor@circumTrilin[{1,1,1},orthocenterTrilin]==0,a>0&&b>0&&c>0]/.{a->3,b->4,c->5}

Test if X(88), X(100) is on E9

FullSimplify[circumTrilin[{1,1,1},x100Trilin]]

FullSimplify[circumTrilin[{1,1,1},x88Trilin]]

FullSimplify[circumTrilin[{1,1,1},x162Trilin]]

Inconic Equation

inconicTrilin[{u_,v_,w_},{x_,y_,z_}]:=u^2 x^2+v^2 y^2+w^2 z^2−2 v w y z−2 w u z x−2 u v x y;(* == 0 *)

inconicBary[{u_,v_,w_},{x_,y_,z_}]=inconicTrilin[{a u,b v,c w},{a x, b y,b z}]

inconicCenterTrilin[{u_,v_,w_},{a_,b_,c_}]:={c v+b w,a w+c u,b u+a v};

inconicCenterTrilin[nagelTrilin,{a,b,c}]

FullSimplify[inconicCenterTrilin[x55Trilin,{a,b,c}]]

mittenTrilin/.{a->1,b->2,c->3}

http://www.maths.gla.ac.uk/wws/cabripages/misc/candi.htm
“if a inconic has centre U, then it has perspector T(A(U)), where T() is isotomic conjugation and A() is the anticomplement.
i.e., if the desired center is X(9):
X(7) = Gergonne = anticomplement of X(9)
X(8) = Nagel = isotomic conjugate of X(7)
the perspector should be T(A(X(9))) = T(X(7))=X(8)

uvwX9inconic={u,v,w}/.First@Solve[Thread[inconicCenterTrilin[{u,v,w},{a,b,c}]==mittenTrilin],{u,v,w}]

uvwX9inconicAlt={((b-c)^2-a^2)a,((c-a)^2-b^2)b,((a-b)^2-c^2)c}

uvwX9inconicAlt2={a(b-c-a)(b-c+a),b(c-a-b)(c-a+b),c(a-b-c)(a-b+c)};

FullSimplify[inconicCenterTrilin[uvwX9inconicAlt,{a,b,c}],(a>0)&&(b>0)&&(c>0)]

FullSimplify[inconicCenterTrilin[uvwX9inconicAlt2,{a,b,c}]]

Equation of Caustic (Mandart Inellipse)

FullSimplify[inconicTrilin[uvwX9inconicAlt2,{x,y,z}]==0]

Test if Caustic is satisfied by X11

FullSimplify[inconicTrilin[uvwX9inconicAlt2,feuerbachTrilin]]

Test if Extouchpoints are on the Caustic

extouchTrilin={0,(a+c-b)/b,(a+b-c)/c};

FullSimplify[inconicTrilin[uvwX9inconicAlt2,extouchTrilin]]

Coup-de-Grâce: are the ACT intouchpoints on the Billiard?

intouchTrilins={0,(a c)/(a-b+c),(a b)/(a+b-c)};
anticomplMtx={1/{-a,b,c},1/{a,-b,c},1/{a,b,-c}};

anticomplMtx//MatrixForm

(anticomplMtx.anticomplMtx)//MatrixForm

Module[{m,p},
m={{a11,a12},{a21,a22}};
p={x,y};
m.p]//MatrixForm

Module[{m,p},
m={{a11,a12},{a21,a22}};
p={x,y};
p.m]//MatrixForm

antiInt[a_,b_,c_]=intouchTrilins.anticomplMtx

intouchTrilins

anticomplMtx

Inverse[anticomplMtx]

Module[{a=1.5,tDeg=10.,ons,act,actSides,actInt,actIntTrils},
ons=orbitNormals[a,tDeg];
act=anticomplementaryTriangle[ons[[1]],ons[[3]]];
actSides=triLengthsRL@act;
actInt=intouchTriangle[act,actSides];
actIntTrils=trilinearToCartesian[
ons[[1]],(* vertices *)
ons[[3]],(* side lengths *)
antiInt@@ons[[3]]];(* trilinears *)
{actInt,actIntTrils}]

If a inconic has perspector U, then it has centre C(T(U)).

Inconic with center Xi has perspector at isot(Xi)
isot(X9) = X85

nagelTrilinOvSides={b c (-a+b+c)/a,a c (a-b+c)/b,a b (a+b-c)/c};

inconicCenterTrilin[nagelTrilinOvSides,{a,b,c}]

FullSimplify[inconicCenterTrilin[1/gergonneTrilin,{a,b,c}]]

inconicCenterTrilin[1/mittenTrilin,{a,b,c}]

inconicCenterTrilin[1/nagelTrilin,{a,b,c}]

FullSimplify[inconicCenterTrilin[x85Trilin,{a,b,c}],(a>0)&&(b>0)&&(c>0)]

Billiard Caustic is Mandart Inellipse, whose perspector is X (8) Nagel Point: (b + c - a)/a::

inconicTrilin[nagelTrilin,{x,y,z}]==0

FullSimplify[inconicTrilin[gergonneTrilin,feuerbachTrilin]]

FullSimplify[inconicTrilin[nagelTrilin,feuerbachTrilin]]

inconicTrilin[x85,feuerbachTrilin]

Peter Moses:
- The circumconics centered on Xi have parallel axes if Xi lies on Feuerbach Circumhyp of Medial Triangle.
- For reference triangle, Feuerbach Circumhyp is centered on X11, perspector X650
- For medial: center is complem[X11]=X3035 and perspector is complement[X650]=X4885
X(3035) = bc[(a - b + c)(a - c)^2 + (a + b - c)(a - b)^2]
X(4885) =  (b - c)(a - b -  c + 2 (b c)/a)


Feuerbach Circumhyp is centered on X(11), perspector X(650)
ETC: X(11) = perspector of circumconic centered at X(650)
X(11) = b c (b + c - a)(b - c)^2

X(3035) = Complement of X(11) = bc[(a - b + c)(a - c)^2 + (a + b - c)(a - b)^2]
X(650) = Trilinears    (b - c)(b + c - a) : (c - a)(c + a - b) : (a - b)(a + b - c)
X(650) = anticomplement of X(4885)
X(4885) =  (b - c)(a - b -  c + 2 (b c)/a)
X(650) = perspector of the Feuerbach hyperbola

Complement of point [u : v : w] = [(b v + c w)/a : (a u+c w)/b : (a u+b v)/c]

Complement of Centroid: 1/a : 1/b : 1/c => 2/a:2/b:2/c => ok

Clear@complementTrils;complementTrils[trilFn_,{a_,b_,c_}]:=Module[{u,v,w},
u=trilFn[a,b,c];
v=trilFn[b,c,a];
w=trilFn[c,a,b];
{(b v+c w)/a,
(a u+c w)/b,
(a u+b v)/c}];

(c/((((a-b))^2) b (a+b-c)))+(b/((((a-c))^2) c (a-b+c)))

(* X11 => X(3035) *)FullSimplify[complementTrils[Function[{a,b,c},((b c)(b+c-a)(b-c)^2)],{a,b,c}],a>0&&b>0&&c>0]

(* X(650) =>? X(4885) *)
FullSimplify[complementTrils[Function[{a,b,c},(b-c)(b+c-a)],{a,b,c}],a>0&&b>0&&c>0]

The Excentral Macbeath Inconic of 3-periodics

https://mathworld.wolfram.com/MacBeathInconic.html

Clear@getMacBeathTouchpoints;
getMacBeathTouchpoints[a_?NumberQ,tDeg_?NumberQ]:=Module[{ons,exc,excL,x264exc,x264excTrils},
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excL=triLengthsRL@exc;
x264exc=getX264Trilin[exc,excL];
x264excTrils=getTrilinears[x264exc,exc,excL];
cevianTriangle[exc,excL,x264excTrils]];

Clear@showExcMacBeath;
Options@showExcMacBeath={minX->-3,maxX->3,minY->-5,maxY->5,touchPtsInfo->False,drExcLocus->False,drPerspector->True,drExcPerspector->True,drExcCircumcircle->False,excLocusClr->Directive[Thick,Darker@Green],sz->600,drIncircle->False,drCircumcircle->False,extra->{}};showExcMacBeath[a_?NumberQ,tDeg_?NumberQ,OptionsPattern[]]:=Module[{ell,ons,exc,excL,excTrils,d,touchPts,gr,f2,x1,x3,x100,r,R,x264exc,x1742,focalDist,pr,macbeath,pl,lgts,cinc,δ,excLocusAxes},
ell=plotEllAxes[a,{AbsoluteThickness@3,Black}];
ons=orbitNormals[a,toRad@tDeg];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excL=triLengthsRL@exc;
(* foci are on X3 and X4 of excentral, i.e., X40 and X1 of reference *)
x1=getIncenterTrilin[ons[[1]],ons[[3]]];
x3=getCircumcenterTrilin[ons[[1]],ons[[3]]];
r=getInradius[ons[[3]]];
R=magn[x3-ons[[1,1]]];
f2=getBevanTrilin[ons[[1]],ons[[3]]];
(* center is on X5 of excentral, X3 of reference *)
x264exc=getX264Trilin[exc,excL];
(* peter moses: X1742 is excentral's X264 *)
x1742=getX1742Trilin[ons[[1]],ons[[3]]];
x100=getX100Trilin[ons[[1]],ons[[3]]];
excTrils=getTrilinears[x264exc,exc,excL];
touchPts=cevianTriangle[exc,excL,excTrils];
focalDist=magn[x1-f2];
macbeath=getCircumAny[touchPts,x3];
lgts=macbeath["lengths"];
cinc=getCircumcenter@@touchPts;
δ=getDelta[a,1.];
excLocusAxes={(δ+1)/a,δ+a^2};
d=Sqrt[R(R-2r)];
gr=Graphics[{PointSize@Large,FaceForm@None,
If[OptionValue@drExcLocus,{OptionValue@excLocusClr,
Circle[{0,0},excLocusAxes],Dashed,Line@{-{excLocusAxes[[1]],0},{excLocusAxes[[1]],0}},
Line@{-{0,excLocusAxes[[2]]},{0,excLocusAxes[[2]]}}},{}],
If[OptionValue@drExcCircumcircle,{Orange,Thick,Point@f2,Circle[f2,2R]},{}],
If[OptionValue@drIncircle,{Darker@Green,Thick,Point@x1,Circle[x1,r]},{}],
If[OptionValue@drCircumcircle,{Purple,Thick,Point@x3,Circle[x3,R]},{}],
drawPolyThick[ons[[1]],Blue],drawPolyThick[exc,Darker@Green],Darker@Red,Point@x3,Point@touchPts,(*,If[OptionValue@drExcPerspector,{Pink,Point@x264exc},{}]*)Black,
If[OptionValue@drPerspector,{Darker@Green,Thick,Dashed,MapThread[Line@{#1,#2}&,{exc,touchPts}],,Point@x1742,Text[Style["(Subscript[X, 1742])",{20}(*,Background->White*)],x1742,{-1.25,-1.25}]},{}],MapThread[{#3,Point@#2,Text[Style[#1,{20}(*,Background->White*)],#2,{-1.25,-1.25}]}&,{{"(Subscript[X, 1])","(Subscript[X, 40])","(Subscript[X, 3])","(Subscript[X, 100])"},{x1,f2,x3,x100},{Darker@Green,Orange,Purple,Black}}]}];
pr={{OptionValue@minX,OptionValue@maxX},{OptionValue@minY,OptionValue@maxY}};
pl="d="<>nfn[d,3]<>", R="<>nfn[R,3]<>", r="<>nfn[r,3]<>", R/r="<>nfn[R/r,3]<>", θ="<>nfn[tDeg,1]<>"°"<>
"\n(Subscript[E, 9]): (Subscript[a, 9])="<>nfn[a,3]<>", (Subscript[b, 9])="<>nfn[1,3]<>", (Subscript[a, 9])(Subscript[b, 9])="<>nfn[a,3]<>", (Subscript[a, 9])/(Subscript[b, 9])="<>nfn[a,3]<>
"\n(Subscript[I, 5])': (Subscript[α, 5])'="<>nfn[lgts[[2]],3]<>", (Subscript[β, 5])'="<>nfn[lgts[[1]],3]<>", (Subscript[α, 5])'(Subscript[β, 5])'="<>nfn[lgts[[2]]lgts[[1]],3]<>", (Subscript[α, 5])'/(Subscript[β, 5])'="<>nfn[lgts[[2]]/lgts[[1]],3]<>
"\n(Subscript[E, 6])': (Subscript[η, 6])'="<>nfn[excLocusAxes[[2]],3]<>", (Subscript[ζ, 6])'="<>nfn[excLocusAxes[[1]],3]<>", (Subscript[η, 6])'(Subscript[ζ, 6])'="<>nfn[excLocusAxes[[2]]excLocusAxes[[1]],3]<>", (Subscript[η, 6])'/(Subscript[ζ, 6])'="<>nfn[excLocusAxes[[2]]/excLocusAxes[[1]],3]<>
If[OptionValue@touchPtsInfo,"\nA="<>nfn[-signedArea[touchPts],3]<>", (Subscript[r, tps]) = "<>nfn[magn[touchPts[[1]]-cinc],3],""]; 
Show[{ell,OptionValue@extra,drawCircumAnyLow[macbeath,x3,ctrLab->"",ps->Directive[AbsoluteThickness@3,Darker@Red]],gr},PlotLabel->Style[pl,{Black,20}(*,Background->White*)],PlotRange->pr,ImageSize->OptionValue@sz]];

DynamicModule[{a=1.5,tpLocus,brianchonLocus,eps=.001},
Manipulate[
brianchonLocus=Quiet@ParametricPlot[getX1742Trilin@@Part[orbitNormals[a,toRad@(tDeg2+eps)],{1,3}],{tDeg2,0,360},PlotStyle->Directive[Thick,Pink],PerformanceGoal->"Quality"];
tpLocus=Quiet@ParametricPlot[getMacBeathTouchpoints[a,tDeg2+eps][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
Dynamic@showExcMacBeath[a,tDeg,drExcLocus->True,extra->{brianchonLocus,tpLocus},drIncircle->True,drCircumcircle->True],
{{tDeg,10.},-180,180,.1}]]

Clear@showMacBeathPair;showMacBeathPair[a1_,a2_,tDeg_]:=Module[{tpLocus1,tpLocus2,outer1,outer2,bri1,bri2},
bri1=Quiet@ParametricPlot[getX1742Trilin@@Part[orbitNormals[a1,toRad@tDeg2],{1,3}],{tDeg2,0,360},PlotStyle->Directive[Thick,Pink],PerformanceGoal->"Quality"];
bri2=Quiet@ParametricPlot[getX1742Trilin@@Part[orbitNormals[a2,toRad@tDeg2],{1,3}],{tDeg2,0,360},PlotStyle->Directive[Thick,Pink],PerformanceGoal->"Quality"];
outer1=Quiet@ParametricPlot[getExcenters[Sequence@@Part[orbitNormals[a1,toRad@tDeg2],{1,2}]][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Darker@Green],PerformanceGoal->"Quality"];
outer2=Quiet@ParametricPlot[getExcenters[Sequence@@Part[orbitNormals[a2,toRad@tDeg2],{1,2}]][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Darker@Green],PerformanceGoal->"Quality"];
tpLocus1=Quiet@ParametricPlot[getMacBeathTouchpoints[a1,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
tpLocus2=Quiet@ParametricPlot[getMacBeathTouchpoints[a2,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
Grid[{{showExcMacBeath[a1,tDeg,extra->{bri1,outer2,tpLocus1}],showExcMacBeath[a2,tDeg,extra->{bri2,outer2,tpLocus2}]}},Frame->All]];

showMacBeathPair[1.5,2,20.]

ratioMacBeath[a_,b_]:=Module[{d,v1,v2},
d=getDelta[a,b];
v1=Sqrt[d+a^2-b^2](b^2+d)/(2b a^2);
v2=Sqrt[d-a^2+b^2](a^2+d)/(2 a b^2);
{v1,v2}]

ratioMacBeath[1.5,1]

ratioMacBeath[2.,1]

macBeathPlot=showExcMacBeath[1.5,22,minY->-1.75,maxY->2.,minX->-2,maxX->2]

export3["0130_macbeath_inconic",macBeathPlot]

Perspector for Inconic centered on Gergonne Point X (7)

X(7) = Barycentrics = 1/(b + c - a)::
InconicPersp(X(7)) = 1/[f(b,c,a)+f(c,a,b)-f(a,b,c)]   [[http://www.maths.gla.ac.uk/wws/cabripages/misc/candi.htm]]

(* return trilinears *)
perspInconicLow[baryFn_]:=
Factor@FullSimplify[1/(baryFn[b,c,a]+baryFn[c,a,b]-baryFn[a,b,c])/a];

perspInconicX9[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a(b+c-a)]]

perspInconicX1[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a]]

perspInconicX2[a_,b_,c_]=perspInconicLow[Function[{a,b,c},1]]

perspInconicX3[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a^2(b^2+c^2-a^2)]]

getX69Trilin[]

perspInconicX4[a_,b_,c_]=perspInconicLow[Function[{a,b,c},1/(b^2+c^2-a^2)]]

perspInconicX5[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a^2(b^2+c^2)-(b^2-c^2)^2]]

perspInconicX6[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a^2]]

perspInconicX7[a_,b_,c_]=perspInconicLow[Function[{a,b,c},1/(b+c-a)]]

perspInconicX8[a_,b_,c_]=perspInconicLow[Function[{a,b,c},b+c-a]]

perspInconicX10[a_,b_,c_]=perspInconicLow[Function[{a,b,c},b+c]]

perspInconicX11[a_,b_,c_]=perspInconicLow[Function[{a,b,c},(b+c-a)(b-c)^2]]

perspInconicX12[a_,b_,c_]=perspInconicLow[Function[{a,b,c},(b+c)^2/(b+c-a)]]

perspInconicX57[a_,b_,c_]=perspInconicLow[Function[{a,b,c},a/(b+c-a)]]

perspInconicTrilin[o_,s_,perspFn_]:=trilinearToCartesian[o,s,{perspFn@@s,perspFn@@RotateLeft[s,1],perspFn@@RotateLeft[s,2]}];

perspInconicX1trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX1];
perspInconicX2trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX2];
perspInconicX3trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX3];
perspInconicX4trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX4];
perspInconicX5trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX5];
perspInconicX6trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX6];
perspInconicX7trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX7];
perspInconicX8trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX8];
perspInconicX9trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX9];
perspInconicX10trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX10];
perspInconicX11trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX11];
perspInconicX12trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX12];
perspInconicX57trilin[o_,s_]:=perspInconicTrilin[o,s,perspInconicX57];

Clear@getInconicTouchPts;
Options@getInconicTouchPts={useTri->"orbit",drCircum->False};
getInconicTouchPts[a_,tDeg_,ctrTrilinFn_,perspTrilinFn_,OptionsPattern[]]:=Module[{ons,exc,tri,triL,ctr,persp,perspTrils,act,ort},
ons=orbitNormals[a,toRad@tDeg];
tri=Switch[OptionValue@useTri,
"orbit",ons[[1]],
"exc",excentralTriangle[ons[[1]],ons[[3]]],
"act",anticomplementaryTriangle[ons[[1]],ons[[3]]],
"ort",orthicTriangle[ons[[1]],ons[[3]]],_,tri];
triL=triLengthsRL@tri;
(* foci are on X3 and X4 of excentral, i.e., X40 and X1 of reference *)
(* center is on X5 of excentral, X3 of reference *)
ctr=ctrTrilinFn[tri,triL];
If[OptionValue@drCircum,
tri,
persp=perspTrilinFn[tri,triL];
perspTrils=getTrilinears[persp,tri,triL];
cevianTriangle[tri,triL,perspTrils]]];

Module[{a=1.5},
Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,getX57Trilin,perspInconicX57trilin,useTri->"act",drCircum->False][[3]],{tDeg2,0,360}]]

Clear@showInconic;
Options@showInconic={minX->-3,maxX->3,minY->-5,maxY->5,touchPtsInfo->False,sz->600,extra->{},ctrN->-1,perspN->-1,drMedial->False,useTri->"orbit",incClr->Purple,drX100->False,drCircumX1->False,drCircum->False};showInconic[a_,tDeg_,ctrTrilinFn_,perspTrilinFn_,OptionsPattern[]]:=Module[{ell,ons,ctr,persp,touchPts,conic,lgts,gr,pr,pl,perspTrils,med,exc,act,ort,tri,triL,x100,x1,circumX1},
ell=plotEllAxes[a,{AbsoluteThickness@3,Black}];
ons=orbitNormals[a,toRad@tDeg];
x100=getX100Trilin[ons[[1]],ons[[3]]];
med=medialTriangle[ons[[1]],ons[[3]]];
tri=Switch[OptionValue@useTri,
"orbit",ons[[1]],
"exc",exc=excentralTriangle[ons[[1]],ons[[3]]];exc,
"act",act=anticomplementaryTriangle[ons[[1]],ons[[3]]];act,
"ort",ort=orthicTriangle[ons[[1]],ons[[3]]];ort,
_,tri];
triL=triLengthsRL@tri;
x1=getIncenterTrilin[tri,triL];
circumX1=If[OptionValue@drCircumX1,getCircumAny[tri,x1],{}];
(* foci are on X3 and X4 of excentral, i.e., X40 and X1 of reference *)
(* center is on X5 of excentral, X3 of reference *)
ctr=ctrTrilinFn[tri,triL];
If[OptionValue@drCircum,
conic=getCircumAny[tri,ctr],
persp=perspTrilinFn[tri,triL];
perspTrils=getTrilinears[persp,tri,triL];
touchPts=cevianTriangle[tri,triL,perspTrils];
conic=getCircumAny[touchPts,ctr]];
lgts=conic["lengths"];
gr=Graphics[{PointSize@Large,FaceForm@None,
drawPoly[ons[[1]],Directive[AbsoluteThickness@3,Blue]],Switch[OptionValue@useTri,"exc",drawPoly[exc,Darker@Green],"act",drawPoly[act,Directive[Dashed,Blue]],"ort",drawPoly[ort,Orange],_,{}],If[OptionValue@drMedial,drawPoly[med,Directive[Red]],{}],Darker@Red,Point@ctr,If[OptionValue@drCircum,{},Point@touchPts],Black,
{Switch[OptionValue@useTri,"orbit",Blue,"exc",Darker@Green,"act",Blue,"ort",Orange,_,Gray],If[OptionValue@drCircum,{},{Point@persp,Text[Style[If[OptionValue@perspN==-1,"P",ToString[Subscript["X",OptionValue@perspN],StandardForm]],{20},Background->White],persp,{-1.25,-1.25}],Thick,Dashed,MapThread[Line@{#1,#2}&,{tri,touchPts}]}]},MapThread[{#3,Point@#2,Text[Style[ToString[Subscript["X",#1],StandardForm],{20},Background->White],#2,{-1.25,-1.25}]}&,{{OptionValue@ctrN,9},{ctr,{0,0}},{OptionValue@incClr,Black}}],
If[OptionValue@drX100,{Black,Point@x100,Text[Style["(Subscript[X, 100])",{20},Background->White],x100,{-1.25,-1.25}]},{}]}];
pr={{OptionValue@minX,OptionValue@maxX},{OptionValue@minY,OptionValue@maxY}};
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°\n"<>"μ'="<>nfn[lgts[[2]],3]<>", μ="<>nfn[lgts[[1]],3]<>", μ'/μ="<>nfn[lgts[[2]]/lgts[[1]],3]<>", μ'μ="<>nfn[lgts[[2]]lgts[[1]],3]<>If[OptionValue@touchPtsInfo&&!OptionValue@drCircum,"\nA="<>nfn[-signedArea[touchPts],3]<>", (Subscript[r, tps]) = "<>nfn[magn[touchPts[[1]]-cinc],3],""]; 
Show[{ell,OptionValue@extra,gr,If[OptionValue@drCircumX1,drawCircumAnyLow[circumX1,x1,ctrLab->"(Subscript[X, 1])",labClr->Darker@Green,ps->Directive[AbsoluteThickness@3,Darker@Green]],{}],drawCircumAnyLow[conic,ctr,ctrLab->"",ps->Directive[AbsoluteThickness@3,OptionValue@incClr]]},PlotLabel->Style[pl,{Black,20},Background->White],PlotRange->pr,ImageSize->OptionValue@sz]];

Range[12]

Thread[Range[5]->ToString/@Range[5]]

DynamicModule[{triples,locus},
triples={
{1,getIncenterTrilin,perspInconicX1trilin},
{2,getBarycenterTrilin,perspInconicX2trilin},
{3,getCircumcenterTrilin,perspInconicX3trilin},
{4,getOrthocenterTrilin,perspInconicX4trilin},
{5,getNinepointCenterTrilin,perspInconicX5trilin},
{6,getSymmedianTrilin,perspInconicX6trilin},
{7,getGergonneTrilin,perspInconicX7trilin},
{8,getNagelTrilin,perspInconicX8trilin},
{9,getMittenTrilin,perspInconicX9trilin},
{10,getSpiekerTrilin,perspInconicX10trilin},
{11,getFeuerbachTrilin,perspInconicX11trilin},
{12,getX12Trilin,perspInconicX12trilin},
{57,getX57Trilin,perspInconicX57trilin}};
Manipulate[
locus=Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,triples[[ctr,2]],triples[[ctr,3]],useTri->useTri0,drCircum->drCircum0][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
Dynamic@showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->True,ctrN->triples[[ctr,1]],minX->-maxX0,maxX->maxX0,
minY->-maxY0,maxY->maxY0,useTri->useTri0,drX100->drX100a,extra->If[drLocus,locus,{}],drCircumX1->drCircumX10,drCircum->drCircum0],
{{a,1.5},1.1,3,.05,Appearance->"Labeled"},
{{tDeg,10.},-180,180,.1,Appearance->"Labeled"},
{{ctr,3},Thread[Range[Length@triples]->First/@triples]},
{{maxX0,2},{1,2,3,4,5}},
{{maxY0,2},{1,2,3,4,5}},
{{useTri0,"orbit"},{"orbit","exc","act","ort"}},
{{drX100a,False,"x100"},{True,False}},
{{drCircumX10,False,"circum X1"},{True,False}},
{{drCircum0,False,"circumconic"},{True,False}},
{{drLocus,True,"locus"},{True,False}},ControlPlacement->Left]]

;

(*DeleteFile[inconicApp]*)

(*inconicApp=CloudDeploy[%,"inconic app v2",Permissions->"Public"]*)

Clear@showX3Inconics;Options@showX3Inconics={drCircumX1->False};
showX3Inconics[a_,tDeg_,opts:OptionsPattern[]]:=Module[{triples,locusRef,locusExc,ctr=3,incRef,incExc},
triples={
{1,getIncenterTrilin,perspInconicX1trilin},
{2,getBarycenterTrilin,perspInconicX2trilin},
{3,getCircumcenterTrilin,perspInconicX3trilin},
{4,getOrthocenterTrilin,perspInconicX4trilin},
{5,getNinepointCenterTrilin,perspInconicX5trilin},
{6,getSymmedianTrilin,perspInconicX6trilin},
{7,getGergonneTrilin,perspInconicX7trilin},
{8,getNagelTrilin,perspInconicX8trilin},
{9,getMittenTrilin,perspInconicX9trilin},
{10,getSpiekerTrilin,perspInconicX10trilin},
{11,getFeuerbachTrilin,perspInconicX11trilin},
{12,getX12Trilin,perspInconicX12trilin}};
locusRef=Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,triples[[ctr,2]],triples[[ctr,3]]][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
locusExc=Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,triples[[ctr,2]],triples[[ctr,3]],useTri->"exc"][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
incRef=showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->False,ctrN->triples[[ctr,1]],perspN->69,minX->-2,maxX->2,minY->-2,maxY->3.5,extra->locusRef,FilterRules[{opts},Options@showInconic]];
incExc=showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->False,ctrN->triples[[ctr,1]],perspN->2951,minX->-2,maxX->2,minY->-2,maxY->3.5,useTri->"exc",extra->locusExc];
Grid[{{incRef,incExc}},Frame->All]];

showX3Inconics[1.5,20.]

twoInvariantInconics[a_,tDeg_]:=Module[{inc3,inc5,xmin=2.25,x0=2.75},
inc3=showInconic[a,tDeg,getCircumcenterTrilin,perspInconicX3trilin,drMedial->False,ctrN->40,perspN->2951,
minX->-xmin,maxX->x0,minY->-2.2,maxY->3.5,useTri->"exc",incClr->Darker@Red,drX100->True,drCircumX1->True];
inc5=showExcMacBeath[1.5,tDeg,minX->-xmin,maxX->x0,minY->-2.2,maxY->3.5];
Grid[{{inc3,inc5}},Frame->All]]

twoInconicPlot=twoInvariantInconics[1.5,30.]

export3["0150_two_inconics",twoInconicPlot]

inconicX3plot=Module[{a=1.5,tDeg=30.,ctr=3,incExc,triples},
triples={
{1,getIncenterTrilin,perspInconicX1trilin},
{2,getBarycenterTrilin,perspInconicX2trilin},
{3,getCircumcenterTrilin,perspInconicX3trilin},
{4,getOrthocenterTrilin,perspInconicX4trilin},
{5,getNinepointCenterTrilin,perspInconicX5trilin},
{6,getSymmedianTrilin,perspInconicX6trilin},
{7,getGergonneTrilin,perspInconicX7trilin},
{8,getNagelTrilin,perspInconicX8trilin},
{9,getMittenTrilin,perspInconicX9trilin},
{10,getSpiekerTrilin,perspInconicX10trilin},
{11,getFeuerbachTrilin,perspInconicX11trilin},
{12,getX12Trilin,perspInconicX12trilin}};
incExc=showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->False,ctrN->40,perspN->2951,minX->-2,maxX->2,minY->-2.2,maxY->3.5,useTri->"exc",incClr->Darker@Red,drX100->True];
incExc]

macBeathPlot2=showExcMacBeath[1.5,22,minX->-2,maxX->2,minY->-2.2,maxY->3.5]

(*export3["0140_x3_inconic",inconicX3plot]*)

twoInconicPlot2=Grid[{{inconicX3plot,macBeathPlot2}},Frame->All]

(*export3["0150_two_inconics_v2",twoInconicPlot2]*)

Module[{ab=getCausticAxes[1.5,1]},
ab[[1]]/ab[[2]]]

getExcR[a_,tDeg_]:=Module[{ons,r,exc,excR,excL,R,npcR},
ons=orbitNormals[a,toRad@tDeg];
r=getInradius[ons[[3]]];
R=getCircumradius[ons[[3]]];
exc=excentralTriangle[ons[[1]],ons[[3]]];
excL=triLengthsRL@exc;
excR=getCircumradius[excL];
{excR,excR/R,excR/r,Sqrt[2R/r]}]

getExcR[1.5,30.]

FullSimplify[R/Sqrt[R^2-R(R-2r)]]/.{R->1,r->.5}

To do: Dual Pair:
Poristic I5' (excentral caustic) is stationary , moving on billiard
Poristic E6’ moving, stationary on Billiard, Excentral Locus

Clear@showDualCircumPair;
Options@showDualCircumPair={tpLocus->{},prAll->False,szs->{600,600}};
showDualCircumPair[a_,tDeg_,OptionsPattern[]]:=Module[{r,d,chap,eb,prChap,prEB},
r=rOvR[a];
d=dsolChapple[r];
chap=showChapple[d,tDeg+.001,drExc->True,drExcCircle->True,drCB->True,drExcCaustic->True,excCausticClr->Directive[AbsoluteThickness@3,Darker@Red],drExcCausticAxes->True,drExcCircumX6->True,drExcCausticAxes->True,fnt->20];
eb=showExcMacBeath[a,tDeg+.001,drPerspector->False,drExcLocus->True,drExcCircumcircle->True,excLocusClr->Directive[AbsoluteThickness@3,ColorData["HTML","OliveDrab"]],extra->OptionValue@tpLocus,drIncircle->True,drCircumcircle->True];
prChap={{-3.25,3.25},{-2.75,3.25}};
prEB={{-3.,3.},{-4.5,4.5}};
Grid[{MapThread[Show[#1,PlotRange->If[OptionValue@prAll,All,#2],ImageSize->#3,Frame->None,Axes->None,PlotRangeClipping->True]&,{{chap,eb},{prChap,prEB},OptionValue@szs}]},Frame->All,Alignment->Top]]

dualCircumPairPlot=
Module[{tpLocus1,a=1.5},
tpLocus1=Quiet@ParametricPlot[getMacBeathTouchpoints[a,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Darker@Red],PerformanceGoal->"Quality"];
showDualCircumPair[a,70.,prAll->True(*,tpLocus->tpLocus1*)]]

export3["0120_dual_circums",dualCircumPairPlot]

Movie Utils

Clear@doMovieFrames;
Options@doMovieFrames=Join[Options@movieFrame,{step->toRad@1.,offset->.0001,ellOpacity->.1}];
doMovieFrames[a_,exp_,lociFn_,view_:"excHalf",opts:OptionsPattern[]]:=Module[{loci,ellPlot,causticPlot,excenterLims,showables},
ellPlot=plotEllFill[a,Directive[Blue,Opacity@OptionValue@ellOpacity],{Thick,Black}];
causticPlot=plotEllb[Sequence@@getTriCausticParams[a],"feu"/.ptClrs];
(*loci=precompLoci[a];*)
loci=Quiet[lociFn[a]];
excenterLims=excenterMax[a];
showables=Join[getExpShowables[exp],{"loci","orbit"}];
(*Print["a=",a,",t=",0,",ellPlot=",ellPlot,",loci=",loci,",excL=",excenterLims,",view=",view,",opts=",FilterRules[{opts,showablesOpt->showables},Options@movieFrame]];*)
Table[movieFrame[a,t,ellPlot,causticPlot,loci,excenterLims,view,FilterRules[{opts,showablesOpt->showables},Options@movieFrame]],{t,OptionValue@offset,2.π+OptionValue@offset,OptionValue@step}]];

doMovieFrames[1.5,"exccircumb",Function[x,{}],"antiorthic2",ellOpacity->.05,step->toRad@45]

Clear@makeExperimentFrame;
makeExperimentFrame[a_,tDeg_,view_,exp_,OptionsPattern[]]:=Module[{img,eps=.001},
img=movieFrameOpts[a,toRad[tDeg+eps],
mainVizCache["ellPlot"],
mainVizCache["causticPlot"],
mainVizCache["lociBasic"],
mainVizCache["excenterLims"],
view,
Sequence@@(Rule[#,True]&/@opts4Exps[exp]),"orbit"->True,ImageSize->800]];

Clear@makeExperimentMovie;
Options@makeExperimentMovie={degStep->.5,showFrames->False};
makeExperimentMovie[a_,view_,exp_,fname_,OptionsPattern[]]:=Module[{imgs,eps=.001},
imgs=Table[
movieFrameOpts[a,toRad[i+eps],
mainVizCache["ellPlot"],
mainVizCache["causticPlot"],
mainVizCache["lociBasic"],
mainVizCache["excenterLims"],
view,
Sequence@@(Rule[#,True]&/@opts4Exps[exp]),"orbit"->True,ImageSize->800],
{i,0,360,OptionValue@degStep}];
If[OptionValue@showFrames,imgs,makeMovie[fname,Join[imgs,Reverse@imgs],3]]];

makeExperimentMovieLoci[a_,view_,exp_,lociName_,fname_]:=Module[{imgs},
imgs=Table[
movieFrameOpts[a,toRad[i+.001],
mainVizCache["ellPlot"],
mainVizCache["causticPlot"],
mainVizCache[lociName],
mainVizCache["excenterLims"],
view,
Sequence@@(Rule[#,True]&/@opts4Exps[exp]),"orbit"->True,"loci"->True,ImageSize->800],
{i,0,360,.5}];
makeMovie[fname,Join[imgs,Reverse@imgs],3]];

Newer Movies

showFocalIsogonalTriple=True;
If[showFocalIsogonalTriple,
Module[{degStep=.2,imgs,a=1.5,tpLocus},
(*tpLocus=Quiet@ParametricPlot[getMacBeathTouchpoints[a,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];*)
imgs=Table[showFocusIsogonalTriple[a,tDeg],{tDeg,0,360,degStep}];
makeMovie["focal isogonal conjugates v1.mov",Join[imgs,Reverse@imgs],1]]];

showImgsDualCircumPair=False;
If[showImgsDualCircumPair,
Module[{degStep=.2,imgs,a=1.5,tpLocus},
(*tpLocus=Quiet@ParametricPlot[getMacBeathTouchpoints[a,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];*)
imgs=Table[showDualCircumPair[a,tDeg,szs->{935,600}],{tDeg,0,360,degStep}];
makeMovie["dual circum pair v2.mov",Join[imgs,Reverse@imgs],1]]]

showImgsExcCircumX6=False;
If[showImgsExcCircumX6,
Module[{degStep=.2,imgs,r=rOvR@1.5},
imgs=Table[showExcCircumX6[r,tDeg],{tDeg,0,360,degStep}];
makeMovie["exc circum X6 v3.mov",Join[imgs,Reverse@imgs],1]]];

showExcX6[rOvR[1.5],0.]

showCircumX5X10=True;
If[showCircumX5X10,
Module[{degStep=.2,imgs,r=rOvR@1.5},
imgs=Table[showX5X10[r,tDeg],{tDeg,0,360,degStep}];
makeMovie["circum X10 and exc X5 v2.mov",Join[imgs,Reverse@imgs],1]]];

showCbFocusLocus=False;
If[showCbFocusLocus,
Module[{degStep=.2,imgs},
imgs=Table[showCBFocusLocus[rOvR[1.5],tDeg],{tDeg,0,360,degStep}];
makeMovie["cb focus locus v1.mov",Join[imgs,Reverse@imgs],1]]];

showC1I3=False;
If[showC1I3,
Module[{d1=dsolChapple[rOvR[1.5]],d2=dsolChapple[rOvR[1.25]],degStep=.2,imgs,eps=.001},
imgs=Table[Grid[{{
Show[showChapple[d1,tDeg+eps,
minX->-2.5,maxX->2.5,minY->-3,maxY->2.5,plShort->True,drCircumX1->True,drExcIncX3->True],ImageSize->600],
Show[showChapple[d2,tDeg+eps,
minX->-2.5,maxX->2.5,minY->-3,maxY->2.5,plShort->True,drCircumX1->True,drExcIncX3->True],ImageSize->600]
}},Frame->All],{tDeg,0,360,degStep}];
makeMovie["circum x1 excInc x3 v2.mov",imgs,2]]];

showX100pedals=False;
If[showX100pedals,
Module[{r1=.3625,r2=.45,imgs,degStep=.2},
imgs=Table[Grid[{{showPoristicSimson[r1,tDeg],showPoristicSimson[r2,tDeg]}},Frame->All],{tDeg,0,360,degStep}];
makeMovie["x100 pedals v1.mov",Join[imgs,Reverse@imgs],1]]];

showPoristicExcIncX3=False;
If[showPoristicExcIncX3,
Module[{imgs,degStep=.2,r=.36266},
imgs=Table[showOnePoristicExcIncX3[r,tDeg],{tDeg,0,360,degStep}];
makeMovie["poristic excentral inconic x3 v5.mov",Join[imgs,Reverse@imgs],1]]];

doChappleCircumbilliard=False;
If[doChappleCircumbilliard,
Module[{a=1.5,imgs,degStep=.2,r=.3625},
imgs=Table[showChappleX9[a,tDeg,r],{tDeg,0,360,degStep}];
makeMovie["poristic circumbilliard v1.mov",Join[imgs,Reverse@imgs],1]]];

doInvIncs=False;
If[doInvIncs,
Module[{a=1.5,imgs,degStep=.2},
imgs=Table[twoInvariantInconics[a,tDeg],{tDeg,0,360,degStep}];
makeMovie["invariant excentral inconics v1.mov",Join[imgs,Reverse@imgs],1]]];

doIncX3Pair=False;
If[doIncX3Pair,
Module[{a=1.5,triples,locusRef,locusExc,ctr=3,incRef,incExc,imgs,degStep=.2},
triples={
{1,getIncenterTrilin,perspInconicX1trilin},
{2,getBarycenterTrilin,perspInconicX2trilin},
{3,getCircumcenterTrilin,perspInconicX3trilin},
{4,getOrthocenterTrilin,perspInconicX4trilin},
{5,getNinepointCenterTrilin,perspInconicX5trilin},
{6,getSymmedianTrilin,perspInconicX6trilin},
{7,getGergonneTrilin,perspInconicX7trilin},
{8,getNagelTrilin,perspInconicX8trilin},
{9,getMittenTrilin,perspInconicX9trilin},
{10,getSpiekerTrilin,perspInconicX10trilin},
{11,getFeuerbachTrilin,perspInconicX11trilin},
{12,getX12Trilin,perspInconicX12trilin}};
locusRef=Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,triples[[ctr,2]],triples[[ctr,3]],][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
locusExc=Quiet@ParametricPlot[getInconicTouchPts[a,tDeg2,triples[[ctr,2]],triples[[ctr,3]],useTri->"exc"][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
imgs=Table[
incRef=showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->False,ctrN->triples[[ctr,1]],minX->-2,maxX->2,minY->-2,maxY->3.5,extra->locusRef];
incExc=showInconic[a,tDeg,triples[[ctr,2]],triples[[ctr,3]],drMedial->False,ctrN->triples[[ctr,1]],minX->-2,maxX->2,minY->-2,maxY->3.5,useTri->"exc",extra->locusExc];
Grid[{{incRef,incExc}},Frame->All],{tDeg,0,360,degStep}];
makeMovie["x3 inconics v1.mov",Join[imgs,Reverse@imgs],1]]];

doMacBeathPair=False;
If[doMacBeathPair,
Module[{a1=1.5,a2=2,outer1,outer2,bri1,bri2,tpLocus1,tpLocus2,tDegStep=.2,imgs},
bri1=Quiet@ParametricPlot[getX1742Trilin@@Part[orbitNormals[a1,toRad@tDeg2],{1,3}],{tDeg2,0,360},PlotStyle->Directive[Thick,Pink],PerformanceGoal->"Quality"];
bri2=Quiet@ParametricPlot[getX1742Trilin@@Part[orbitNormals[a2,toRad@tDeg2],{1,3}],{tDeg2,0,360},PlotStyle->Directive[Thick,Pink],PerformanceGoal->"Quality"];
outer1=Quiet@ParametricPlot[getExcenters[Sequence@@Part[orbitNormals[a1,toRad@tDeg2],{1,2}]][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Darker@Green],PerformanceGoal->"Quality"];
outer2=Quiet@ParametricPlot[getExcenters[Sequence@@Part[orbitNormals[a2,toRad@tDeg2],{1,2}]][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Dashed,Darker@Green],PerformanceGoal->"Quality"];
tpLocus1=Quiet@ParametricPlot[getMacBeathTouchpoints[a1,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
tpLocus2=Quiet@ParametricPlot[getMacBeathTouchpoints[a2,tDeg2][[1]],{tDeg2,0,360},PlotStyle->Directive[Thick,Orange],PerformanceGoal->"Quality"];
imgs=Table[Grid[{{showExcMacBeath[a1,tDeg,extra->{bri1,outer1,tpLocus1}],showExcMacBeath[a2,tDeg,extra->{bri2,outer2,tpLocus2}]}},Frame->All],{tDeg,0,360,tDegStep}];
makeMovie["excentral macbeath inconic v3.mov",Join[imgs,Reverse@imgs],1]]];

doNewSideTps=False;
If[doNewSideTps,
Module[{a=1.5,sideTpsData,ons,slackX=3,slackY=4,pre,pr,pl,conicA,conicB,imgs,eps=.001,degStep=.2,showLoci=False},
pr={{-a-slackX,a+slackX},{-1-slackY,1+slackY}};
pre=sideTpsLocusPre[a];
imgs=Table[
ons=orbitNormals[a,toRad@(tDeg+eps)];
sideTpsData=getExcircleSideTouchpoints[ons[[1]],ons[[3]]];
conicA=sideTpsData["conic"]["a"];
conicB=sideTpsData["conic"]["b"];
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°"<>"\n (Subscript[L, hex])="<>nfn[sideTpsData["perHex"],2]<> ", (Subscript[A, hex])="<>nfn[Abs@sideTpsData["areaHex"],2]<>"\n"<>"cA="<>nfn[conicA,3]<>", cB="<>nfn[conicB,3];
Show[(Graphics@Rotate[List@@#,π/2,{0,0}])&/@{pre["ell"],pre["ellCaustic"],pre["excLocus"],pre["env12Locus"],If[showLoci,pre["loci"],{}],
drawExcircleSideTouchpoints[sideTpsData,drSubtris->False,drExt->False,drHexVtxCircs->{1,2},drHexConic->True]},PlotLabel->Style[pl,{Black,16}],PlotRange->pr,ImageSize->1200],{tDeg,0,360,degStep}];
makeMovie["sidetps conic v1.mov",Join[imgs,Reverse@imgs],2]]];

doZeroHyps=False;
If[doZeroHyps,
Module[{a=1.5,imgs,degStep=.2},
imgs=Table[showZeroHyps[a,tDeg,slackX->1,slackY->1,sz->1200],{tDeg,0,360,degStep}];
makeMovie["zero hyps v5.mov",Join[imgs,Reverse@imgs],1]]];

doChapplePorism=False;
If[doChapplePorism,
Module[{d=.5,excLocus,imgs,degStep=.2,eps=.0001},
excLocus=Quiet@ParametricPlot[chappleData[d,tDeg]["exc"][[1]],{tDeg,0,360},PlotStyle->{Thick,Orange},PerformanceGoal->"Speed"];
imgs=Table[Show[{showChapple[d,tDeg+eps,minX->-4,maxX->4,minY->-3,maxY->3],excLocus},ImageSize->800],
{tDeg,0.1,360,degStep}];
makeMovie["stationary orthic chapple v3.mov",Join[imgs,Reverse@imgs],2]]];

doSideTouchpoints=False;
If[doSideTouchpoints,
Module[{a=1.618,sideTpsData,ons,slackX=2,slackY=3,pre,pr,pl,showLoci=True,imgs},
pr={{-a-slackX,a+slackX},{-1-slackY,1+slackY}};
pre=sideTpsLocusPre[a];
imgs=Table[
ons=orbitNormals[a,toRad@tDeg];
sideTpsData=getExcircleSideTouchpoints[ons[[1]],ons[[3]]];
pl="a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°"<>"\n (Subscript[L, hex])="<>nfn[sideTpsData["perHex"],2]<> ", (Subscript[A, hex])="<>nfn[Abs@sideTpsData["areaHex"],2];
Show[{pre["ell"],pre["ellCaustic"],pre["excLocus"],pre["env12Locus"],If[showLoci,pre["loci"],{}],
drawExcircleSideTouchpoints[sideTpsData,drSubtris->False,drExt->False,drHexVtxCircs-> {1,2}]},PlotLabel->Style[pl,{Black,16}],PlotRange->pr,ImageSize->800],{tDeg,0,360,.2}];
makeMovie["side touch points caustic v1.mov",Join[imgs,Reverse@imgs],2]]]

doCBtrio=False;
If[doCBtrio,
Module[{a=1.618,objs,uiExc,uiAct,uiMed,imgs,degStep=.2},
objs=getCBVizObjs[a];
Print@"objs done";
imgs=Table[
uiExc=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->True,"drActCB"->False,"drMedCB"->False,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-3.`,"maxX"->3.5`,"minY"->-2.5`,"maxY"->5.`,"imgSize"->640,"drRas"->False,"pl"->False,"drX9X7"->False,"drVtxLoci"->True\[RightAssociation];
uiAct=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->False,"drActCB"->True,"drMedCB"->False,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-4.`,"maxX"->3.`,"minY"->-2.75,"maxY"->1.75,"imgSize"->600,"drRas"->False,"pl"->False,"drX9X7"->False,"drVtxLoci"->True\[RightAssociation];
uiMed=\[LeftAssociation]"a"->a,"tDeg"->tDeg,"drLoci"->True,"drExcCB"->False,"drActCB"->False,"drMedCB"->True,"drOrtCB"->False,"drExtCB"->False,"drOrtExc"->False,"minX"->-2.`,"maxX"->2.`,"minY"->-1.25`,"maxY"->1.125`,"imgSize"->600,"drRas"->False,"pl"->False,"drX9X7"->True,"drVtxLoci"->True\[RightAssociation];
Grid[{{Style["a/b="<>nfn[a,3]<>", θ="<>nfn[tDeg,1]<>"°",{Black,30}],SpanFromLeft},{oneCBPrintObjs[uiExc,objs],Grid[{{oneCBPrintObjs[uiAct,objs]},{oneCBPrintObjs[uiMed,objs]}},Spacings->0,Dividers->{None,{False,True}}]}},Spacings->0,Frame->All,Alignment->Top],{tDeg,0,360,degStep}];
makeMovie["cb trio v1.mov",Join[imgs,Reverse@imgs],2]]];

doOrtCB=False;
If[doOrtCB,
Module[{as={1.618,1.982},objs,uis,imgs,degStep=.2,mp3},
objs=getCBVizObjs/@as;
uis=MapThread[<|
"drLoci"->True,
"drExcCB"->False,
"drActCB"->False,
"drMedCB"->False,
"drOrtCB"->True,
"drExtCB"->False,
"drOrtExc"->True,
"maxX"->#1,
"minY"->-1.1,
"maxY"->#2,
"imgSize"->#3
|>&,{{1.7,2.1},{4,4},600{1,1.01as[[2]]/as[[1]]}}];
imgs=Table[mp3=MapThread[drCBVizObjs[#1,tDeg,#2,#3]&,{as,objs,uis}];
Grid[{{mp3[[1]],mp3[[2]]}},Frame->All,Alignment->{Center,Top},Spacings->0],{tDeg,0,-45,-degStep}];
makeMovie["ort circum v2.mov",Join[imgs,Reverse@imgs],2]]
];

(* from envelopes notebook *)
doEnvelopeV1negV2=False;
If[doEnvelopeV1negV2,
DynamicModule[{a=2.5,props,imgs},
props=MakeSwanFrameProps[a,False];
imgs=Table[MakeOneSwanFrameWithProps[a,tDeg,props,lgtP1->.133,arrowL->.15],{tDeg,0,360,.2}];
makeMovie["envelope [P1,-P2] v3.mov",imgs,3]]]

doSwanDance3=False;
If[doSwanDance3,
Module[{a=2.5,props,imgs,i,tDegs,degStep=.1},
props=MakeSwanFrameProps[a,ellFill->False];
tDegs=Range[0,360,degStep];
imgs=MakeOneSwanFrameWithProps[a,#,props,arrowL->.125,imgSize->1200,drP1dir->False]&/@tDegs;
makeMovie["swan dance v4.mov",imgs,2]]];

doSwanDance=False;
If[doSwanDance,Module[{a=2.5,ell,slack=.4,pl,waves,waveScaled,rp,gr,imgs},
waves=Module[{r=1,k=4},
ParametricPlot[r{(k t- Sin[k t])/( k π),(Cos[k t]+1)/8},{t,π/k,2π-π/k},Axes->True,AspectRatio->Automatic]];
waveScaled=Graphics[Table[Translate[Scale[List@@waves,{.5,.33},{.5,.5}],{x,y}],{x,-3,2.5,.5},{y,-1.25,1,.25}]];
ell=plotEllFill[a,Directive[Cyan,Opacity@.1],{AbsoluteThickness[3],Black}];
rp=RegionPlot[(x/a)^2+y^2>1,{x,-2a,2a},{y,-2,2},BoundaryStyle->None,PlotStyle->White];
imgs=Table[
pl="a/b="<>nfn[a,2]<>", θ="<>nfn[tDeg,1]<>"°";
gr=makeOneSwanFrame[a,tDeg];
Show[{waveScaled,rp,ell,gr},
PlotLabel->Style[pl,{Black,20}],ImageSize->1200,PlotRange->{{-a-slack,a+slack},{-1-slack,1+slack}}],
{tDeg,0,360,.2}];
makeMovie["swan dance v1.mov",imgs,3]]]

doVtxToVtx90Caustic=False;
If[doVtxToVtx90Caustic,
Module[{a=1.5,duo,fn=Function[{o,s},o],imgs},
duo=getVtxToVtxEvolutePair90[a,fn,clr->{Thick,Darker@Green}];
imgs=Table[vtxToVtx90Frame[a,tDeg,duo],{tDeg,0,360,.5}];
makeMovie["p to p90 caustic v2.mov",Join[imgs,Reverse@imgs],2]]]

doEvoluteTris=True;
If[doEvoluteTris,
Module[{a=1.45,imgs,eps=.0001},
imgs=Table[showEvTris[a,tDeg+eps],{tDeg,0,360,.2}];
makeMovie["evolute triangles v1.mov",Join[imgs,Reverse@imgs],2]]]

doEvoluteGrid=False;
If[doEvoluteGrid,
Module[{imgs,aeps=10^-4},
imgs=Table[showOneEvoluteGrid[a+aeps],{a,1,2,.0025}];
makeMovie["evolute grid X1 thru X20 v4.mov",Join[imgs,Reverse@imgs],3]]]

doX1X5evolute=False;
If[doX1X5evolute,
Module[{a=1.618,envX1X5,envTouchX1,envTouchX1gr,imgs,eps=.001},
envX1X5=showEnvelopePairLow[a,getIncenterTrilin,getNinepointCenterTrilin,
perfGoal->"Speed","n1"->1,"n2"->5,slack->.5,imgSize->800,drCirc->False,drEvolute->True];
envTouchX1=evoluteX1touch[a,1];
(*ellCaustic=plotEllb[Sequence@@getCausticAxes[a,1],{Brown,Thick}];*)
envTouchX1gr={(*ellCaustic,*)Graphics[{Blue,PointSize@Large,Point@{envTouchX1,flipX@envTouchX1,flipY@envTouchX1,-envTouchX1}}]};
imgs=Table[Grid[{
{showGenericLineEnvelope[a,tDeg+eps,getIncenterTrilin,getNinepointCenterTrilin,envX1X5,drEvolute->True,
"n1"->1,"n2"->5,addedGr->envTouchX1gr,drC->False,rayL->4,imgSize->600,drX4->True]}},Frame->All],{tDeg,0,360,.2}];
makeMovie["ellipse evolute and x1x5 envelope v1.mov",Join[imgs,Reverse@imgs],1]
]];

doAntiGergEnv=False;
If[doAntiGergEnv,
Module[{a=(1+Sqrt@5.)/2,envGergonne,envAntiorthic,imgs,labs,eps=.001},
envAntiorthic=showEnvelopePairLow[a,getX44Trilin,getX1155Trilin,perfGoal->"Quality","n1"->44,"n2"->1155,slack->4,imgSize->800,drCirc->False,envDashed->True];
envGergonne=showEnvelopePairLow[a,getX857Trilin,getX908Trilin,perfGoal->"Quality","n1"->857,"n2"->908,slack->4,imgSize->400,drCirc->False,envDashed->True];
labs={
"Antiorthic Axis: ("<>ToString[Style["(Subscript[X, 44])",Red],StandardForm]<>","<>ToString[Style["(Subscript[X, 1155])",Darker@Green],StandardForm]<>")","Gergonne Line: ("<>ToString[Style["(Subscript[X, 857])",Red],StandardForm]<>","<>ToString[Style["(Subscript[X, 908])",Darker@Green],StandardForm]<>")"};
imgs=Table[Grid[{
Style[#,{Blue,20}]&/@labs,
{showGenericLineEnvelope[a,tDeg+eps,getX44Trilin,getX1155Trilin,envAntiorthic,"n1"->44,"n2"->1155,rayL->4,imgSize->600],
showGenericLineEnvelope[a,tDeg+eps,getX857Trilin,getX908Trilin,envGergonne,"n1"->857,"n2"->908,rayL->4,imgSize->600]}},Frame->All],{tDeg,0,360,.2}];
makeMovie["antiorthic and gergonne line envelopes v3.mov",Join[imgs,Reverse@imgs],1]
]];

doX88ComplexTrio=False;
If[doX88ComplexTrio,
Module[{eps=.001,imgs,objs123,as={1.35,1.486,1.75}},
objs123=showX88complexObjs/@as;(* hack to take repeated objects out of loop *)
imgs=Table[showX88complexTrioLow[as,{tDeg+eps,tDeg+eps,tDeg+eps},objs123],{tDeg,0,360,.2}];
makeMovie["x88 complex v2.mov",Join[imgs,Reverse@imgs],2]]]

showThomsonCubicDuo[a_,tDeg_]:=Grid[{Show[#,Frame->None]&/@{showThomsonCubic[a,tDeg],Show[showThomsonCubic[a,tDeg,fontSize->24],ImageSize->2400,PlotRange->{{-2.5,2.5},{-a,a}}]}},Frame->All]

doThomsonCubicDuo=True;
If[doThomsonCubicDuo,
Module[{a=1.5,eps=.001,imgs},
imgs=Table[showThomsonCubicDuo[a,tDeg+eps],{tDeg,0,360,1/3.}];
makeMovie["thomson cubic duo v3.mov",Join[imgs,Reverse@imgs],2]]]

doThomsonCubic=False;
If[doThomsonCubic,
Module[{a=1.5,eps=.001,imgs},
imgs=Table[showThomsonCubic[a,tDeg+eps],{tDeg,0,360,.2}];
makeMovie["thomson cubic v1.mov",Join[imgs,Reverse@imgs],2]]];

doYffTri=False;
If[doYffTri,
Module[{a=1.5,vtxLocus,dirFootLocus,eps=.01,max=3.,imgs},
vtxLocus=Quiet@ParametricPlot[YffVtx[a,tDeg2+eps],{tDeg2,0,180},
PlotStyle->{Orange},Axes->None,PerformanceGoal->"Speed"];
dirFootLocus=Quiet@ParametricPlot[YffDirFoot[a,tDeg+eps],{tDeg,0,140},
PlotStyle->{Purple},Axes->None,PerformanceGoal->"Quality"];
imgs=Table[Show[{vtxLocus,dirFootLocus,drYffTri[a,tDeg+eps]},
ImageSize->800,PlotRange->{{-max,max},{-max,max}}],{tDeg,0,360,.2}];
makeMovie["yff tri locus vtx v5.mov",Join[imgs,Reverse@imgs],2]]];

Old Movies

doFeuerActMedialCircumb=False;
If[doFeuerActMedialCircumb,Module[{imgs,a=1.5,eps=.0001,degStep=.25},
imgs=Table[Show[makeExperimentFrame[a,tDeg+eps,"ell","medial"],
Frame->False,Axes->False,PlotRange->{{-3.75,3.75},{-3,3}},ImageSize->800],{tDeg,0,360,degStep}];
makeMovie["feuerActMedialCircumb.mov",imgs,3]]];

doFeuerExcJerabekHyps=False;
If[doFeuerExcJerabekHyps,Module[{imgs,a=1.5,eps=.0001},
imgs=Table[showHypsImg[a,tDeg+eps,drMoses->False],{tDeg,0,360,.25}];
makeMovie["feu jer hyps v1.mov",imgs,3]]];

doX40=False;
If[doX40,Module[{imgs,eps=.0001},
imgs=Table[frameX40single[1.5,tDeg+eps],{tDeg,0,360,.25}];
makeMovie["x40 v2.mov",imgs,2]]];

shX59[a_,tDeg_]:=Show[plotX59[a,deg1->tDeg,drX4->True,lgt->.1,degStep->.25,degMax->142.],PlotRange->{{-1.6,1.6},{-1.2,1.1}},ImageSize->800];

doX59=False;
If[doX59,Module[{imgs,a1=1.24,a2=1.58005,eps=.0001},
imgs=Table[
Grid[{{shX59[a1,tDeg+eps],shX59[a2,tDeg+eps]}}],{tDeg,0,360,.25}];
makeMovie["x59 v1.mov",imgs,2]]]

doThreeEllsPinP1vert=False;
If[doThreeEllsPinP1vert,
Module[{a=1.5,loci,lociPts,pts,pts0,lociCircs,circ,gr,imgs},
lociPts=Table[Drop[getOuterPtsPinP1[a,tDeg2+.001,"freezeUp"->True],2],{tDeg2,0,360,1}];
loci=ListLinePlot[Transpose@lociPts,PlotStyle->{(*Darker@Green,Blue,*)Red,{Dashed,Blue},{Dashed,Red},{Dashed,Darker@Green}}];
lociCircs=ListLinePlot[(getCircumcenter@@Rest[#])&/@lociPts,PlotStyle->Purple];
imgs=Table[
pts0=getOuterPtsPinP1[a,tDeg,"freezeUp"->True];
pts=Drop[pts0,3];
circ=getCircumcenter@@pts;
gr=Graphics@{PointSize@Large,Purple,Point@circ,Dashed,Circle[circ,magn[pts[[1]]-circ]],MapThread[{#1,Text[Style[#2,{Bold,16}],#3,{-1,-1}]}&,{{Blue,Red,Darker@Green,Purple,Red,Darker@Green,Blue,Red},
{"(Subscript[P, 3])","(Subscript[P, 1])'","(Subscript[P, 2])''","O","(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])'","(Subscript[P, 1])''"},
Join[pts,{circ,{0,0},pts0[[1]],pts0[[2]],pts0[[3]]}]}],
{FaceForm@{Opacity@.1,Yellow},EdgeForm@Gray,Polygon@pts}};
Show[{show3ellsPinP1[a,tDeg,"lgt"->.66,"freezeUp"->True],loci},Epilog->{List@@gr,List@@lociCircs},PlotRange->{{-3,4},{-1,8}},ImageSize->800],{tDeg,0,360.,.2}];
makeMovie["three ells pin P1 vert v1.mov",imgs,2]
]];

doThreeEllsPinP1circ=False;
If[doThreeEllsPinP1circ,Module[{loci,imgs,a=1.5},
loci=ListLinePlot[Transpose@Table[getOuterPtsPinP1[a,tDeg2+.001,"n1vert"->False],{tDeg2,0,360,1}],
PlotStyle->{Darker@Green,Blue,Red,{Dashed,Blue},{Dashed,Red},{Dashed,Darker@Green}}];
imgs=Table[
Show[{show3ellsPinP1[a,tDeg+.001,"minX"->-8,"maxX"->8,"minY"->-8,"maxY"->8,"lgt"->.66,"n1vert"->False],loci},ImageSize->800],{tDeg,0,360.,.2}];
makeMovie["three ells pin P1 circ v3.mov",imgs,2]
]];

doThreeEllsPinP1=False;
If[doThreeEllsPinP1,Module[{loci,imgs,a=1.5},
loci=ListLinePlot[Transpose@Table[getOuterPtsPinP1[a,tDeg2+.001],{tDeg2,0,360,1}],
PlotStyle->{Darker@Green,Blue,Red,{Dashed,Blue},{Dashed,Red},{Dashed,Darker@Green}}];
imgs=Table[
Show[{show3ellsPinP1[a,tDeg+.001,"minX"->-6,"maxX"->2,"minY"->-1,"maxY"->7,"lgt"->.66],loci},ImageSize->800],{tDeg,0,360.,.2}];
makeMovie["three ells pin P1 v1.mov",imgs,2]
]];

doThreeElls=False;
If[doThreeElls,Module[{loci,imgs,a=1.5},
loci=ListLinePlot[Transpose@Table[getOuterPts[a,tDeg2+.001],{tDeg2,0,360,1}],PlotStyle->{Red,Darker@Green}];
imgs=Table[
Show[{show3ells[a,tDeg,"max"->.8,"lgt"->.66],loci}],{tDeg,0,360,.25}];
makeMovie["three ells v1.mov",imgs,2]
]];

x88row[as_,tDeg_]:=Show[x88motion[#,tDeg],PlotRange->{{-2.5,2.5},{-1.25,1.25}},ImageSize->400]&/@as;

doX88Motion=False;
If[doX88Motion,Module[{imgs,as={1.25,1.3954,1.485,2}},
imgs=Table[
Grid[Partition[x88row[as,tDeg+.0001],2],Spacings->{0,2},Alignment->Center],{tDeg,0.,360.,.25}];
makeMovie["x88 v3.mov",imgs,3]
]];

If[doX88Motion,Module[{imgs,as={1.25,1.3954,1.485,2}},
imgs=Table[
Grid[Partition[x88row[as,tDeg+.0001],2],Spacings->{0,2},Alignment->Center],{tDeg,0.,360.,.25}];
makeMovie["x88 v4.mov",imgs,3]
]];

doImgsPoncPencil=False;
If[doImgsPoncPencil,Module[{imgs,a=2.},
imgs=Table[drawPonceletPencil[a,b0,4.π*b0+10^-6,
drLoci->True,
drLabels->True,
degStep->.25,
degMax->150.],{b0,0.05,.95,.00025}];
makeMovie["ponc pencil v3.mov",Join[imgs,Reverse@imgs],1]]];

doImgsPoncCirc=False;
If[doImgsPoncCirc,Module[{imgs},
imgs=Table[drOnePoncCirc[3.,tDeg+10^-5],{tDeg,0,360,.5}];
makeMovie["ponc circ v3.mov",Join[imgs,Reverse@imgs],2]]];

doImgsMiquel=False;
If[doImgsMiquel,Module[{cachedObjs,a=1.5,imgsExt,imgsExc,imgs,cachedObjsExc,degStep=.25},
cachedObjs=<|
"ell"->plotEll[a,{Black,Thick}],
"caustic"->(plotEllb[Sequence@@getTriCausticParams[a],{Thick,"feu"/.ptClrs}]),
"locusCtrs"->Quiet@ParametricPlot[getMiquelPoint[a,t]["cs"][[1]],{t,0,2π},PlotStyle->{Darker@Cyan,Dashed,Thick}],
(*"ortlocus"->orthocenterLocus[a,π/1.2],*)
"locus"->Quiet@ParametricPlot[getMiquelPoint[a,t]["miquel"],{t,0,π/1.2},PlotStyle->{Red,Dashed,Thick}]|>;
imgsExt=Table[Show[miquelOfExtouchPoints[a,toRad@tDeg,cachedObjs],ImageSize->800],{tDeg,0,359,degStep}];
cachedObjsExc=<|
"ell"->plotEll[a,{Black,Thick}],
"locusCtrs"->Quiet@ParametricPlot[getMiquelPointExc[a,t]["cs"][[1]],{t,0,2π},PlotStyle->{Darker@Cyan,Dashed,Thick}],
(*"ortlocus"->orthocenterLocus[a,π/1.2],*)
"locus"->Quiet@ParametricPlot[getMiquelPointExc[a,t]["miquel"],{t,0,π/1.2},PlotStyle->{Red,Dashed,Thick}]|>;
imgsExc=Table[Show[miquelOfExcentral[a,toRad@tDeg,cachedObjsExc],ImageSize->800],{tDeg,0,359,degStep}];
imgs=MapThread[Grid[{{#1,#2}}]&,{imgsExt,imgsExc}];
makeMovie["miquel point on extouchpoints and excentral v1.mov",Join[imgs,Reverse@imgs],2]]]

doImgsArmUV=False;
If[doImgsArmUV,Module[{imgs},
imgs=tableExcUVlocus[1.5,tDegStep->.5,imgSz->400];
makeMovie["uv arm v1.mov",Join[imgs,Reverse@imgs],2]]];

doImgsInterE1E9=False;
If[doImgsInterE1E9,Module[{imgs15,imgs20,degStep=.25,imgs},
imgs15=getOneE1E2Imgs[1.5,2.5,1.1,degStep];
imgs20=getOneE1E2Imgs[2.0,2.5,1.1,degStep];
imgs=MapThread[Grid[{{#1},{#2}}]&,{imgs15,imgs20}];
makeMovie["intersection locus E1 and E9.mov",Join[imgs,Reverse@imgs],2]]]

doImgsInterE1E2=True;
If[doImgsInterE1E2,Module[{degStep=.25,imgs},
imgs=Table[Show[getOneE1E2Img[1.5,3,3,tDeg],Axes->None,Frame->None,PlotLabel->None,PlotRange->{{-3,3},{-1.25,1.25}}],{tDeg,0,360,degStep}];
makeMovie["e1e2 v1.mov",Join[imgs,Reverse@imgs],2]]]

doImgsOuterNapoleonAllLoci=False;
If[doImgsOuterNapoleonAllLoci,
Module[{a=1.5,ell,ons,gr,napPts,imgs},
ell=plotEll[a,{Black,Thick}];
napPts=Table[getOuterNapoleonSummits[a,toRad@tDeg0],{tDeg0,0,359,.5}];
imgs=Table[Show[makeOneNapoleonFrame[a,ell,napPts,tDeg],ImageSize->800],{tDeg,0,359,.5}];
makeMovie["napoleon loci v2.mov",Join[imgs,Reverse@imgs],3]]]

Sequence@@(Rule[#,True]&/@opts4Exps["antiorthic"])

opts4Exps["basic loci"]

Module[{fr1},
fr1=movieFrameOpts[1.5,toRad[30+.001],
mainVizCache["ellPlot"],
mainVizCache["causticPlot"],
mainVizCache["lociNonEll"],
mainVizCache["excenterLims"],
"ell",
Sequence@@(Rule[#,True]&/@opts4Exps["nonell"]),"loci"->True,"orbit"->True,ImageSize->800];
fr1]

doBasicFeuerSweeps=False;
If[doBasicFeuerSweeps,makeExperimentMovie[1.5,"excHalf","feuerall","feuer loci v1.mov"]];

doLociNonEll=False;
If[doLociNonEll,makeExperimentMovieLoci[1.5,"ell","nonell","lociNonEll","non-elliptic loci v1.mov"]];

doBasicEllLoci=False;
If[doBasicEllLoci,makeExperimentMovie[1.5,"ort","basic loci","basic loci v3.mov"]];

doSteinerCircumEll=False;
If[doSteinerCircumEll,makeExperimentMovie[1.5,"anticompl2","steinercircumell","steiner circumellipse and inellipse v1.mov"]];

doSteinerIncircumEll=False;
If[doSteinerIncircumEll,makeExperimentMovie[1.5,"anticompl2","inccircumell","incenter-centered circumellipse v2.mov"]];

doIsogIsotAxes=False;
If[doIsogIsotAxes,makeExperimentMovie[1.5,"antiorthic8","antiorthic","isogonal and isotomic axes v3.mov"]];

doImgsReflExcCircle=False;
If[doImgsReflExcCircle,Module[{loci,degStep=.25,sz=800,a=1.5,imgs},
imgs=Table[Show[drawAntiTangent[a,tDeg,"drCircle"->True,"drExcRefl"->True],ImageSize->sz],
{tDeg,0,360,degStep}];
makeMovie["antiexccircle v1.mov",Join[imgs,Reverse@imgs],2]]];

doImgsAntiTangentsCircle=False;
If[doImgsAntiTangentsCircle,Module[{loci,degStep=.5,sz=800,a=1.5,imgs1,imgs2,imgs},
imgs1=Table[Show[
drawAntiTangent[a,tDeg,"drCircle"->True,"drAllTangs"->False,"drOrbitRefl"->False],ImageSize->sz],{tDeg,0,360,degStep}];
imgs2=Table[Show[
drawAntiTangent[a,tDeg,"drCircle"->True,"drAllTangs"->True,"drOrbitRefl"->True],ImageSize->sz],{tDeg,0,360,degStep}];
imgs=Join[imgs1,imgs2];
makeMovie["antitangs v1.mov",Join[imgs,Reverse@imgs],2]]]

Cosine Circle

doImgsCosineCircle=False;
If[doImgsCosineCircle,Module[{loci,degStep=.25,sz=800,a=1.5,imgs},
imgs=Table[Show[drawCosineCircle[a,tDeg,"drHex"->True],ImageSize->sz],{tDeg,0,360,degStep}];
makeMovie["cosineCircle v3.mov",Join[imgs,Reverse@imgs],2]]]

HypX100 + ExcCircumb

doMovieFrames[1.5,"exccircumb",Function[x,{}],"antiorthic2",ellOpacity->.05,step->toRad@45]

doImgsExcCircumb=False;
If[doImgsExcCircumb,Module[{loci,degStep=.25,sz=800,a=1.5,imgs},
imgs=doMovieFrames[a,"exccircumb",Function[a,{}],"antiorthic2",ellOpacity->.05,step->toRad@degStep,ImageSize->sz];
makeMovie["exccircumb v1.mov",Join[imgs,Reverse@imgs],2]]]

Hyp Feu + X100

doImgsHyps=False;
If[doImgsHyps,Module[{loci,degStep=.25,sz=800,a=1.5,imgs},
loci=Graphics[{FaceForm@None,Thick,
{"bev"/.ptClrs,Line@loci15t[[40]]},
{"ort"/.ptClrs,Line@loci15t[[4]]}}];
imgs=doMovieFrames[a,"hypfeux100",Function[a,loci],"antiorthic2",ellOpacity->.05,step->toRad@degStep,ImageSize->sz];
makeMovie["hypfeux100 v1.mov",Join[imgs,Reverse@imgs],2]]]

X100 Hyperbola

doImgsX100Hyp=False;
If[doImgsX100Hyp,
Module[{imgs},
imgs=Table[showOneHyp5[1.25,tDeg+RandomReal[{-.001,.001}]],{tDeg,0,360,.25}];
makeMovie["x100hyp v1.mov",Join[imgs,Reverse@imgs],2]]];

Ronaldo Hi-Quality Demo

doMovieFrames[1.5,"mitten",excenterLocus[#,2π,{Dashed,"exc"/.ptClrs}]&,"excHalf",labExtra->"xxx: ",step->toRad@120,ImageSize->300][[1]]

doMovieFrames[1.5,"anticomplSimple",getAntiComplementaryVertexLocus,"anticompl2",step->toRad@120,ImageSize->600][[2]];

(*imgACTtop=doMovieFrames[1.5,"feuerall",excenterLocus[#,2π,{Dashed,"exc"/.ptClrs}]&,"anticompl",step->toRad@120,ImageSize->600][[2]];
imgACTbot=doMovieFrames[1.5,"anticomplSimple",getAntiComplementaryVertexLocus,"anticompl2",step->toRad@120,ImageSize->600][[2]];*)

doImgsIncCircum=False;
If[doImgsIncCircum,
Module[{imgs,degStep=1,sz=800},
imgs=doMovieFrames[1.5,"inccircum",Function[a,{}],"ort",step->toRad@degStep,ImageSize->sz];
makeMovie["inccircum.mov",Join[imgs,Reverse@imgs],2]]]

doImgsAntiorthicAxis=False;
If[doImgsAntiorthicAxis,Module[{imgs,degStep=.5,sz=1200},
imgs=doMovieFrames[1.5,"x88",Function[a,{}],"antiorthic",step->toRad@degStep,ImageSize->sz];
makeMovie["antiorthicaxis.mov",Join[imgs,Reverse@imgs],2]]]

doImgsAnticomplAndMedialPt=False;
If[doImgsAnticomplAndMedialPt,Module[{imgsACT,imgsMED,imgs,degStep=.5,sz=800},
imgsACT=doMovieFrames[1.5,"anticomplSimple",getAntiComplementaryVertexLocus,"anticompl2",step->toRad@degStep,ImageSize->sz];
imgsMED=doMovieFrames[1.5,"medialSimple",medialLocus[#,2π,{Dashed,"med"/.ptClrs}]&,"ell",step->toRad@degStep,ImageSize->sz];
imgs=MapThread[Grid[{{#1},{#2}},Alignment->Center]&,{imgsACT,imgsMED}];
makeMovie["anticompl and gergonne v1.mov",Join[imgs,Reverse@imgs],2]]];

doImgsGergonnePt=False;
If[doImgsGergonnePt,Module[{imgs},
imgs=doMovieFrames[1.5,"anticomplGergonne",Function[a,{}],"anticompl2",step->toRad@.5,ImageSize->1200];
makeMovie["gergonne v2.mov",Join[imgs,Reverse@imgs],2]]];

doImgsDarbouxPt=False;
If[doImgsDarbouxPt,Module[{imgs},
imgs=doMovieFrames[1.5,"darboux",Function[a,{}],"anticompl2",step->toRad@.5,ImageSize->1200];
makeMovie["darboux point v1.mov",Join[imgs,Reverse@imgs],2]]];

doImgsDerivedTris=False;
If[doImgsDerivedTris,Module[{a=1.5,imgs},
imgs=Table[Show[showDerivedTris[a,tDeg],ImageSize->800],{tDeg,0,359,.5}];
makeMovie["derived tris v3.mov",Join[imgs,Reverse@imgs],2]]];

doImgsAnticomplBoth=False;
If[doImgsAnticomplBoth,Module[{imgsTop,imgsBot,imgs},
imgsTop=doMovieFrames[1.5,"feuerall",excenterLocus[#,2π,{Dashed,"exc"/.ptClrs}]&,
"anticompl",step->toRad@.25,ImageSize->800];
imgsBot=doMovieFrames[1.5,"anticomplSimple",getAntiComplementaryVertexLocus,
"anticompl",step->toRad@.25,ImageSize->800];
imgs=MapThread[Grid[{{#1},{#2}}]&,{imgsTop,imgsBot}];
makeMovie["anticompl triangle v3.mov",Join[imgs,Reverse@imgs],3]]];

doImgsAnticomplSimple=False;
If[doImgsAnticomplSimple,Module[{imgs},
imgs=doMovieFrames[1.5,"anticomplSimple",getAntiComplementaryVertexLocus,"anticompl2",step->toRad@1,ImageSize->800];
makeMovie["anticompl triangle circII.mov",Join[imgs,Reverse@imgs],2]]];

(* combo - "ell" *)
doImgsDemo=False;
If[doImgsDemo,Module[{imgs,fr,a=1.5,step0=toRad@.25},
imgs=Join@MapThread[(fr=doMovieFrames[a,#1,#2,"ell",step->step0,labExtra->#3,ImageSize->800];Join[Most@fr,Reverse@fr])&,
{{"feuerall"},
{getDashedFeuLoci},
{"Feuerbach+Extouch+Anti-Complement\n"}}];
makeMovie["ronaldo combo.mov",imgs,1]]];

(* mitten tall - "exc" *)
doImgsDemo=False;
If[doImgsDemo,Module[{imgs,fr,a=1.5,step0=toRad@.25},
imgs=Join@MapThread[(fr=doMovieFrames[a,#1,#2,"excHalf",step->step0,labExtra->#3,ImageSize->800];Join[Most@fr,Reverse@fr])&,
{{"mitten"},
{Function[a,{}]},
{"Mittenpunkt is Stationary\n"}}];
makeMovie["ronaldo mitten.mov",imgs,1]]];

doImgsDemo=False;
If[doImgsDemo,Module[{imgs,fr,a=1.5,step0=toRad@.25},
imgs=Join@MapThread[(fr=doMovieFrames[a,#1,#2,"ort",step->step0,labExtra->#3,ImageSize->800];Join[Most@fr,Reverse@fr])&,
{{"antifeuer","caustic","feuerall"},
{Function[a,{}],getDashedFeuLoci,getDashedFeuLoci},
{"Anti-Complement of Feuerbach Point Sweeps Billiard\n",
"Feuerbach and ExtouchPoints Sweep Caustic\n",
"Feuerbach+Extouch+Anti-Complement\n"}}];
makeMovie["ronaldo combo feuer.mov",imgs,1]]];

Circumbilliard

doImgCircs=False;
If[doImgCircs,
Module[{imgs,ts},
ts=Table[{-2+4t/(2π),-2Cos[t]},{t,0,2π,toRad[1.]}];
imgs=drawSolCB[{{-1.5,2},{2,0},#}]&/@ts;
makeMovie["circumbilliard_hires3.mov",imgs]]];

Study Maxima Locus of Orthocenter and Orthic Triangle

Orthic Incenter

Valor critico de "a" para o ortocentro encostar no bilhar por cima e por baixo (orbita = triangulo retangulo, cos (a) = 1/Sqrt[2]

doOrtInc=False;If[doOrtInc,ortIncFrames=doMovieFrames[1.5,"orthicinc",
Show[{
orthocenterLocus[#,π/1.2]//Quiet,
orthicIncenterLocus[#,π/1.2,{"inc"/.ptClrs}]
}]&,"ortHalf",toRad@1.]//Quiet;doOrtInc=False];

Whats the "a" such that the orthocenter locus y maximum is a: approx. 1.4854

cosAlphaX0[a_]=FullSimplify[cosAlpha[a,0],a>0]

ortMaxA=Module[{theRay,eqn,ssol,interEll,eqn2},
theRay=ray[{0,1},{Sqrt[1-ca^2],-ca},s];
eqn=ellEqn[a,theRay[[1]],theRay[[2]]];
ssol=FullSimplify[(s/.Solve[eqn==0,s]),a>1&&ca≥0];
ssol=ssol[[2]];(* first is zero *)
(* eliminates s and ca *)
interEll=FullSimplify[(theRay/.s->ssol)/.ca->cosAlphaX0[a],a>1&&ca≥0];
Print@interEll;
Print["example: a=1.5, inter at: ",(interEll/.a->1.5)];
(* ERRO: tem q achar um a q gera o ortocentro correto at (0,a) *)
eqn2=FullSimplify[(a-interEll[[2]])/interEll[[1]]==(Sqrt[1-ca^2]/ca)/.ca->cosAlphaX0[a],a>1];
Solve[eqn2,{a}]];

ortMaxA=a/.N@{a->Root[-1-((#1)^2)-4 ((#1)^3)+((#1)^4)+((#1)^6)&,2]}

Since the ortho locus is elliptic, what is its x max at ortMaxA? It’s exactly 1!!!

Module[{orbit,n,s,ort},
{orbit,n,s}=orbitNormals[ortMaxA,0];
Chop[getOrthocenter@@orbit]]

Other Points : Mitten, Feuer, ExFeuer

Mittenpunkt Frames

doMitten=False;If[doMitten,mittenFrames=doMovieFrames[1.5,"mitten",precompLoci];doMitten=False];

Feuer and Extouch Frames (internal caustic)

doCaustic=False;If[doCaustic,causticFrames=doMovieFrames[1.5,"caustic",getFeuLoci];doCaustic=False];

Export["caustic30a.png",causticFrames[[31]]]

ExFeuerbach Locus

doExFeuer=False;If[doExFeuer,exFeuerFrames=doMovieFrames[1.5,"exfeuer",getFeuLoci[#,True]&,"ort"];doExFeuer=False];

exFeuerFrames[[31]]

Anti-Feuerbach Locus

doAntiFeuer=False;If[doAntiFeuer,antiFeuerFrames=doMovieFrames[1.5,"antifeuer",getDashedFeuLoci,"ell"];doExFeuer=False];

(*Save["mitten.m",mittenFrames]*)

antiFeuerFrames[[31]]

doMitten=False;If[doMitten,makeMovie["mitten15.mov",mittenFrames];doMitten=False];

doCaustic=False;If[doCaustic,makeMovie["caustic15a.mov",causticFrames];doCaustic=False];

doExFeuer=False;If[doExFeuer,makeMovie["exfeuer15.mov",exFeuerFrames];doExFeuer=False];

doAntiFeuer=False;If[doAntiFeuer,makeMovie["antifeuer15.mov",antiFeuerFrames];doExFeuer=False];

doImgsConvexBarInc=False;
If[doImgsConvexBarInc,Module[{imgs},
imgs=Table[combineConvexBarInc[1.5,s],{s,0,1,.01}];makeMovie["convexBarInc.mov",Join[imgs,Reverse@imgs]]]];

(*Export["convexBarInc01.png",imgsConvexBarInc[[1]]];
Export["convexBarInc02.png",imgsConvexBarInc[[51]]];
Export["convexBarInc03.png",imgsConvexBarInc[[101]]];*)

doImgsConvexOrtCir=False;
If[doImgsConvexOrtCir,Module[{imgs},
imgs=Table[combineConvexOrtCir[1.5,s],{s,0,1,.01}];
makeMovie["convexOrtCir.mov",Join[imgs,Reverse@imgs]]]];

doImgsConvexExcFoot=False;
If[doImgsConvexExcFoot,Module[{imgs},
imgs=Table[Show[convExcTps[1.5,s],ImageSize->800],{s,0,1,.01}];makeMovie["convexExcFoot.mov",Join[imgs,Reverse@imgs]]
]];

doImgsOrthicOrtIncFrames=False;

Clear@orthicOrtIncFrames

If[doImgsOrthicOrtIncFrames,
Module[{imgs},
imgs=Table[getOneOrthicOrtIncFrame[a],{a,1.1,3.5,0.01}];
makeMovie["orthicOrtIncFrames.mov",Join[imgs,Reverse@imgs]]]];

Directory[]

exportOrtOrtImgs=False;
If[exportOrtOrtImgs,
MapIndexed[Export["ortortinc-"<>ToString[First@#2]<>".png" ,getOneOrthicOrtIncFrame[#1]]&,
{1.01,1.25,1.5,2,2.25,2.5,3,3.5}]];

doImgsOrthicPreimages=False;
If[doImgsOrthicPreimages,
Module[{imgs,op},
op=Show[{ortPath[-1.5,1.5,1.2],Graphics[{Dotted,Blue,Line[{{-1.51,1.2},{1.51,1.2}}]}]}];
imgs=Table[Show[drawOrthic[x,1.2,op],ImageSize->800],{x,-1.351,1.351,.01}];
makeMovie["orthicPreimages.mov",Join[imgs,Reverse@imgs]]]];

Quadrangle

doImgsQuadrangle=False;
If[doImgsQuadrangle,
Module[{imgs,op},
imgs=Table[Show[showOneQuad[quadAlphaT,i,True,True],ImageSize->800],{i,Length["alphas"/.quadAlphaT]}];
makeMovie["quadrangle3.mov",imgs]]];

MakeMovies II

Generate Frames

Clear@oneImage;
oneImage[a_,t_,loci_,maxX_,maxY_]:=Show[drawSimT[a,t,loci],
PlotRange->{{-maxX,maxX},{-maxY,maxY}},
ImageSize->600];

Clear@imgsFixedA;
imgsFixedA[a_,clipExcenters_:False]:=Module[{loci,maxX,maxY,lims},
loci=precompLoci[a];
lims=excenterMax[a];
maxX=Round[lims[[1]]+.1,.1];
maxY=If[clipExcenters,Round[orthocenterMaxY[a,π/1.2]+.1,.1],
Round[lims[[2]]+.1,.1]];
Table[oneImage[a,t,loci,maxX,maxY],{t,0,2π,2π/360.}]];
Clear@imgsFixedT;
imgsFixedT[t_,aStart_,aEnd_,aStep_,clipExcenters_:False]:=Module[{loci,lims,maxX,maxY},
Table[
loci=precompLoci[a];
lims=excenterMax[a];
maxX=Round[lims[[1]]+.1,.1];
maxY=If[clipExcenters,Round[orthocenterMaxY[a,π/1.2]+.1,.1],
Round[lims[[2]]+.1,.1]];
oneImage[a,t,loci,maxX,maxY],
{a,aStart,aEnd,aStep}]];

Clear@makeAnimTransB;
makeAnimTransB[initB_,finalB_,stepB_]:=Module[{imgsInitB,imgsTransB,imgsFinalB},
imgsInitB=imgsFixedA[initB];
Print[Length[imgsInitB]];
imgsTransB=imgsFixedT[0,initB,finalB,stepB];
Print[Length[imgsTransB]];
imgsFinalB=imgsFixedA[finalB];Print[Length[imgsFinalB]];
Print["total frames = "<>ToString[Total[Length/@{imgsInitB,imgsTransB,imgsFinalB}]]];
{"initB"->imgsInitB,
"transB"->imgsTransB,
"finalB"->imgsFinalB
}
];

Generate Frames

doImgs=False;

If[doImgs,
(*imgs15=imgsFixedA[1.5];*)
imgs15clipped=imgsFixedA[1.5,True];
(*imgs20=imgsFixedA[2.0];*)
imgs20clipped=imgsFixedA[2.0,True];
]

Directory[]

Export Animated MOVs (install quicktime)

$PasswordFile

© 2019 Dan S. Reznik -- dan@upperwestsolucoes.com