Cover Code and Art

Basic Code for ρ1, trans, devil, etc.

<<BTP`;//Quiet

Remove[triangle];

try1=(Sqrt[2-(Sqrt[3])]) (+(1/2)+((I (Sqrt[3]))/2)) ;
try=(Sqrt[2-(Sqrt[3])]) (-(1/2)+((I (Sqrt[3]))/2)) ;

triangle=N@Join[top=Reverse[Table[{0,(Sqrt[2])}+{Cos[t],Sin[t]},{t,-(π/2)+(π/12),-(π/2)-(π/12),-(π/(6 10))}]],tt=Table[ReIm[t try],{t,0,1,.1}];Reverse[tt]/. {x_,y_}:>{-x,y},tt];
projMat={{1,(1/2)-((I (Sqrt[3]))/2)},{-I,((Sqrt[3])/2)-(I/2)}};

Clear[y0,r];
Solve[{( x^2 + ( y-y0)^2 ==r^2 ) /. {x-> -(1/2) (Sqrt[2-(Sqrt[3])]), y->(1/2)  (Sqrt[3 (2-(Sqrt[3]))])},
( x^2 + ( y-y0)^2 ==r^2 ) /. {x->0, y->  ((Sqrt[2])-1)}},{y0,r}]//FullSimplify

triangle=N@Join[top=Reverse[Table[{0,(Sqrt[2])}+{Cos[t],Sin[t]},{t,-(π/2)+(π/12),-(π/2)-(π/12),-(π/(6 10))}]],tt=Table[ReIm[t try],{t,0,1,.1}];Reverse[tt]/. {x_,y_}:>{-x,y},tt];
sol1=Solve[{a d - b c == 1,
 ((a z+ b)/(c z + d)/.z->try1)==Conjugate@try1,
 ((a z+ b)/(c z + d)/.z->0)==0 ,
((a z+ b)/(c z + d)/.z->try)==Conjugate[(Cos[-π/3]+I Sin[-π/3])try1]}, {a,b,c,d}]//FullSimplify;
sol2=Solve[{a d - b c == 1,
 ((a z+ b)/(c z + d)/.z->try)== Conjugate[try],
 ((a z+ b)/(c z + d)/.z->0)==0,
((a z+ b)/(c z + d)/.z->try1)==Conjugate[(Cos[π/3]+I Sin[π/3])try]}, {a,b,c,d}]//FullSimplify//ToRadicals//FullSimplify;
sol3=Solve[{a d - b c == 1,
 ((a z+ b)/(c z + d)/.z->try)== Conjugate@try,
 ((a z+ b)/(c z + d)/.z->try1)==Conjugate@try1,
((a z+ b)/(c z + d)/.z->0)==-(Sqrt[2])/2 I}, {a,b,c,d}]//FullSimplify//ToRadicals//FullSimplify;


τ1={{a,b}, {c,d}}/. sol1[[1]];
τ2={{a,b}, {c,d}}/. sol2[[1]];
τ3={{a,b}, {c,d}}/. sol3[[1]];
ρ1[z_] :=Conjugate[ToC@ LFT[τ1][z]]
ρ2[z_] :=Conjugate[ToC@ LFT[τ2][z]]
ρ3[z_] := Conjugate[ ToC@LFT[τ3][z]]

(*Clear[z];sol=FindInstance[{a d - b c == 1.,
 ((a z+ b)/(c z + d)/.z->try1HP)==N@originHP}, {a,b,c,d}, Reals] *)

Clear[z,a,b,c,d];
sol=FindInstance[{a d - b c == 1,
 ((2 a c)/((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2)))+(((Sqrt[2]) a c)/((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2)))+((b c)/((Sqrt[2]) ((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2))))+((a d)/((Sqrt[2]) ((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2))))+((b d)/((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2)))==-1/2,

(-(((Sqrt[(1/2) (3+2 (Sqrt[2]))]) b c)/((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2)))+(((Sqrt[(1/2) (3+2 (Sqrt[2]))]) a d)/((1/2) (3+2 (Sqrt[2])) (c^2)+((((c/(Sqrt[2]))+d))^2))))==Sqrt[3]/2 
}, {a,b,c,d}, Reals]//N

trans={{a,b}, {c,d}}/. sol[[1]]

transform[{x_,y_}]:=(z=x+I y; MM= projMat.trans.Inverse[projMat]; (MM[[1,1]]z+MM[[1,2]])/(MM[[2,1]]z + MM[[2,2]]))

devilmotif=N[{0,.7+5 I,2+5 I,2+7 I,10+10 I,12+13 I,5+12 I,6+20 I,5+27 I,12+28 I,30+28 I,27+37 I,27+42 I,30+48 I,30+50 I,((140 Exp[((π I)/3)])/(Sqrt[3])),30+65 I,20+62 I,15+60 I,10+55 I,5+55 I,4.5+61 I,7+64 I,8+71 I,5+77 I,4+77 I,4.5+71 I,3+64 I,62 I}];
back=-Conjugate[devilmotif];
a=.5176380902;
devil=N[(1/140) a (Sqrt[3]) Join[devilmotif,Reverse[back]]];
angel=ToC/@ {{-0.25881904510000003`,0.4482877360796609`},{-0.18124446201864414`,0.3264864347355931`},{-0.17015221722864404`,0.32008232422016936`},{-0.14648164863177968`,0.2842316254888982`},{-0.11875103665677966`,0.2682213492003388`},{-0.059229769328644065`,0.2560412190659321`},{-0.11686676396745758`,0.15621101595593212`},{-0.13373502837644072`,0.11418610393322029`},{-0.09171011635372878`,0.09731783952423723`},{-0.050543192451440684`,0.06615527506754233`},{-0.033674928042457655`,0.1081801870902542`},{-0.023440671372881552`,0.0874817765271187`},{-0.03241874624957621`,0.033506631593983004`},{-0.021326501459576354`,0.027102521078559347`},{-0.02548917329460164`,0.01989256196505928`},{0.`,0.`},{0.`,0.`},{0.025489173294601673`,0.019892561965059306`},{0.021326501459576378`,0.02710252107855924`},{0.03241874624957627`,0.03350663159398303`},{0.02344067137288143`,0.08748177652711854`},{0.03367492804245783`,0.10818018709025409`},{0.050543192451440636`,0.06615527506754237`},{0.0917101163537287`,0.09731783952423723`},{0.1337350283764406`,0.11418610393322026`},{0.11686676396745749`,0.15621101595593206`},{0.05922976932864413`,0.256041219065932`},{0.1187510366567796`,0.2682213492003388`},{0.14648164863177981`,0.2842316254888981`},{0.17015221722864446`,0.3200823242201693`},{0.18124446201864391`,0.326486434735593`},{0.2588190451000002`,0.4482877360796609`},{0.18602029764963754`,0.4479680965961519`},{0.12186503465862634`,0.44642825323662005`},{0.0897722395860656`,0.45168136878735`},{0.05657747886059822`,0.4759946749425272`},{0.028365822509241807`,0.4734381523818907`},{0.027485155219778186`,0.43800780470605755`},{0.04435288820848309`,0.42052488002298183`},{0.05548847677314055`,0.3749904276566787`},{0.03769584722821682`,0.32986207603417095`},{0.030169787613313348`,0.32939068244927766`},{0.031273042465381914`,0.37296692722066294`},{0.01903928313604011`,0.41890941153713823`},{4.80740671595891`*^-17,0.43108281811568483`},{4.80740671595891`*^-17,0.43108281811568483`},{-0.019039283136040353`,0.4189094115371382`},{-0.0312730424653817`,0.37296692722066294`},{-0.030169787613313393`,0.3293906824492778`},{-0.037695847228216915`,0.329862076034171`},{-0.05548847677314068`,0.3749904276566788`},{-0.04435288820848271`,0.42052488002298183`},{-0.027485155219778117`,0.43800780470605727`},{-0.028365822509242314`,0.4734381523818906`},{-0.05657747886059843`,0.47599467494252706`},{-0.0897722395860654`,0.45168136878734977`},{-0.12186503465862651`,0.44642825323662005`},{-0.1860202976496378`,0.4479680965961519`},{-0.2588190450981547`,0.44828773608654715`}};

Fig 4.10 (Angels and Devils; several minutes (in 2016)) NEEDS BASIC ABOVE

(*  Needs["BTP`"];//Quiet  *)   (* in BASIC *)

