The Banach–Tarski Paradox

Code for COA

.  The Paradoxical Free Product (Subscript[ℤ, 2])*(Subscript[ℤ, 3])

Unprotect[NonCommutativeMultiply];
s**s=t**t**t=e;
e ** w_=w_ ** e=w;
Format[NonCommutativeMultiply[s__]]:=SequenceForm[s]
SetAttributes[NonCommutativeMultiply,{Protected,Listable}]

s**t**t**t**s**e**t**s**s**s

s ** t ** t**s

%% ** %

Attributes[groupExtend] = Listable; 
groupExtend[(x__:e)** s] := x ** s ** t; 
groupExtend[(x__:e)** t] := x ** t **{s, t}; 
groupExtend[(x___) ** t ** t] := x ** t ** t ** s; 
groupExtend[e] = {s, t};

Take[G=Flatten[NestList[groupExtend,e,13]],30]

Unprotect[C];

Nest[({A, B, C} = #;
    {A ⋃ (t ** t ** B)⋃ (t ** C)⋃(s ** Join[B, C]),
      B⋃( t ** A)⋃ Complement[s ** A, C],
      C⋃( t ** t ** A)}) &, {{e}, {}, {}}, 12];

Length /@ {A,B,C}

thinned =Prepend[Transpose[Take[#, 30] & /@ {A, B, C}], {"A","B","C"}];

Style[Grid[Map[ToString,thinned, {2}], Dividers->{All,Join[{True,True},Table[False,{29}],{True }]}],10, FontFamily->"Times", Background->GrayLevel[0.9]]

.  A Hyperbolic Representation of the Group

f[z_]:=-(1/(z+1))
Simplify[Nest[f,z,3]]

LFTToMatrix[f_,v_:z]:=(Reverse[CoefficientList[#1,z]]&)/@{Numerator[f],Denominator[f]}/.{n_}:>{0,n};
MatrixForm/@({σ,τ}=LFTToMatrix/@{-(1/z),-(1/(z+1))})

MatrixForm /@ {MatrixPower[σ,2],MatrixPower[τ,3]}

iden=IdentityMatrix[2]

MatrixForm[s**t**s**t**t**s**t**s /. {NonCommutativeMultiply ->  Dot, e  ->  iden, s  ->  σ,  t  ->  τ}]

ToMatrix={NonCommutativeMultiply->Dot,e->iden,s->σ,t->τ};
ReIm[z_] := N[{Re[z], Im[z]}];
ReIm[ComplexInfinity]={0,1000};
Attributes[ReIm] = Listable;

triangle[res_:20]:=N[Join[(E^(I Range[60 °,120 °,((60 °)/res)])),-1+(E^(I Range[60 °,0,-((60 °)/res)])),1+(E^(I Range[180 °,120 °,-((60 °)/res)]))]];

Graphics[{EdgeForm[Thick],Yellow,Polygon[ReIm[triangle[]]]},Frame->True,PlotRange->{{-0.6,0.6},{-0.05,1.05}},FrameTicks->{{-0.5,0,0.5},{{1,I},{0.5,(I/2)},0},None,None}]

LFT[mat_List][z_?NumericQ]:=ReIm[Divide@@(mat.{z,1})]
LFT[mat_List][z_List]:=LFT[mat]/@z
LFT[word_Symbol|word_NonCommutativeMultiply][z_?NumericQ]:=LFT[word/.ToMatrix][z]
LFT[word_Symbol|word_NonCommutativeMultiply][z_List]:=LFT[word]/@z

Off[Power::infy,General::dbyz, Divide::infy];

LFT[σ.τ.τ][{I,2 I+3}]

LFT[s**t**t][{I,2 I+3}]

ReIm[1/0]

polys=Table[{FaceForm[Hue[Random[],0.6]],Polygon[LFT[w][triangle[]]]},{w,G}];
Graphics[{EdgeForm[Black],polys},PlotRange->{{-3,4},{0,2.4}},Frame->True,FrameTicks->False]

GroupForm[word_Symbol]:=GroupForm[ToString[word]];
GroupForm[word_String]:=If[StringLength[word]≤1, Identity,NonCommutativeMultiply]@@(ToExpression/@Characters[word])/.SequenceForm[c_]:>c;
Attributes[GroupForm]=Listable;
GroupForm[st]

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

Centroid[poly_]:=Mean[Union[poly/.{x_,y_}:>{x,Min[2.2,y]}]];

Graphics[{Thickness[0.002],
Text[Style["e",12],{0,0.7}],({Line[poly=LFT[#][triangle[]]],If[MemberQ[someWords,#],Text[Style[ToString[#], {FontSlant->"Italic",If[MemberQ[GroupForm[{ttstt,tt,s,sts,ststs,tts,st,stst,ttstts}],#],13,8]}],Centroid[DeleteCases[poly,{0,100}]]],{}]}&)/@Take[G,{2,75}]},
Frame->True,FrameStyle->{Black,White,White,White},FrameTicks->{Range[-2,2],{{1,I}}},
PlotRange->{{-2.7,2.7},{0,2.2}}, PlotRangeClipping->True]

.  The Geometrical Paradox

Position[{A,B,C},s**t**s]

Hausdorff[word_]:=Position[{A,B,C},word,{2}][[1,1]]
Hausdorff /@ {e,s,t,s**t**s}

cols={RGBColor[1,0.1,0.2],RGBColor[0.15,1,0.25],RGBColor[0.1,0.2,1]};paradoxPieces[colors_]:=Table[{FaceForm[colors[[Hausdorff[w]]]],Polygon[LFT[w][triangle[]]]},{w,Take[G,100]}];
polys=paradoxPieces[cols];
Graphics[{EdgeForm[Black],polys},Frame->True,FrameTicks->{{-1,0,1},{},{},{{1,I}}},PlotRange->{{-3.5,2.5},{-0.01,2.44}},PlotRangeClipping->True]

{col1,col2,col3}={RGBColor[1,0.1,0.2],RGBColor[0.15,1,0.25],RGBColor[0.1,0.2,1]};
basicArc1[]:=(E^(I Range[60. °,120 °,3 °]));
basicArc2[]:=-1.+(E^(I Range[60 °,0,-3 °]));
ymax=1.8;
redRight=ReIm[Join[basicArc2[],{2.8,2.8+ymax I,-0.5+ymax I}]];
greenMiddle=ReIm[Join[basicArc2[],(E^(I Range[N[π],2 π/3,-6 °]))]];
blueLeft=ReIm[Join[(E^(I Range[N[π],2 π/3,-6 °])),{-0.5+ymax I,-2.8+ymax I,-2.8}]];
Graphics[{EdgeForm[{Thick,Black}],col3,Polygon[blueLeft],col1,Polygon[ redRight], 
col2,Polygon[greenMiddle]},Frame->True, FrameTicks->{Range[-2,2],{{1, I}}, {}, {}}]

nn=11;
basicArc3[]:=1+(E^(I Range[180. °,120 °,-3 °]));
redTail=Table[LFT[MatrixPower[τ . τ . σ,i]][triangle[]],{i,nn}];
greenTail=Table[LFT[σ . MatrixPower[τ . τ . σ,i]][triangle[]],{i,nn}];
blueTail=TranslationTransform[{-1,0}]/@ greenTail;
greenTop=ReIm[Join[basicArc1[],{-0.5+ymax I,0.5+ymax I}]];
Graphics[{{col1,Polygon[redRight]},{col3,Polygon[blueLeft]},{col2,Polygon[greenMiddle]},
EdgeForm[{Thickness[0.004]}],{col1,Polygon[redTail]},{col3,Polygon[blueTail]},
{col2,Green,Polygon[greenTail],Polygon[greenTop]}},
Frame->True,FrameStyle->Thickness[0.007],FrameTicks->False,PlotRangeClipping->True,PlotRange->{{-2.8,ymax},{-0.02,ymax}}]

g[z_]:=((a z+b)/(c z+d));
(3^(1/4)){a,b,c,d}/.Solve[{a d-b c==1,
g[0]==((Sqrt[3])/2)-(I/2),g[-1]==-((Sqrt[3])/2)-(I/2),g[-(1/2)+(((Sqrt[3]) I)/2)]==0}][[2]]//ToRadicals//FullSimplify//ExpToTrig

project1[z_]:=LFT[{{1,(1/2)-I ((Sqrt[3])/2)},{-I,((Sqrt[3])/2)-(I/2)}}][z];
nn=14;sq=(Sqrt[3]) I/2;
blueLeft={Disk[{0,0},1,{(π/2),((3 π)/2)}]};
greenMiddle={Disk[{0,0},1,{((7 π)/6),((11 π)/6)}]};
redTail=Table[LFT[MatrixPower[τ . τ . σ,i]][triangle[]],{i,nn}];
greenTail=Table[LFT[σ . MatrixPower[τ . τ . σ,i]][triangle[]],{i,nn}];
blueTail=TranslationTransform[{-1,0}]/@greenTail;
greenTop=N[Join[basicArc1[],Range[-0.5+sq,-0.5+20 sq,sq/2],Range[-0.5+20 sq,0.5+20 sq,0.1],0.5+sq Range[200,1,-0.5]]];
ToC[e_]:=e/.{a_Real,b_}:>a+b I;
PoincareImage1=Graphics[{EdgeForm[Thickness[0.005]],{col1,Disk[]},{col3,blueLeft},{col2,greenMiddle},{col1,Polygon[project1/@ToC[redTail]]},{col3,Polygon[project1/@ToC[blueTail]]},{col2,Polygon[project1[greenTop]],Polygon[project1/@ToC[greenTail]]}}]

project2[z_]:=LFT[{{1,-I},{-I,1}}][z];
δ=π/30.;
bigred=Join[Table[{2,1}+2 {Cos[t],Sin[t]},{t,π,π+ArcTan[(4/3)],δ}],Table[{Cos[t],Sin[t]},{t,-ArcTan[(3/4)],(π/2),δ}]];
bigred1=Join[Table[{-2,-1}+2 {Cos[t],Sin[t]},{t,(π/6),0,-(π/30)}],Table[{Cos[t],Sin[t]},{t,-(π/2),0,δ}]];
biggreen=Join[Table[{-2,-1}+2 {Cos[t],Sin[t]},{t,(π/6),0,-(π/30)}],Table[{Cos[t],Sin[t]},{t,((3 π)/2),π,-δ}]];
bigblue=Join[Table[{1,-1} ({-2,-1}+2 {Cos[t],Sin[t]}),{t,(π/6),0,-δ}],Table[{Cos[t],Sin[t]},{t,(π/2),π,δ}]];

col2A=Blend[{col2, col3}, 0.7];
Graphics[{EdgeForm[Thickness[0.005]],{col2A,Disk[]},
{col1,Polygon[{bigred,bigred1}]},{col2A,Polygon[biggreen]},
{col3,Polygon[bigblue]},
{col1,Polygon[project2/@ToC[redTail]]},
{col3,Polygon[project2/@ToC[blueTail]]},
{col2A,Polygon[project2/@ToC[greenTail]]}}]