In[]:=
n=7;m=3;dt=2Pi/n;dtm=2Pi/m;r=1./(1-Sin[dt/2]/Cos[dtm/2]);R=1.rCos[(dt+dtm)/2]/Cos[dtm/2];​​ToMatrix[z_,r_]:=(I/r){{z,r^2-zConjugate[z]},{1,-Conjugate[z]}};​​alist=Table[ToMatrix[rExp[It],r-1],{t,dt/2,2Pi,dt}];Tlist=Join[{IdentityMatrix[2]},alist];​​homography[{{a_,b_},{c_,d_}},z_]:=(az+b)/(cz+d);​​FindT[T0_,Tlist_]:=MemberQ[Tlist,T_/;Abs[homography[T,0]-homography[T0,0]]<1.0*^-3];
In[]:=
i2=1;Do[i1=i2+1;i2=Length[Tlist];​​Do[Scan[(T=Tlist[[i]].#;​​If[!FindT[T,Tlist],Tlist=Append[Tlist,T]])&,alist],{i,i1,i2}],{2}];​​plot=Show[Graphics[Map[Line[Table[z=homography[#,RExp[It]];{Re[z],Im[z]},{t,0,2Pi,dt}]]&,Tlist],AspectRatio->Automatic],Axes->True]
Out[]=
-3
-2
-1
1
2
3
-3
-2
-1
1
2
3
In[]:=
data=(Table[z=homography[#1,RExp[It]];{Re[z],Im[z],0.},{t,0,2π,dt}]&)/@Tlist;​​L=MeshRegion[Join@@Most/@data,Line[Join@@(Partition[#1,2,1,1]&)/@Partition[Range[7Length[data]],7]]];​​f=RegionDistance[L];​​θ1=0.08;​​θ2=0.01;​​z=.​​R1=ImplicitRegion[f[{x,y,z}]<=θ1,{{x,-4,4},{y,-4,4},{z,-2,2}}];​​S1=DiscretizeRegion[R1,MaxCellMeasure->0.0001]
Out[]=