Clear[s,t,u];
rels={{a___, t, t,  b___}:> {a,b},{a___, s, s, b___}:> {a,b},{a___, u, u, b___}:> {a,b},
{a___, s,t, s,t,s,t, b___}:> {a,b},{a___, t,s,t, s,t,s, b___}:> {a,b},
{a___, t,u, t,u,t,u,t,u, b___}:> {a,b},{a___, u, t,u,t,u,t,u, t,b___}:> {a,b},
{a___, u,s,u,s,u,s,u,s,b___}:> {a,b},{a___, s,u,s,u,s,u,s,u,b___}:> {a,b}};

ww=DeleteDuplicates[Flatten[Table[Tuples[{s,t,u},i]//. rels, {i,0,10}],1]];
wwFunc=Composition@@@(Flatten/@ (ww /. Thread[{s,t,u}->{ρ1,ρ2,ρ3}]));
Length[ww]

Here we define two words x, y as being the same if (xy^(-1)) reduces to e. NO. That does not work! Instead we define them to be the same if they agree as LFTs on 3 points! The Chop is necessary.

same[w_,v_] :=(func1=Composition@@w/.Thread[{s,t,u}->{ρ1 ,ρ2 ,ρ3}];
func2=Composition@@v/.Thread[{s,t,u}->{ρ1 ,ρ2 ,ρ3}];
And @@ (tt=Table[Chop[func1[z]]==Chop[func2[z]], {z,N@{0, 1,I}}]))
same[{u,t,s,t}, {u,s,t,s}]

And then we define a canonical word by finding the shortest representative in the reduced set. Because ww is already sorted by length, we just take first that works.

canonical[w_] := SortBy[Select[ww, same[#,w]&], Length][[1]]

canonical[w_] := Select[ww, same[#,w]&,1][[1]]
canonical[{s,u,u}]

We are interested in what will ultimately be a fund domain. Here are the two types of bad words when forming the tree in the domain. These are on the left and right borders and they come as initial segs. of an infinite word.

Here are canonical words in the section of interest. This is a little tricky. We extend a word only in ways that lead to no reductions. And we check for the presence in the boundary...  if so, we extend in a certain periodic way.

Clear[sectorWords];
bad=Rest[FoldList[Join, {},Flatten[Table[{{u,t,u},{s,t},{u,s,u}, {t,s}}, {2}],1]]];
bad1=Prepend[Prepend[#,u]&/@Rest[FoldList[Join, {},Flatten[Table[{{t,s},{u,t,u},{s,t}, {u,s,u}}, {2}],1]]],{u}];
sectorWords[1] ={ {u}};
sectorWords[n_] := sectorWords[n]=Flatten[Table[
Which[pos=Position[bad,w]; pos≠{},pos=pos[[1,1]]; 
          {Append[w,Which[pos==1,s,EvenQ[pos],u,True,t]]},
pos=Position[bad1,w]; pos≠{},pos=pos[[1,1]];
           {Append[w,Which[pos==1, t,EvenQ[pos],u,True,s]]},
Position[Join[bad,bad1], canonical[w]]=={},
Select[( Append[w,#] & /@ {s,t,u}), Length[#]==Length[#/. rels]&],
True, {}],  {w, sectorWords[n-1]}],1]

sectorWords[9]={{u,t,s,u,s,t,s,t,s},{u,t,s,u,s,t,s,t,u},{u,t,s,u,s,t,s,u,s},{u,t,s,u,s,t,s,u,t},{u,t,s,u,s,t,u,s,t},{u,t,s,u,s,t,u,s,u},{u,t,s,u,s,t,u,t,s},{u,t,s,u,s,t,u,t,u},{u,t,s,u,s,u,s,t,s},{u,t,s,u,s,u,s,t,u},{u,t,s,u,s,u,s,u,s},{u,t,s,u,s,u,s,u,t},{u,t,s,u,s,u,t,s,t},{u,t,s,u,s,u,t,s,u},{u,t,s,u,s,u,t,u,s},{u,t,s,u,s,u,t,u,t},{u,t,s,u,t,s,t,s,t},{u,t,s,u,t,s,t,s,u},{u,t,s,u,t,s,t,u,s},{u,t,s,u,t,s,t,u,t},{u,t,s,u,t,s,u,s,t},{u,t,s,u,t,s,u,s,u},{u,t,s,u,t,s,u,t,s},{u,t,s,u,t,s,u,t,u},{u,t,s,u,t,u,s,t,u},{u,t,s,u,t,u,s,u,s},{u,t,s,u,t,u,s,u,t},{u,t,u,s,t,u,s,t,s},{u,t,u,s,t,u,s,t,u},{u,t,u,s,t,u,s,u,t},{u,t,u,s,t,u,t,s,t},{u,t,u,s,t,u,t,s,u},{u,t,u,s,t,u,t,u,s},{u,t,u,s,t,u,t,u,t},{u,t,u,s,u,s,t,s,t},{u,t,u,s,u,s,t,s,u},{u,t,u,s,u,s,t,u,s},{u,t,u,s,u,s,t,u,t},{u,t,u,s,u,s,u,s,t},{u,t,u,s,u,s,u,s,u},{u,t,u,s,u,s,u,t,s},{u,t,u,s,u,s,u,t,u},{u,t,u,s,u,t,s,t,s},{u,t,u,s,u,t,s,t,u},{u,t,u,s,u,t,s,u,s},{u,t,u,s,u,t,s,u,t},{u,t,u,s,u,t,u,s,t},{u,t,u,s,u,t,u,s,u},{u,t,u,s,u,t,u,t,s},{u,t,u,s,u,t,u,t,u}};
sectorWords[8]={{u,t,s,u,s,t,s,t},{u,t,s,u,s,t,s,u},{u,t,s,u,s,t,u,s},{u,t,s,u,s,t,u,t},{u,t,s,u,s,u,s,t},{u,t,s,u,s,u,s,u},{u,t,s,u,s,u,t,s},{u,t,s,u,s,u,t,u},{u,t,s,u,t,s,t,s},{u,t,s,u,t,s,t,u},{u,t,s,u,t,s,u,s},{u,t,s,u,t,s,u,t},{u,t,s,u,t,u,s,t},{u,t,s,u,t,u,s,u},{u,t,u,s,t,u,s,t},{u,t,u,s,t,u,s,u},{u,t,u,s,t,u,t,s},{u,t,u,s,t,u,t,u},{u,t,u,s,u,s,t,s},{u,t,u,s,u,s,t,u},{u,t,u,s,u,s,u,s},{u,t,u,s,u,s,u,t},{u,t,u,s,u,t,s,t},{u,t,u,s,u,t,s,u},{u,t,u,s,u,t,u,s},{u,t,u,s,u,t,u,t}};
sectorWords[10]={{u,t,s,u,s,t,s,t,s,u},{u,t,s,u,s,t,s,t,u,s},{u,t,s,u,s,t,s,t,u,t},{u,t,s,u,s,t,s,u,s,t},{u,t,s,u,s,t,s,u,s,u},{u,t,s,u,s,t,s,u,t,s},{u,t,s,u,s,t,s,u,t,u},{u,t,s,u,s,t,u,s,t,s},{u,t,s,u,s,t,u,s,t,u},{u,t,s,u,s,t,u,s,u,s},{u,t,s,u,s,t,u,s,u,t},{u,t,s,u,s,t,u,t,s,t},{u,t,s,u,s,t,u,t,s,u},{u,t,s,u,s,t,u,t,u,s},{u,t,s,u,s,t,u,t,u,t},{u,t,s,u,s,u,s,t,s,t},{u,t,s,u,s,u,s,t,s,u},{u,t,s,u,s,u,s,t,u,s},{u,t,s,u,s,u,s,t,u,t},{u,t,s,u,s,u,t,s,t,s},{u,t,s,u,s,u,t,s,t,u},{u,t,s,u,s,u,t,s,u,s},{u,t,s,u,s,u,t,s,u,t},{u,t,s,u,s,u,t,u,s,t},{u,t,s,u,s,u,t,u,s,u},{u,t,s,u,s,u,t,u,t,s},{u,t,s,u,s,u,t,u,t,u},{u,t,s,u,t,s,t,s,t,u},{u,t,s,u,t,s,t,s,u,s},{u,t,s,u,t,s,t,s,u,t},{u,t,s,u,t,s,t,u,s,t},{u,t,s,u,t,s,t,u,s,u},{u,t,s,u,t,s,t,u,t,s},{u,t,s,u,t,s,t,u,t,u},{u,t,s,u,t,s,u,s,t,s},{u,t,s,u,t,s,u,s,t,u},{u,t,s,u,t,s,u,s,u,s},{u,t,s,u,t,s,u,s,u,t},{u,t,s,u,t,s,u,t,s,t},{u,t,s,u,t,s,u,t,s,u},{u,t,s,u,t,s,u,t,u,s},{u,t,s,u,t,s,u,t,u,t},{u,t,s,u,t,u,s,t,u,s},{u,t,s,u,t,u,s,t,u,t},{u,t,s,u,t,u,s,u,s,t},{u,t,s,u,t,u,s,u,s,u},{u,t,s,u,t,u,s,u,t,s},{u,t,s,u,t,u,s,u,t,u},{u,t,u,s,t,u,s,t,s,t},{u,t,u,s,t,u,s,t,s,u},{u,t,u,s,t,u,s,t,u,s},{u,t,u,s,t,u,s,t,u,t},{u,t,u,s,t,u,s,u,t,s},{u,t,u,s,t,u,s,u,t,u},{u,t,u,s,t,u,t,s,t,s},{u,t,u,s,t,u,t,s,t,u},{u,t,u,s,t,u,t,s,u,s},{u,t,u,s,t,u,t,s,u,t},{u,t,u,s,t,u,t,u,s,t},{u,t,u,s,t,u,t,u,s,u},{u,t,u,s,t,u,t,u,t,s},{u,t,u,s,t,u,t,u,t,u},{u,t,u,s,u,s,t,s,t,s},{u,t,u,s,u,s,t,s,t,u},{u,t,u,s,u,s,t,s,u,s},{u,t,u,s,u,s,t,s,u,t},{u,t,u,s,u,s,t,u,s,t},{u,t,u,s,u,s,t,u,s,u},{u,t,u,s,u,s,t,u,t,s},{u,t,u,s,u,s,t,u,t,u},{u,t,u,s,u,s,u,s,t,s},{u,t,u,s,u,s,u,s,t,u},{u,t,u,s,u,s,u,t,s,t},{u,t,u,s,u,s,u,t,s,u},{u,t,u,s,u,s,u,t,u,s},{u,t,u,s,u,s,u,t,u,t},{u,t,u,s,u,t,s,t,s,t},{u,t,u,s,u,t,s,t,s,u},{u,t,u,s,u,t,s,t,u,s},{u,t,u,s,u,t,s,t,u,t},{u,t,u,s,u,t,s,u,s,t},{u,t,u,s,u,t,s,u,s,u},{u,t,u,s,u,t,s,u,t,s},{u,t,u,s,u,t,s,u,t,u},{u,t,u,s,u,t,u,s,t,s},{u,t,u,s,u,t,u,s,t,u},{u,t,u,s,u,t,u,s,u,s},{u,t,u,s,u,t,u,s,u,t},{u,t,u,s,u,t,u,t,s,t},{u,t,u,s,u,t,u,t,s,u},{u,t,u,s,u,t,u,t,u,s},{u,t,u,s,u,t,u,t,u,t}};

num=15; (* the top in the fd iterators must be 1 less than sectorWords is defined *) 
rule23={{a___,s,b___}:> {a,ρ,σ, ρ,σ,b},{a___,t,b___}:> {a,σ, τ,b},{a___,t1,b___}:> {a,σ, τ,σ,τ,b}};
val[X_] :=0;

devils=Show[(*DeleteCases[im, Line[_], ∞] /. {red->ftLighter@Lighter@red,green->Lighter@Lighter@green, blue -> Lighter@Lighter@blue};*) 

 Graphics[{{EdgeForm[{AbsoluteThickness@.5,Black}], FaceForm[yellowbackground;Black],Disk[]},
Line[triangle];  {EdgeForm@{AbsoluteThickness@.5,Black},Circle[]},
red,EdgeForm[{AbsoluteThickness@.5,Black}],
fdMinus=Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[devil/.z_?NumericQ:> FF[z]]], {g,Flatten[ Table[sectorWords[i], {i,1,9,2}],1]}];
fdMinus1=Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[devil/.z_?NumericQ:> FF[z]]], {g,Prepend[Flatten[ Table[sectorWords[i], {i,2,8,2}],1], {}]}];

fdAngelMinus=Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[angel/.z_?NumericQ:> FF[z]]], {g,Flatten[ Table[sectorWords[i], {i,2,8,2}],1]}];
fdAngelMinus1=Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[angel/.z_?NumericQ:> FF[z]]], {g,Flatten[ Table[sectorWords[i], {i,1,9,2}],1]}];

fd=Join[fdMinus, Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[devil/.z_?NumericQ:> FF[z]]], {g,Prepend[Flatten[ Table[Prepend[#,s]& /@ sectorWords[i], {i,2,8,2}],1],s]}]];
fd1=Join[fdMinus1, Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[devil/.z_?NumericQ:> FF[z]]], {g,Flatten[ Table[Prepend[#,s]& /@ sectorWords[i], {i,1,9,2}],1]}]];

fdAngel=Join[fdAngelMinus, Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[angel/.z_?NumericQ:> FF[z]]], {g,Prepend[Flatten[ Table[Prepend[#,s]& /@ sectorWords[i], {i,1,9,2}],1],{}]}]];fdAngel1=Join[fdAngelMinus1, Table[  FF=wwFunc[[Position[ww, g][[1,1]]]];Polygon[ReIm[angel/.z_?NumericQ:> FF[z]]], {g,Prepend[Flatten[ Table[Prepend[#,s]& /@ sectorWords[i], {i,2,8,2}],1],s]}]];

choiceA=
Composition@@@(Flatten/@ ((List@@@(AA=Prepend[Rest@Take[A,num], {}])//.rule23) /. Thread[{σ,τ,ρ}->{ρ1 ,ρ2 ,ρ3}]));
choiceA=choiceA[[xxx={1,2,3,4,5,6,7,8,9,11,12,13,14}]];
AA=AA[[xxx]];
Table[q=choiceA[[qind]];{red,If[mPrint[{qind, List@@AA[[qind]], val[List@@AA[[qind]]]}];val[List@@AA[[qind]]]==0,fd,fd1]/. {x_?NumericQ, y_} :> ReIm[q[x+y I]]},{qind,Length@choiceA}],
Table[q=choiceA[[qind]];{Lighter@Lighter@Lighter@Lighter@red,If[val[List@@AA[[qind]]]==0,fdAngel,fdAngel1]/. {x_?NumericQ, y_} :> ReIm[q[x+y I]]},{qind,Length@choiceA}],

choiceB=Composition@@@(Flatten/@ (((BB=(List@@@(Join[{{s}, {t}},Rest@Rest@Take[B,num]])))//.rule23) /. Thread[{σ,τ,ρ}->{ρ1 ,ρ2 ,ρ3}]));
choiceB=choiceB[[xxx={1,2,3,4,5,6,7,9,10,11,15}]];
BB=BB[[xxx]];

Table[q=choiceB[[qind]];{green,If[val[List@@BB[[qind]]]==0,fd,fd1]/. {x_?NumericQ, y_} :> ReIm@q[x+y I]},{qind,Length@choiceB}],

Table[q=choiceB[[qind]];{Lighter@Lighter@Lighter@green,If[val[List@@BB[[qind]]]==1,fdAngel1,fdAngel]/. {x_?NumericQ, y_} :> ReIm[q[x+y I]]},{qind,Length@choiceB}],


choiceC=Composition@@@(Flatten/@ (((CC=(List@@@(Join[{{t,s}, {t,t}},Rest@Rest@Take[C,num]])))//.rule23) /. Thread[{σ,τ,ρ}->{ρ1 ,ρ2 ,ρ3}]));
choiceC=choiceC[[xxx={1,2,3,4,5,6,7,8,9,10,15}]];
CC=CC[[xxx]];
Table[q=choiceC[[qind]];{blue,If[val[List@@CC[[qind]]]==0,fd,fd1]/. {x_?NumericQ, y_} :> ReIm@q[x+y I]},{qind,Length@choiceC}],
Table[q=choiceC[[qind]];{Lighter[Lighter[Lighter[blue]]],If[val[List@@CC[[qind]]]==1,fdAngel1,fdAngel]/. {x_?NumericQ, y_} :> ReIm[q[x+y I]]},{qind,Length@choiceC}]}]/. Polygon[z_] :> Polygon[z/. {x_?NumericQ, y_,14}:>project1[ToC[LFT[trans][ToC[project1Inv[x+I y]]]]]], Frame->!True, ImageSize->700];

cols=Cases[devils, RGBColor[___], ∞]//DeleteDuplicates;
cols//InputForm

newCols={newRed,lightRed,newGreen,lightGreen,newBlue,lightBlue}=CMYKColor@@@{{.37,.72,.58;.45,.34;.1},{.07,.31,.29;
.2,.01},{.62,.39,.71,.27},{.29,.17,.37,.04},{.69,.3,.03,0},{.41,.22,.07,.01}};

cover=Show[devils/. Thread[cols->newCols], Graphics[{AbsolutePointSize[7.5],Black, Point[{{0,0}, view2=(((Sqrt[3])-1)/(Sqrt[2])) {Cos[60 Degree], Sin[60 Degree]}}];
{EdgeForm[{AbsoluteThickness[0.8], Black}], FaceForm[White],Disk[#, .015]& /@ {{0,0}, view2=(((Sqrt[3])-1)/(Sqrt[2])) {Cos[60 Degree], Sin[60 Degree]}}}}], Frame->!True, ImageSize-> 7  72]

Red : .37, .72, .58, .34
Light Red : .07, .31, .29, .01
Green : .62, .39, .71, .27
Light Green : .29, .17, .37, .04
Blue : .69, .3, .03, 0
Light Blue : .41, .22, .07, .01
Could use yellow insteaD of green ?? ??  adjust the dark green?  add points  NO. THis is good. Maybe darken the dark blue.

About the Cover:

Escher, Fricke, Hausdorff, and Klein: A Paradoxical Connection

Curtis D. Bennett (curtis.bennett@csulb.edu) and Stan Wagon (wagon@macalester.edu)

Affiliations:  California State University, Long Beach, CA; Macalester College, St. Paul, MN

The cover image shows how ideas of Klein, Fricke, Hausdorff, and Escher can be used to partition the hyperbolic plane (ℍ^2) in a way that provides a concrete view of a paradoxical decomposition. The key to the famous Banach–Tarski paradox (1924; see [2]) is a decomposition found by Felix Hausdorff (1914) in the group G=(Subscript[ℤ, 2])*(Subscript[ℤ, 3]). This group consists of all words in σ and τ where (σ^2)=(τ^3)=identity; that is: G=⟨σ,τ|(σ^2)=(τ^3)=e⟩. The group, which is the free product of (Subscript[ℤ, 2]) and (Subscript[ℤ, 3]), arises prominently in a famous tiling of (ℍ^2), found by Klein and Fricke in 1890 (Figure ). Hausdorff saw how to partition G into A⋃B⋃C such that A∼B∼C and also Α∼B⋃C, where ∼ denotes congruence in the group (Figure ). Thus A can be viewed as being a third of G, and also half of G. He then found that the group could be represented as rotations of a sphere. The three sets can then, with the help of the Axiom of Choice, be lifted to the sphere, less D, a set of countably many exceptional points (D consists of the points on the axes of the rotations that lie on the sphere). That construction leads to three subsets of the sphere minus D that are paradoxical (each is a third, and also a half). Banach and Tarski worked out how to absorb D into the construction, allowing them to define pairwise disjoint subsets of the sphere that be rearranged to form two copies of the sphere: the Banach–Tarski Paradox.

Hausdorff’s three sets can be defined as follows, where, for α∈{σ,τ,(τ^2)}, (Subscript[W, α]) consists of the words starting with α. Set A=(Subscript[W, σ]), B=(Subscript[W, τ]), C=(Subscript[W, (τ^2)]). Then, ignoring e, we have the desired identities σ(A)=B⋃C, τA=B, and (τ^2)A=C. To include e, let β=(τ^2)σ, place e into A, and place the words β,τ β,(τ^2)β,(β^2),τ (β^2),(τ^2)(β^2),(β^3),τ (β^3),(τ^2)(β^3),(β^4),… in order, into A,B,C,A,B,C,A,B,C,A,…. This infinite sequence absorbs the identity and yields the desired congruences (Figure ). This is similar to how the fixed point set D was absorbed by Banach and Tarski to get their Euclidean paradox.

Code for table ABC in all black

Unprotect[C];
BTP`ToC[X_/; Depth[X]>2] := X /. {x_?NumericQ, y_}:> x + I y;
A0=(NonCommutativeMultiply@@@ Prepend[Table[Join@@ Table[{t,s}, {k}], {k,1,15}], {e}])/.   NonCommutativeMultiply[e]->e;
 B0=t **A0;
C0=t ** B0;
rule = {t->"τ", s->"σ", e->"e"};
{A,B,C} = {ASW,BSW,CSW} ;

Needs["BTP`"]
all=SortBy[Union[A,B,C], Length];
Hausdorff[word_]:=Position[{A,B,C},word,{2}][[1,1]]
Hausdorff /@ {e,s,t,s**t**s};

(* from file ArtForChaps1To5 *) 
Grid[Prepend[Transpose[Take[#,mx= 22]& /@ ({A, B, C}/. { s-> σ,t-> τ, e-> "e"})],{"A", "B", "C"}], Background-> RGBColor[1,1,.85], Dividers->{(q=AbsoluteThickness[1])&/@ Range[4],Join[{ q,q},Table[AbsoluteThickness[0],mx-1],{q}]}, BaseStyle->{FontFamily->Times, 11}, Spacings-> {{1}, {1,1.15}}]

Using preceding, this gives table with β

Anew = Select[all, #=!= e&&(#===s ||Length[#]≥1 && #[[1]]===s)&];
Bnew = Select[all, #=!= e&&(#===t ||Length[#]≥1 && #[[1]]===t && #[[2]]==s)&];
Cnew = Select[all, #=!= e&&(Length[#]≥2 && #[[1]]===t && #[[2]]==t)&];
{Length[all],Total[Length/@{Anew,Bnew,Cnew}]};
β=t**t**s;
z[r_]:= Style[r, Red];
zi[r_]:= Style[ToString@r,{ Red, FontSlant -> "Italic"}];
Grid[Prepend[qq=((ToString/@Take[#,mx= 22])& /@ ({Prepend[Anew, zi@"e"], Bnew, Cnew}/.  { s-> σ,t-> τ, e-> zi@"e"}));
Transpose[qq]/.{"ττσ"-> z@"τ τ β","ττσττσ"-> z@"τ τ (β^2)","ττσττσττσ"-> z@"τ τ (β^3)"}/.
{"σ"-> z@" β","σττσ"-> z@" (β^2)","σττσττσ"->z@ " (β^3)"}/.{ "τσ"-> z@"τ β","τσττσ"-> z@"τ (β^2)","τσττσττσ"-> z@"τ (β^3)"},

{"A", "B", "C"}]/. z_String:> StringReplace[z, "ττwwww"->"ρ"], Background-> RGBColor[1,1,.85], Dividers->{(q=AbsoluteThickness[1])&/@ Range[4],Join[{ q,q},Table[AbsoluteThickness[0],mx-1],{q}]}, BaseStyle->{FontFamily->Times, 11}, Spacings-> {{1}, {1,1.15}}]

The Klein–Fricke tiling arises by repeated reflection starting from the triangle labeled e in Figure , which uses the upper-half-plane model; each triangle has a vertex at ∞ and the corresponding group is the triangle group (Subscript[T, 3,3,∞]). Each tile can be labeled with an element of G, and Mycielski and Wagon (1984) had the idea of coloring the tiles according to which of A,B,C contains the label. The congruences in the group then become congruences in (ℍ^2), leading to a geometric visualization of the Hausdorff paradox [2, Figure 4.5]; for an animation see [3].

Needs["BTP`"];//Quiet

e=.;someWords=GroupForm[{s,sts,tt,ttstt,ststs,tts,st,stst,sts,t,ts,stt,stts,ttst;ttstt,ststs,ststts;ttsts;ststt;ttstts,ttsttsts;stststt;e}];

offset[_] := {0, 0};
offset[t ** t ** s ** t ** t] = offset[t ** t] = offset[s] = offset[s ** t ** s] = offset[s ** t ** s ** t ** s] = {0, 0.15};
offset[t ** t ** s] = offset[s ** t]   =  {0, 0.1};
offset[t ** t ** s ** t ** t ** s] =  {0, 0.21 };
 offset[s ** t ** s ** t]  =  {0, 0.15};
offset[t ** t ** s ** t] = offset[t] = offset[t ** s] = offset[s ** t ** t] =  offset[s ** t ** t ** s] = {0.0, 0.07};
offset[s ** t ** s ** t ** t] = {0.02, 0.08}; offset[t ** t ** s ** t ** s] = {0, 0.07};
offset[s ** t ** s ** t ** t ** s] = {0.025, 0.02};
 offset[t ** t ** s ** t ** t ** s ** t ** s] = {-.0, 0.02};
offset[s ** t ** s ** t ** s ** t ** t] = {.0, 0.02};
im=Graphics[{AbsoluteThickness[.5],Text[Style["e",{FontFamily -> "Times",12}], {0, 0.7}],
    	www={Line[poly = LFT[#][triangle[40]]],
  If[MemberQ[someWords, #],  Text[Style[StringReplace[ToString[#], {"s"->"σ","tt"->"(τ^2)", "t"-> "τ"}],{
If[MemberQ[ GroupForm[{ttstt, tt, s, sts, ststs, tts, st, stst}],#],11,8]}],
              	Centroid[DeleteCases[poly,{0, 100}]] + offset[#]], {}]} & /@  (Take[G, {2,120}])},
  		Frame -> {True,False, False, False}, 
FrameTicks -> {Range[-2, 2], {{1, I}}}, PlotRange -> {{-2.6, 2.61}, {0, 2.2}}, ImageSize ->  420];

fd=Graphics[{GrayLevel[0.9],RGBColor[.97, .63, .74],qq=Polygon[ReIm/@ triangle[50]]; 
Table[qq/. {x_, y_}:> {x-j,y}, {j,0,3}]}];
Fig51=Show[fd,DeleteCases[ im/.{ "(τ^2)σ"-> "β","(τ^2)σ(τ^2)σ"-> "(β^2)" }, Text[Style["(β^2)",___], ___],∞], Graphics[{ PointSize[.007],Point[{0,1}],Text[Style["i",10], {0,1.1}], 
Text[Style["(β^3)",11], {-2.73,.8}],
Text[Style["(β^2)",11], {-2.,.8}],
Text[Style["σ",12], {0,1.6}],
Text[Style["στσ",12], {1,1.6}],
Text[Style["στστσ",12], {2,1.6}],
Text[Style["(τ^2)",12], {-1,1.6}],
Text[Style["(τ^2)((στ)^2)",12], {-2,1.6}],
Text[Style["((στστ)^2)σ",8], {1.688,.55}, {0,0}, {.2, -.28}, Background->None],
 Text[Style["((στστστ)^2)",9], {2.3,.54}, {0,0}, {.2, .2}, Background->Red];
Text[Style["(τ^2)((στ)^2)στσ",9], {-2.27,.53}, {0,0}, {.2, -.25}];
Text[Style["(τ^2)στ",9], {-1.675,.525}, {0,0}, {.2, .25}],
Text[Style["((στστ)^2)",9], {1.31,.53}, {0,0}, {.2, .2}],
Text[Style["(τ^2)στσ",9], {-1.26,.51}, {0,0}, {.2, -.19}]}], PlotRange -> {{-2.83, 2.61}, {0, 2.2}}, PlotRangePadding->None,ImageSize->5.8 72,Frame -> {True,False, False, False}, BaseStyle->FontFamily->"Times",
FrameTicks -> {{{},{}},{Range[-2, 2],{}}}]/. Style[t___, {8}|8]:> Style[t, 9.01]/. Style[t_, 9]:> Style[t, 10.01]/. Style[t_, 10]:> Style[t, 11.1]/. Style[t_, {11}]:> Style[t, 11.8]/. Style[t_, 12]:> Style[t, 13.1];
Cases[Fig51, Style[y___,{x_?NumericQ}|x_?NumericQ,___]:> x,∞]//DeleteDuplicates;
Fig51

The question now arises whether a similar construction exists for one of the artistic tilings of (ℍ^2) used by M. C. Escher. Bennett, working with the group

H=⟨σ,τ,ρ|(σ^2)=(τ^2)=(ρ^2)=(((σ τ))^3)=(((τ ρ))^4)=(((ρ σ))^4)=e⟩,

succeeded in this idea [1]. This group is also known as the triangle group (Subscript[T, 3,4,4]). The tiling of (ℍ^2) corresponding to this group is shown in Figure , where the Poincaré disk model is used. As before, each triangle corresponds to an element of H and so a decomposition of H into three paradoxical sets leads to the same for (ℍ^2). But now the tiling matches Escher’s and so each tile can be viewed as either an angel or devil. The three sets arise by first taking the subgroup G' of H generated by (((τ ρ))^2) and σ τ. Then G' is isomorphic to the group G used by Hausdorff and the paradoxical subsets of G can be used to obtain a similar paradox in H.

The division into angels and devils is unimportant for the paradoxical coloring. In the images, angels are elements of H with odd length (i.e., in the free product they correspond to a  product of an odd number of generators), while the devils have even length. Unlike the tiling in Figure 1, this tiling has only finite triangles.

The cover image shows the three sets in magenta, green, and cyan, with a viewpoint is directly above the origin; it is clear that the three sets are congruent by rotations. When the viewpoint is moved to (((Sqrt[3])-1)/(Sqrt[2]))((1/2)+(Sqrt[(3/2)]) i) (the white disk at upper right on the cover), and one combines the green and cyan regions into a single set, then it is evident that the magenta set is congruent to its complement (Figure ). Thus the magenta set is both one third and one half of the hyperbolic plane. This paradox is not at all problematic because the standard measure of measurable sets in  (ℍ^2) assigns measure ∞ to the entire plane.

transform1[{x_, y_}]:= - transform[{x,y}];

Show[cover/.Polygon[z_] :> Polygon[z/. {x_?NumericQ, y_}:>ReIm[transform1[{x, y}]]]/.Disk[z_,r_] :> Disk[z/. {x_?NumericQ, y_}:>ReIm[transform1[{x, y}]],r 1.5], ImageSize-> 5 72, Frame->!True]

Paradoxes generally mean that certain measures cannot exist. A Mycielski measure on (ℝ^n) is a finitely additive, isometry invariant measure on the Lebesgue measurable sets having total measure 1 (see [2], p. 261). These measures exist for all (ℝ^n), so a paradox similar to those discussed here cannot exist in Euclidean space. But the constructive paradox in (ℍ^2) means that a hyperbolic Mycielski measure cannot exist in dimension 2, or higher. This highlights an interesting distinction between hyperbolic and Euclidean space.

The Banach–Tarski Paradox is considered one of the most surprising and bizarre theorems of mathematics. Constructive versions of the paradox can shed light on what underlies the construction, and it is remarkable that classic ideas of hyperbolic geometry can combine with Escher’s artistic work in the hyperbolic plane to bring the paradox to life.

REFERENCES

Junk

Here is the full citation:
Author: H. A. Schwarz
Title: “Ueber diejenigen Fälle, in welchen die Gaussische hypergeometrische Reihe eine algebraische Function ihres vierten Elementes darstellt” (On those cases in which the Gaussian hypergeometric series represents an algebraic function of its fourth element)
Journal: Journal für die reine und angewandte Mathematik
Volume: 75
Year: 1873
Pages: 292–335


Mycielski???

???https://people.physics.anu.edu.au/~vbr110/papers/frickeklein.pdf

But the point is the paradox in the Escher tiling -- who was the first discoverer of that tiling? KF seems to be the first publication of the art (Schwarz 1873 is relevant, but no art) -- rather than KF above.