(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.1' Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 227274, 8388]*) (*NotebookOutlinePosition[ 230171, 8472]*) (* CellTagsIndexPosition[ 229856, 8459]*) (*WindowFrame->Normal*) Notebook[{ Cell["Autos.nb", "Title", FontFamily->"Times"], Cell["Automorphisms of free groups and character varieties", "Subtitle"], Cell["W.Goldman, 20 June 2005", "Subsubtitle", FontFamily->"Times"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Preliminaries", FontWeight->"Plain"]], "Section", FontFamily->"Times"], Cell[CellGroupData[{ Cell[BoxData[ \(Off[General::"\"]; Off[General::"\"]; Off[Syntax::"\"]; Off[Solve::"\"]\)], "Input"], Cell["\<\ First, turn off the annoying warning messages. Also, here is a \ useful matrix output routine:\ \>", "Text"] }, Open ]], Cell[BoxData[ \(MF[l_List]\ := \ Map[MatrixForm, l]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["The Word Datatype", "Section", FontFamily->"Times"], Cell[TextData[{ "We define a head ", StyleBox["Word", FontWeight->"Bold"], " which implements reduced words in a free group. The generators are given \ by positive\nintegers, and their inverses are given by their negatives. For \ example ", StyleBox["Word[3]", FontWeight->"Bold"], " denotes the third generator and\n", StyleBox["Word[-3] ", FontWeight->"Bold"], " denotes its inverse. The ", StyleBox["Dot", FontWeight->"Bold"], " function implements multiplication in the free group and ", StyleBox["Inverse ", FontWeight->"Bold"], " implements inversion: " }], "Text"], Cell[BoxData[{ \(\(Unprotect[Word, Dot, Inverse];\)\), "\n", \(Word[a___, m_Integer, n_Integer, b___]\ := \ Word[a, b]\ /; \ m\ + \ n\ == \ 0\), "\n", \(Dot[Word[], Word[]]\ := \ \(Word[]\n Dot[Word[], Word[a__]]\ := \ \(Word[a]\n Dot[Word[a__], Word[]]\ := \ Word[a]\)\)\), "\n", \(Dot[Word[a___], Word[b___]]\ := \ Word[a, b]\), "\n", \(Word[a___, 0, b___]\ := \ Word[a, b]\), "\n", \(Inverse[Word[]]\ := \ Word[]\), "\n", \(Inverse[Word[n_Integer]]\ := \ Word[\(-\ n\)]\), "\n", \(Inverse[Word[a___, n_Integer]]\ := \ Word[\(-\ n\)]\ . \ Inverse[Word[a]]\), "\n", \(\(Protect[Dot, Word, Inverse];\)\)}], "Input"], Cell["Here is an example of the implementation of reduced words:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Word[1, 2, \(-2\), 3]\)], "Input"], Cell[BoxData[ \(Word[1, 3]\)], "Output"] }, Open ]], Cell["\<\ Here is an example of the implementation of multiplication of \ reduced words:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Word[1]\ . \ Word[2]\)], "Input"], Cell[BoxData[ \(Word[1, 2]\)], "Output"] }, Open ]], Cell["\<\ Here is an example of the implementation of inversion of reduced \ words:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Inverse[Word[1, 2, 3, \(-4\)]]\)], "Input"], Cell[BoxData[ \(Word[4, \(-3\), \(-2\), \(-1\)]\)], "Output"] }, Open ]], Cell[BoxData[ \(\(KWord = Word[1, 2, \(-1\), \(-2\)];\)\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Words and Lists", FontWeight->"Plain"]], "Subsection"], Cell[TextData[{ "Here are routines for converting between words (as defined above) and \ lists. The function ", StyleBox["toList[w] ", FontWeight->"Bold"], "drops the head ", StyleBox["Word ", FontWeight->"Bold"], "and returns the list of variables. The function ", StyleBox["toWord[l] ", FontWeight->"Bold"], "applies the head ", StyleBox["Word ", FontWeight->"Bold"], "to the list l." }], "Text"], Cell[BoxData[{ \(\(toList[w_Word]\ := \ Apply[List, w];\)\), "\n", \(\(toWord[l_List]\ := \ Apply[Word, l];\)\)}], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(toList[Word[2, 3, 4, 1, 2, 3, 2]]\)], "Input"], Cell[BoxData[ \({2, 3, 4, 1, 2, 3, 2}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(toWord[{2, 3, 4, 1, 2, 4}]\)], "Input"], Cell[BoxData[ \(Word[2, 3, 4, 1, 2, 4]\)], "Output"] }, Open ]], Cell[TextData[{ "Notice that ", StyleBox["toWord", FontWeight->"Bold"], " automatically reduces the word." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(toWord[{1, \(-1\), 2}]\)], "Input"], Cell[BoxData[ \(Word[2]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Output routine", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "A routine for converting a ", StyleBox["Word ", FontWeight->"Bold"], "into its standard notation." }], "Text"], Cell[BoxData[ \(\(\(SymbolWord[w_Word]\)\(\ \)\(:=\)\(\ \)\(Apply[StringJoin, \n\t Map[{\ "\", \ "\", \ "\", \ "\", "\"}[\([#]\)] &, \ \n\t\t3\ + \ toList[w]]]\)\(\ \)\)\)], "Input"], Cell[BoxData[ \(SymbolWord[l_List]\ := \ Map[SymbolWord, l]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(SymbolWord[Word[1, 2, 1, \(-2\), 1, 2, \(-1\)]]\)], "Input"], Cell[BoxData[ \("ABAbABa"\)], "Output"] }, Open ]] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Applying Words to Other Words (substitution)", FontWeight->"Plain"]], "Subsection"], Cell[TextData[{ "Here is the routine for applying a word ", StyleBox["Word[a] ", FontWeight->"Bold"], "to a list of elements of a free group." }], "Text"], Cell[BoxData[{ \(ApplyWord[Word[], l_List]\ := \ Word[]\), "\n", \(ApplyWord[Word[a_ /; a > \ 0, b___], l_List\ ]\ := \ l[\([a]\)]\ . \ ApplyWord\ [Word[b], l]\), "\n", \(ApplyWord[Word[a_ /; a < 0, b___], l_List]\ := \ Inverse[l[\([\(-a\)]\)]\ ]\ . \ ApplyWord[Word[b], l]\)}], "Input"], Cell[TextData[{ "For example, ", StyleBox["ApplyWord[KWord,{ W1,W2}] ", FontWeight->"Bold"], "returns the commutator of ", StyleBox["W1 ", FontWeight->"Bold"], "and ", StyleBox["W2", FontWeight->"Bold"], ".\.13" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyWord[KWord, {Word[3], Word[4, 5]}]\)], "Input"], Cell[BoxData[ \(Word[3, 4, 5, \(-3\), \(-5\), \(-4\)]\)], "Output"] }, Open ]], Cell["Free group automorphisms", "Section", FontFamily->"Times"], Cell[CellGroupData[{ Cell[TextData[{ "An automorphism ", StyleBox["A", FontWeight->"Bold"], " of ", StyleBox["F2", FontWeight->"Bold"], " will be given by a pair of words ", StyleBox["{W1,W2}", FontWeight->"Bold"], " which freely generate ", StyleBox["F2. ", FontWeight->"Bold"], " The elements of this list are ", StyleBox["W1 = A(Word[1]) ", FontWeight->"Bold"], "and ", StyleBox["W2 = A(Word[2]). ", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(ApplyAuto[A_, W_Word]\ := \ ApplyWord[W, A]\)], "Input"], Cell[TextData[{ "Composing automorphisms ", StyleBox["A1 ", FontWeight->"Bold"], "and ", StyleBox["A2 ", FontWeight->"Bold"], " is implemented as follows. The following function gives the composition \ ", StyleBox["A1 o A2:", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(ComposeAuto[A1_, A2_]\ := \ Map[ApplyWord[#, A2] &, A1]\)], "Input"] }, Open ]], Cell["\<\ While we're at it, let's extend this function so we can compose \ several automorphisms at a time:\ \>", "Text"], Cell[BoxData[ \(ComposeAuto[A1_, A2_, X__]\ := \ ComposeAuto[A1, ComposeAuto[A2, X]]\)], "Input"], Cell["\<\ The identity automorphism is just given by the standard \ basis:\ \>", "Text"], Cell[BoxData[ \(\(Basis0\ = \ {Word[1], Word[2]};\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["The Three-Generator (Geometric) Presentation of F2 ", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "For several applications the presentation of ", StyleBox["F2", FontWeight->"Bold"], " with three generators and one relation is uesful. This\npresentation \ corresponds to the \"pair of pants\" (3-holed sphere) which has fundamental \ group ", StyleBox["F2.", FontWeight->"Bold"], "\nIts generators ", StyleBox["A,B,C", FontWeight->"Bold"], " correspond to the three boundary components and satisfy the relation ", StyleBox["ABC=I", FontWeight->"Bold"], "." }], "Text"], Cell[BoxData[ \(\(ThreeGenerators\ \ = {Word[1], Word[2], Word[\(-2\), \(-1\)]};\)\)], "Input"], Cell[BoxData[ \(PantsRep[A_]\ := \ Map[ApplyAuto[A, #] &, ThreeGenerators]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(PantsRep[Basis0] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell["\<\ Here's a useful display routine to see the action of sets of \ automorphisms on this generating set:\ \>", "Text"], Cell[BoxData[ \(DisplayPantsRep[A__]\ := \ Map[PantsRep, Prepend[List[A], Basis0]] // MF\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Inner Automorphisms ", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(InnerAutomorphism[w1_Word, w2_Word]\ \ := \ w1\ . \ w2\ . \ Inverse[w1]\)], "Input"], Cell[BoxData[ \(Inn[w_Word]\ := \ Map[InnerAutomorphism[w, #] &, Basis0]\)], "Input"], Cell[TextData[{ StyleBox["Inn[w]", FontWeight->"Bold"], " returns the inner automorphism determined by ", StyleBox["w", FontWeight->"Bold"], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Inn[Word[2, 1]]\)], "Input"], Cell[BoxData[ \({Word[2, 1, \(-2\)], Word[2, 1, 2, \(-1\), \(-2\)]}\)], "Output"] }, Open ]] }, Open ]] }, Open ]], Cell["Here's a convenient shorthand:", "Text"], Cell[BoxData[ \(Inn[w__]\ := \ Inn[Word[w]]\)], "Input"], Cell[BoxData[ \(InnerAutomorphism[n_Integer, w_Word] := InnerAutomorphism[Word[n], w]\)], "Input"], Cell["\<\ Let's display a few inner automorphisms in the 3-generator \ set:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Inn[2]\)], "Input"], Cell[BoxData[ \({Word[2, 1, \(-2\)], Word[2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[Inn[1], Inn[2], Inn[1, 2], Inn[KWord]]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[1, 2, \(-1\)]\)}, {\(Word[1, \(-2\), \(-1\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\)]\)}, {\(Word[2]\)}, {\(Word[\(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1, 2, 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\)]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1, 2, \(-1\), \(-2\), 1, 2, 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), 2, 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), \(-2\), \(-2\), \(-1\), 2, 1, \(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Permutations", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "Here are the permutation generators of ", StyleBox["Aut(F2)", FontWeight->"Bold"], ": The symbol ", StyleBox["P12 ", FontWeight->"Bold"], "denotes the transposition ", StyleBox["(12)", FontWeight->"Bold"], " etc." }], "Text"], Cell[BoxData[ \(\(P12\ = \ {Word[2], Word[1]};\)\)], "Input"], Cell[TextData[{ "Although ", StyleBox["P12 ", FontWeight->"Bold"], " interchanges the two free generators ", StyleBox["Word[1], Word[2]", FontWeight->"Bold"], ", it doesn't leave invariant the third generator\n", StyleBox["Word[-2,-1] ", FontWeight->"Bold"], " in the geometric presentation ", StyleBox["Word[1] Word[2] Word[-2,-1] = I ", FontWeight->"Bold"], " corresponding to pants:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[PantsRep, {Basis0, P12}] // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2]\)}, {\(Word[1]\)}, {\(Word[\(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[TextData[{ "It does preserve ", StyleBox["KWord ", FontWeight->"Bold"], " up to inversion:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({ApplyAuto[P12, KWord], Inverse[KWord]}\)], "Input"], Cell[BoxData[ \({Word[2, 1, \(-2\), \(-1\)], Word[2, 1, \(-2\), \(-1\)]}\)], "Output"] }, Open ]], Cell["This automorphism has order two:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({ComposeAuto[P12, P12], Basis0}\)], "Input"], Cell[BoxData[ \({{Word[1], Word[2]}, {Word[1], Word[2]}}\)], "Output"] }, Open ]], Cell[TextData[{ "We define a function to detect whether an automorphism is an involution \ taking ", StyleBox["KWord ", FontWeight->"Bold"], "to its inverse:" }], "Text"], Cell["\<\ KWordInv[A_] := {ApplyAuto[A, KWord] == Inverse[KWord], \ ComposeAuto[A, A] == Basis0}\ \>", "Input"], Cell[TextData[{ "Next we permute the first and third generator for this presentation to \ obtain an automorphism ", StyleBox["P13", FontWeight->"Bold"], ":" }], "Text"], Cell[BoxData[ \(\(P13\ = \ {Word[\(-2\), \(-1\)], Word[1, 2, \(-1\)]};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[PantsRep, {Basis0, P13}] // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\)]\)}, {\(Word[1]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[TextData[{ "It's an involution and preserves ", StyleBox["KWord ", FontWeight->"Bold"], " up to inversion:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(KWordInv[P13]\)], "Input"], Cell[BoxData[ \({True, True}\)], "Output"] }, Open ]], Cell[TextData[{ "Next we permute the second and third generator for this presentation to \ obtain the permutation ", StyleBox["P23", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(P23 = \ ComposeAuto[P12, P13, P12]\)], "Input"], Cell[BoxData[ \({Word[2, 1, \(-2\)], Word[\(-1\), \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(KWordInv[P23]\)], "Input"], Cell[BoxData[ \({True, True}\)], "Output"] }, Open ]], Cell[TextData[{ "The composition ", StyleBox["P13 P12 ", FontWeight->"Bold"], "is the 3-cycle ", StyleBox["(123)", FontWeight->"Bold"], ". Remember that permutations act on the left on symbols!" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(P123\ = ComposeAuto[P13, P12]\)], "Input"], Cell[BoxData[ \({Word[\(-1\), \(-2\)], Word[2, 1, \(-2\)]}\)], "Output"] }, Open ]], Cell[TextData[{ "Its inverse is the 3-cycle ", StyleBox["(132):", FontWeight->"Bold"] }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(P132 = ComposeAuto[P12, P13]\)], "Input"], Cell[BoxData[ \({Word[1, 2, \(-1\)], Word[\(-2\), \(-1\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[PantsRep, {Basis0, P123, P132}] // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\)]\)}, {\(Word[2]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1, 2, \(-1\)]\)}, {\(Word[\(-2\), \(-1\)]\)}, {\(Word[1, 2, 1, \(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell["P123 and P132 are mutually inverse and are normalized:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({ComposeAuto[P123, P132] == Basis0, Map[ApplyAuto[#, KWord] == KWord &, {P123, P132}]}\)], "Input"], Cell[BoxData[ \({True, {True, True}}\)], "Output"] }, Open ]], Cell["but they only have order three up to an inner automorphism:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[P123, P123, P123] == \ Inn[Inverse[KWord]]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["The Elliptic Involution", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "See ", StyleBox["2.1", FontWeight->"Bold"], " of the ", StyleBox["Modular Group", FontWeight->"Bold"], " paper." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(EllInv\ = \ {Word[\(-1\)], \ Word[\(-2\)]}\)], "Input"], Cell[BoxData[ \({Word[\(-1\)], Word[\(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[EllInv, EllInv]\)], "Input"], Cell[BoxData[ \({Word[1], Word[2]}\)], "Output"] }, Open ]], Cell[TextData[{ "so indeed ", StyleBox["EllInv", FontWeight->"Bold"], " is an involution. However:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[EllInv, KWord]\)], "Input"], Cell[BoxData[ \(Word[\(-1\), \(-2\), 1, 2]\)], "Output"] }, Open ]], Cell[TextData[{ "so ", StyleBox["EllInv ", FontWeight->"Bold"], " is not normalized. Normalize ", StyleBox["EllInv ", FontWeight->"Bold"], "by composing with the inner automorphism ", StyleBox["Inn[Word[2,1]]:", FontWeight->"Bold"] }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(EllAut\ = \ ComposeAuto[EllInv, Inn[Word[2, 1]]]\)], "Input"], Cell[BoxData[ \({Word[2, \(-1\), \(-2\)], Word[2, 1, \(-2\), \(-1\), \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[EllAut, KWord]\)], "Input"], Cell[BoxData[ \(Word[1, 2, \(-1\), \(-2\)]\)], "Output"] }, Open ]], Cell[TextData[{ "so ", StyleBox["EllAut", FontWeight->"Bold"], " is normalized. However, it no longer has order 2 in ", StyleBox["Aut(F2)", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[EllAut, EllAut]\ == \ Inn[Inverse[KWord]]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[TextData[{ "The elliptic involution commutes with the permutation ", StyleBox["P12", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({ComposeAuto[EllInv, P12], ComposeAuto[P12, EllInv]} // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[\(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[\(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[TextData[{ "But it doesn't commute with ", StyleBox["P23 ", FontWeight->"Bold"], "(and thus neither with the other permutations):" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({ComposeAuto[P23, EllInv], ComposeAuto[EllInv, P23]} // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\), \(-1\), 2]\)}, {\(Word[1, 2]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, \(-1\), \(-2\)]\)}, {\(Word[2, 1]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]] }, Open ]], Cell[TextData[{ "Here is the action of ", StyleBox["EllInv ", FontWeight->"Bold"], "on the 3-element generating set:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[EllInv]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-1\)]\)}, {\(Word[\(-2\)]\)}, {\(Word[2, 1]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Other involutions", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "These next automorphisms induce the quadratic reflections on the character \ variety (see ", StyleBox["2.3", FontWeight->"Bold"], " of the ", StyleBox["Modular Group ", FontWeight->"Bold"], "paper). Begin with the following automorphism. It's obviously an \ involution:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[{ \(\(Qz1\ = \ {Word[1], Word[\(-2\)]};\)\), "\n", \(ComposeAuto[Qz1, Qz1] == Basis0\)}], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["but it's not normalized:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[Qz1, KWord]\)], "Input"], Cell[BoxData[ \(Word[1, \(-2\), \(-1\), 2]\)], "Output"] }, Open ]], Cell["Let's normalize it:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[ComposeAuto[Inn[\(-1\)], Qz1], KWord]\)], "Input"], Cell[BoxData[ \(Word[\(-2\), \(-1\), 2, 1]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[ComposeAuto[Inn[\(-2\), \(-1\)], Qz1], KWord]\)], "Input"], Cell[BoxData[ \(Word[\(-1\), 2, 1, \(-2\)]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[Qz\ = \ ComposeAuto[Inn[1, \(-2\), \(-1\)], Qz1], KWord]\)], "Input"], Cell[BoxData[ \(Word[2, 1, \(-2\), \(-1\)]\)], "Output"] }, Open ]], Cell[TextData[{ "so composing with ", StyleBox["Inn[1,-2,-1] ", FontWeight->"Bold"], "normalizes it. Is it an involution?" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Qz, Qz] == Basis0\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[TextData[{ "We could have used our little function ", StyleBox["KWordInv", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(KWordInv[Qz]\)], "Input"], Cell[BoxData[ \({True, True}\)], "Output"] }, Open ]], Cell["Here's what it looks like:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Qz\)], "Input"], Cell[BoxData[ \({Word[1, 2, 1, \(-2\), \(-1\)], Word[1, 2, \(-1\), \(-2\), 1, \(-2\), \(-1\)]}\)], "Output"] }, Open ]], Cell[TextData[{ "We obtain the other involutions ", StyleBox["Qy ", FontWeight->"Bold"], "and ", StyleBox["Qx", FontWeight->"Bold"], " by conjugating by ", StyleBox["P23 ", FontWeight->"Bold"], "and ", StyleBox["P13", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \({Qy\ = \ ComposeAuto[P23, Qz, P23], Qx\ = \ ComposeAuto[P13, Qz, P13]} // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\), \(-1\), 2, 1, \(-2\), 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), \(-1\), \(-1\), \(-2\), 1, 2, \(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, 2]\)}, {\(Word[\(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell["They are normalized involutions:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[KWordInv, {Qy, Qx}]\)], "Input"], Cell[BoxData[ \({{True, True}, {True, True}}\)], "Output"] }, Open ]] }, Open ]], Cell["Here is what they look like on the 3 generators:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[Qx, Qy, Qz]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, 2]\)}, {\(Word[\(-2\)]\)}, {\(Word[\(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\), \(-1\), 2, 1, \(-2\), 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), \(-1\), \(-1\), \(-2\), 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), 2, 1, 1, 2, \(-1\), \(-2\), 1, 2, \(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1, 2, 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), \(-2\), 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["An order-four automorphism", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(\(A4a = {Word[\(-2\)], Word[1]};\)\)], "Input"], Cell[TextData[{ "Thus ", StyleBox["A4a", FontWeight->"Bold"], " has order 4:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[A4a, A4a] == EllInv\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["but it's not normalized:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[A4a, KWord]\)], "Input"], Cell[BoxData[ \(Word[\(-2\), 1, 2, \(-1\)]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[A4 = ComposeAuto[Inn[\(-1\)], A4a], KWord]\)], "Input"], Cell[BoxData[ \(Word[1, 2, \(-1\), \(-2\)]\)], "Output"] }, Open ]], Cell[TextData[{ "Now ", StyleBox["A4 ", FontWeight->"Bold"], " is normalized. However, it no longer has order 4:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[A4, A4, A4, A4] == Inn[Inverse[KWord]]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[A4]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[2, 1, \(-2\)]\)}, {\(Word[2, \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["A Dehn twist", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "Here is the automorphism (Nielsen transformation) corresponding to Dehn \ twist about ", StyleBox["X", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Tx\ = \ {Word[1], Word[2, 1]}\)], "Input"], Cell[BoxData[ \({Word[1], Word[2, 1]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell["Here is the inverse:", "Text"], Cell[BoxData[ \(\(Txi\ = \ {Word[1], Word[2, \(-1\)]};\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Tx, Txi]\)], "Input"], Cell[BoxData[ \({Word[1], Word[2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell["These automorphisms are normalized:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ApplyAuto[#, KWord] == KWord\ &, {Tx, Txi}]\)], "Input"], Cell[BoxData[ \({True, True}\)], "Output"] }, Open ]] }, Open ]], Cell[TextData[{ StyleBox["A relation between", FontWeight->"Plain"], " Tx, Qz", StyleBox[" and ", FontWeight->"Plain"], " P23", StyleBox[":", FontWeight->"Plain"] }], "Subsubsection"], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[Tx, P23, Qz]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2, 1]\)}, {\(Word[\(-1\), \(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\)]\)}, {\(Word[\(-1\), \(-2\)]\)}, {\(Word[2, 1, 2, \(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1, 2, 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), \(-2\), 1, \(-2\), \(-1\)]\)}, {\(Word[1, 2, \(-1\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(DisplayPantsRep[ComposeAuto[Qz, P23]\ , Tx, ComposeAuto[Inn[2, 1, \(-2\), \(-1\)], Tx]]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[\(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\), 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), 2, 1, 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), \(-1\), \(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2, 1]\)}, {\(Word[\(-1\), \(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 1, \(-2\), 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), 2, 1, 1, 2, \(-1\), \(-2\)]\)}, {\(Word[2, 1, \(-2\), \(-1\), \(-1\), \(-1\), \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Inn[2, 1, \(-2\), \(-1\)], Tx] == \ ComposeAuto[Qz, P23]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Tx\ == \ ComposeAuto[Inn[1, 2, \(-1\), \(-2\)], Qz, P23]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["More Dehn twists", "Subsubsection", FontWeight->"Plain"], Cell[TextData[{ "We define the Dehn twist about ", StyleBox["Y:", FontWeight->"Bold"] }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Ty\ = \ ComposeAuto[P12, Tx, P12]\)], "Input"], Cell[BoxData[ \({Word[1, 2], Word[2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell["Here is the inverse:", "Text"], Cell[BoxData[ \(\(Tyi\ = \ {Word[1, \(-2\)], Word[2]};\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["The Fibonacci automorphism", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(\(FibAut\ = \ {Word[2, 1], Word[1]};\)\)], "Input"], Cell[TextData[{ "This is the simplest hyperbolic automorphism of ", StyleBox["F2", FontWeight->"Bold"], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[SymbolWord[#[\([2]\)]\ ] &, NestList[ComposeAuto[FibAut, #] &, FibAut, 8]] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"\<\"A\"\>"}, {"\<\"BA\"\>"}, {"\<\"ABA\"\>"}, {"\<\"BAABA\"\>"}, {"\<\"ABABAABA\"\>"}, {"\<\"BAABAABABAABA\"\>"}, {"\<\"ABABAABABAABAABABAABA\"\>"}, {"\<\"BAABAABABAABAABABAABABAABAABABAABA\"\>"}, {"\<\"ABABAABABAABAABABAABABAABAABABAABAABABAABABAABAABABAABA\"\ \>"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell["Homology", "Section", FontFamily->"Times"], Cell[TextData[{ "First we need a function to compute the total exponent sum of a letter in \ a word.\n", StyleBox["Length[Cases[List,Integer]] ", FontWeight->"Bold"], StyleBox["returns the number of occurrences of ", FontWeight->"Plain"], "Integer ", StyleBox["in ", FontWeight->"Plain"], StyleBox["List ", FontWeight->"Bold"], StyleBox["(with multiplicity).", FontWeight->"Plain"] }], "Text"], Cell[BoxData[ \(ExponentSum[l_List, j_Integer]\ := \ Length[Cases[l, j]]\ - \ Length[Cases[l, \(-j\)]]\)], "Input"], Cell[TextData[{ "The function ", StyleBox["HomologyClass[W] ", FontWeight->"Bold"], "returns the homology class (an element in ", StyleBox["Z^2", FontWeight->"Bold"], ") of the word ", StyleBox["W.", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(HomologyClass[w_Word]\ := \ Module[{l = toList[w]}, Table[ExponentSum[l, j], {j, 2}]]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(HomologyClass[Word[1, 2, \(-1\), 2]]\)], "Input"], Cell[BoxData[ \({0, 2}\)], "Output"] }, Open ]], Cell["\<\ The action on homology is determined by the homology classes of the \ images of the generators.\ \>", "Text"], Cell[BoxData[ \(AutToGL2Z[A_]\ := \ Transpose[Map[HomologyClass, A]]\)], "Input"], Cell[TextData[StyleBox["Representation of the Symmetric Group", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "For example here is the representation of the symmetric group in ", StyleBox["GL(2,Z)", FontWeight->"Bold"], ":" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(\((Sym3\ = Map[AutToGL2Z[#] &, {Basis0, P12, P23, P13, P123, P132}]\ )\) // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Table[Sym3[\([i]\)] . Sym3[\([j]\)], {i, 6}, {j, 6}] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ { RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]}, { RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]}, { RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]}, { RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]}, { RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]}, { RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", \(-1\)}, {"1", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}]} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell["\<\ For future reference, here is the multiplication table for the \ Symmetric Group:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(\((Sym3MultiplicationTable\ = \ {\n\t\t{"\", "\", \ "\", "\", "\", "\"}, \n\t\ \ {"\", "\", \ "\", "\", "\", "\"}, \n\t\t{"\", "\", \ "\", "\", "\", "\"}, \n\t\t{"\", "\", \ "\", "\", "\", "\"}, \n\t\t{"\", "\", \ "\", "\", "\", "\"}, \n\t\t{"\", "\", \ "\", "\", "\", "\"}\n\t\t\t\t\t\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ })\)\ // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"\<\"P0\"\>", "\<\"P12\"\>", "\<\"P23\"\>", "\<\"P13\"\>", \ "\<\"P123\"\>", "\<\"P132\"\>"}, {"\<\"P12\"\>", "\<\"P0\"\>", "\<\"P132\"\>", "\<\"P123\"\>", "\<\ \"P13\"\>", "\<\"P23\"\>"}, {"\<\"P23\"\>", "\<\"P123\"\>", "\<\"P0\"\>", "\<\"P132\"\>", "\<\ \"P12\"\>", "\<\"P13\"\>"}, {"\<\"P13\"\>", "\<\"P132\"\>", "\<\"P123\"\>", "\<\"P0\"\>", "\<\ \"P23\"\>", "\<\"P12\"\>"}, {"\<\"P123\"\>", "\<\"P23\"\>", "\<\"P13\"\>", "\<\"P12\"\>", "\<\ \"P132\"\>", "\<\"P0\"\>"}, {"\<\"P132\"\>", "\<\"P13\"\>", "\<\"P12\"\>", "\<\"P23\"\>", "\<\ \"P0\"\>", "\<\"P123\"\>"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[TextData[{ "GL(2,Z) ", StyleBox["representations of other automorphisms", FontWeight->"Plain"] }], "Subsubsection"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[AutToGL2Z[#] &, {EllAut, Qx, Qy, Qz, A4, Tx, Ty, FibAut}] // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"2", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-2\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "1"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"1", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "1"}, {"1", "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell["\<\ Let's check the relation between the Dehn twist, the reflection \ and the permutation in terms of matrices:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(\(({p23, qz, tx}\ = \ Map[AutToGL2Z[#] &, {P23, Qz, Tx}])\) // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", \(-1\)}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "1"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(p23 . qz\ == \ tx\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell["The Trace Function in SL(2)", "Section", FontFamily->"Times"], Cell[TextData[{ "If ", StyleBox["W(x1,...,xn)", FontWeight->"Bold"], " is an element in the free group ", StyleBox["Fn", FontWeight->"Bold"], ", then the trace function ", StyleBox["trace W(X1,...,Xn), ", FontWeight->"Bold"], " where ", StyleBox["X1,....,Xn", FontWeight->"Bold"], " are elements of ", StyleBox["SL(2)", FontWeight->"Bold"], ", is a polynomial in the traces of monomials ", StyleBox["trace(Xi Xj Xk ...) ", FontWeight->"Bold"], " where ", StyleBox["i < j < k ... ", FontWeight->"Bold"], " The algorithm below uses several easy facts about the ", StyleBox["trace ", FontWeight->"Bold"], " function and the basic trace relation ", StyleBox[" trace(XY) + tr(XY^{-1}) = trace(X)trace(Y) ", FontWeight->"Bold"], " to compute this polynomial from W:" }], "Text"], Cell[TextData[StyleBox["The TTrace Function", FontWeight->"Plain"]], "Subsection"], Cell[CellGroupData[{ Cell["\<\ First implement some easy facts: the trace of the identity is 2 and \ the trace is invariant under conjugation.\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(TTrace[Word[]]\ := \ 2\)], "Input"], Cell[BoxData[ \(TTrace[Word[i_Integer, a__, j_Integer]]\ := \ TTrace[Word[a]]\ \ \ \ \ /; \ i + j\ == 0\)], "Input"], Cell[BoxData[{ \(TTrace[Word[j_Integer, a___]]\ := \ TTrace[Inverse[Word[a, j]]]\ \ \ /; \ j\ < \ 0\), "\n", \( (*\ make\ the\ first\ letter\ positive\ *) \)}], "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell["\<\ Next, use the basic trace relation to eliminate repeated letters:\ \ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(TTrace[Word[a___, i_Integer, b__, j_Integer, c___]]\ := \ \n\t TTrace[Word[c, a, i]]\ TTrace[Word[b, j]]\ - \n\t TTrace[Word[c, a] . Inverse[Word[b]]]\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ /; \ i\ == \ j\)], "Input"], Cell[BoxData[ \(TTrace[Word[a___, i_Integer, j_Integer, c___]]\ := \ \n\t TTrace[Word[c, a, i]]\ TTrace[Word[j]]\ - \n\t TTrace[Word[c, a]]\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ /; \ i\ == \ j\)], "Input"] }, Open ]] }, Open ]], Cell["\<\ The case when the letters have opposite sign is slightly different:\ \ \>", "Text"], Cell[BoxData[ \(TTrace[Word[a__, i_Integer, b___, j_Integer, c___]]\ := \ \n\t TTrace[Word[c, a, i]]\ TTrace[Word[b, j]]\ + \n\t TTrace[Word[c, a] . Inverse[Word[b]]]\ \ \ \ - \n\t TTrace[Word[c, a, i] . Inverse[Word[b]]]\ TTrace[Word[i]]\ /; \ i + j\ == \ 0\)], "Input"], Cell["\<\ Finally, we want to reduce to traces of words with only positive \ exponents:\ \>", "Text"], Cell[BoxData[ \(Letters[w_Word]\ := \ Sort[Union[\n\ \ \ \ \ \ \ \ Abs[ Map[w[\([#]\)] &, Range[Length[w]]]]\ ]\ ]\)], "Input"], Cell["This just lists the letters in a word.", "Text"], Cell[BoxData[{ \(\(Unprotect[PositiveQ];\)\), "\n", \(PositiveQ[Word[a___, j_Integer]]\ := \ PositiveQ[Word[a]]\ \ \ \ \ /; \ j\ > \ 0\), "\n", \(PositiveQ[Word[a___, j_Integer, b___]]\ := \ False\ \ \ \ \ \ \ \ \ \ \ \ \ /; \ j\ < \ 0\), "\n", \(\(PositiveQ[Word[]]\ := \ True\ ;\)\), "\n", \(\(Protect[PositiveQ];\)\)}], "Input"], Cell["This detects when a word is positive:", "Text"], Cell[BoxData[ \(\(LetterLessThanQ[j_Integer, w_Word]\ := \n\t Apply[And, Map[j < # &, \ Letters[w]]]\ ;\)\)], "Input"], Cell["\<\ This function detects when letter j is less than any of the letters \ in Word w.\ \>", "Text"], Cell[BoxData[ \(\(\(LetterMoreThanQ[j_Integer, w_Word]\)\(\ \)\(:=\)\(\n\)\(\t\)\(Apply[ And, Map[j > # &, \ Letters[w]]]\)\(\ \)\)\)], "Input"], Cell["\<\ This function detects when letter j is more than any of the letters \ in Word w.\ \>", "Text"], Cell[BoxData[{ \(TTrace[Word[a__, j_Integer /; j < 0, b___]]\ := \n\t TTrace[Word[a]]\ TTrace[Word[j, b]]\ - \ \n\t TTrace[Word[a] . Inverse[Word[j, b]]]\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ /; \ \((PositiveQ[ Word[a]]\ && \ LetterNotInWordQ[\(-j\), Word[a]]\ && \n\t\tLetterLessThanQ[\(-j\), Word[b]]\ && \n\t\tLetterMoreThanQ[\(-j\), Word[a]])\)\), "\n", \( (*\ eliminate\ negative\ letters\ in\ middle\ of\ word\ *) \)}], "Input"], Cell[BoxData[ \(TTrace[Word[i_Integer, j_Integer /; j < 0]]\ := \ TTrace[Word[i]] TTrace[Word[j]]\ - \ TTrace[Word[i, \(-j\)]]\)], "Input"], Cell[BoxData[ \(LetterNotInWordQ[j_Integer, w_Word]\ \ := \ \((Position[Letters[w], j]\ == \ {})\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Fricke\ Relation\ puts\ the\ letters\ in\ order\ *) \)\(\n\)\(TTrace[ Word[a__, j_Integer, k_Integer, b___]]\ := \t\n\t\(\(TTrace[Word[a]]\ TTrace[ Word[j, k, b]]\ + \ \n\t TTrace[Word[j]]\ TTrace[Word[k, b, a]]\ + \ \n\t TTrace[Word[k, b]]\ TTrace[Word[a, j]]\ - \n\t TTrace[Word[a]]\ TTrace[Word[j]]\ TTrace[Word[k, b]]\ - \n\t TTrace[Word[a, k, b, j]]\)\(\ \t\t\t\t\)\(/;\)\((Abs[k]\ < \ Abs[j])\)\(\ \)\)\)\)\)], "Input"], Cell[BoxData[ \(TTrace[ Word[j_Integer, k_Integer, b___]]\ := \ \n\t\t\(\(TTrace[ Word[k, b, j]]\)\(\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \)\(/;\)\((Abs[ k]\ < \ Abs[j])\)\(\ \)\)\)], "Input"], Cell[TextData[StyleBox["Some Examples", FontWeight->"Plain"]], "Subsection"], Cell[TextData[{ StyleBox["TTrace[Word[...]] ", FontWeight->"Bold"], "expresses the trace of a word in elements of ", StyleBox["SL(2)", FontWeight->"Bold"], " in terms of traces of the generators and their products, in increasing \ order. Here are some examples:" }], "Text"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(TTrace[Word[1, 2, \(-3\)]]\)], "Input"], Cell[BoxData[ \(TTrace[Word[3]]\ TTrace[Word[1, 2]] - TTrace[Word[1, 2, 3]]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(TTrace[Word[1, \(-2\), \(-3\)]]\)], "Input"], Cell[BoxData[ \(TTrace[Word[1]]\ TTrace[Word[2]]\ TTrace[Word[3]] - TTrace[Word[3]]\ TTrace[Word[1, 2]] - TTrace[Word[2]]\ TTrace[Word[1, 3]] + TTrace[Word[1, 2, 3]]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(TTrace[Word[1, 2, \(-1\), 2, 2]]\)], "Input"], Cell[BoxData[ \(TTrace[Word[2]] - TTrace[Word[1]]\ TTrace[ Word[1, 2]] + \((TTrace[Word[1]]\ TTrace[Word[2]] - TTrace[Word[1, 2]])\)\ \((\(-TTrace[Word[1]]\) + TTrace[Word[2]]\ TTrace[Word[1, 2]])\)\)], "Output"] }, Open ]], Cell[TextData[{ "Using ", StyleBox["Mathematica", FontSlant->"Italic"], "'s substitution rules, we can write the trace polynomials in terms of \ variables. Here we use the ", StyleBox["Fricke ", FontWeight->"Bold"], " coordinates ", StyleBox["(TTrace[Word[1]],TTrace[Word[2]],TTrace[Word[1,2]]):", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(TracePoly[Word[w__], {x_, y_, z_}]\ := \ Expand[TTrace[Word[w]] /. {TTrace[Word[1]] -> x, TTrace[Word[2]] -> y, TTrace[Word[1, 2]] -> z}]\)], "Input"], Cell["Here is a typical trace polynomial:", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(TracePoly[Word[1, 2, \(-1\), 2, 2], {a, y, z}]\)], "Input"], Cell[BoxData[ \(y - a\^2\ y + a\ y\^2\ z - y\ z\^2\)], "Output"] }, Open ]], Cell[TextData[StyleBox["Tschebyshev Polynomials", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "The traces of powers of an element ", StyleBox["A ", FontWeight->"Bold"], " of ", StyleBox["SL(2)", FontWeight->"Bold"], " are Tschebyshev polynomials in the trace of ", StyleBox["A.", FontWeight->"Bold"] }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[TracePoly[Apply[Word, Table[1, {#}]], {x, y, z}] &, Range[12]] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"x"}, {\(\(-2\) + x\^2\)}, {\(\(-3\)\ x + x\^3\)}, {\(2 - 4\ x\^2 + x\^4\)}, {\(5\ x - 5\ x\^3 + x\^5\)}, {\(\(-2\) + 9\ x\^2 - 6\ x\^4 + x\^6\)}, {\(\(-7\)\ x + 14\ x\^3 - 7\ x\^5 + x\^7\)}, {\(2 - 16\ x\^2 + 20\ x\^4 - 8\ x\^6 + x\^8\)}, {\(9\ x - 30\ x\^3 + 27\ x\^5 - 9\ x\^7 + x\^9\)}, {\(\(-2\) + 25\ x\^2 - 50\ x\^4 + 35\ x\^6 - 10\ x\^8 + x\^10\)}, {\(\(-11\)\ x + 55\ x\^3 - 77\ x\^5 + 44\ x\^7 - 11\ x\^9 + x\^11\)}, {\(2 - 36\ x\^2 + 105\ x\^4 - 112\ x\^6 + 54\ x\^8 - 12\ x\^10 + x\^12\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[TextData[StyleBox["The Commutator Trace ", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "Here is the familiar cubic polynomial expressing the commutator trace in ", StyleBox["F2:", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(Kappa[{x_, y_, z_}]\ := \ TracePoly[KWord, {x, y, z}]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(Kappa[{a, b, c}]\)], "Input"], Cell[BoxData[ \(\(-2\) + a\^2 + b\^2 - a\ b\ c + c\^2\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Traces in a rank 3 free group", FontWeight->"Plain"]], "Subsubsection", CellTags->"tag1"], Cell[BoxData[ \(TracePoly3[Word[w__], {t12_, t23_, t13_, t1_, t2_, t3_, t123_}]\ := \ Expand[TTrace[Word[w]] /. {TTrace[Word[1]] \[Rule] t1, TTrace[Word[2]] \[Rule] t2, TTrace[Word[1, 2]] \[Rule] t12, \[IndentingNewLine]TTrace[Word[3]] \[Rule] \ t3, \ TTrace[Word[1, 3]] \[Rule] t13, \ TTrace[Word[2, 3]] \[Rule] \ t23, TTrace[Word[1, 2, 3]] \[Rule] t123}]\)], "Input", CellTags->{"tag1", "In[132]:="}], Cell[BoxData[ \(\(tList\ = {t12, t23, t13, t1, t2, t3, t123}\ ;\)\)], "Input", CellTags->{"tag1", "In[133]:="}], Cell[BoxData[ \(\(S12sub\ = \ {t1 \[Rule] a, t2 \[Rule] x, t3 \[Rule] y, t12 \[Rule] w, t13 \[Rule] p, t23 \[Rule] z, t123 \[Rule] \ u};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(\((t123m2\ = \ TracePoly3[Word[\ 1, 2, 3, \(-2\)], tList])\) /. S12sub\)], "Input", CellTags->{"tag1", "In[135]:="}], Cell[BoxData[ \(\(-p\) + u\ x + a\ y - w\ z\)], "Output", CellTags->{"tag1", "In[135]:="}] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\((t123m2m3 = \ TracePoly3[Word[\ 1, 2, 3, \(-2\), \(-3\)], tList])\) /. S12sub\)], "Input", CellTags->{"tag1", "In[136]:="}], Cell[BoxData[ \(\(-a\) + w\ x - p\ y + a\ y\^2 + u\ z - w\ y\ z\)], "Output", CellTags->{"tag1", "In[136]:="}] }, Open ]], Cell[BoxData[ \(FrickePolynomial[{{a_, b_, c_, d_}, {x_, y_, z_}}] := Simplify[x\^2 + y\^2 + z\^2 + x\ y\ z - \((a\ b + c\ d)\)\ x - \((b\ c + a\ d)\)\ y - \((a\ c + b\ d)\)\ z + \((\(-4\) + a\^2 + b\^2 + c\^2 + d\^2 + a\ b\ c\ d)\)]\)], "Input", CellTags->{"tag1", "In[137]:="}] }, Open ]], Cell["Computations for the 1-holed Klein Bottle", "Subsection"], Cell[TextData[StyleBox["The boundary element of a 1-holed Klein bottle", FontWeight->"Plain"]], "Text"], Cell[BoxData[ \(\(KleinBottleDWord\ = \ Word[1, 1, 2, 2];\)\)], "Input"], Cell[TextData[StyleBox["The simple loop on the 1-holed Klein bottle \ separating off a handle from the boundary", FontWeight->"Plain"]], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(KleinBottleCWord\ = \ ApplyWord[KWord, {Word[1, 1], Word[2]}]\)], "Input"], Cell[BoxData[ \(Word[1, 1, 2, \(-1\), \(-1\), \(-2\)]\)], "Output"] }, Open ]], Cell[TextData[{ "We assume that the elements ", StyleBox["X, Y ", FontWeight->"Bold"], " reverse orientation and thus ", StyleBox["XY ", FontWeight->"Bold"], "preserves orientation." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(kbd\ = \ TracePoly[KleinBottleDWord, {I\ x, \ I\ y, z}]\)], "Input"], Cell[BoxData[ \(2 + x\^2 + y\^2 - x\ y\ z\)], "Output"] }, Open ]], Cell["This is the peripheral trace for the 1-holed Klein bottle.", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(kbc\ = \ TracePoly[KleinBottleCWord, {I\ x, \ I\ y, z}]\)], "Input"], Cell[BoxData[ \(2 + 4\ x\^2 + x\^4 + x\^2\ y\^2 - x\^3\ y\ z - x\^2\ z\^2\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(kappa\ = \ Kappa[{I\ x, \ I\ y, z}]\)], "Input"], Cell[BoxData[ \(\(-2\) - x\^2 - y\^2 + x\ y\ z + z\^2\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(kbc\ - \ \((\(-\ \((kappa\ - \ 2\ )\)\)\ x\^2\ \ + \ 2)\) // Simplify\)], "Input"], Cell[BoxData[ \(0\)], "Output"] }, Open ]], Cell["Automorphisms of the Character Variety", "Section", FontFamily->"Times"], Cell[TextData[{ "Now we see how ", StyleBox["Aut(F2) ", FontWeight->"Bold"], " acts by polynomial automorphisms of the relative character variety. That \ is, we find polynomial automorphisms of affine 3-space which preserve the ", StyleBox["Kappa ", FontWeight->"Bold"], "polynomial.\.13 " }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(P12\)], "Input"], Cell[BoxData[ \({Word[2], Word[1]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, P12]\)], "Input"], Cell[BoxData[ \({y, x}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(PantsRep[P12]\)], "Input"], Cell[BoxData[ \({Word[2], Word[1], Word[\(-1\), \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, PantsRep[P12]]\)], "Input"], Cell[BoxData[ \({y, x, z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, PantsRep[Qx]]\)], "Input"], Cell[BoxData[ \({\(-x\) + y\ z, y, z}\)], "Output"] }, Open ]], Cell[TextData[{ "The ", StyleBox["TrAuto[A] ", FontWeight->"Bold"], " computes the action on traces induced by the ", StyleBox["inverse", FontWeight->"Bold"], " of the automorphism ", StyleBox["A ", FontWeight->"Bold"], " of ", StyleBox["F2.", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(TrAuto[A_]\ := \ Map[TracePoly[#, {x, y, z}] &, PantsRep[A]]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(TrAuto[EllInv]\)], "Input"], Cell[BoxData[ \({x, y, z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(TrAuto[P23]\)], "Input"], Cell[BoxData[ \({x, z, y}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(TrAuto[P123]\)], "Input"], Cell[BoxData[ \({z, x, y}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\(\(TrAuto[Tx]\)\(\ \)\)\)], "Input"], Cell[BoxData[ \({x, z, \(-y\) + x\ z}\)], "Output"] }, Open ]], Cell["Relations in the Mapping Class Group", "Section", FontFamily->"Times"], Cell[TextData[StyleBox["The Braid Relation", FontWeight->"Plain"]], "Subsection"], Cell[TextData[{ "The twist automorphisms ", StyleBox["Tx, Tyi ", FontWeight->"Bold"], " satisfy the relation ", StyleBox["Tx Tyi Tx = Tyi Tx Tyi. ", FontWeight->"Bold"], " This common value is the element ", StyleBox["A4", FontWeight->"Bold"], " which has order 4 in ", StyleBox["Out(F2)", FontWeight->"Bold"], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[# == A4 &, {ComposeAuto[Tx, Tyi, Tx], ComposeAuto[Tyi, Tx, Tyi]}]\)], "Input"], Cell[BoxData[ \({True, True}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[MatrixForm[SymbolWord[#]] &, {Tx, Tyi, A4}]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"\<\"A\"\>"}, {"\<\"BA\"\>"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"\<\"Ab\"\>"}, {"\<\"B\"\>"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"\<\"b\"\>"}, {"\<\"BAb\"\>"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Tx, Tyi, Tx, Ty, Txi, Ty]\)], "Input"], Cell[BoxData[ \({Word[1], Word[2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\[AliasDelimiter]\)], "Input"], Cell[BoxData[ \(\[AliasDelimiter]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \({ComposeAuto[Tx, Tyi, Tx], ComposeAuto[Tyi, Tx, Tyi], A4} // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[2, 1, \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[2, 1, \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-2\)]\)}, {\(Word[2, 1, \(-2\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[TextData[{ "Here is what their images in ", StyleBox["GL(2,Z)", FontWeight->"Bold"], " look like:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[AutToGL2Z, {Tx, Tyi, ComposeAuto[Tx, Tyi, \ Tx]}] // MF\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "1"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {\(-1\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "1"}, {\(-1\), "0"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[A4, A4, A4, A4]\ \[Equal] \ Inn[Word[2, 1, \(-2\), \(-1\)]]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[A4, A4]\)], "Input"], Cell[BoxData[ \({Word[2, \(-1\), \(-2\)], Word[2, 1, \(-2\), \(-1\), \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(EllInv\)], "Input"], Cell[BoxData[ \({Word[\(-1\)], Word[\(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Inn[Word[\(-2\), \(-1\)]]\)], "Input"], Cell[BoxData[ \({Word[\(-2\), 1, 2], Word[\(-2\), \(-1\), 2, 1, 2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Inn[Word[\(-2\), \(-1\)]], EllInv] \[Equal] ComposeAuto[A4, A4]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["The modular group SL(2,Z) (by Matt Bainbridge)\.18\.13", "Section", FontFamily->"Times"], Cell[BoxData[ \(expand[M_]\ := \ Block[{w\ = \ Word[], \ m\ = \ M, \ i\ = \ 0, \ s}, \ \n\ \ \ \ \ While[ m[\([1, 1]\)]\ != \ 0\ && \ m[\([2, 1]\)]\ != \ 0, \ \n\ \ \ \ \ If[ Abs[m[\([2, 1]\)]]\ > \ Abs[m[\([1, 1]\)]], \ \n\ \ \ \ \ \ \ \ \ m\ = \ {{0, \ \(-1\)}, \ \ {1, \ 0}}\ . \ m; \ \n\ \ \ \ \ \ \ \ \ w\ = \ w\ . \ Word[2]]; \ \n\ \ \ \ \ \ \ \ w\ = \ w\ . \ Word[ s\ = \ Sign[m[\([1, 1]\)]]* Sign[m[\([2, 1]\)]]]; \ \n\ \ \ \ \ \ \ \ m\ = \ {{1, \ \ \(-s\)}, \ {0, \ 1}}\ . \ m]; \ \n\ \ \ \ \ If[ m[\([1, 1]\)]\ == \ 0, \ \n\ \ \ \ \ \ \ m\ = \ {{0, \ \(-1\)}, \ {1, \ 0}}\ . \ m; \ \n\ \ \ \ \ \ \ w\ = \ w\ . \ Word[2]]; \ \n\ \ \ \ \ If[ m[\([1, 1]\)]\ == \ \(-1\), \ \n\ \ \ \ \ \ \ m\ = \ {{\(-1\), \ 0}, \ {0, \ \(-1\)}}\ . \ m; \ \n\ \ \ \ \ \ \ w\ = \ w\ . \ Word[2, \ 2]]; \ \n\ \ \ \ \ \ For[i\ = \ 1, \ i\ <= \ Abs[m[\([1, 2]\)]], \ \n\ \ \ \ \ \ \ \ \ \ \(i++\), \ w\ = \ w\ . \ Word[Sign[m[\([1, 2]\)]]]]; \ w]\)], "Input"], Cell[BoxData[ \(Uu[n_]\ := \ {{1, n}, {0, 1}}\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(Uu[5] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "5"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(expand[Uu[5]]\)], "Input"], Cell[BoxData[ \(Word[1, 1, 1, 1, 1]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(expand[Uu[\(-6\)]]\)], "Input"], Cell[BoxData[ \(Word[\(-1\), \(-1\), \(-1\), \(-1\), \(-1\), \(-1\)]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(expand[{{5, \(-1\)}, {1, 0}} . {{0, \(-1\)}, {1, 3}}]\)], "Input"], Cell[BoxData[ \(Word[2, 2, 1, 1, 1, 1, 1, 1, 1, 1]\)], "Output"] }, Open ]], Cell["The Trace-Reduction Algorithm (by George Stantchev)", "Section", FontFamily->"Times"], Cell[BoxData[ \(traceReduce[v_List] := Module[{l, \ w}, \n\t (*\t\(If[f @@ v\ < \ 2, \ Print["\"]; \ Return[]];\)\n\t\t\t*) \[IndentingNewLine]If[\((v[\([1]\)]\ - 2\ )\)*\((\ v[\([2]\)]\ - 2)\)\ *\((\ v[\([3]\)]\ - \ 2)\)\ <= 0, \ Print[\n\t\t\t\t"\"]; \ \ \[IndentingNewLine]\t If[v[\([1]\)]\ > \ \(-2\)\ || \ v[\([2]\)]\ > \ \(-2\)\ || \ v[\([3]\)]\ > \ \(-2\), \ Print[\[IndentingNewLine]\t"\"]]; Print[v]; \n\t\t\tcount\ = \ 0; Return[]]; \[IndentingNewLine]w\ = \ v; \[IndentingNewLine]Print["\", \ v]; \[IndentingNewLine]Print["\", \ count]; \[IndentingNewLine]If[w[\([1]\)]\ < \ \(-2\), \ w[\([1]\)]\ = \ \(-w[\([1]\)]\)]; \[IndentingNewLine]If[ w[\([2]\)]\ < \ \(-2\), \ w[\([2]\)]\ = \ \(-w[\([2]\)]\)]; \[IndentingNewLine]If[ w[\([3]\)]\ < \ \(-2\), \ w[\([3]\)]\ = \ \(-w[\([3]\)]\)]; If[w[\([1]\)]\ <= 2\ || \ w[\([2]\)]\ <= 2\ || w[\([3]\)]\ <= \ 2, \ Print[\n\t\t\t\t"\"]; \t\t\n\t\t\ \t\tPrint[v]; count = 0; Return[]]; \n\t\tw\ = Sort[w]; \n\t\tw[\([3]\)]\ = \ w[\([1]\)]*w[\([2]\)]\ - \ w[\([3]\)]; \n\t\t\(count++\); \n\t traceReduce[w];\n\t\t]\)], "Input"], Cell["An example", "Subsection"], Cell[CellGroupData[{ Cell[BoxData[ \(ExampleAuto\ = \ ComposeAuto[Ty, Tx, Ty, Tx, Ty]\)], "Input"], Cell[BoxData[ \({Word[1, 2, 2, 1, 2, 2, 1, 2, 1, 2, 2, 1, 2], Word[2, 1, 2, 1, 2, 2, 1, 2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ExampleTrace\ = \ TrAuto[ExampleAuto]\)], "Input"], Cell[BoxData[ \({x - x\ y\^2 - 2\ x\^2\ y\ z + y\^3\ z + x\ z\^2 - x\^3\ z\^2 + 4\ x\ y\^2\ z\^2 - y\ z\^3 + 3\ x\^2\ y\ z\^3 - 2\ y\^3\ z\^3 - 3\ x\ y\^2\ z\^4 + y\^3\ z\^5, x\ y - z + x\^2\ z - y\^2\ z - 2\ x\ y\ z\^2 + y\^2\ z\^3, y + x\^2\ y - x\^2\ y\^3 + x\^3\ z - 3\ x\^3\ y\^2\ z + 2\ x\ y\^4\ z - y\ z\^2 + x\^2\ y\ z\^2 - 3\ x\^4\ y\ z\^2 - y\^3\ z\^2 + 9\ x\^2\ y\^3\ z\^2 - y\^5\ z\^2 - x\ z\^3 + 2\ x\^3\ z\^3 - x\^5\ z\^3 - 5\ x\ y\^2\ z\^3 + 12\ x\^3\ y\^2\ z\^3 - 9\ x\ y\^4\ z\^3 + y\ z\^4 - 6\ x\^2\ y\ z\^4 + 5\ x\^4\ y\ z\^4 + 3\ y\^3\ z\^4 - 18\ x\^2\ y\^3\ z\^4 + 3\ y\^5\ z\^4 + 6\ x\ y\^2\ z\^5 - 10\ x\^3\ y\^2\ z\^5 + 12\ x\ y\^4\ z\^5 - 2\ y\^3\ z\^6 + 10\ x\^2\ y\^3\ z\^6 - 3\ y\^5\ z\^6 - 5\ x\ y\^4\ z\^7 + y\^5\ z\^8}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[{ \(\(count\ = \ 0;\)\), "\n", \(traceReduce[ ExampleTrace\ /. \ {x -> \ \(-3\), y -> \(-3\), z -> \(-3\)}]\)}], "Input"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{12957, \(-393\), \ \(-5092068\)}\), SequenceForm[ "v=", {12957, -393, -5092068}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]0\), SequenceForm[ "count =", 0], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{393, 12957, 33}\), SequenceForm[ "v=", {393, 12957, 33}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]1\), SequenceForm[ "count =", 1], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{33, 393, 12}\), SequenceForm[ "v=", {33, 393, 12}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]2\), SequenceForm[ "count =", 2], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{12, 33, 3}\), SequenceForm[ "v=", {12, 33, 3}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]3\), SequenceForm[ "count =", 3], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{3, 12, 3}\), SequenceForm[ "v=", {3, 12, 3}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]4\), SequenceForm[ "count =", 4], Editable->False]], "Print"], Cell[BoxData[ \("character in [-inf, 2]^3. Exiting..."\)], "Print"], Cell[BoxData[ \("character in [-2, 2]"\)], "Print"], Cell[BoxData[ \({3, 3, \(-3\)}\)], "Print"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(traceReduce[ ExampleTrace\ /. \ {x -> \ \(-3\), y -> \(-3\), z -> 0}]\)], "Input"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{24, 9, 213}\), SequenceForm[ "v=", {24, 9, 213}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]0\), SequenceForm[ "count =", 0], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{9, 24, 3}\), SequenceForm[ "v=", {9, 24, 3}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]1\), SequenceForm[ "count =", 1], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("v="\[InvisibleSpace]{3, 9, 3}\), SequenceForm[ "v=", {3, 9, 3}], Editable->False]], "Print"], Cell[BoxData[ InterpretationBox[\("count ="\[InvisibleSpace]2\), SequenceForm[ "count =", 2], Editable->False]], "Print"], Cell[BoxData[ \("character in [-inf, 2]^3. Exiting..."\)], "Print"], Cell[BoxData[ \("character in [-2, 2]"\)], "Print"], Cell[BoxData[ \({3, 3, 0}\)], "Print"] }, Open ]], Cell[" Free Groups of Rank 3", "Section", FontFamily->"Times"], Cell[CellGroupData[{ Cell["Trace Computations", "Subsection"], Cell[TextData[{ "The following function expresses the trace of a word in 3 generators ", StyleBox["Word[1], Word[2], Word[3] ", FontWeight->"Bold"], "in terms of the traces of the words ", StyleBox[" Word[1,], Word[2], Word[3], Word[1,2], Word[2,3], Word[1,3] ", FontWeight->"Bold"], " and ", StyleBox["Word[1,2,3].", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(TracePoly3[Word[w__], {t12_, t23_, t13_, t1_, t2_, t3_, t123_}]\ := \ Expand[TTrace[Word[w]] /. {TTrace[Word[1]] \[Rule] t1, TTrace[Word[2]] \[Rule] t2, TTrace[Word[1, 2]] \[Rule] t12, \[IndentingNewLine]TTrace[Word[3]] \[Rule] \ t3, \ TTrace[Word[1, 3]] \[Rule] t13, \ TTrace[Word[2, 3]] \[Rule] \ t23, TTrace[Word[1, 2, 3]] \[Rule] t123}]\)], "Input"], Cell[BoxData[ \(\(tList\ = {t12, t23, t13, t1, t2, t3, t123}\ ;\)\)], "Input"], Cell["Let's define a shorthand function for dealing with traces. ", "Text"], Cell[BoxData[ \(t[inputs__] := \ TracePoly3[Word[inputs], tList]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(t[2, 3, 1]\)], "Input"], Cell[BoxData[ \(t123\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(t[1, 2, 3]\)], "Input"], Cell[BoxData[ \(t123\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[TextData[StyleBox["Derivation of Fricke's 3-Generator Sum Formula ", FontWeight->"Plain"]], "Subsubsection"], Cell[CellGroupData[{ Cell[BoxData[ \(t[1, 3, 2]\)], "Input"], Cell[BoxData[ \(\(-t123\) + t13\ t2 + t1\ t23 + t12\ t3 - t1\ t2\ t3\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(t[1, 2, 3]\ + \ t[1, 3, 2]\)], "Input"], Cell[BoxData[ \(t13\ t2 + t1\ t23 + t12\ t3 - t1\ t2\ t3\)], "Output"] }, Open ]], Cell[TextData[{ "obtaining ", StyleBox["Fricke's Sum Formula", FontWeight->"Bold", FontSlant->"Italic"], ". " }], "Text"], Cell[TextData[StyleBox["Derivation of Fricke's 3-Generator Product Formula ", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "The Product Formula is trickier. We want to use the Basic Identity to \ express the product \n ", StyleBox["Trace(Word[1,2,3]) Trace(Word[1,3,2]) ", FontWeight->"Bold"], "as the sum \n", StyleBox["Trace[Word[1,2,3] Word [1,3,2]) + Trace[Word[1,2,3] \ Inverse(Word[1,3,2])] \n", FontWeight->"Bold"], " but our algorithm expresses the first summand in terms of ", StyleBox["Trace[Word[1,2,3]] = t[1,2,3]", FontWeight->"Bold"], "." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(t[1, 2, 3, 1, 3, 2]\)], "Input"], Cell[BoxData[ \(2 - t123\^2 + t123\ t13\ t2 - t2\^2 + t1\ t123\ t23 - t23\^2 + t12\ t123\ t3 - t1\ t123\ t2\ t3 + t2\ t23\ t3 - t3\^2\)], "Output"] }, Open ]], Cell["The other summand is OK:", "Text", FontWeight->"Plain"], Cell[CellGroupData[{ Cell[BoxData[ \(t[1, 2, 3, \(-2\), \(-3\), \(-1\)]\)], "Input"], Cell[BoxData[ \(\(-2\) + t2\^2 + t23\^2 - t2\ t23\ t3 + t3\^2\)], "Output"] }, Open ]], Cell[TextData[{ "So let's break up", "\n ", StyleBox["Word[1,2,3,1,3,2]", FontWeight->"Bold"], "\nas ", "the product ", StyleBox["Word[1,2] Word[3,1,3,2] ", FontWeight->"Bold"], " and express the ", "traces in terms of positive words of length at most 2." }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Word[1, 2] . Word[3, 1, 3, 2]\)], "Input"], Cell[BoxData[ \(Word[1, 2, 3, 1, 3, 2]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Inverse[Word[1, 2]] . Word[3, 1, 3, 2]\)], "Input"], Cell[BoxData[ \(Word[\(-2\), \(-1\), 3, 1, 3, 2]\)], "Output"] }, Open ]], Cell["\<\ These are the words to which we apply the Basic Identity, obtaining \ an expression for the trace of Word[1,2,3,1,3,2] in terms of traces of words \ of length at most 2.\ \>", "Text", FontWeight->"Plain"], Cell[CellGroupData[{ Cell[BoxData[ \(temp123132\ = t[1, 2]\ t[3, 1, 3, 2] - t[\(-2\), \(-1\), 3, 1, 3, 2] // Expand\)], "Input"], Cell[BoxData[ \(\(-2\) + t1\^2 + t12\^2 + t13\^2 - t1\ t12\ t2 + t12\ t13\ t23 - t1\ t13\ t3\)], "Output"] }, Open ]], Cell[TextData[{ "This expression represents the trace ", StyleBox[" t[1,2,3,1,3,2] ", FontWeight->"Bold"], "of ", StyleBox["Word[1,2,3,1,3,2]", FontWeight->"Bold"], ". " }], "Text"], Cell[TextData[{ "The product ", StyleBox["t[1,2,3] t[1,3,2]", FontWeight->"Bold"], " equals the sum ", StyleBox["t[1,2,3,1,3,2] + t[1,2,3,-2,-3,-1] ", FontWeight->"Bold"], " so that ", StyleBox["t[1,2,3] t[1,3,2]", FontWeight->"Bold"], " equals:" }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(temp123132\ \ + \ t[1, 2, 3, \(-2\), \(-3\), \(-1\)]\)], "Input"], Cell[BoxData[ \(\(-4\) + t1\^2 + t12\^2 + t13\^2 - t1\ t12\ t2 + t2\^2 + t12\ t13\ t23 + t23\^2 - t1\ t13\ t3 - t2\ t23\ t3 + t3\^2\)], "Output"] }, Open ]], Cell[TextData[{ "obtaining ", StyleBox["Fricke's Product Formula", FontWeight->"Bold", FontSlant->"Italic"], ". " }], "Text"] }, Open ]], Cell[CellGroupData[{ Cell["The Four-Holed Sphere", "Subsection"], Cell[TextData[{ "The fundamental group of the 4-holed sphere S4 has presentation\n\t\t\t", StyleBox["< A , B, C, D | A B C D = 1>", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(\({AA, BB, CC, DD} = \ {Word[1], Word[2], \ Word[3], Word[\(-3\), \(-2\), \(-1\)]};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(AA . \ BB . \ CC . \ DD\ \[Equal] Word[]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[BoxData[ \(QTracePoly[Word[w__], {a_, b_, c_, d_, x_, y_, z_}]\ := \ Expand[TTrace[Word[w]] /. {TTrace[Word[1]] -> a, TTrace[Word[2]] -> b, \n\t\t\t\tTTrace[Word[3]] -> \ c, \ TTrace[Word[1, 2, 3]] -> \ d, \n\t\t\t\t\tTTrace[Word[1, 2]] -> x, \ TTrace[Word[2, 3]] -> \ y, \ TTrace[Word[3, 1]] -> z}]\)], "Input"], Cell[BoxData[ \(\(abcd\ = \ {a, b, c, d, x, y, z};\)\)], "Input"], Cell[BoxData[ \(\(S4Words = {Word[1], Word[2], Word[3], Word[\(-3\), \(-2\), \(-1\)], Word[1, 2], Word[2, 3], Word[3, 1]};\)\)], "Input"], Cell[TextData[{ "The symmetric group acting on ", StyleBox["S4", FontWeight->"Bold"] }], "Subsubsection", FontWeight->"Plain"], Cell[TextData[{ "The permutations of the boundary components act on the surface ", StyleBox["S4", FontWeight->"Bold"], ",. The action on the fundamental\ngroup is described as follows:" }], "Text"], Cell[BoxData[ \(\(\(\(Q12\ = \ {Word[2], Word[\(-2\), 1, 2], Word[3]};\)\[IndentingNewLine] \(Q23\ = \ {Word[1], Word[3], Word[\(-3\), 2, 3]};\)\[IndentingNewLine] \(Q34\ = \ {Word[1], Word[2], \ Word[\(-3\), \(-2\), \(-1\)]};\)\)\(\ \)\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(S4Words\)], "Input"], Cell[BoxData[ \({Word[1], Word[2], Word[3], Word[\(-3\), \(-2\), \(-1\)], Word[1, 2], Word[2, 3], Word[3, 1]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ApplyAuto[Q12, #] &, {Word[1], Word[2]}]\)], "Input"], Cell[BoxData[ \({Word[2], Word[\(-2\), 1, 2]}\)], "Output"] }, Open ]], Cell[BoxData[ \(\(\(\ \)\(TP12\ = \((Expand[\(TracePoly3[#, tList] /. S12sub\)\ /. \ pSub]\ &)\);\)\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(aa = Map[ApplyAuto[Q12, #] &, S4Words]\)], "Input"], Cell[BoxData[ \({Word[2], Word[\(-2\), 1, 2], Word[3], Word[\(-3\), \(-2\), \(-1\)], Word[1, 2], Word[\(-2\), 1, 2, 3], Word[3, 2]}\)], "Output"] }, Open ]], Cell[BoxData[ \(\(TPS4\ = \ \((QTracePoly[#, abcd] &)\);\)\)], "Input"], Cell[BoxData[ \(TPolyAutS4[a_] := \ Map[TPS4, Map[ApplyAuto[a, #] &, S4Words]]\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ MatrixForm[TPolyAutS4[#]] &, {Map[Word, Range[3]], Q12, Q23, Q34}]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {"x"}, {"y"}, {"z"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"b"}, {"a"}, {"c"}, {"d"}, {"x"}, {\(a\ c + b\ d - x\ y - z\)}, {"y"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"c"}, {"b"}, {"d"}, {"z"}, {"y"}, {\(a\ b + c\ d - x - y\ z\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"d"}, {"c"}, {"x"}, {\(a\ c + b\ d - x\ y - z\)}, {"y"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[TextData[{ "The induced maps on boundary traces are:\n\n", StyleBox["Q12: (a,b,c,d) |-> (b,a,c,d),\nQ23: (a,b,c,d) |-> (a,c,b,d)\nQ34: \ (a,b,c,d_|-> (a,b,d,c). ", FontWeight->"Bold"] }], "Text"], Cell["For the interior traces, let:", "Text"], Cell[BoxData[{ \(\(zprime\ = \ \(-z\)\ - \ x\ y\ + \ a\ c\ + \ b\ d;\)\), "\n", \(\(xprime\ = \ \(-x\)\ - \ y\ z\ + \ a\ b\ + \ c\ d;\)\), "\[IndentingNewLine]", \(\(yprime\ = \ \ \(-y\) - \ x\ z\ \ + \ b\ c + a\ d;\)\)}], "Input"], Cell[TextData[{ "and the induced maps on interior traces are:\n", StyleBox["Q12: (x, y, z) |-> (x, zprime, y),\nQ23: (x, y, z) |-> (z, y, \ xprime),\nQ34: (x, y, z) |-> (x, zprime, y). ", FontWeight->"Bold"], "\n", StyleBox[" \n ", FontWeight->"Bold"], "The even involutions act trivially on the three interior traces." }], "Text"], Cell[CellGroupData[{ Cell[TextData[{ StyleBox["The genus-1 double cover of ", FontWeight->"Plain"], "S4 " }], "Subsubsection"], Cell[TextData[{ "To understand the mapping class group of the 4-holed sphere ", StyleBox["S4", FontWeight->"Bold"], ", we pass to the double covering\ndefined by the 2-fold character which is \ nontrivial on each boundary component.\nThe total space is a 4-holed torus \ T4 whose fundamental group has presentation\n\n\t\t\t", StyleBox["< U, V, AA, BB, CC, DD | U V u v AA BB CC DD = 1 >", FontWeight->"Bold"] }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(T4Relation = KWord . Word[3, 4, 5, 6]\)], "Input"], Cell[BoxData[ \(Word[1, 2, \(-1\), \(-2\), 3, 4, 5, 6]\)], "Output"] }, Open ]], Cell[TextData[{ "The covering space induces the homomorphism\n\n", StyleBox["U \t|->\tA B\nV\t|->\tC A\nAA\t|->\t(C A c)^2\nBB \t|->\t(C B \ c)^2\nCC\t|->\tC ^2\nDD\t|->\t(D)^2", FontWeight->"Bold"] }], "Text"], Cell["\<\ We verify that this induces a homorphism of fundamental \ groups:\ \>", "Text"], Cell[BoxData[ \(\({UU\ = \ Word[1, 2], \ VV\ = \ Word[3, 1]};\)\)], "Input"], Cell[BoxData[ \(\({AA2, BB2, CC2, DD2}\ = \ {InnerAutomorphism[CC, AA . AA], InnerAutomorphism[CC, BB . BB], \((CC . CC)\), \((DD . DD)\)};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyWord[T4Relation, {UU, VV, AA2, BB2, CC2, DD2}]\ \[Equal] Word[]\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["The homology of T4 is obtained by killing AA,BB,CC,DD. ", "Text"], Cell["\<\ We work in the fundamental group of S4, where the generators A, B, \ C are denoted Word]1], Word[2], Word[3] respectively. Here is the first Dehn twist (around \ X = AB ):\ \>", "Text"] }, Open ]], Cell[TextData[StyleBox["Dehn Twists", FontWeight->"Plain"]], "Subsubsection"], Cell[CellGroupData[{ Cell[BoxData[ \(\((Twx\ = \ {Word[1], Word[2], Word[1, 2, 3, \(-2\), \(-1\)]})\) // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[2]\)}, {\(Word[1, 2, 3, \(-2\), \(-1\)]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell["\<\ Since the images of U and V generate the homology, it suffices to \ check the effect of an automorphism on U = Word[1,2] and V = Word[3,1]:\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ApplyAuto[Twx, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \({Word[1, 2], Word[1, 2, 3, \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[Twx, Word[3, 1]]\ \[Equal] \[IndentingNewLine]UU . \ Word[3, 3]\ . \ \((DD . DD)\) . \ UU . \ VV\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[MatrixTwx = {{1, 2}, {0, 1}}]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "2"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\((Twy\ = \ {Word[2, 3, 1, \(-3\), \(-2\)], Word[2], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 3, 1, \(-3\), \(-2\)]\)}, {\(Word[2]\)}, {\(Word[3]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ApplyAuto[Twy, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \({Word[2, 3, 1, \(-3\)], Word[3, 2, 3, 1, \(-3\), \(-2\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ ApplyAuto[Twy, #] &, {UU, VV}]\ \[Equal] \[IndentingNewLine]{Inverse[VV] . Inverse[UU] . Inverse[DD2] . Inverse[VV] . AA2, BB2 . CC2 . DD2 . UU . VV . VV . DD2 . UU . VV}\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[MatrixTwy = {{\(-1\), 2}, {\(-2\), 3}}]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "2"}, {\(-2\), "3"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\((Twz\ = \ {Word[1], Word[3, 1, 2, \(-1\), \(-3\)], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[1]\)}, {\(Word[3, 1, 2, \(-1\), \(-3\)]\)}, {\(Word[3]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ApplyAuto[Twz, UU]\)], "Input"], Cell[BoxData[ \(Word[1, 3, 1, 2, \(-1\), \(-3\)]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(YY = Word[2, 3]\)], "Input"], Cell[BoxData[ \(Word[2, 3]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(mm = Map[QTracePoly[ApplyAuto[Twz, #], abcd] &, {UU, YY, VV}]\)], "Input"], Cell[BoxData[ \({a\ b + c\ d - x - b\ c\ z - a\ d\ z + y\ z + x\ z\^2, b\ c + a\ d - y - x\ z, z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(mm[\([1]\)]\ - \ xprime\ \ + \ z\ \((\ yprime\ - \ y)\) // Simplify\)], "Input"], Cell[BoxData[ \(0\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ApplyAuto[Twz, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \({Word[1, 3, 1, 2, \(-1\), \(-3\)], Word[3, 1]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ ApplyAuto[Twz, #] &, {UU, VV}]\ \[Equal] \[IndentingNewLine]{UU . Inverse[VV] . Inverse[UU] . Inverse[DD2] . Inverse[CC2] . Inverse[BB2] . CC2 . UU . Inverse[VV], VV}\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[MatrixTwz = {{1, 0}, {\(-2\), 1}}]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {\(-2\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell["\<\ These are the generators of the level 2 congruence subgroup of \ SL(2,Z).\ \>", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(MF[{MatrixTwx, MatrixTwy, MatrixTwz}]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "2"}, {"0", "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "2"}, {\(-2\), "3"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"1", "0"}, {\(-2\), "1"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixTwx . MatrixTwz . MatrixTwy\ // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(-1\), "0"}, {"0", \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell["\<\ This is from 6/04/05 with Benson Farb. Conjugating the Dehn Twist \ about Y by the Dehn twist about X is the image of the Dehn twist about X to the curve Y. \ \ \>", "Section"], Cell[CellGroupData[{ Cell[BoxData[ \(Twx\)], "Input"], Cell[BoxData[ \({Word[1], Word[2], Word[1, 2, 3, \(-2\), \(-1\)]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[Twy]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[2, 3, 1, \(-3\), \(-2\)]\)}, {\(Word[2]\)}, {\(Word[3]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Twxi = {Word[1], Word[2], Word[\(-2\), \(-1\), 3, 1, 2]}\)], "Input"], Cell[BoxData[ \({Word[1], Word[2], Word[\(-2\), \(-1\), 3, 1, 2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[Twxyxi = ComposeAuto[Twx, Twy, Twxi]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-1\), 3, 1, 2, 1, \(-2\), \(-1\), \(-3\), 1]\)}, {\(Word[2]\)}, {\(Word[\(-1\), 3, 1, 2, 1, \(-2\), \(-1\), 3, 1, 2, \(-1\), \(-2\), \(-1\), \(-3\), 1]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[{newX, newY, newZ} = Map[ApplyAuto[Twxyxi, #] &, {Word[1, 2], Word[2, 3], Word[1, 3]}]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(Word[\(-1\), 3, 1, 2, 1, \(-2\), \(-1\), \(-3\), 1, 2]\)}, {\(Word[2, \(-1\), 3, 1, 2, 1, \(-2\), \(-1\), 3, 1, 2, \(-1\), \(-2\), \(-1\), \(-3\), 1]\)}, {\(Word[\(-1\), 3, 1, 2, 1, 1, \(-2\), \(-1\), 3, 1, 2, \(-1\), \(-2\), \(-1\), \(-3\), 1]\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[BoxData[ \(\({tnewX, tnewY, tnewZ} = Map[QTracePoly[#, {a, b, c, d, x, y, z}] &, {newX, newY, newZ}];\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(tnewX\)], "Input"], Cell[BoxData[ \(a\ b - a\ b\ c\^2 + c\ d - a\^2\ c\ d - b\^2\ c\ d - a\ b\ d\^2 - x + b\^2\ c\^2\ x + 2\ a\ b\ c\ d\ x + a\^2\ d\^2\ x + a\ c\ y + b\ d\ y - 2\ b\ c\ x\ y - 2\ a\ d\ x\ y + x\ y\^2 + b\ c\ z + a\ d\ z + a\ c\ x\ z + b\ d\ x\ z - 2\ b\ c\ x\^2\ z - 2\ a\ d\ x\^2\ z - y\ z + 2\ x\^2\ y\ z - x\ z\^2 + x\^3\ z\^2\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(tnewY\)], "Input"], Cell[BoxData[ \(\(-a\^2\)\ b\ c + a\^2\ b\ c\^3 + 4\ a\ d - a\^3\ d - 2\ a\ b\^2\ d - 2\ a\ c\^2\ d + a\^3\ c\^2\ d + 2\ a\ b\^2\ c\^2\ d - b\ c\ d\^2 + a\^2\ b\ c\ d\^2 + b\^3\ c\ d\^2 - a\ d\^3 + a\ b\^2\ d\^3 + a\ c\ x + a\ b\^2\ c\ x - 2\ a\ b\^2\ c\^3\ x + b\ d\ x + 2\ a\^2\ b\ d\ x + b\ c\^2\ d\ x - 4\ a\^2\ b\ c\^2\ d\ x - 2\ b\^3\ c\^2\ d\ x + 2\ a\ c\ d\^2\ x - 2\ a\^3\ c\ d\^2\ x - 4\ a\ b\^2\ c\ d\^2\ x - 2\ a\^2\ b\ d\^3\ x - b\ c\ x\^2 + b\^3\ c\^3\ x\^2 - 2\ a\ d\ x\^2 + 3\ a\ b\^2\ c\^2\ d\ x\^2 + 3\ a\^2\ b\ c\ d\^2\ x\^2 + a\^3\ d\^3\ x\^2 - 3\ y + a\^2\ y + b\^2\ y + c\^2\ y - a\^2\ c\^2\ y + d\^2\ y + a\^2\ d\^2\ y - b\^2\ d\^2\ y - 2\ a\ b\ x\ y + 4\ a\ b\ c\^2\ x\ y - 2\ c\ d\ x\ y + 4\ a\^2\ c\ d\ x\ y + 4\ b\^2\ c\ d\ x\ y + 4\ a\ b\ d\^2\ x\ y + 2\ x\^2\ y - 3\ b\^2\ c\^2\ x\^2\ y - 6\ a\ b\ c\ d\ x\^2\ y - 3\ a\^2\ d\^2\ x\^2\ y - b\ c\ y\^2 - 2\ a\ d\ y\^2 - 2\ a\ c\ x\ y\^2 - 2\ b\ d\ x\ y\^2 + 3\ b\ c\ x\^2\ y\^2 + 3\ a\ d\ x\^2\ y\^2 + y\^3 - x\^2\ y\^3 + a\ b\ z - 2\ a\ b\ c\^2\ z + c\ d\ z - a\^2\ c\ d\ z - 2\ b\^2\ c\ d\ z - a\ b\ d\^2\ z - 4\ x\ z + a\^2\ x\ z + b\^2\ x\ z + c\^2\ x\ z - a\^2\ c\^2\ x\ z + 2\ b\^2\ c\^2\ x\ z + 3\ a\ b\ c\ d\ x\ z + d\^2\ x\ z + 2\ a\^2\ d\^2\ x\ z - b\^2\ d\^2\ x\ z - 2\ a\ b\ x\^2\ z + 4\ a\ b\ c\^2\ x\^2\ z - 2\ c\ d\ x\^2\ z + 4\ a\^2\ c\ d\ x\^2\ z + 4\ b\^2\ c\ d\ x\^2\ z + 4\ a\ b\ d\^2\ x\^2\ z + 2\ x\^3\ z - 3\ b\^2\ c\^2\ x\^3\ z - 6\ a\ b\ c\ d\ x\^3\ z - 3\ a\^2\ d\^2\ x\^3\ z + a\ c\ y\ z + b\ d\ y\ z - 5\ b\ c\ x\ y\ z - 6\ a\ d\ x\ y\ z - 4\ a\ c\ x\^2\ y\ z - 4\ b\ d\ x\^2\ y\ z + 6\ b\ c\ x\^3\ y\ z + 6\ a\ d\ x\^3\ y\ z + 4\ x\ y\^2\ z - 3\ x\^3\ y\^2\ z + b\ c\ z\^2 + a\ c\ x\ z\^2 + b\ d\ x\ z\^2 - 4\ b\ c\ x\^2\ z\^2 - 4\ a\ d\ x\^2\ z\^2 - 2\ a\ c\ x\^3\ z\^2 - 2\ b\ d\ x\^3\ z\^2 + 3\ b\ c\ x\^4\ z\^2 + 3\ a\ d\ x\^4\ z\^2 + 5\ x\^2\ y\ z\^2 - 3\ x\^4\ y\ z\^2 + 2\ x\^3\ z\^3 - x\^5\ z\^3\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(tnewZ\)], "Input"], Cell[BoxData[ \(a\ c + b\ d - b\ c\ x - a\ d\ x + x\ y - z + x\^2\ z\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Map[ MatrixForm[TPolyAutS4[#]] &, {Map[Word, Range[3]], Twx, Twy, Twz}]\)], "Input"], Cell[BoxData[ RowBox[{"{", RowBox[{ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {"x"}, {"y"}, {"z"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {"x"}, {\(b\ c + a\ d - a\ c\ x - b\ d\ x - y + x\^2\ y + x\ z\)}, {\(a\ c + b\ d - x\ y - z\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {\(a\ b + c\ d - x - y\ z\)}, {"y"}, {\(a\ c + b\ d - a\ b\ y - c\ d\ y + x\ y - z + y\^2\ z\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]], ",", TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {\(a\ b + c\ d - x - b\ c\ z - a\ d\ z + y\ z + x\ z\^2\)}, {\(b\ c + a\ d - y - x\ z\)}, {"z"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]}], "}"}]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(u1 = Expand[Take[ TPolyAutS4[ Twx], \(-2\)] - \ {{\(-1\) + x^2, x}, {\(-x\), \(-1\)}} . {y, z}]\)], "Input"], Cell[BoxData[ \({b\ c + a\ d - a\ c\ x - b\ d\ x, a\ c + b\ d}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[{{\(-1\) + x^2, x}, {\(-x\), \(-1\)}}]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(\(-1\) + x\^2\), "x"}, {\(-x\), \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Ax = {{x, 1}, {\(-1\), 0}}\)], "Input"], Cell[BoxData[ \({{x, 1}, {\(-1\), 0}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Ax . Ax\)], "Input"], Cell[BoxData[ \({{\(-1\) + x\^2, x}, {\(-x\), \(-1\)}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Expand[ Take[TPolyAutS4[Twx], \(-2\)] - \ Ax . Ax . {y, z} - u1]\)], "Input"], Cell[BoxData[ \({0, 0}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Aa = {{x, 1}, {\(-1\), 0}}\)], "Input"], Cell[BoxData[ \({{x, 1}, {\(-1\), 0}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[Aa2 = Simplify[Aa . Aa]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {\(\(-1\) + x\^2\), "x"}, {\(-x\), \(-1\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[ Aa2i = Simplify[\((4 - x^2)\) Inverse[IdentityMatrix[2] - Aa2]]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"2", "x"}, {\(-x\), \(2 - x\^2\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(bb = {q - r\ x, r}\)], "Input"], Cell[BoxData[ \({q - r\ x, r}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[Simplify[Aa2i\ . \ bb]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(2\ q - r\ x\)}, {\(2\ r - q\ x\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Aa\)], "Input"], Cell[BoxData[ \({{x, 1}, {\(-1\), 0}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[SymA = {{2, x}, {x, 2}}]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"2", "x"}, {"x", "2"} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Transpose[Aa] . SymA . Aa \[Equal] SymA\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(VecFA = {{x, 2}, {\(-2\), \(-x\)}}\)], "Input"], Cell[BoxData[ \({{x, 2}, {\(-2\), \(-x\)}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Inverse[Aa] . VecFA . Aa \[Equal] VecFA\)], "Input"], Cell[BoxData[ \(True\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Twy\)], "Input"], Cell[BoxData[ \({Word[2, 3, 1, \(-3\), \(-2\)], Word[2], Word[3]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(SqrtTwy = {Word[1], Word[3], Word[\(-3\), 2, 3]}\)], "Input"], Cell[BoxData[ \({Word[1], Word[3], Word[\(-3\), 2, 3]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[Inn3[Word[2, 3]], SqrtTwy, SqrtTwy]\)], "Input"], Cell[BoxData[ \(Inn3[Word[2, 3]]\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[TPolyAutS4[SqrtTwy]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"c"}, {"b"}, {"d"}, {"z"}, {"y"}, {\(a\ b + c\ d - x - y\ z\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(SqrtTwyI = {Word[1], Word[2, 3, \(-2\)], Word[2]}\)], "Input"], Cell[BoxData[ \({Word[1], Word[2, 3, \(-2\)], Word[2]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(ComposeAuto[SqrtTwy, SqrtTwyI]\)], "Input"], Cell[BoxData[ \({Word[1], Word[2], Word[3]}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[TPolyAutS4[SqrtTwyI]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"c"}, {"b"}, {"d"}, {\(a\ c + b\ d - x\ y - z\)}, {"y"}, {"x"} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(a1 = Take[TPolyAutS4[SqrtTwy], \(-3\)] /. {a\ b\ + \ c\ d\ \[Rule] \ p}\)], "Input"], Cell[BoxData[ \({z, y, p - x - y\ z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Transpose[Map[D[a1, #] &, {x, y, z}]] // MatrixForm\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", GridBox[{ {"0", "0", "1"}, {"0", "1", "0"}, {\(-1\), \(-z\), \(-y\)} }, RowSpacings->1, ColumnSpacings->1, ColumnAlignments->{Left}], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Take[ TPolyAutS4[SqrtTwyI], \(-3\)] /. {a\ c\ + \ b\ d\ \[Rule] \ r}\)], "Input"], Cell[BoxData[ \({r - x\ y - z, y, x}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\(?ComposeAuto\)\)], "Input"], Cell["Global`ComposeAuto", "Print", CellTags->"Info3328785069-7229558"], Cell[BoxData[ InterpretationBox[GridBox[{ {GridBox[{ {\(ComposeAuto[A1_, A2_] := \((ApplyWord[#1, A2] &)\) /@ A1\)}, {" "}, {\(ComposeAuto[A1_, A2_, X__] := ComposeAuto[A1, ComposeAuto[A2, X]]\)} }, GridBaseline->{Baseline, {1, 1}}, ColumnWidths->0.999, ColumnAlignments->{Left}]} }, GridBaseline->{Baseline, {1, 1}}, ColumnAlignments->{Left}], Definition[ "ComposeAuto"], Editable->False]], "Print", CellTags->"Info3328785069-7229558"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(\(?Inn3\)\)], "Input"], Cell["Global`Inn3", "Print", CellTags->"Info3328785069-4152954"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[TPolyAutS4[Twy]]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {"a"}, {"b"}, {"c"}, {"d"}, {\(a\ b + c\ d - x - y\ z\)}, {"y"}, {\(a\ c + b\ d - a\ b\ y - c\ d\ y + x\ y - z + y\^2\ z\)} }, RowSpacings->1, ColumnAlignments->{Left}], Column], "\[NoBreak]", ")"}], Function[ BoxForm`e$, MatrixForm[ BoxForm`e$]]]], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \({p - x - y\ z, \ r\ - \ p\ y\ + \ x\ y\ - \ z\ + \ y^2\ z} - {p, r\ - \ p\ y}\)], "Input"], Cell[BoxData[ \({\(-x\) - y\ z, x\ y - z + y\^2\ z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \({{0, 1}, {\(-1\), \(-y\)}} . {{0, 1}, {\(-1\), \(-y\)}} . {z, x} // Expand\)], "Input"], Cell[BoxData[ \({\(-x\)\ y - z, \(-x\) + x\ y\^2 + y\ z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Inverse[{{0, 1}, {\(-1\), \(-y\)}}]\)], "Input"], Cell[BoxData[ \({{\(-y\), \(-1\)}, {1, 0}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(% . %\)], "Input"], Cell[BoxData[ \({{\(-1\) + y\^2, y}, {\(-y\), \(-1\)}}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(Simplify[% . {x, z}\ - \ % . {p, r\ - \ p\ y}]\)], "Input"], Cell[BoxData[ \({p + x\ \((\(-1\) + y\^2)\) + y\ \((\(-r\) + z)\), r - x\ y - z}\)], "Output"] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ \(MatrixForm[%]\)], "Input"], Cell[BoxData[ TagBox[ RowBox[{"(", "\[NoBreak]", TagBox[GridBox[{ {\(p + x\ \((\(-1\) + y\^2)\) + y\ \((\(-r\) + z)\)\)}, {\(r - x\ y - z\)} }, RowSpacings->1, ColumnAlignments