Drawing Triangle Tilings in The Hyperbolic Plane

a companion to "Triangle tilings in the hyperbolic plane"
comp.uark.edu/~cgstraus/papers

Chaim Goodman-Strauss  (c) 2001

The techniques used in this notebook are described in the paper "Triangle Tilings in the Hyperbolic Plane", available at comp.uark.edu/~cgstraus/papers.  Here we allow the reader to make pictures of such tilings.

1) Evaluate This Stuff!
be sure to evaluate all cells in this first section:
simply click once on the arrow at right and press <enter>

A minor preliminary

Off[General::"spell1"];

Choosing Substitution Rules

First we choose substitution rules. This is precisely the method by which we found the "nice" rules given in the paper.

Setting Up The System

Defining our symbols

First define the greek letters:

alph  =  {α, β, γ};

\(\(li_List\ \)\&_ := \(#\&_&\)/@\ Reverse[li]\)

\(\(alphFull\  = \ Join[alph, alph\&_]; \)\)

\(\(Table[
      \((alph\&_[[i]])\)\&_ = 
        alph[[4 - i]], {i, 1, 3}]; 
    \)\)

Protect/@alph;

(a fast key board equivalent:)

\(ol[x_] := \(ol[x] = x\&_\)\)

Define the language describing allowed vertex arrangements:

\(\(Table[
      follow[alph[[i]]] = {
          \(Append[alph, alph[[1]]]
              \)[[i + 1]], 
          \(alph[[i]]\)\&_}, {i, 1, 3}]; 
    \)\)

\(\(Table[
      follow[alph\&_[[i]]] = {
          \(Append[alph\&_, alph\&_[[1]]]
              \)[[i + 1]], 
          \(alph\&_[[i]]\)\&_}, {i, 1, 
        3}]; \)\)

Making 𝒱

Here we create a list of all vertex arrangements for a given r,s,t

LegitQ checks to see if a string of greek symbols lies in our language

\(LegitQ[vertex_List] := 
      And\ @@\ \((
          Table[
		
            MemberQ[follow[vertex[[i]]], 
              
				
              \(Append[vertex, 
                  vertex[[1]]]
                  \)[[i + 1]]], {i, 1, 
              Length[vertex]}])\)\)

AlphIndex just counts the number of each kind of symbol in a list

\(AlphIndex[vertex_List] := 
      \((\(Count[vertex, #]&\)/@alph)\) + 
			
        \((\(Count[vertex, #]&\)/@Reverse[alph\&_])\)\)

\(\(
ExtendVertexList[partialVertex_, indices_] := 

	
      Select[
				
        \((\(Append[partialVertex, #]&\)/@follow[partialVertex[\([\(-1\)]\)]])
          \), 
		
			
        \((aa = AlphIndex[#]; 
            And\ @@\((
                Table[aa[[i]] <= \ 
                    indices[[i]], {i, 1, 
                    3}])\))\)&
]\)\)

\(\(


    ExtendVertexLists[listOfLists_, indices_] := 
\ 	
      Join\ @@	\((\(ExtendVertexList[#, indices]&\)/@listOfLists)\)
	

    \)\)

chiralStandardListing puts an arrangement in canonical form, not allowing reflection.

\(chiralStandardListing[vertex_] := 
      \(Sort[\((Table[RotateRight[vertex, i], {i, 1, Length[vertex]}])\)]\)

        			[[1]]\)

MakeAllVerticesChiral obtains a list of all vertices with the given indices

\(MakeAllVerticesChiral[indices_] := 	
      Union[chiralStandardListing\ /@\ 
	
          Select[

	
            \((
		Nest[
                ExtendVertexLists[#, indices]&, {{α}, {α\&_}}, 
                \((Plus@@indices)\)\  - 1])\), 
	
		
            MemberQ[follow[#
                    [[\(-1\)]]], #
                  [[1]]]&]]\)

\(\(

\)\)

Converting between greek and roman letters

The easiest way to understand this is: using the conventions describing the labels on a vertex arrangement, at a triangle (Subscript[T, i]), we have:

        (Subscript[E, i]) =  G2R[(Subscript[v, i])](Subscript[L, i]) = G2RLeft[(Subscript[v, i])](Subscript[R, i]) = G2RRight[(Subscript[v, i])](Subscript[l, i]) = R2G[(Subscript[R, i])] = R2G[G2RRight[(Subscript[v, i])]] (Subscript[r, i]) = R2G[(Subscript[L, i])] = R2G[G2RLeft[(Subscript[v, i])]]

We also take G2R[{ρ,ψ...,σ}] := {G2RLeft[ρ], ψ,..., G2RRight[σ]}

\(RAlph\  = \ {A, B, C}; 

Protect/@RAlph; 


    RAlphFull\  = \ Join[RAlph, RAlph\&_]; 

    Table[\((RAlph\&_[[i]])\)\&_ = 
        RAlph[[4 - i]], {i, 1, 3}]; 


    
Table[G2R[alph[[i]]] = 
        RAlph[[i]], {i, 1, 3}]; 


    Table[R2G[RAlph[[i]]] = 
        alph[[i]], {i, 1, 3}]; 


    Table[G2R[alph\&_[[i]]] = 
        RAlph\&_[[i]], {i, 1, 3}]; 


    Table[R2G[RAlph\&_[[i]]] = 
        alph\&_[[i]], {i, 1, 3}]; 


    c[l_] := Append[l, l[\([1]\)]]; 


    cc[l_] := Prepend[l, l[\([\(-1\)]\)]]; 


    Table[G2RLeft[alph[[i]]] = \ 
        \((RAlph // c)\)[\([i + 1]\)], {i, 1, 3}]; 


    Table[G2RRight[alph[[i]]] = 
        \((RAlph // cc)\)[\([i]\)], {i, 1, 3}]; 


    Table[G2RLeft[alph\&_[\([i]\)]] = \(G2RRight[alph[\([4 - i]\)]]\)\&_, {i, 
        1, 3}]; 


    Table[G2RRight[alph\&_[\([i]\)]] = \(G2RLeft[alph[\([4 - i]\)]]\)\&_, {i, 
        1, 3}]; 


    Table[R2GLeft[RAlph[[i]]] = \ 
        \((alph // cc)\)[\([i]\)], {i, 1, 3}]; 


    Table[R2GRight[RAlph[[i]]] = 
        \((alph // c)\)[\([i + 1]\)], {i, 1, 3}]; 


    Table[R2GLeft[RAlph\&_[\([i]\)]] = \(R2GRight[RAlph[\([4 - i]\)]]\)\&_, {
        i, 1, 3}]; 

    Table[R2GRight[RAlph\&_[\([i]\)]] = \(R2GLeft[RAlph[\([4 - i]\)]]\)\&_, {
        i, 1, 3}]; 


    R2G[list_] /; Length[list] > 1 := 
      Join[{R2GLeft[list[[1]]]}, 
        Take[list, {2, \(-2\)}], {
          R2GRight[list[[\(-1\)]]]}]; 

    
G2R[list_] /; Length[list] > 1 := 
      Join[{G2RLeft[list[[1]]]}, 
        Take[list, {2, \(-2\)}], {
          G2RRight[list[[\(-1\)]]]}]; 
    \)

\(RemoveBar[symb_] := If[Head[symb]\  === OverBar, symb\&_, symb]\)

Making (Subscript[ℛ, 𝒱])

\(AdjustBar[a_, b_] := 
		
      If[
			
        \((MemberQ[alph, a]\  && \ MemberQ[alph, b])\)\  || 
			
          \((\(! MemberQ[alph, a]\)\  && \ \(! MemberQ[alph, b]\))\), a, 
        a // ol]\)

\(\(
A2Rule[vertex_] := 
	
      \({
		G2R[vertex[\([{1, 2}]\)]], 
		
            Join[
			G2R/@\((Reverse[Take[vertex, {4, \(-2\)}]])\), 

              			{R2G[
                  G2RLeft[
                    vertex[[3]]]]}, 

              			{#}
		]
	}&\)/@

        		{\(G2RRight[vertex[[3]]]
              \)\&_, G2RLeft[
            vertex[[3]]]}\)\)

All2Rules[vertex_] := 
      Join @@ Table[A2Rule[RotateRight[vertex, i]], {i, 1, Length[vertex]}]

\(A3Rule[vertex_] := 
	
      \({
		G2R[vertex[\([{1, 2, 3}]\)]], 
		
            Join[
			G2R/@\((Reverse[Take[vertex, {5, \(-2\)}]])\), 

              			{R2G[
                  G2RLeft[
                    vertex[[4]]]]}, 

              			{#}
		]
	}&\)/@

        		{\(G2RRight[vertex[[4]]]
              \)\&_, G2RLeft[
            vertex[[4]]]}\)

All3Rules[vertex_] := 
      Join @@ Table[A3Rule[RotateRight[vertex, i]], {i, 1, Length[vertex]}]

\(AllRules[vertex_] := 
      Join[All2Rules[vertex] // Union, 
		All3Rules[vertex] // Union]\)

\(\(AllPossibleRules[indices_] := 
      Union\ @@\ \((
	AllRules/@	MakeAllVerticesChiral[indices])\); \)\)

Getting "Nice" rules:

A "nice" rule is of the form [XY]->X...YyY or [XxX]->X..XxX

\(GetNiceRules[rulelist_] := 
      Select[rulelist, 

        		#[[1, 1]] === #
                [[2, 1]]\  && 

            		#[[1, \(-1\)]] === #
                [[2, \(-1\)]] && 

            		#[[2, \(-1\)]] === 
              G2R[#[[2, \(-2\)]]]\  && 

            		#[[2, \(-3\)]] === 
              G2R[#[[2, \(-2\)]]] && 

            		If[Length[#[[1]]] === 3, 
              
					#[[1, 1]] === 
                  G2R[#[[1, 2]]]\  && 

                					#[[1, 3]] === 
                  G2R[#[[1, 2]]], True]

          				
			&]\)

Displaying a list of rules. !Careful!

We allow Mathematica to display rules and lists of rules. NOTE: we abuse the function Times. This means that under certain circumstances both this display function and arithmetic may not perform properly!!

DisplayARule[arule_] := 
      (Times@@#&/@arule) // #[[1]] -> #[[2]]&

\(\(RuleListForm[ruleList_] := 
	
      \((
		Unprotect[Times]; 
		ClearAttributes[Times, \ Orderless]; 

        		Protect[Times]; 
		
		
	
        \((DisplayARule/@ruleList)\) // TableForm)\); \)\)

Some simple cases

Obtaining Rules for 422

We choose only the "nice rules" that contain only α, \(α\&_, A, A\&_\)

\(\(r422\  = \ 	
      Select[
	AllPossibleRules[{4, 2, 2}], 
          \(! MemberQ[#[\([1]\)], C]\) && \(! MemberQ[#[\([1]\)], B]\)\  && 

              			\(! MemberQ[#[\([1]\)], C\&_]\) && 
              \(! MemberQ[#[\([1]\)], B\&_]\)\ 
			
			&\ ]

 // 
        GetNiceRules; \)\)

r422  // RuleListForm

Obtaining Rules for 442

\(\(r442Temp\  = \ \ 
      Select[
	AllPossibleRules[{4, 4, 2}], 
          \(! MemberQ[#[\([1]\)], C]\) && 
			
              \(! MemberQ[#[\([1]\)], C\&_]\) && 
              \(! MemberQ[#[\([2]\)], C]\) && 
			
              \(! MemberQ[#[\([2]\)], C\&_]\)
			
			&\ ]
 // 
        GetNiceRules; \)\)

r442Temp //  RuleListForm

Here see that we may have some redundancy (for example, we have two nice rules for BA). This next function chooses at most one rule per letter; rather arbitrarily we take the first rule on the list for a given letter:

\(EliminateRedundancy[ruleList_] := 

      \((lets\  = \ 
          Union[\(#[[1]]&\)/@ruleList]; 
        
	Table[
		
          \(Select[
              ruleList, #[[1]] === 
                  lets[[i]]&]
              \)[[1]], {i, 1, 
            Length[lets]}])\)\)

r442  =  EliminateRedundancy[r442Temp];

r442 // RuleListForm

Obtaining Rules for 222

\(\(\ 
	\(r222\  = \ AllPossibleRules[{2, 2, 2}]
 // GetNiceRules; 
    \)\)\)

r222  //  RuleListForm

Making General Rules from the Simple Cases

Construct "State Strings"

We insert "state strings" into our rules for 222,442, 422:

\(\(StateString[{let_, i_}] /; MemberQ[Join[RAlph, RAlph\&_], let] := 
	
      Join\ @@\ Table[{let, let\&_}, {ii, 1, i}]
		\)\)

\(\(StateString[{let_, i_, j_, k_, p_}] /; 
        MemberQ[Join[RAlph, RAlph\&_], let]
		 := 
	

      \((
		If[MemberQ[RAlph, \ let], \ ral\  = RAlph\  // Reverse; \ 
          ind = {k, j, i}, \ ral\  = RAlph\&_ // Reverse; \ ind = {i, j, k}]; 
        
	ind\  = \ RotateLeft[ind, 0]; 
		ii\  = \ 0; 
		
        While[\(! 
            \((ral[[1]] === let)\)\), 

          			ral\  = \ RotateRight[ral, 1]; 
			
          ind\  = \ RotateRight[ind, 1]; 
			\(ii++\); ]; 
		
        ral\  = \ RotateLeft[ral, 1]; 
		ind\  = \ RotateLeft[ind, 1]; 

        		
		
        Join[
			Join\ @@\ 
			Table[ral, {pp, 1, p}], 
			
          Join\ @@\ 
		\ 
            Table[Append[
			
                StateString[{ral[[ii]], 
                    ind[[ii]]}], 
                ral[[ii]]], {ii, 1, 3}]

          			
			
			]
	
	
	
	)\)
		\)\)

The actual rules, then:

First do some error checking to thwart the senseless user:

\(subRules[{r_, s_, t_}] /; 
		
        \((\((r + s + t ≤ 6\ )\) || \ 
            \((r < 2\  || \ s < 2\  || \ t < 2)\) || 
		
            \(! \((Mod[r, 2] === Mod[s, 2])\)\) || 
		
            \(! \((Mod[s, 2] === Mod[t, 2])\)\)\  || 
		
            \(! \((Mod[r, 1] === 0)\)\))\)\  := \ "Invalid Indices 1"\)

\(subRules[{r_, 2, 2}] /; 
	
        \((\(! \((Mod[r, 2] === 0)\)\)\  || 
		\(! \((r > 2)\)\)\ )\)\  := 
      \ \ "Invalid Indices 2"
	\)\(subRules[{2, r_, 2}] := subRules[{r, 2, 2}]; 

		
    subRules[{2, 2, r_}] := subRules[{r, 2, 2}]; \)

\(subRules[{r_, s_, 2}] /; 
	
        \((\(! \((Mod[r, 2] === 0)\)\)\  || 
			
              \(! \((Mod[s, 2] === 0)\)\)\  || 
				
              \(! \((s > 2)\)\)\  || 
		\(! \((r > 2)\)\)\ )\)\  && 
		
          \((\(! \((r === 2)\)\) && \(! \((s === 2)\)\))\) := \ \ 
      "Invalid Indices 3"
		\)\(subRules[{r_, 2, s_}] := subRules[{r, s, 2}]; 


    subRules[{2, r_, s_}] := subRules[{r, s, 2}]; \)

Let's now turn to the usable cases:

\(\(subRules[{r_, 2, 2}] := 
	
      \((ii\  = \ \((r - 4)\)/2; 
	
        \({#[[1]], 
              Join[StateString[{#[[2, 1
                      ]], ii}], #[[2
                  ]]]}&\)/@\ r422)\)
	

\)\)

\(\(subRules[{r_, s_, 2}] /; 
			
        \((\(! \((r === 2)\)\) && \(! \((s === 2)\)\))\) := 
	
      Module[{ii, jj, posA, posB, lets, inds}, 

        \((ii\  = \ \((r - 4)\)/2; \ jj\  = \ \((s - 4)\)/2; 
		
          \(\((posA\  = \ 
                  \((Join\ @@\ 
                        Select[
                          Position[#[[2
                              ]], A], Length[#] === 1&])\)[
                    \([1]\)]; 
		
                posB\  = \ 
                  \((Join\ @@\ 
                        Select[
                          Position[#[[2
                              ]], B], Length[#] === 1&])\)[
                    \([1]\)]; 
		
                If[posA < posB, \ 
				lets\  = \ {A\&_, B\&_}; \ 
                  poss = {posA, posB}; \ inds\  = \ {ii, jj}, 
				
                  lets\  = \ {B\&_, A\&_}; \ poss\  = {posB, posA}; \ 
                  inds\  = \ {jj, ii}]; 

                		{#[[1]], 
				
                  Join[
					
                    Take[#[[2]], 
                      poss[[1]]], 

                    					
                    StateString[{
                        lets[[1]], 
                        inds[[1]]}], 

                    					
                    Take[#[[2]], {
                        poss[[1]] + 1, 
                        poss[[2]]}], 

                    					
                    StateString[{
                        lets[[2]], 
                        inds[[2]]}], 

                    					
                    Take[#[[2]], 
                      poss[[2]] - 
                        Length[#[[2]]]]

                    					]}
		)\)&\)/@\ r442)\)]
		
\)\)

\(subRules[{r_, s_, t_}] /; 
	
        \((\((r > 2\  && \ s > 2\  && \ t > 2)\) && 
			
            \((
	\ \ \ \ 
              Mod[r, 2] === Mod[s, 2]\  && 
			
                Mod[s, 2] === Mod[t, 2]\  && 
			Mod[r, 1] === 0)\))\)

      \  := \ Module[{pp, ii, jj, kk}, 
	
        \((\ pp\  = \ Mod[r, 2]; 
			If[pp === 0, pp = 1, pp = 0]; 
		
          ii = \((r - pp - 3)\)/2; 
				jj\  = \ \((s - pp - 3)\)/2; 

          				kk\  = \ \((t - pp - 3)\)/2; 
				
				
          \(\(({#[[1]], 
                  Join[
						{#[[2, 1
                        ]]}, 
                    StateString[{#[[2, 1
                          ]], ii, jj, kk, pp}], 

                    						
                    Take[#[[2]], {2, 
                        Length[#[[2
                            ]]]}]]})\)&\)/@r222)\)]\)

subRules[x___] := {};

Looking at vertices

This is just for checking our work:

\(VertexFromRule[rule_] := 
      Join\ @@\ {
				
				R2G[rule[\([1]\)]], 
				

          		{R2GRight[
              G2RLeft[rule[[2, 
                  \(-2\)]]]]}, 
	
				
          R2G/@\ Reverse[
              Take[rule[\([2]\)], 
                Length[rule[[2]]] - 2]], 
          
			
		
          Select[follow[
              R2G[rule[[2, 1]]]], 
            MemberQ[{rule[[1, 1]], 
                  \(rule[[1, 1]]\)\&_}, 
                G2RRight[#]]&]	
		
		
				
			}\)

VertexDisplayForm[vertex_] := Times @@ vertex

Applying substitution rules to make symbolic strips

We won't be making any checks; we assume the strings are in the right language and the rules are deterministic

Our first command takes the first letter at the beginning of a string, applies the appropriate rule, and prepends it to producedString. Keep in mind that our letters consist of two or three symbols in alph, RAlph

\(ApplySubRulesAtEnd[ruleList_, {string_, \ producedString_}] := 
	
      \((\ If[MemberQ[alphFull, \ 
            string[[2]]], len\  = \ 3, \ 
          len\  = \ 2]; 
		let\  = \ Take[string, \ len]; 

        		{Take[string, \(-Length[string]\) + len\  - \ 1], 
		
          Join[producedString, 
				
            If[producedString === {}, 
              \(\(Select[
                    ruleList, #[[1]] === 
                        let&]\)[[1
                  ]]\)[[2
                ]], 
				
              Drop[\(\(Select[
                      ruleList, #[[1
                            ]] === let&]
                      \)[[1
                    ]]\)[[2
                  ]], 1]]]})\)\)

\(ApplySubRulesToString[ruleList_, string_] := 
      Module[{temp}, 
	
        \((temp\  = \ {string, {}}; 
		
          While[Length[temp[[1]]] > 1, 

            			\(temp = \ ApplySubRulesAtEnd[ruleList, temp]; \)]; 
		
          temp[[2]])\)]\)

\(ApplySubRules[ruleList_, string_, depth_] := 
	
      NestList[ApplySubRulesToString[ruleList, #]&, string, depth]\)

Making The Tilings

Hyperbolic Geometry

Generators for the isometries

It is easiest to work in the Minkowski model;  here points are of the form {a,b,c} with c^2 - (a^2+b^2) = 1,  c>0.
Since there is at most one point along any line through {0,0,0}, these are effectively homogeneous coordinates.  In this model, all isometries are given by multiplication by 3x3 matrices, and can be generated by:

a reflection along the x axis.  Hence {a,b,c}->{-a,b,c}

Rx= {	{-1,0,0},
		{0,1,0},
		{0,0,1}};

a rotation about the z axis:

RotZ[th_]:={{Cos[th],-Sin[th],0},
{Sin[th],Cos[th],0},{0,0,1}};

rot[th_] := RotZ[th // N]

a "translation" (hyperbolic transformation) preserving the yz plane. This can be thought of, roughly, as a translation parallel to the x-axis.  Note the striking similarity to the previous generator.

trans[th_]:={{1,0,0},{0,Cosh[th],Sinh[th]},{0,Sinh[th],Cosh[th]}}

All other isometries can be formed by combining these.  For example, to rotate 60 degrees about a point A: 
	1) rotate about the z axis so A lies in the yz plane. 
	2) translate A to the origin
	3) rotate by 60 degrees. 
	4 & 5) undo steps 2 & 1.

Projections

{Poincare,  Klein,  UpperHalfPlane,  Minkowski};

Protect[Poincare,  Klein,  UpperHalfPlane,  Minkowski];

These give other familiar models:

The first projection simply drops the last coordinate: {a,b,c}->{a,b}.  This model is somewhat unusual, but can be seen, eg, in Week's Kaleidotile program.

MinkowskiProj[vect_]:=Drop[vect,-1]

Second, we give the projection to the Klein model; this is simply central projection: {a,b,c}->{a/c, b/c}.  For numerical reasons, we do not assume c is correct, and work it out in terms of a and b.

KleinProj[vect_] := 
      Drop[vect, -1]/(Sqrt[1 + # . #&])[Drop[vect, -1]]

Finally, we give the projection to the Poincare model.

PoincareProj[vect_] := 
      Drop[vect, -1]/(1 + (Sqrt[1 + # . #&])[Drop[vect, -1]])

UpperHalfPlaneProj[{a_, b_, c_}] := {a,  1}/
        (b + (Sqrt[1 + (a^2) + (b^2)]))

\(\(Project\_model_ := 
	
      Which[
		model\  === \ Poincare, PoincareProj, 
		
        model\  === \ Klein, \ KleinProj, 
		model\  === \ UpperHalfPlane, 
        UpperHalfPlaneProj, 
		model\  === \ Minkowski, \ MinkowskiProj, 

        		True, \ PoincareProj]
		\)\)

It is also helpful to be able to return to the Minkowski model from those of Poincare and Klein:

\(Poincare2hyp[vect_] := 
      \(Append[#, \@\(1 + # . #\)]&\)[\ \ \ \ \ \ \ 
        2  vect/\((1 - vect . vect)\)]
\)Klein2hyp[vect_] := (Append[#, 1]/(Sqrt[1 - # . #]))&[vect]

KleinPoint[vect_] := Point[KleinProj[vect]]

PoincarePoint[vect_] := Point[PoincareProj[vect]]

\(UnProject\_model_ := 
	
      Which[
		model\  === \ Poincare, Poincare2hyp, 
		
        model\  === \ Klein, \ Klein2hyp, 
		True, \ Poincare2hyp]\)

Measuring Distance

\[LeftBracketingBar]v_\[RightBracketingBar] := 
      (Sqrt[v⊙v]) // N

\(v_\&^ := \ v/\[LeftBracketingBar]v\[RightBracketingBar]\)

v1_⊙v2_ := 
      -Drop[v1, -1]  .  Drop[v2, -1] + 
        v1[[-1]]  
          v2[[-1]]

HypDist[v1_, v2_] := 
      ArcCosh[(v1⊙v2)/
            \[LeftBracketingBar]v1\[RightBracketingBar]/
          \[LeftBracketingBar]v2\[RightBracketingBar]]

\(HypMag[v_] := 
      ArcCosh[v[[\(-1\)]]/
          \[LeftBracketingBar]v\[RightBracketingBar]]
\)KleinDist[v1_, v2_] := 
      HypDist @@ (Append[#, 1]& /@ {v1, v2})

KleinMag[v_] := ArcCosh[1/(Sqrt[1 - v . v])]

Some Line Stuff

\(M_\^†\):=(({{1, 0, 0}, {0, 1, 0}, {0, 0, -1}})).Transpose[Inverse[M]].(({{1, 0, 0}, {0, 1, 0}, {0, 0, -1}}))

Moving Stuff around

return the transformation taking vect straight to origin

\(\(PtToOrigin[vect_] := 
      Module[{a, b, θ, τ}, 
		{a, b} = KleinProj[vect]; 
	
        If[Chop[a // N, 10^\(-7\)] === 0\  && \ 
            Chop[b // N, 10^\(-7\)] === 0, \ θ = 0, \ 
		
          θ = Arg[\((a + b\ I)\)] - π/2]; 
			
        τ = HypMag[vect]; 
			
        \((RotZ[θ])\) . trans[\(-τ\)] . \((RotZ[\(-θ\)])\)]
        
			
		\)\)

return the transformation moving vect a distance τ straight towards origin

\(PtToOrigin[vect_, τ_] := 
      Module[{a, b, θ}, 
		{a, b} = KleinProj[vect]; 
	
        If[Chop[a, 10^\(-14\)] === 0\  && \ Chop[b, 10^\(-14\)] === 0, \ 
          θ = 0, \ 
		θ = Arg[\((a + b\ I)\)] - π/2]; 

        			\((RotZ[θ])\) . trans[\(-τ\)] . 
          \((RotZ[\(-θ\)])\)]\)

PtToOrigin[{0, 0, z_}] := {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};

PtToOrigin[{0, 0, z_}, τ_] := {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}};

rotate clockwise by θ about v1

\(RotAboutPt[v1_, θ_] := 
      Module[{AA}, 
		AA = PtToOrigin[v1]; 
		
        AA . RotZ[θ] . Inverse[AA]]\)

move v1 straight to v2

\(\(PtToPt[v1_, v2_] := 
      Module[{AA}, 
			AA = PtToOrigin[v2]; 
		
        AA . PtToOrigin[v1 . AA] . Inverse[AA]]
		
		\)\)

move v1 straight towards v2 by a distance of τ

\(\(PtToPt[v1_, v2_, τ_] := 
	
      Module[{AA}, 
			AA = PtToOrigin[v2]; 
		
        AA . PtToOrigin[v1 . AA, τ] . Inverse[AA]]	


\)\)

given a points B,C , construct a copy of the triangle AAA={A1,A2,A3} on the line BC, with vertex Ai at the point B, Aj on the line.  All given in Minkowski Model.

\(\(\(TriPositioner[AAA_, B_, Cc_, \ i_, j_] := 
	
      Module[{}, 
		
		BB = PtToOrigin[B]; 

        		{Ba, Bb} = KleinProj[Cc . BB]; 
		
        If[a === 0\  && \ b === 0, \ θ = 0, \ 
		
          θ = Arg[\((a + b\ I)\)] - π/2]; 
		
			
        AA = PtToOrigin[AAA[[i]]]; 

        		{Aa, Ab} = 
          KleinProj[AAA[[j]] . AA]; 

        			Ψ = Arg[\((Aa + Ab\ I)\)] - π/2; 
		
		
        T = AA . RotZ[Ψ] . \((Inverse[BB . RotZ[θ]])\)]; 
    \)
				
				
				
				
				
				\)\)

Triangle Stuff

\(\(TriangleCorners[{α_, β_, γ_}, {a_, b_, c_}] := 
      
{{0, 0, 1}, {0, 0, 1} . trans[c], {0, 0, 1} . trans[b] . 
          RotZ[\(-α\)]}
	\)\)

\(PolygonSidePts[ptlist_, n_] := 
      Module[{pp}, 
		
        pp = Append[ptlist, 
            ptlist[[1]]]; 
        \(Append[#, #[\([1]\)]]&\)[\ 
          Join\ @@\ 
		
            Table[Segment[pp[[i]], 
                pp[[i + 1]], n], {i, 1, 
                Length[ptlist]}]]]\)

A few helpful graphics commands

gives sequence of n points running from vect1 to vect2

\(\(Segment[{vect1_, vect2_}, n_] := 
      Module[{a, b, c, d, θ, τ, AA}, 
	
			
        τ = HypDist[vect2, vect1]; 
		AA = PtToOrigin[vect1]; 

        			{a, b} = KleinProj[vect2 . AA] // N; 
		
        If[a === 0\  && \ b === 0, \ θ = 0, \ 
		
          θ = Arg[\((a + b\ I)\)] - π/2]; 
		
        Table[
		
          vect1 . 	AA . \((RotZ[θ])\) . trans[τ\ k/n] . 
              \((RotZ[\(-θ\)])\) . Inverse[AA] // N, 
		{k, 0, n}]]
        
		\)\)

This is a useful command; later we will actually represent paths as a list of points. Off towards the boundary of the image, these points are only microscopically close to one another.  So it is helpful to delete points within a certain distance of one another.  This command is not quite optimized, but you need a magnifying glass to find the problem...
path is of the form {x0,x1,x2,....,xn}, where each xi is a vector.

\[LeftDoubleBracketingBar]v_\[RightDoubleBracketingBar] := 
      (Sqrt[v . v])

\(cleanpath[path_, res_] := 
      Module[{ppath, i}, 
        ppath = {path[[1]]}; \ i = 0; 
        While[i < Length[path], 
			
          If[\[LeftDoubleBracketingBar]path[[i
                    ]] - 
                  path[[i + 1
                      ]]\[RightDoubleBracketingBar] > res, 
            ppath = Append[ppath, 
                path[[i + 1]]]]; 
          \(i++\)]; ppath]\)

cleanpath[path_] := cleanpath[path,  .0001]

cleanpath[path_] := Chop[path, 10^-4];

Converting symbolic strings to geometry:

We will assume (Subscript[l, A])and (Subscript[m, α])etc will have been defined (this is to be done when the user selects the initial triangle.

Given the previous segment {v0,v1} along the curve, we define a set of lines to be drawn for each letter in the alphabet:

\(\(AddSegments[{v0_, v1_}, let_, \ firstQ_] := 
	
      Module[{z3, z4, σ, ψ, v2, v3, v4, ans}, 
	
        \((If[Length[let] === 2, 
		
            z3\  = G2R[
                  R2GLeft[let[[2]]]] // 
                RemoveBar; 
		
            σ = 
              R2GLeft[let[[1]]]; 
		
            ψ = R2GRight[let[[2]]]; 
            
		v3 = 
              v1 . PtToPt[v1, v0, L\_z3] . RotAboutPt[v1, m\_σ]; 
		
            v2\  = \ v1 . 
                PtToPt[v1, v3, 
                  L\_\(let[[2]]\)] . 
                RotAboutPt[v1, m\_ψ]; 
		
            ans = {{z3, {v1, v3}}, {
                  let[[2]] // 
                    RemoveBar, {v1, v2}}}, 
		
		
            z3\  = \ G2RLeft[
                  let[[2]]] // 
                RemoveBar; 
		
            z4\  = \ \ 
              G2RRight[let[[2]]] // 
                RemoveBar; 
		
            σ = 
              R2GLeft[let[[1]]]; 
		
            ψ = 
              R2GRight[let[[\(-1\)]]]; 

            		v3\  = \ 
              v1 . PtToPt[v1, v0, L\_z3] . RotAboutPt[v1, m\_σ]; 
		
            v4\  = \ v1 . PtToPt[v1, v3, L\_z4] . 
                RotAboutPt[v1, 
                  m\_\(let[[2]]\)]; 

            		v2\  = \ 
              v1 . PtToPt[v1, v4, 
                  L\_\(let
                      [[\(-1\)]]\)] . 
                RotAboutPt[v1, m\_ψ]; 
		
            ans\  = {{z3, {v1, v3}}, {z4, {v1, v4}}, {
                  let[[\(-1\)]] // 
                    RemoveBar, {v1, v2}}}]; 

          If[firstQ, 
		
            Join[
				
              v2 = v1 . 
                  PtToPt[v1, v0, 
                    L\_\(let[[1]]\)]; 

              					
              σ = 
                R2GRight[let[[1]]]; 

              							
              v3 = v2 . PtToPt[v2, v1, L\_\(G2RLeft[σ]\)] . 
                  RotAboutPt[v2, \(-m\_σ\)]; 
							

              						{{
                  RemoveBar[let[[1]]], {
                    v2, v1}}, 

                							{RemoveBar[G2RLeft[σ]], {v3, v2}}}, 
              ans], 
			ans])\)]
		
		
		\)\)

\(AddLastSegment[strip_] := 
	
      Append[strip, 
		
        Module[{v0, v1, let}, 
			
          v0 = strip[[\(-1\), 2, 1]]; 

          			v1 = 
            strip[[\(-1\), 2, 2]]; 

          			let = 
            strip[[\(-1\), 1]]; 
			
          v2 = v1 . PtToPt[v1, v0, L\_\(G2R[R2GRight[let]]\)] . 
              RotAboutPt[v1, m\_\(R2GLeft[let]\)]; 

          			{G2R[R2GRight[let]], {v2, v1}}]]\)

\(\(MakeStrip[{v0_, v1_}, symbolicStrip_] := 
	
      Module[{sss, ttt, first, seq, let, temp}, 

        ttt = 	Join\ @@\ 
            \((\ sss\  = \ symbolicStrip; 
		ttt = {}; 
		first = True; 
              
		seg\  = \ {v0, v1}; 
		
              While[Length[sss] > 1\  && 
				
                  \((And\ @@\ \((\(# < 1000&\)/@\((Join\ @@\((seg)\))\))\))
                    \), 
			
                If[MemberQ[alphFull, 
                    sss[[2]]], 
				
                  let\  = \ Take[sss, 3]; 
				sss = Drop[sss, 2], 

                  				let\  = \ Take[sss, 2]; \ sss = \ Drop[sss, 1]]; 

                			temp\  = \ AddSegments[seg, let, first]; 
			
                first\  = \ False; 
			ttt\  = \ Append[ttt, temp]; 

                			seg\  = \ 
                  temp[[\(-1\), 2]]]; 
              ttt)\); 
		AddLastSegment[ttt]]
	
		
		\)\)

\(\(MakeStrips[{vv0_, vv1_}, symbolicStripList_] := 

      Module[{ttt, sss, seg, z0, z1, v0, v1, v2, v3, σ, ψ, temp, 
          first}, 
			ttt\  = \ {}; 
			seg\  = \ {vv0, vv1}; 
			
        sss\  = \ symbolicStripList; 
			
        z0 = \ symbolicStripList[[1, 1
            ]]; 
			first\  = \ True; 
		i = 0; 

        		v0 = vv0; v1 = vv1; 
		StartSegList = {}; 
			
			
        While[\ Length[sss] > 0\ \  && 
            \((And\ @@\ \((\(# < 1000&\)/@\((Join\ @@\((seg)\))\))\))\), 

          				\(i++\); 
				
          If[\(! first\), 
					
            v0 = seg[[1]]; 
					
            v1\  = \ seg[[2]]; 

            					
            z1\  = sss[[1, 1]]; 

            				
					ψ = R2G[z1]; 
				
				
            σ = 
              \(Select[follow[ψ], MemberQ[{z0, z0\&_}, G2RRight[#]]&]
                  \)[[1]]; 
				

            				
				
					
            v2 = v1 . PtToPt[v1, v0, L\_\(G2RRight[R2G[z0]]\)] . 
                RotAboutPt[v1, \(-m\_σ\)]; 
					
            v3 = v1 . PtToPt[v1, v0, L\_\(G2RLeft[ψ]\)] . 
                RotAboutPt[v1, \(-\((m\_σ + m\_ψ)\)\)]; 
				
            seg = {v2, v3}; 
					z0\  = \ z1]; 
				
          temp\  = \ 
            MakeStrip[seg, sss[[1]]]; 

          			seg = temp[\([1, 2]\)]; 
				
          StartSegList = Append[StartSegList, temp[\([1, 2]\)]]; 
				
          sss = \ Drop[sss, 1]; 
				ttt = \ Join[ttt, temp]; 
			
          first\  = \ False; ]; 
		ttt]
				

	\)\)

\(MoveStrip[symbolicStrip_, transform_] := 
	
      \({#[[1
              ]], {#[[2, 1
                  ]] . 
                transform, #[[2, 2]] . 
                transform}}&\)/@symbolicStrip\)

Converting  geometric strips to graphics commands:

\(\(StripToGraphics[strips_] := 
	
      Join\ [\ 
		LineStyle\_A, 
	\ 
          Line/@\ \((
              Map[Project\_model, 
                \((\(Segment[#[[2]], 
                        divisionsPerEdge]&\)/@
		
                    Select[strips, #[[1
                            ]] === A&])\), {2}])\), 

          			LineStyle\_B, 
	\ 
          Line\ /@\ 
            \((Map[Project\_model, 
                \((\(Segment[#[[2]], 
                        divisionsPerEdge]&\)/@
		
                    Select[strips, #[[1
                            ]] === B&])\), {2}])\), 

          			LineStyle\_C, 
	\ 
          Line\ /@\ 
            \((Map[Project\_model, 
                \((\(Segment[#[[2]], 
                        divisionsPerEdge]&\)/@
		
                    Select[strips, #[[1
                            ]] === C&])\), {2}])\)]
 // 
        Chop[#, 10^\(-2\)]&
\)\)

Drawing the Pictures

Initialization

\(\(SetThingsUp\  := 
	

      \((\ m\_γ = \ 
          \(m\_γ\&_ = 
            \((2  π\  - \ \(m\_α\) v\_α - 
                    \(m\_β\) v\_β)\)/v\_γ // N\); 
		
        m\_α\  = \(m\_α\&_ = \ m\_α // N\); 
			
        m\_β\  = \ \(m\_β\&_ = m\_β // N\); 

        Which[
		
          \(! \((And\ @@\ 
                \((NumberQ
                    \ /@{m\_α, v\_α, m\_β, v\_β, 
                      m\_γ, v\_γ})\))\)\), 
			
          "Invalid Input: one of the parameters is not a number", 
		
          \((v\_α + v\_β + v\_γ ≤ 6)\)\ , 
          \*""Invalid Input: (Subscript[v, α])+(Subscript[v, β])+(Subscript[v, γ])≤6"", 
		
          \((m\_α + m\_β + m\_γ ≥ \ π)
            \)\ , \*""Invalid Input: (Subscript[m, α])+(Subscript[m, β])+(Subscript[m, γ])≥ π"", 
		
          \((m\_\(α\ \) ≤ \ 0)\)\  || \ 
            \((m\_\(β\ \) ≤ \ 0)\)\  || \ 
            \((m\_\(γ\ \) ≤ \ 0)\)\ , 
          "Invalid Input: one of the angles is negative", 
		
          \(! \((Mod[v\_α, 2] === Mod[v\_β, 2])\)\)\  || 
		
            \(! \((Mod[v\_α, 2] === Mod[v\_γ, 2])\)\)\ , 
          \*""Invalid Input: parities of (Subscript[v, α]),(Subscript[v, β]),(Subscript[v, γ]) don't all match"", 

          			v\_α < v\_β\  || 
			
            v\_β < v\_γ, \ 
          \*""Invalid Input: don't have (Subscript[v, α])≤(Subscript[v, β])≤(Subscript[v, γ])"", 
				
				True, \ 

          				
				
          \(\((L\_#\  = 
                  \(L\_#\&_ = \ 
                    ArcCosh[\ \ 
                        \((Cos\ [m\_\(R2G[#]\)] + \ 
                              Cos[m\_α]\ Cos[m\_β] 
                                Cos[m\_γ]/Cos[m\_\(R2G[#]\)])\)/
                          \((Sin[m\_α]\ Sin[m\_β]\ 
                              Sin[m\_γ]/Sin[m\_\(R2G[#]\)])\)] // N
                      \)\ )\)&\)/@\ {A, B, C}; 
			
			
          ourRules\  = \ subRules[{v\_α, v\_β, v\_γ}]; 

          			
			LineStyle\_A = DefaultLineStyle\_A; 
          LineStyle\_B = DefaultLineStyle\_B; 
          LineStyle\_C = DefaultLineStyle\_C; 

			divisionsPerEdge = 6; 
          model = Poincare; startingPosition = trans[0]; 
          ExtraOptions = DefaultExtraGraphicsOptions; 
			
				

          				"These Parameters Are Fine"])\)
		\)\)

\(MakeTheSymbolicStripsOfTriangles\  := 
	
      \((strips\  = \ ApplySubRules[ourRules, {A, α, A}, \ depth])
        \)\)

Setting defaults

\(\(orange = RGBColor[1,  .4, 0]; 
purple = RGBColor[0.5, \ 0, \ 0.75]; 
    
green = RGBColor[0,  .75,  .25]; 
gray\ \  = \ GrayLevel[ .5]; 

    thick = Thickness[ .0012]; 
thin = Thickness[ .0006]; 
\)\)

\(\(DefaultLineStyle\_A\  = {orange, \ thick}; 

    DefaultLineStyle\_B\  = {purple, \ thin}; 

    DefaultLineStyle\_C\  = {green, \ thin}; 

\)\)

\(NeededGraphicsOptions\  := 
	
      \((If[\(! MemberQ[{Poincare, \ Klein, \ UpperHalfPlane}, model]\), \ 
          model\  = Poincare]; 
	
	
        Join[
		\ {AspectRatio -> Automatic}, 
		
          Which[model\  === \ Poincare, \ 

            			{PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}, 
				
              Prolog -> {thick, gray, \ Circle[{0, 0}, 1]}}, 
			\ 
            model\  === \ Klein, \ 

            			{PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}, 
				
              Prolog -> {thick, gray, \ Circle[{0, 0}, 1]}}, 
			\ 
            model\  === \ UpperHalfPlane, 
            \ {
				PlotRange -> All, 
              Prolog -> {thick, gray, Line[{{\(-4\), 0}, {4, 0}}]}}]])\)\)

DefaultExtraGraphicsOptions = {};

Actually Drawing

\(\(ShowOurTriangle\  := 
      Show[Graphics[
          StripToGraphics[


            Module[{v0, v1, tri}, 
v0 = {0, 0, 1}; 
v1 = { .3, 0, 1}; 

              tri\  = \ 
                Table[{
			
                    let = RAlph[[i]], 

                    			v2 = 
                      v1 . PtToPt[v1, v0, L\_let] . 
                          RotAboutPt[v1, m\_\(R2GRight[let]\)] // 
                        Chop[#, 10^\(-9\)]&; 
		\ {v0 = v1, v1 = v2}}, 

                  		{i, 1, 3}]; 

              MoveStrip[tri, 
	
                PtToOrigin[
		
                  UnProject\_Klein[
			
                    \((Plus\ @@
                          \((\(Project\_Klein[#[[2, 1
                                    ]]]&\)/@tri)\))\)/3

                    		]]]
	]
		
		], 
          Sequence\ @@\ NeededGraphicsOptions]]; \)\)

\(\(DrawTheTiling := 

      Show[Graphics[
			
          StripToGraphics[
				
            MakeStrips[
						
              \(# . startingPosition&\)/@

                								{{0, 0, 1}, {1, 0, \@2 // N}}, 
					
              strips
				]], 
			AspectRatio -> Automatic, 
			
          PlotRange -> All, 
			
          Sequence@@Join[
					NeededGraphicsOptions, ExtraOptions]

          		]]
		
		
	\)\)

2) Make Some Pictures!

2.1) Initialize the program.. The parameters in red can be changed. You  must evaluate the commands with a gray background, in order.

(Subscript[v, α]), (Subscript[v, β]), (Subscript[v, γ]) describe the number of copies of each vertex in some vertex configuration v.
Note these must all have the same parity, two of these must be ≥2, and the third must be >2.
Also, to make the program a little simpler, we require (Subscript[v, α]) ≤ (Subscript[v, β]) ≤ (Subscript[v, γ])

(Subscript[v, α])=  6;
(Subscript[v, β  ])= 4;
(Subscript[v, γ]) = 2;

(Subscript[m, α]), (Subscript[m, β]) are the measures of angles α and β. Of cours (Subscript[m, γ])is determined  by (Subscript[m, α]) (Subscript[v, α]) + (Subscript[m, β]) (Subscript[v, β]) + 
          (Subscript[m, γ]) (Subscript[v, γ]) = 2  π.  We require that each of the measures be positive. Note that we do not require that these values be less than π/3 as we do for the theorem in the paper. That condition seems to be quite unnecessary.

(Subscript[m, α])=  π/7;
(Subscript[m, β]) =((Sqrt[5]) - 1)/2;

2.2) Check to see if these are valid and make some calculations.

If the following function returns "Invalid Input", please select new values for the above parameters. Otherwise, it is fine to continue.  This function calculates information about the triangle, including the set of substitution rules we'll use and some of the geometry.

\(\(SetThingsUp
\)\)

If you'd like to see the list of rules we'll be using, evaluate the following:

ourRules  // RuleListForm

2.3) Apply the substitutions.

Depth affects how many layers of the tiling we will make. You can increase this pretty high without bogging down our substitution function, but the drawing function will take a very long time, and a lot of memory, if you increase it too much.

depth = 2;

MakeTheSymbolicStripsOfTriangles;

2.4) If you want, set some options (optional)

This step can be skipped. Most users, I suspect, will be happy using the default values of these parameters.

a) Select a model of the hyperbolic plane.  The choices are Poincare, Klein and UpperHalfPlane.

model = Poincare;

b) Set the graphics options for the three kinds of edges, A,B,C  in the tiling. 
These can be any list, such as {RGBColor[.6,.4,.2], Thickness[.02]}.

(Subscript[LineStyle, A])  = (Subscript[DefaultLineStyle, A]);
(Subscript[LineStyle, B])= (Subscript[DefaultLineStyle, B]);
(Subscript[LineStyle, C])= (Subscript[DefaultLineStyle, C]);

c) Set the number of line segments to draw on each edge.

divisionsPerEdge = 6;

If you'd like, you can examine these parameters with:

ShowOurTriangle

This sets the position of the first triangle to be placed in the tiling.  We define our transformations in the section Hyperbolic Geometry above; 
	trans[τ] translates by  τ along the y axis, 
	rot[θ] rotates around the origin by θ
	multiplication is on the right

startingPosition =  trans[1.5] . rot[π/10];

\(\(startingPosition\  // MatrixForm
\)\)

Finally set any additional graphics options that Mathematica provides, such as PlotRange, AspectRatio, etc.

ExtraOptions = DefaultExtraGraphicsOptions;

2.5) AND NOW: draw the picture!

DrawTheTiling