(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 4.2' 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[ 81977, 2978]*) (*NotebookOutlinePosition[ 84525, 3055]*) (* CellTagsIndexPosition[ 84244, 3042]*) (*WindowFrame->Normal*) Notebook[{ Cell["Autos.nb", "Title"], Cell["Automorphisms of free groups and character varieties", "Subtitle"], Cell["W.Goldman, 9 March 2003", "Subsubtitle"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Preliminaries", FontWeight->"Plain"]], "Section"], Cell[CellGroupData[{ Cell[BoxData[ \(Off[General::"\"]; Off[General::"\"]; Off[Syntax::"\"];\)], "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"], 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[BoxData[ \(Word[1, 2, \(-2\), 3]\)], "Input"], Cell["\<\ Here is an example of the implementation of multiplication of \ reduced words:\ \>", "Text"], Cell[BoxData[ \(Word[1]\ . \ Word[2]\)], "Input"], Cell["\<\ Here is an example of the implementation of inversion of reduced \ words:\ \>", "Text"], Cell[BoxData[ \(Inverse[Word[1, 2, 3, \(-4\)]]\)], "Input"], 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[BoxData[ \(toList[Word[2, 3, 4, 1, 2, 3, 2]]\)], "Input"], Cell[BoxData[ \(toWord[{2, 3, 4, 1, 2, 4}]\)], "Input"], Cell[TextData[{ "Notice that ", StyleBox["toWord", FontWeight->"Bold"], " automatically reduces the word." }], "Text"], Cell[BoxData[ \(toWord[{1, \(-1\), 2}]\)], "Input"], 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[BoxData[ \(SymbolWord[Word[1, 2, 1, \(-2\), 1, 2, \(-1\)]]\)], "Input"] }, 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[BoxData[ \(ApplyWord[KWord, {Word[3], Word[4, 5]}]\)], "Input"], Cell["Free group automorphisms", "Section"], 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[BoxData[ \(PantsRep[Basis0] // MatrixForm\)], "Input"], 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[BoxData[ \(Inn[Word[2, 1]]\)], "Input"] }, Open ]] }, Open ]], Cell["Here's a convenient shorthand:", "Text"], Cell[BoxData[ \(Inn[w__]\ := \ Inn[Word[w]]\)], "Input"], Cell["\<\ Let's display a few inner automorphisms in the 3-generator \ set:\ \>", "Text"], Cell[BoxData[ \(DisplayPantsRep[Inn[1], Inn[2], Inn[1, 2], Inn[KWord]]\)], "Input"], 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[BoxData[ \(Map[PantsRep, {Basis0, P12}] // MF\)], "Input"], Cell[TextData[{ "It does preserve ", StyleBox["KWord ", FontWeight->"Bold"], " up to inversion:" }], "Text"], Cell[BoxData[ \({ApplyAuto[P12, KWord], Inverse[KWord]}\)], "Input"], Cell["This automorphism has order two:", "Text"], Cell[BoxData[ \({ComposeAuto[P12, P12], Basis0}\)], "Input"], 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[BoxData[ \(Map[PantsRep, {Basis0, P13}] // MF\)], "Input"], Cell[TextData[{ "It's an involution and preserves ", StyleBox["KWord ", FontWeight->"Bold"], " up to inversion:" }], "Text"], Cell[BoxData[ \(KWordInv[P13]\)], "Input"], Cell[TextData[{ "Next we permute the second and third generator for this presentation to \ obtain the permutation ", StyleBox["P23", FontWeight->"Bold"], ":" }], "Text"], Cell[BoxData[ \(P23 = \ ComposeAuto[P12, P13, P12]\)], "Input"], Cell[BoxData[ \(KWordInv[P23]\)], "Input"], 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[BoxData[ \(P123\ = ComposeAuto[P13, P12]\)], "Input"], Cell[TextData[{ "Its inverse is the 3-cycle ", StyleBox["(132):", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(P132 = ComposeAuto[P12, P13]\)], "Input"], Cell[BoxData[ \(Map[PantsRep, {Basis0, P123, P132}] // MF\)], "Input"], Cell["P123 and P132 are mutually inverse and are normalized:", "Text"], Cell[BoxData[ \({ComposeAuto[P123, P132] == Basis0, Map[ApplyAuto[#, KWord] == KWord &, {P123, P132}]}\)], "Input"], Cell["but they only have order three up to an inner automorphism:", "Text"], Cell[BoxData[ \(ComposeAuto[P123, P123, P123] == \ Inn[Inverse[KWord]]\)], "Input"] }, 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[BoxData[ \(EllInv\ = \ {Word[\(-1\)], \ Word[\(-2\)]}\)], "Input"], Cell[BoxData[ \(ComposeAuto[EllInv, EllInv]\)], "Input"], Cell[TextData[{ "so indeed ", StyleBox["EllInv", FontWeight->"Bold"], " is an involution. However:" }], "Text"], Cell[BoxData[ \(ApplyAuto[EllInv, KWord]\)], "Input"], 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[BoxData[ \(EllAut\ = \ ComposeAuto[EllInv, Inn[Word[2, 1]]]\)], "Input"], Cell[BoxData[ \(ApplyAuto[EllAut, KWord]\)], "Input"], Cell[TextData[{ "so ", StyleBox["EllAut", FontWeight->"Bold"], " is normalized. However, it no longer has order 2 in ", StyleBox["Aut(F2)", FontWeight->"Bold"], ":" }], "Text"], Cell[BoxData[ \(ComposeAuto[EllAut, EllAut]\ == \ Inn[Inverse[KWord]]\)], "Input"], Cell[TextData[{ "The elliptic involution commutes with the permutation ", StyleBox["P12", FontWeight->"Bold"], ":" }], "Text"], Cell[BoxData[ \({ComposeAuto[EllInv, P12], ComposeAuto[P12, EllInv]} // MF\)], "Input"], Cell[TextData[{ "But it doesn't commute with ", StyleBox["P23 ", FontWeight->"Bold"], "(and thus neither with the other permutations):" }], "Text"], Cell[BoxData[ \({ComposeAuto[P23, EllInv], ComposeAuto[EllInv, P23]} // MF\)], "Input"] }, Open ]], Cell[TextData[{ "Here is the action of ", StyleBox["EllInv ", FontWeight->"Bold"], "on the 3-element generating set:" }], "Text"], Cell[BoxData[ \(DisplayPantsRep[EllInv]\)], "Input"], 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[BoxData[{ \(\(Qz1\ = \ {Word[1], Word[\(-2\)]};\)\), "\n", \(ComposeAuto[Qz1, Qz1] == Basis0\)}], "Input"], Cell["but it's not normalized:", "Text"], Cell[BoxData[ \(ApplyAuto[Qz1, KWord]\)], "Input"], Cell["Let's normalize it:", "Text"], Cell[BoxData[ \(ApplyAuto[ComposeAuto[Inn[\(-1\)], Qz1], KWord]\)], "Input"], Cell[BoxData[ \(ApplyAuto[ComposeAuto[Inn[\(-2\), \(-1\)], Qz1], KWord]\)], "Input"], Cell[BoxData[ \(ApplyAuto[Qz\ = \ ComposeAuto[Inn[1, \(-2\), \(-1\)], Qz1], KWord]\)], "Input"], Cell[TextData[{ "so composing with ", StyleBox["Inn[1,-2,-1] ", FontWeight->"Bold"], "normalizes it. Is it an involution?" }], "Text"], Cell[BoxData[ \(ComposeAuto[Qz, Qz] == Basis0\)], "Input"], Cell[TextData[{ "We could have used our little function ", StyleBox["KWordInv", FontWeight->"Bold"], ":" }], "Text"], Cell[BoxData[ \(KWordInv[Qz]\)], "Input"], Cell["Here's what it looks like:", "Text"], Cell[BoxData[ \(Qz\)], "Input"], 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[BoxData[ \({Qy\ = \ ComposeAuto[P23, Qz, P23], Qx\ = \ ComposeAuto[P13, Qz, P13]} // MF\)], "Input"], Cell["They are normalized involutions:", "Text"], Cell[BoxData[ \(Map[KWordInv, {Qy, Qx}]\)], "Input"] }, Open ]], Cell["Here is what they look like on the 3 generators:", "Text"], Cell[BoxData[ \(DisplayPantsRep[Qx, Qy, Qz]\)], "Input"], 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[BoxData[ \(ComposeAuto[A4a, A4a] == EllInv\)], "Input"], Cell["but it's not normalized:", "Text"], Cell[BoxData[ \(ApplyAuto[A4a, KWord]\)], "Input"], Cell[BoxData[ \(ApplyAuto[A4 = ComposeAuto[Inn[\(-1\)], A4a], KWord]\)], "Input"], Cell[TextData[{ "Now ", StyleBox["A4 ", FontWeight->"Bold"], " is normalized. However, it no longer has order 4:" }], "Text"], Cell[BoxData[ \(ComposeAuto[A4, A4, A4, A4] == Inn[Inverse[KWord]]\)], "Input"], Cell[BoxData[ \(DisplayPantsRep[A4]\)], "Input"] }, 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[BoxData[ \(Tx\ = \ {Word[1], Word[2, 1]}\)], "Input"], Cell[CellGroupData[{ Cell["Here is the inverse:", "Text"], Cell[BoxData[ \(\(Txi\ = \ {Word[1], Word[2, \(-1\)]};\)\)], "Input"] }, Open ]], Cell[BoxData[ \(ComposeAuto[Tx, Txi]\)], "Input"], Cell[CellGroupData[{ Cell["These automorphisms are normalized:", "Text"], Cell[BoxData[ \(Map[ApplyAuto[#, KWord] == KWord\ &, {Tx, Txi}]\)], "Input"] }, Open ]], Cell[TextData[{ StyleBox["A relation between", FontWeight->"Plain"], " Tx, Qz", StyleBox[" and ", FontWeight->"Plain"], " P23", StyleBox[":", FontWeight->"Plain"] }], "Subsubsection"], Cell[BoxData[ \(DisplayPantsRep[Tx, P23, Qz]\)], "Input"] }, Open ]], Cell[BoxData[ \(DisplayPantsRep[ComposeAuto[Qz, P23]\ , Tx, ComposeAuto[Inn[2, 1, \(-2\), \(-1\)], Tx]]\)], "Input"], Cell[BoxData[ \(ComposeAuto[Inn[2, 1, \(-2\), \(-1\)], Tx] == \ ComposeAuto[Qz, P23]\)], "Input"], Cell[BoxData[ \(Tx\ == \ ComposeAuto[Inn[1, 2, \(-1\), \(-2\)], Qz, P23]\)], "Input"], Cell["More Dehn twists", "Subsubsection", FontWeight->"Plain"], Cell[TextData[{ "We define the Dehn twist about ", StyleBox["Y:", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(Ty\ = \ ComposeAuto[P12, Tx, P12]\)], "Input"], 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[BoxData[ \(Map[SymbolWord[#[\([2]\)]\ ] &, NestList[ComposeAuto[FibAut, #] &, FibAut, 8]] // MatrixForm\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["Homology", "Section"], 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[BoxData[ \(HomologyClass[Word[1, 2, \(-1\), 2]]\)], "Input"], 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[BoxData[ \(\((Sym3\ = Map[AutToGL2Z[#] &, {Basis0, P12, P23, P13, P123, P132}]\ )\) // MF\)], "Input"] }, Open ]], Cell[BoxData[ \(Table[Sym3[\([i]\)] . Sym3[\([j]\)], {i, 6}, {j, 6}] // MatrixForm\)], "Input"], Cell["\<\ For future reference, here is the multiplication table for the \ Symmetric Group:\ \>", "Text"], 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[TextData[{ "GL(2,Z) ", StyleBox["representations of other automorphisms", FontWeight->"Plain"] }], "Subsubsection"], Cell[BoxData[ \(Map[AutToGL2Z[#] &, {EllAut, Qx, Qy, Qz, A4, Tx, Ty, FibAut}] // MF\)], "Input"], Cell["\<\ Let's check the relation between the Dehn twist, the reflection \ and the permutation in terms of matrices:\ \>", "Text"], Cell[BoxData[ \(\(({p23, qz, tx}\ = \ Map[AutToGL2Z[#] &, {P23, Qz, Tx}])\) // MF\)], "Input"], Cell[BoxData[ \(p23 . qz\ == \ tx\)], "Input"], Cell[CellGroupData[{ Cell["The Trace Function in SL(2)", "Section"], 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[BoxData[ \(TTrace[Word[1, 2, \(-3\)]]\)], "Input"], Cell[BoxData[ \(TTrace[Word[1, \(-2\), \(-3\)]]\)], "Input"], Cell[BoxData[ \(TTrace[Word[1, 2, \(-1\), 2, 2]]\)], "Input"], 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[BoxData[ \(TracePoly[Word[1, 2, \(-1\), 2, 2], {a, y, z}]\)], "Input"], 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[BoxData[ \(Map[TracePoly[Apply[Word, Table[1, {#}]], {x, y, z}] &, Range[12]] // MatrixForm\)], "Input"], 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[BoxData[ \(Kappa[{a, b, c}]\)], "Input"], Cell[CellGroupData[{ Cell["Traces in a rank 3 free group", "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[BoxData[ \(\((t123m2\ = \ TracePoly3[Word[\ 1, 2, 3, \(-2\)], tList])\) /. S12sub\)], "Input", CellTags->{"tag1", "In[135]:="}], Cell[BoxData[ \(\((t123m2m3 = \ TracePoly3[Word[\ 1, 2, 3, \(-2\), \(-3\)], tList])\) /. S12sub\)], "Input", CellTags->{"tag1", "In[136]:="}], 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]:="}], Cell[BoxData[ \(k\ = \ x^2\ \ + \ y^2\ + \ z^2\ - \ x\ y\ z\ - \ 2\)], "Input", CellTags->{"tag1", "In[138]:="}], Cell[BoxData[ \(fp = FrickePolynomial[{{a, b, y, y}, {k, v, p}}] /. \ {p \[Rule] \ u\ x\ + \ a\ y\ - \ w\ z\ - \ v} // Expand\)], "Input", CellTags->{"tag1", "In[139]:="}] }, Open ]], Cell[BoxData[ \(fp\ - \ \((fp /. {a \[Rule] b, b \[Rule] a, x \[Rule] y, \ y \[Rule] x, v \[Rule] u, u \[Rule] v})\) // Expand\)], "Input"], 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[BoxData[ \(KleinBottleCWord\ = \ ApplyWord[KWord, {Word[1, 1], Word[2]}]\)], "Input"], Cell[TextData[{ "We assume that the elements ", StyleBox["X, Y ", FontWeight->"Bold"], " reverse orientation and thus ", StyleBox["XY ", FontWeight->"Bold"], "preserves orientation." }], "Text"], Cell[BoxData[ \(kbd\ = \ TracePoly[KleinBottleDWord, {I\ x, \ I\ y, z}]\)], "Input"], Cell["This is the peripheral trace for the 1-holed Klein bottle.", "Text"], Cell[BoxData[ \(kbc\ = \ TracePoly[KleinBottleCWord, {I\ x, \ I\ y, z}]\)], "Input"], Cell[BoxData[ \(kappa\ = \ Kappa[{I\ x, \ I\ y, z}]\)], "Input"], Cell[BoxData[ \(kbc\ - \ \((\(-\ \((kappa\ - \ 2\ )\)\)\ x\^2\ \ + \ 2)\) // Simplify\)], "Input"], Cell["Automorphisms of the Character Variety", "Section"], 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[BoxData[ \(P12\)], "Input"], Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, P12]\)], "Input"], Cell[BoxData[ \(PantsRep[P12]\)], "Input"], Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, PantsRep[P12]]\)], "Input"], Cell[BoxData[ \(Map[TracePoly[#, {x, y, z}] &, PantsRep[Qx]]\)], "Input"], 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[BoxData[ \(TrAuto[EllInv]\)], "Input"], Cell[BoxData[ \(TrAuto[P23]\)], "Input"], Cell[BoxData[ \(TrAuto[P123]\)], "Input"], Cell[BoxData[ \(\(\(TrAuto[Tx]\)\(\ \)\)\)], "Input"], Cell["Relations in the Mapping Class Group", "Section"], 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[BoxData[ \(Map[# == A4 &, {ComposeAuto[Tx, Tyi, Tx], ComposeAuto[Tyi, Tx, Tyi]}]\)], "Input"], Cell[BoxData[ \({ComposeAuto[Tx, Tyi, Tx], ComposeAuto[Tyi, Tx, Tyi], A4} // MF\)], "Input"], Cell[TextData[{ "Here is what their images in ", StyleBox["GL(2,Z)", FontWeight->"Bold"], " look like:" }], "Text"], Cell[BoxData[ \(Map[AutToGL2Z, {Tx, Tyi, ComposeAuto[Tx, Tyi, \ Tx]}] // MF\)], "Input"], Cell[BoxData[ \(ComposeAuto[A4, A4, A4, A4]\ \[Equal] \ Inn[Word[2, 1, \(-2\), \(-1\)]]\)], "Input"], Cell["The modular group SL(2,Z) (by Matt Bainbridge)\.18\.13", "Section"], 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[BoxData[ \(Uu[5] // MatrixForm\)], "Input"], Cell[BoxData[ \(expand[Uu[5]]\)], "Input"], Cell[BoxData[ \(expand[Uu[\(-6\)]]\)], "Input"], Cell[BoxData[ \(expand[{{5, \(-1\)}, {1, 0}} . {{0, \(-1\)}, {1, 3}}]\)], "Input"], Cell["The Trace-Reduction Algorithm (by George Stantchev)", "Section"], 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[BoxData[ \(ExampleAuto\ = \ ComposeAuto[Ty, Tx, Ty, Tx, Ty]\)], "Input"], Cell[BoxData[ \(ExampleTrace\ = \ TrAuto[ExampleAuto]\)], "Input"], Cell[BoxData[{ \(\(count\ = \ 0;\)\), "\n", \(traceReduce[ ExampleTrace\ /. \ {x -> \ \(-3\), y -> \(-3\), z -> \(-3\)}]\)}], "Input"], Cell[BoxData[ \(traceReduce[ ExampleTrace\ /. \ {x -> \ \(-3\), y -> \(-3\), z -> 0}]\)], "Input"], Cell[" Free Groups of Rank 3", "Section"], 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[BoxData[ \(t[2, 3, 1]\)], "Input"], Cell[BoxData[ \(t[1, 2, 3]\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Derivation of Fricke's 3-Generator Sum Formula ", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(t[1, 3, 2]\)], "Input"], Cell[BoxData[ \(t[1, 2, 3]\ + \ t[1, 3, 2]\)], "Input"], 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[BoxData[ \(t[1, 2, 3, 1, 3, 2]\)], "Input"], Cell["The other summand is OK:", "Text", FontWeight->"Plain"], Cell[BoxData[ \(t[1, 2, 3, \(-2\), \(-3\), \(-1\)]\)], "Input"], 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[BoxData[ \(Word[1, 2] . Word[3, 1, 3, 2]\)], "Input"], Cell[BoxData[ \(Inverse[Word[1, 2]] . Word[3, 1, 3, 2]\)], "Input"], 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[BoxData[ \(temp123132\ = t[1, 2]\ t[3, 1, 3, 2] - t[\(-2\), \(-1\), 3, 1, 3, 2] // Expand\)], "Input"], 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[BoxData[ \(temp123132\ \ + \ t[1, 2, 3, \(-2\), \(-3\), \(-1\)]\)], "Input"], 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[BoxData[ \(AA . \ BB . \ CC . \ DD\ \[Equal] Word[]\)], "Input"], 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[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[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[BoxData[ \(T4Relation = KWord . Word[3, 4, 5, 6]\)], "Input"], 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[BoxData[ \(ApplyWord[T4Relation, {UU, VV, AA2, BB2, CC2, DD2}]\ \[Equal] Word[]\)], "Input"], 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[BoxData[ \(\((Twx\ = \ {Word[1], Word[2], Word[1, 2, 3, \(-2\), \(-1\)]})\) // MatrixForm\)], "Input"], 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[BoxData[ \(Map[ApplyAuto[Twx, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(ApplyAuto[Twx, Word[3, 1]]\ \[Equal] \[IndentingNewLine]UU . \ Word[3, 3]\ . \ \((DD . DD)\) . \ UU . \ VV\)], "Input"], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwx = {{1, 2}, {0, 1}}]\)], "Input"], Cell[BoxData[ \(\((Twy\ = \ {Word[2, 3, 1, \(-3\), \(-2\)], Word[2], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ \(Map[ApplyAuto[Twy, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(Map[ ApplyAuto[Twy, #] &, {UU, VV}]\ \[Equal] {Inverse[VV] . Inverse[UU] . Inverse[DD2] . Inverse[VV] . AA2, BB2 . CC2 . DD2 . UU . VV . VV . DD2 . UU . VV}\)], "Input"], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwy = {{\(-1\), 2}, {\(-2\), 3}}]\)], "Input"], Cell[BoxData[ \(\((Twz\ = \ {Word[1], Word[3, 1, 2, \(-1\), \(-3\)], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ \(ApplyAuto[Twz, UU]\)], "Input"], Cell[BoxData[ \(YY = Word[2, 3]\)], "Input"], Cell[BoxData[ \(mm = Map[QTracePoly[ApplyAuto[Twz, #], abcd] &, {UU, YY, VV}]\)], "Input"], Cell[BoxData[ \(mm[\([1]\)]\ - \ xprime\ \ + \ z\ \((\ yprime\ - \ y)\) // Simplify\)], "Input"], Cell[BoxData[ \(Map[ApplyAuto[Twz, #] &, {UU, VV}]\)], "Input"], 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["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwz = {{1, 0}, {\(-2\), 1}}]\)], "Input"], Cell["\<\ These are the generators of the level 2 congruence subgroup of \ SL(2,Z).\ \>", "Text"], Cell[BoxData[ \(MF[{MatrixTwx, MatrixTwy, MatrixTwz}]\)], "Input"], Cell[BoxData[ \(MatrixTwx . MatrixTwz . MatrixTwy\ // MatrixForm\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["The Lantern Relation", FontWeight->"Plain"]], "Subsubsection"], Cell["\<\ Now we consider a free group of rank 3. Recall the Dehn twists \ Twx, Twy, Twz. The following is a convenient shorthand for inner automorphisms of a rank 3 \ free group.\ \>", "Text"], Cell[BoxData[{ \(Inn3[w__]\ := \ Inn3[Word[w]]\), "\n", \(Inn3[w_Word]\ := \ \((InnerAutomorphism[w, \ #1]\ &\ )\)\ /@ \ Map[Word, Range[3]]\)}], "Input"], Cell[BoxData[ \(Inn3[3] // MatrixForm\)], "Input"], Cell[BoxData[ \({ComposeAuto[Twz, Twx, Twy], ComposeAuto[Inn3[1], Inn3[3], Inn3[2]]} // MF\)], "Input"] }, Open ]], Cell[BoxData[ \({MatrixTwz, MatrixTwy, MatrixTwx} // MF\)], "Input"], Cell[BoxData[ \(MatrixTwz . MatrixTwy . MatrixTwx // MatrixForm\)], "Input"], Cell[TextData[StyleBox["A quadratic reflection", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(QRz\ = {Inverse[AA], InnerAutomorphism[AA, Inverse[BB]], \[IndentingNewLine]InnerAutomorphism[AA . BB, Inverse[CC]]}\)], "Input"], Cell[BoxData[ \(QRzUV\ = \ Map[ApplyAuto[QRz, #] &, {UU, YY, VV}]\)], "Input"], Cell[BoxData[ \(QRzUV\ = \ Map[ApplyAuto[QRz, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(QRzUV\ \[Equal] \ {Inverse[UU], UU . DD2 . UU . Inverse[AA2] . VV}\)], "Input"], Cell["Thus this reflection corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixQz = {{\(-1\), 0}, {2, 1}}]\)], "Input"], Cell[BoxData[ \(MatrixQz . MatrixTwz\)], "Input"], Cell[BoxData[ \(\(abcd\ = \ {a, b, c, d, x, y, z};\)\)], "Input"], Cell[BoxData[ \(QTracePoly[ Word[2, \(-3\), \(-2\), \(-1\)], {a, b, c, d, x, y, z}]\)], "Input"], Cell[BoxData[ \(\((QRR\ = ComposeAuto[QRz, Twz])\) // MatrixForm\)], "Input"], Cell[BoxData[ \(\((QRR1\ = ComposeAuto[QRR, Inn3[Word[\(-1\), \(-3\), \(-1\)]]])\)\ // MatrixForm\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, UU]\)], "Input"], Cell[BoxData[ \(ff\ = QTracePoly[ApplyAuto[QRR1, UU], abcd]\)], "Input"], Cell[BoxData[ \(Simplify[ ff\ + \ z\ yprime\ - \ \((\ \(-x\)\ + \ a\ b\ + \ c\ d)\) \[Equal] 0]\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, YY = Word[2, 3]]\)], "Input"], Cell[BoxData[ \(yprime\ == \ QTracePoly[ApplyAuto[QRR1, YY = Word[2, 3]], abcd]\)], "Input"], 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[BoxData[ \(QTracePoly[ApplyAuto[QRz, VV], abcd] \[Equal] zprime\)], "Input"], Cell[BoxData[ \(ffz\ - \ zprime\)], "Input"], Cell[BoxData[ \(ffz\ - \ zprime\ - \ x\ yprime // Expand\)], "Input"], Cell[BoxData[ \(%341\ + \ xprime\ yprime // Expand\)], "Input"], Cell[BoxData[ \(ffz\ = QTracePoly[ApplyAuto[QRR1, VV], abcd] // Expand\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, VV]\)], "Input"], Cell[BoxData[ \(QRR1\)], "Input"], Cell[BoxData[ \(Map[QTracePoly[ApplyAuto[QRR1, #], abcd] &, {UU, VV}] // MatrixForm\)], "Input"], Cell[BoxData[ \(ww\ = ApplyAuto[QRz, VV]\)], "Input"], Cell[BoxData[ \(UU\)], "Input"], Cell[BoxData[ \(UU . DD2 . UU . Inverse[AA2] . VV\)], "Input"], Cell[BoxData[ \(Inverse[VV] . Inverse[AA2] . VV\)], "Input"], Cell[BoxData[ \(Inverse[AA]\)], "Input"], Cell[BoxData[ \(\(abcd\ = \ {a, b, c, d, x, y, z};\)\)], "Input"], Cell["The orientable double cover of the 2-holed projective plane", \ "Subsubsection", FontWeight->"Plain"], Cell[TextData[{ "The orientable double cover of the punctured Moebius band P (2-holed \ projective plane) \nis a 4-holed sphere S ; the corresponding monomorphism of \ fundamental groups is:\n", StyleBox["A = X Y, B = y X, C = x y, D = Y x,", FontWeight->"Bold"], " where ", StyleBox["", FontWeight->"Bold"], " is the fundamental group\nof ", StyleBox["S", FontWeight->"Bold"], " (the generators ", StyleBox["A,B,C,D ", FontWeight->"Bold"], "correspond to", StyleBox[" bd S", FontWeight->"Bold"], ")\nand ", StyleBox["", FontWeight->"Bold"], " is the fundamental group of", StyleBox[" P ", FontWeight->"Bold"], "(", StyleBox["bd P", FontWeight->"Bold"], " corresponds to ", StyleBox["XY", FontWeight->"Bold"], " and ", StyleBox["Xy", FontWeight->"Bold"], "). If\n", StyleBox["I xx", FontWeight->"Bold"], " denotes the trace of ", StyleBox["X", FontWeight->"Bold"], ", ", StyleBox[" I yy", FontWeight->"Bold"], " the trace of ", StyleBox["Y", FontWeight->"Bold"], " and ", StyleBox[" zz", FontWeight->"Bold"], " the trace of ", StyleBox["Z", FontWeight->"Bold"], ", then the corresponding\ncharacters for ", StyleBox["S", FontWeight->"Bold"], " are given by the following:" }], "Text"], Cell[BoxData[ \(Fricke[{{a, b, c, d}, {x, y, z}} /. {\[IndentingNewLine]a -> zz, \[IndentingNewLine]b -> \(-xx\)\ yy\ - \ zz, \ \[IndentingNewLine]c\ -> \ zz, \[IndentingNewLine]d\ -> \ \(-xx\)\ yy\ - \ zz, \[IndentingNewLine]x\ -> \ \(-\ xx^2\)\ - 2, \ \[IndentingNewLine]y\ -> \ \(-yy^2\)\ - 2, \ \[IndentingNewLine]z -> \(-xx^2\)\ - \ yy^2\ + \ zz^2\ + \ xx\ yy\ zz\ - 2}]\)], "Input"], Cell["\<\ This defines the mapping of the character variety of P into that of \ S.\ \>", "Text"] }, Open ]], Cell[CellGroupData[{ 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[BoxData[ \(\((t123m2\ = \ TracePoly3[Word[\ 1, 2, 3, \(-2\)], tList])\) /. S12sub\)], "Input"], Cell[BoxData[ \(\((t123m2m3 = \ TracePoly3[Word[\ 1, 2, 3, \(-2\), \(-3\)], tList])\) /. S12sub\)], "Input"], 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"], Cell[BoxData[ \(k\ = \ x^2\ \ + \ y^2\ + \ z^2\ - \ x\ y\ z\ - \ 2\)], "Input"], Cell[BoxData[ \(FrickePolynomial[{{a, b, y, y}, {k, v, p}}] /. \ {p \[Rule] \ u\ x\ + \ a\ y\ - \ w\ z\ - \ v} // Expand\)], "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell["The Mapping Class Group of the Four-Holed Sphere", "Section"], Cell["\<\ The fundamental group of the 4-holed sphere S4 has presentation \t\t\tA , B, C, D | A B C D=1\ \>", "Text"], Cell[BoxData[ \(\({AA, BB, CC, DD} = \ {Word[1], Word[2], \ Word[3], Word[\(-3\), \(-2\), \(-1\)]};\)\)], "Input"], Cell[BoxData[ \(AA . \ BB . \ CC . \ DD\ \[Equal] Word[]\)], "Input"], Cell["\<\ To understand the mapping class group of the 4-holed sphere S4, we \ pass to the double covering defined by the 2-fold character which is nontrivial on each boundary \ component. The total space is a 4-holed torus T4 whose fundamental group has \ presentation \t\t\tU, V, AA, BB, CC, DD | U V u v AA BB CC DD = 1\ \>", "Text"], Cell[BoxData[ \(T4Relation = KWord . Word[3, 4, 5, 6]\)], "Input"], Cell["\<\ The covering space induces the homomorphism U \t|->\tA B V\t|->\tC A AA\t|->\t(C A c)^2 BB \t|->\t(C B c)^2 CC\t|->\tC ^2 DD\t|->\t(D)^2\ \>", "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[BoxData[ \(ApplyWord[T4Relation, {UU, VV, AA2, BB2, CC2, DD2}]\ \[Equal] Word[]\)], "Input"], Cell["The homology of T4 is obtained by killing AA,BB,CC,DD. ", "Text"], Cell["Dehn Twists", "Subsection"], 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"], Cell[BoxData[ \(\((Twx\ = \ {Word[1], Word[2], Word[1, 2, 3, \(-2\), \(-1\)]})\) // MatrixForm\)], "Input"], 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[BoxData[ \(Map[ApplyAuto[Twx, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(ApplyAuto[Twx, Word[3, 1]]\ \[Equal] \[IndentingNewLine]UU . \ Word[3, 3]\ . \ \((DD . DD)\) . \ UU . \ VV\)], "Input"], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwx = {{1, 2}, {0, 1}}]\)], "Input"], Cell[BoxData[ \(\((Twy\ = \ {Word[2, 3, 1, \(-3\), \(-2\)], Word[2], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ \(Map[ApplyAuto[Twy, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(Map[ ApplyAuto[Twy, #] &, {UU, VV}]\ \[Equal] {Inverse[VV] . Inverse[UU] . Inverse[DD2] . Inverse[VV] . AA2, BB2 . CC2 . DD2 . UU . VV . VV . DD2 . UU . VV}\)], "Input"], Cell["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwy = {{\(-1\), 2}, {\(-2\), 3}}]\)], "Input"], Cell[BoxData[ \(\((Twz\ = \ {Word[1], Word[3, 1, 2, \(-1\), \(-3\)], Word[3]})\) // MatrixForm\)], "Input"], Cell[BoxData[ \(ApplyAuto[Twz, UU]\)], "Input"], 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[ \(\((mm = Map[QTracePoly[ApplyAuto[Twz, #], abcd] &, {UU, YY, VV}])\)\ // MatrixForm\)], "Input"], Cell[BoxData[ \(mm[\([1]\)]\ - \ xprime\ \ + \ z\ \((\ yprime\ - \ y)\) // Simplify\)], "Input"], Cell[BoxData[ \(Map[ApplyAuto[Twz, #] &, {UU, VV}]\)], "Input"], 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["Thus this Dehn twist corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixTwz = {{1, 0}, {\(-2\), 1}}]\)], "Input"], Cell["\<\ These are the generators of the level 2 congruence subgroup of \ SL(2,Z).\ \>", "Text"], Cell[BoxData[ \(MF[{MatrixTwx, MatrixTwy, MatrixTwz}]\)], "Input"], Cell[BoxData[ \(MatrixTwx . MatrixTwz . MatrixTwy\ // MatrixForm\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["The Lantern Relation", FontWeight->"Plain"]], "Subsection"], Cell["\<\ Now we consider a free group of rank 3. Recall the Dehn twists \ Twx, Twy, Twz. The following is a convenient shorthand for inner automorphisms of a rank 3 \ free group.\ \>", "Text"], Cell[BoxData[{ \(Inn3[w__]\ := \ Inn3[Word[w]]\), "\n", \(Inn3[ w_Word]\ := \ \((InnerAutomorphism[ w, \ #1]\ &\ )\)\ /@ \((Identity3Aut\ = \ \ Map[Word, Range[3]])\)\)}], "Input"], Cell[BoxData[ \({Identity3Aut, Inn3[3]} // MF\)], "Input"], Cell[BoxData[ \({ComposeAuto[Twz, Twx, Twy], ComposeAuto[Inn3[1], Inn3[3], Inn3[2]]} // MF\)], "Input"] }, Open ]], Cell[BoxData[ \({MatrixTwz, MatrixTwy, MatrixTwx} // MF\)], "Input"], Cell[BoxData[ \(MatrixTwz . MatrixTwy . MatrixTwx // MatrixForm\)], "Input"], Cell["A quadratic reflection", "Subsection", FontWeight->"Plain"], Cell[BoxData[ \(QRz\ = {Inverse[AA], InnerAutomorphism[AA, Inverse[BB]], \[IndentingNewLine]InnerAutomorphism[AA . BB, Inverse[CC]]}\)], "Input"], Cell[BoxData[ \(QRzUV\ = \ Map[ApplyAuto[QRz, #] &, {UU, VV}]\)], "Input"], Cell[BoxData[ \(QRzUV\ \[Equal] \ {Inverse[UU], UU . DD2 . UU . Inverse[AA2] . VV}\)], "Input"], Cell["Thus this reflection corresponds to the matrix", "Text"], Cell[BoxData[ \(MatrixForm[MatrixQz = {{\(-1\), 0}, {2, 1}}]\)], "Input"], Cell[BoxData[ \(MatrixQz . MatrixTwz\)], "Input"], Cell[BoxData[ \(QTracePoly[ Word[2, \(-3\), \(-2\), \(-1\)], {a, b, c, d, x, y, z}]\)], "Input"], Cell[BoxData[ \(\((QRR\ = ComposeAuto[QRz, Twz])\) // MatrixForm\)], "Input"], Cell[BoxData[ \(\((QRR1\ = ComposeAuto[QRR, Inn3[Word[\(-1\), \(-3\), \(-1\)]]])\)\ // MatrixForm\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, UU]\)], "Input"], Cell[BoxData[ \(ff\ = QTracePoly[ApplyAuto[QRR1, UU], abcd]\)], "Input"], Cell[BoxData[ \(Simplify[ ff\ + \ z\ yprime\ - \ \((\ \(-x\)\ + \ a\ b\ + \ c\ d)\) \[Equal] 0]\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, YY = Word[2, 3]]\)], "Input"], Cell[BoxData[ \(yprime\ == \ QTracePoly[ApplyAuto[QRR1, YY = Word[2, 3]], abcd]\)], "Input"], 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[BoxData[ \(QTracePoly[ApplyAuto[QRz, VV], abcd] \[Equal] zprime\)], "Input"], Cell[BoxData[ \(ffz\ - \ zprime\)], "Input"], Cell[BoxData[ \(ffz\ - \ zprime\ - \ x\ yprime // Expand\)], "Input"], Cell[BoxData[ \(%341\ + \ xprime\ yprime // Expand\)], "Input"], Cell[BoxData[ \(ffz\ = QTracePoly[ApplyAuto[QRR1, VV], abcd] // Expand\)], "Input"], Cell[BoxData[ \(ApplyAuto[QRR1, VV]\)], "Input"], Cell[BoxData[ \(QRR1\)], "Input"], Cell[BoxData[ \(Map[QTracePoly[ApplyAuto[QRR1, #], abcd] &, {UU, VV}] // MatrixForm\)], "Input"], Cell[BoxData[ \(ww\ = ApplyAuto[QRz, VV]\)], "Input"], Cell[BoxData[ \(UU\)], "Input"], Cell[BoxData[ \(UU . DD2 . UU . Inverse[AA2] . VV\)], "Input"], Cell[BoxData[ \(Inverse[VV] . Inverse[AA2] . VV\)], "Input"], Cell[BoxData[ \(Inverse[AA]\)], "Input"], Cell[BoxData[ \(\(abcd\ = \ {a, b, c, d, x, y, z};\)\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["The 4-holed Sphere", FontWeight->"Plain"]], "Subsection"], Cell[TextData[{ "In analogy with the punctured torus and pair-of-pants, we find geometric \ parameters for the character varieties.\nWe consider a 4-holed sphere with \ boundary components ", StyleBox[" A = Word[1], B= Word[2], C=Word[3], \nD=Word[-3,-2,-1] ", FontWeight->"Bold"], "and interior simple closed curves ", StyleBox["X = Word[1,2], Y = Word[2,3], Z = Word[3,1].", FontWeight->"Bold"] }], "Text"], 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[ \(QTracePoly[Word[1, 3, 2], {a, b, c, d, x, y, z}]\)], "Input"], Cell[BoxData[ \(QTracePoly[ Word[2, \(-3\), \(-2\), \(-1\)], {a, b, c, d, x, y, z}]\)], "Input"] }, Open ]], Cell["\<\ The orientable double cover of the punctured Moebius band P \ (2-holed projective plane) is a 4-holed sphere S ; the corresponding monomorphism of fundamental groups \ is: A = X Y, B = y X, C = x y, D = Y x, where is the \ fundamental group of S (the generators A,B,C,D correspond to bd S) and is the fundamental group of P (bd P corresponds to XY and Xy). If I xx denotes the trace of X, I yy the trace of Y and zz the trace of Z, \ then the corresponding characters for S are given by the following:\ \>", "Text"], Cell[BoxData[ \(Fricke[{{a, b, c, d}, {x, y, z}} /. {\[IndentingNewLine]a -> zz, \[IndentingNewLine]b -> \(-xx\)\ yy\ - \ zz, \ \[IndentingNewLine]c\ -> \ zz, \[IndentingNewLine]d\ -> \ \(-xx\)\ yy\ - \ zz, \[IndentingNewLine]x\ -> \ \(-\ xx^2\)\ - 2, \ \[IndentingNewLine]y\ -> \ \(-yy^2\)\ - 2, \ \[IndentingNewLine]z -> \(-xx^2\)\ - \ yy^2\ + \ zz^2\ + \ xx\ yy\ zz\ - 2}]\)], "Input"], Cell["\<\ This defines the mapping of the character variety of P into that of \ S.\ \>", "Text"] }, Open ]], Cell[CellGroupData[{ Cell["The 2-holed torus", "Section"], Cell["\<\ We want to find trace coordinates for the relative character \ variety of the 2-holed torus. The fundamental group is freely generated by X, \ Y, U with peripheral elements A = Uyx and B = Uyx. This gives the more familiar presentation AXYxyb = 1. The variables x,y,z,u,v,w,a,b \ represent the traces of the words X, Y, XY,U,Ux,Uy,A,B respectively. Fricke's relation gives the \ presentation\ \>", "Text"], Cell["a + b = x w + y v + u z - x y u", "Text", FontSlant->"Italic"], Cell["\<\ a b = x^2 + y^2 + u^2 + v^2 + w^2 + z^2+ v w z - x y z - x u v - \ y u w - 4\ \>", "Text", FontSlant->"Italic"], Cell[CellGroupData[{ Cell[BoxData[ \(\(BoundarySum\ = \ \((x\ w + y\ v + u\ z - x\ y\ u)\);\)\)], "Input"], Cell[BoxData[ \(\(BoundaryProduct\ = \ \((x^2 + y^2 + u^2 + v^2 + w^2 + z^2 + v\ w\ z - x\ y\ z - x\ u\ v - y\ u\ w - 4)\);\)\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["The 2-holed torus doubly covering the 1-holed torus", "Subsubsection", FontWeight->"Plain"], Cell["\<\ Let be the fundamental group of a 1-holed torus and \ consider the covering space corresponding to the Z/2-valued homomorphism which is nontrivial on P and Q. \ The commuator identity [S,T^2] = [S,T] S [S,.T] s implies (taking S = y x and T = X ) that A = [P,q p] = PqpQ B = P q P Q p^2 X = q p Y = P^2 satisfy AXYxyb = 1. The corresponding embedding of fundamental groups \t\t\t -----> < P,Q > \t\tmaps elements Z = X Y \t\t\t|->\t q P V = B Y\t\t\t|-> P q P Q U = A X Y = B Y X\t\t|-> P q W = A X \t\t\t|-> \tP Q p p with the corresponding map of character varieties\ \>", "Text"], Cell[BoxData[ \(\(Embedding = \[IndentingNewLine]{a \[Rule] p^2 + q^2 + r^2 - p\ q\ r - 2, \[IndentingNewLine]b \[Rule] p^2 + q^2 + r^2 - p\ q\ r - 2, \[IndentingNewLine]x \[Rule] r, \[IndentingNewLine]y \[Rule] p^2 - 2, \[IndentingNewLine]z \[Rule] p\ q - r, u \[Rule] p\ q - r, \[IndentingNewLine]v \[Rule] \(-q^2\) - r^2 + p\ q\ r + 2, \[IndentingNewLine]w \[Rule] r};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(\(BoundarySum\ = \ \((x\ w + y\ v + u\ z - x\ y\ u)\);\)\)], "Input"], Cell[BoxData[ \(\(BoundaryProduct\ = \ \((x^2 + y^2 + u^2 + v^2 + w^2 + z^2 + v\ w\ z - x\ y\ z - x\ u\ v - y\ u\ w - 4)\);\)\)], "Input"] }, Open ]], Cell[BoxData[ \(Simplify[{a\ + \ b\ - \ BoundarySum, \ a\ b\ - BoundaryProduct} /. Embedding]\)], "Input"] }, Open ]], Cell[TextData[StyleBox["An involution interchanging the boundary components", FontWeight->"Plain"]], "Subsubsection"], Cell[TextData[{ "Here is a basic (orientation-reversing) symmetry which interchanges the \ two boundary components\n", StyleBox["A ", FontWeight->"Bold"], " and ", StyleBox["B. ", FontWeight->"Bold"], " It operates by interchanging ", StyleBox["X ", FontWeight->"Bold"], "and ", StyleBox["Y", FontWeight->"Bold"], ". From the defining relation in the form\n", StyleBox[" \t\t\t\t\tA X Y = B Y X \n", FontWeight->"Bold"], "one sees that ", StyleBox["V", FontWeight->"Bold"], " ", StyleBox["= B Y ", FontWeight->"Bold"], " and ", StyleBox["W", FontWeight->"Bold"], " ", StyleBox["= A X", FontWeight->"Bold"], " are interchanged. However the traces of ", StyleBox["Z= X Y ", FontWeight->"Bold"], " and ", StyleBox["U = A X Y", FontWeight->"Bold"], "\nare fixed.", StyleBox[" ", FontWeight->"Bold"], "We check that it leaves invariant the two boundary parameters." }], "Text"], Cell[BoxData[ \(\(S12inv\ = \ {a \[Rule] b, b \[Rule] a, v \[Rule] w, w \[Rule] v, x \[Rule] y, y \[Rule] x};\)\)], "Input"], Cell[BoxData[ \(Map[ Expand[#\ - \ \((# /. S12inv)\)] &, {BoundarySum, BoundaryProduct}]\)], "Input"], Cell["Another trace", "Subsubsection", FontWeight->"Plain"], Cell[TextData[{ "We next write the character variety of the rank-three free group in terms \ of the peripheral structure.\nWe introduce a new variable ", StyleBox["p ", FontWeight->"Bold"], "which is the trace of the word ", StyleBox["AY", FontWeight->"Bold"], ". We compute the trace\nof ", StyleBox["AXYx = B Y = V ", FontWeight->"Bold"], " in two different ways. First make a substitution rule implementing\nthe \ definition of ", StyleBox["p", FontWeight->"Bold"], ". ", " " }], "Text"], 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[BoxData[ \(vPoly\ = \((t123m2\ = \ TracePoly3[Word[\ 1, 2, 3, \(-2\)], tList])\) /. S12sub\)], "Input"], Cell["\<\ This expresses relates p to v. Here is the inverse \ substitution:\ \>", "Text"], Cell[BoxData[ \(pSub\ = \ {p \[Rule] \ \(-v\)\ + \ u\ x\ + \ a\ y\ - \ w\ z\ }\)], "Input"], Cell["Now we compute the trace of xyAXYY in terms of a,x,y,z,w,p.", "Text"], Cell[BoxData[ \(\((tm2m31233\ = \ TracePoly3[Word[\ \(-2\), \(-3\), 1, 2, 3, 3], tList])\) /. S12sub\)], "Input"], Cell[BoxData[ \(% /. pSub // Expand\)], "Input"], Cell[BoxData[ \(Collect[%, y]\)], "Input"], Cell[BoxData[ \(\(\((tm2m31323\ = \ TracePoly3[Word[\(-2\), \(-3\), 1, 3, 2, 3], tList])\) /. \ S12sub\)\ /. \ pSub\ // Expand\)], "Input"], Cell[BoxData[ \(\(\(\((tm2m31323\ = \ TracePoly3[Word[\(-2\), \(-3\), 1, 3, 2, 3], tList])\) /. \ S12sub\)\(\ \)\(//\)\(Expand\)\(\ \)\)\)], "Input"], Cell[BoxData[ \(% /. pSub\)], "Input"], Cell[BoxData[ \(% // Expand\)], "Input"], Cell[BoxData[ \(Collect[%297, z]\)], "Input"], Cell[BoxData[ \(%135\ /. \((a \[Rule] \ BoundarySum\ - \ b)\) // Expand\)], "Input"], Cell[BoxData[ \(tList\)], "Input"], Cell[BoxData[ \(\((tm1m231212m1\ = \ TracePoly3[Word[\ \(-2\), \(-3\), 1, 2, 3, 3], tList])\) /. S12sub\)], "Input"], Cell[BoxData[ \(Collect[%, p]\)], "Input"], Cell[BoxData[ \(%266 /. pSub // Expand\)], "Input"], Cell[BoxData[ \(\((tm1m23122 = \ TracePoly3[Word[\ \(-1\), \(-2\), 3, 1, 2, 2], tList])\) /. S12sub\)], "Input"], Cell[BoxData[ \(Collect[%, p]\)], "Input"], Cell[BoxData[ \(Collect[Expand[%], {p, x, px, x^2, x^3}]\)], "Input"], Cell[BoxData[ \(\((\ %265\ + \ y\ BoundaryDifference\ - \ p)\) /. pSub\ // Expand\)], "Input"], Cell[BoxData[ \(BoundaryDifference\ = \ \(\(2\ a\)\(\ \)\(-\)\(\ \)\(BoundarySum\)\(\ \ \)\)\)], "Input"], Cell[BoxData[ \(BoundarySum\)], "Input"], Cell[BoxData[ \(%277\ - \ y\ BoundarySum\ - \((p /. pSub)\) // Expand\)], "Input"], Cell[BoxData[ \(pSub\)], "Input"], Cell[CellGroupData[{ Cell[TextData[StyleBox["Output routine", FontWeight->"Plain"]], "Subsubsection"], Cell[BoxData[ \(\(\(SymbolWordS12[w_Word]\)\(\ \)\(:=\)\(\ \)\(Apply[StringJoin, \n\t Map[{\ "\", "\", \ "\", \ "\", \ "\", "\", \ "\"}[\([#]\)] &, \n\t\t4 + \ toList[w]]]\)\(\ \)\)\)], "Input"], Cell[BoxData[ \(SymbolWordS12[l_List]\ := \ Map[SymbolWordS12, l]\)], "Input"], Cell["Here is the word for V = Inverse( BY):", "Text"] }, Open ]], Cell[BoxData[ \(SymbolWordS12[Word[1, 2, 3, \(-2\)]]\)], "Input"] }, Open ]], Cell[CellGroupData[{ Cell["The 2-holed torus doubly covering the 1-holed torus", "Subsubsection", FontWeight->"Plain"], Cell["\<\ Let be the fundamental group of a 1-holed torus and \ consider the covering space corresponding to the Z/2-valued homomorphism which is nontrivial on P and Q. \ The commuator identity [S,T^2] = [S,T] S [S,.T] s implies (taking S = y x and T = X ) that A = [P,q p] = PqpQ B = P q P Q p^2 X = q p Y = P^2 satisfy AXYxyb = 1. The corresponding embedding of fundamental groups \t\t\t -----> < P,Q > \t\tmaps elements Z = X Y \t\t\t|->\t q P V = B Y\t\t\t|-> P q P Q U = A X Y = B Y X\t\t|-> P q W = A X \t\t\t|-> \tP Q p p with the corresponding map of character varieties\ \>", "Text"], Cell[BoxData[ \(\(Embedding = \[IndentingNewLine]{a \[Rule] p^2 + q^2 + r^2 - p\ q\ r - 2, \[IndentingNewLine]b \[Rule] p^2 + q^2 + r^2 - p\ q\ r - 2, \[IndentingNewLine]x \[Rule] r, \[IndentingNewLine]y \[Rule] p^2 - 2, \[IndentingNewLine]z \[Rule] p\ q - r, u \[Rule] p\ q - r, \[IndentingNewLine]v \[Rule] \(-q^2\) - r^2 + p\ q\ r + 2, \[IndentingNewLine]w \[Rule] r};\)\)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(\(BoundarySum\ = \ \((x\ w + y\ v + u\ z - x\ y\ u)\);\)\)], "Input"], Cell[BoxData[ \(\(BoundaryProduct\ = \ \((x^2 + y^2 + u^2 + v^2 + w^2 + z^2 + v\ w\ z - x\ y\ z - x\ u\ v - y\ u\ w - 4)\);\)\)], "Input"] }, Open ]], Cell[BoxData[ \(Simplify[{a\ + \ b\ - \ BoundarySum, \ a\ b\ - BoundaryProduct} /. Embedding]\)], "Input"] }, Open ]], Cell["The Mapping Class Group of the 2-holed torus", "Section"], Cell[TextData[{ "We use the presentation ", StyleBox["A = Word[1], X = Word[2], Y = Word[3], B = Word[3,2,-3,-2,-1] ", FontWeight->"Bold"], " with defining relation ", StyleBox["A X Y x y b . ", FontWeight->"Bold"], " \nLet ", StyleBox["V ", FontWeight->"Bold"], " denote the word ", StyleBox[" B Y", FontWeight->"Bold"], "; then the simple loops ", StyleBox["Y, X, V ", FontWeight->"Bold"], "form a spine for ", StyleBox["T2. ", FontWeight->"Bold"], "Here are the Dehn twists: ", StyleBox[" ", FontWeight->"Bold"] }], "Text"], Cell[BoxData[ \(\(VWord\ = \ Word[1, 2, 3, \(-2\)];\)\)], "Input"], Cell[BoxData[{ \(\(T2x\ = \ {Word[1], Word[2], \ Word[3, 2]};\)\), "\[IndentingNewLine]", \(\(T2y\ = \ {Word[1], \ Word[2, \(-3\)], \ Word[3]};\)\), "\[IndentingNewLine]", \(\(T2v\ = \ {Word[1], \ Word[2] . VWord, \ Inverse[VWord] . Word[3] . VWord};\)\)}], "Input"], Cell[BoxData[ \(T2vi = {Word[1], \ Word[2] . Inverse[VWord], \ VWord . Word[3] . Inverse[VWord]}\)], "Input"], Cell[BoxData[ \(Map[MatrixForm[SymbolWordS12[#]] &, {T2x, T2y, T2v, T2vi}]\)], "Input"], Cell[BoxData[ \(\(ComposeAuto[T2y, T2v]\ // SymbolWordS12\)\ // MatrixForm\)], "Input"], Cell[TextData[{ StyleBox["Y", FontWeight->"Bold"], " and ", StyleBox["V ", FontWeight->"Bold"], " are disjoint, so their respective Dehn twists commute." }], "Text"], Cell[BoxData[ \(ComposeAuto[T2v, T2y] == ComposeAuto[T2y, T2v]\)], "Input"], Cell[TextData[{ "X ", StyleBox[" and ", FontWeight->"Plain"], " Y ", StyleBox["intersect once transversely, so their Dehn twists satisfy a braid \ relation:", FontWeight->"Plain"] }], "Text", FontWeight->"Bold"], Cell[BoxData[ \(brXY\ = \ ComposeAuto[T2x, T2y, T2x]\)], "Input"], Cell[BoxData[ \(ComposeAuto[T2y, T2x, T2y] \[Equal] \ ComposeAuto[T2x, T2y, T2x]\)], "Input"], Cell["\<\ Unlike a torus (where this element has order 4), or a 1-holed torus \ (where the 4th power is an inner automorphism), the 4th power here is a Dehn twist around the simple \ loop separating the handle from the two boundary components.\ \>", "Text"], Cell[BoxData[ \(ComposeAuto[brXY, brXY, brXY, brXY]\)], "Input"], Cell[TextData[{ "X ", StyleBox[" and ", FontWeight->"Plain"], " V ", StyleBox["also intersect once transversely, so their Dehn twists also \ satisfy a braid relation:", FontWeight->"Plain"] }], "Text", FontWeight->"Bold"], Cell[BoxData[ \(brXV\ = \ ComposeAuto[T2x, T2vi, T2x]\)], "Input"], Cell[BoxData[ \(ComposeAuto[T2vi, T2x, T2vi] \[Equal] brXV\)], "Input"], Cell[BoxData[ \(T2yxv\ = ComposeAuto[T2y, T2x, T2vi]\)], "Input"], Cell[BoxData[ \(ComposeAuto[T2yxv, Inn3[3, 2, \(-3\), \(-2\), \(-1\)]]\)], "Input"], Cell[BoxData[ \(ComposeAuto[Inn3[\(-1\)], T2yxv, T2yxv, T2yxv, T2yxv]\)], "Input"], Cell[TextData[{ "Thus the 4th power of the product ", StyleBox["Ty Tx Tz ", FontWeight->"Bold"], " is inverse Dehn twist around the boundary component ", StyleBox["A", FontWeight->"Bold"], "," }], "Text"], Cell[BoxData[ \(\(\(\ \)\(TP12\ = \((Expand[\(TracePoly3[#, tList] /. S12sub\)\ /. \ pSub]\ &)\);\)\)\)], "Input"], Cell[BoxData[ \(Map[MatrixForm[Map[TP12, #]] &, {T2y, T2x, T2v, T2vi}]\)], "Input"], Cell[BoxData[ \(S12sub\)], "Input"], Cell[BoxData[ \(Map[TP12, S12Words = {Word[2], Word[3], Word[2, 3], Word[1, 2, 3], Word[1, 2, 3, \(-2\)], Word[1, 2]}]\)], "Input"], Cell[BoxData[ \(AutoS12[a_]\ := Map[ApplyAuto[a, #] &, S12Words]\)], "Input"], Cell[BoxData[ \(AutoS12[T2vi]\)], "Input"], Cell[BoxData[ \(TPolyS12[a_]\ := \ Map[TP12, AutoS12[a]]\)], "Input"], Cell[BoxData[ \(TPolyS12[T2vi] // MatrixForm\)], "Input"], Cell[BoxData[ \(Map[ MatrixForm[TPolyS12[#]] &, {Identity3Aut, T2x, T2y, T2v, T2vi}]\)], "Input"], Cell[BoxData[""], "Input"] }, FrontEndVersion->"4.2 for X", ScreenRectangle->{{0, 1152}, {0, 900}}, CellGrouping->Manual, WindowSize->{1024, 694}, WindowMargins->{{Automatic, 39}, {33, Automatic}}, PrintingPageRange->{Automatic, Automatic}, PrintingOptions->{"PaperSize"->{612, 792}, "PaperOrientation"->"Portrait", "PostScriptOutputFile":>FrontEnd`FileName[{$RootDirectory, "home", "wmg", \ "Mathematica"}, "Autos.nb.ps", CharacterEncoding -> "iso8859-1"], "Magnification"->1} ] (******************************************************************* Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. *******************************************************************) (*CellTagsOutline CellTagsIndex->{ "tag1"->{ Cell[31687, 1232, 74, 1, 42, "Subsubsection", CellTags->"tag1"], Cell[31764, 1235, 496, 9, 59, "Input", CellTags->{"tag1", "In[132]:="}], Cell[32263, 1246, 118, 2, 27, "Input", CellTags->{"tag1", "In[133]:="}], Cell[32565, 1255, 146, 3, 27, "Input", CellTags->{"tag1", "In[135]:="}], Cell[32714, 1260, 154, 3, 27, "Input", CellTags->{"tag1", "In[136]:="}], Cell[32871, 1265, 335, 6, 47, "Input", CellTags->{"tag1", "In[137]:="}], Cell[33209, 1273, 123, 2, 27, "Input", CellTags->{"tag1", "In[138]:="}], Cell[33335, 1277, 202, 4, 27, "Input", CellTags->{"tag1", "In[139]:="}]}, "In[132]:="->{ Cell[31764, 1235, 496, 9, 59, "Input", CellTags->{"tag1", "In[132]:="}]}, "In[133]:="->{ Cell[32263, 1246, 118, 2, 27, "Input", CellTags->{"tag1", "In[133]:="}]}, "In[135]:="->{ Cell[32565, 1255, 146, 3, 27, "Input", CellTags->{"tag1", "In[135]:="}]}, "In[136]:="->{ Cell[32714, 1260, 154, 3, 27, "Input", CellTags->{"tag1", "In[136]:="}]}, "In[137]:="->{ Cell[32871, 1265, 335, 6, 47, "Input", CellTags->{"tag1", "In[137]:="}]}, "In[138]:="->{ Cell[33209, 1273, 123, 2, 27, "Input", CellTags->{"tag1", "In[138]:="}]}, "In[139]:="->{ Cell[33335, 1277, 202, 4, 27, "Input", CellTags->{"tag1", "In[139]:="}]} } *) (*CellTagsIndex CellTagsIndex->{ {"tag1", 82855, 3000}, {"In[132]:=", 83529, 3017}, {"In[133]:=", 83630, 3020}, {"In[135]:=", 83731, 3023}, {"In[136]:=", 83832, 3026}, {"In[137]:=", 83933, 3029}, {"In[138]:=", 84034, 3032}, {"In[139]:=", 84135, 3035} } *) (*NotebookFileOutline Notebook[{ Cell[1754, 51, 25, 0, 112, "Title"], Cell[1782, 53, 72, 0, 64, "Subtitle"], Cell[1857, 55, 48, 0, 57, "Subsubtitle"], Cell[CellGroupData[{ Cell[1930, 59, 75, 1, 58, "Section"], Cell[CellGroupData[{ Cell[2030, 64, 119, 2, 27, "Input"], Cell[2152, 68, 118, 3, 32, "Text"] }, Open ]], Cell[2285, 74, 69, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[2391, 80, 36, 0, 58, "Section"], Cell[2430, 82, 615, 19, 68, "Text"], Cell[3048, 103, 700, 13, 187, "Input"], Cell[3751, 118, 74, 0, 32, "Text"], Cell[3828, 120, 54, 1, 27, "Input"], Cell[3885, 123, 102, 3, 32, "Text"], Cell[3990, 128, 54, 1, 27, "Input"], Cell[4047, 131, 97, 3, 32, "Text"], Cell[4147, 136, 63, 1, 27, "Input"], Cell[4213, 139, 72, 1, 27, "Input"], Cell[CellGroupData[{ Cell[4310, 144, 80, 1, 45, "Subsection"], Cell[4393, 147, 432, 15, 50, "Text"], Cell[4828, 164, 134, 2, 43, "Input"], Cell[4965, 168, 66, 1, 27, "Input"], Cell[5034, 171, 59, 1, 27, "Input"], Cell[5096, 174, 128, 5, 32, "Text"], Cell[5227, 181, 55, 1, 27, "Input"], Cell[CellGroupData[{ Cell[5307, 186, 82, 1, 42, "Subsubsection"], Cell[5392, 189, 137, 5, 32, "Text"], Cell[5532, 196, 215, 3, 59, "Input"], Cell[5750, 201, 77, 1, 27, "Input"], Cell[5830, 204, 80, 1, 27, "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[5959, 211, 109, 1, 45, "Subsection"], Cell[6071, 214, 164, 5, 32, "Text"], Cell[6238, 221, 320, 5, 59, "Input"], Cell[6561, 228, 249, 11, 32, "Text"], Cell[6813, 241, 72, 1, 27, "Input"], Cell[6888, 244, 43, 0, 61, "Section"], Cell[CellGroupData[{ Cell[6956, 248, 461, 19, 32, "Text"], Cell[7420, 269, 77, 1, 27, "Input"], Cell[7500, 272, 281, 11, 32, "Text"], Cell[7784, 285, 89, 1, 27, "Input"] }, Open ]], Cell[7888, 289, 122, 3, 32, "Text"], Cell[8013, 294, 109, 2, 27, "Input"], Cell[8125, 298, 88, 3, 32, "Text"], Cell[8216, 303, 69, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[8322, 309, 119, 1, 42, "Subsubsection"], Cell[8444, 312, 520, 16, 68, "Text"], Cell[8967, 330, 111, 2, 27, "Input"], Cell[9081, 334, 92, 1, 27, "Input"], Cell[9176, 337, 63, 1, 27, "Input"], Cell[9242, 340, 124, 3, 32, "Text"], Cell[9369, 345, 113, 2, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[9519, 352, 88, 1, 42, "Subsubsection"], Cell[9610, 355, 114, 2, 27, "Input"], Cell[9727, 359, 90, 1, 27, "Input"], Cell[9820, 362, 172, 7, 32, "Text"], Cell[9995, 371, 48, 1, 27, "Input"] }, Open ]] }, Open ]], Cell[10070, 376, 46, 0, 32, "Text"], Cell[10119, 378, 61, 1, 27, "Input"], Cell[10183, 381, 89, 3, 32, "Text"], Cell[10275, 386, 87, 1, 27, "Input"], Cell[CellGroupData[{ Cell[10387, 391, 80, 1, 42, "Subsubsection"], Cell[10470, 394, 268, 11, 32, "Text"], Cell[10741, 407, 66, 1, 27, "Input"], Cell[10810, 410, 432, 14, 50, "Text"], Cell[11245, 426, 67, 1, 27, "Input"], Cell[11315, 429, 118, 5, 32, "Text"], Cell[11436, 436, 72, 1, 27, "Input"], Cell[11511, 439, 48, 0, 32, "Text"], Cell[11562, 441, 64, 1, 27, "Input"], Cell[11629, 444, 180, 6, 32, "Text"], Cell[11812, 452, 111, 3, 27, "Input"], Cell[11926, 457, 178, 6, 32, "Text"], Cell[12107, 465, 90, 1, 27, "Input"], Cell[12200, 468, 67, 1, 27, "Input"], Cell[12270, 471, 135, 5, 32, "Text"], Cell[12408, 478, 46, 1, 27, "Input"], Cell[12457, 481, 179, 6, 32, "Text"], Cell[12639, 489, 67, 1, 27, "Input"], Cell[12709, 492, 46, 1, 27, "Input"], Cell[12758, 495, 224, 8, 32, "Text"], Cell[12985, 505, 63, 1, 27, "Input"], Cell[13051, 508, 105, 4, 32, "Text"], Cell[13159, 514, 61, 1, 27, "Input"], Cell[13223, 517, 74, 1, 27, "Input"], Cell[13300, 520, 70, 0, 32, "Text"], Cell[13373, 522, 126, 2, 27, "Input"], Cell[13502, 526, 75, 0, 32, "Text"], Cell[13580, 528, 87, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[13704, 534, 91, 1, 42, "Subsubsection"], Cell[13798, 537, 159, 8, 32, "Text"], Cell[13960, 547, 76, 1, 27, "Input"], Cell[14039, 550, 60, 1, 27, "Input"], Cell[14102, 553, 121, 5, 32, "Text"], Cell[14226, 560, 57, 1, 27, "Input"], Cell[14286, 563, 269, 10, 32, "Text"], Cell[14558, 575, 82, 1, 27, "Input"], Cell[14643, 578, 57, 1, 27, "Input"], Cell[14703, 581, 194, 8, 32, "Text"], Cell[14900, 591, 87, 1, 27, "Input"], Cell[14990, 594, 136, 5, 32, "Text"], Cell[15129, 601, 91, 1, 27, "Input"], Cell[15223, 604, 157, 5, 32, "Text"], Cell[15383, 611, 91, 1, 27, "Input"] }, Open ]], Cell[15489, 615, 139, 5, 32, "Text"], Cell[15631, 622, 56, 1, 27, "Input"], Cell[CellGroupData[{ Cell[15712, 627, 85, 1, 42, "Subsubsection"], Cell[15800, 630, 318, 10, 50, "Text"], Cell[16121, 642, 121, 2, 43, "Input"], Cell[16245, 646, 40, 0, 32, "Text"], Cell[16288, 648, 54, 1, 27, "Input"], Cell[16345, 651, 35, 0, 32, "Text"], Cell[16383, 653, 80, 1, 27, "Input"], Cell[16466, 656, 88, 1, 27, "Input"], Cell[16557, 659, 107, 2, 27, "Input"], Cell[16667, 663, 144, 5, 32, "Text"], Cell[16814, 670, 62, 1, 27, "Input"], Cell[16879, 673, 126, 5, 32, "Text"], Cell[17008, 680, 45, 1, 27, "Input"], Cell[17056, 683, 42, 0, 32, "Text"], Cell[17101, 685, 35, 1, 27, "Input"], Cell[17139, 688, 288, 14, 32, "Text"], Cell[17430, 704, 120, 2, 27, "Input"], Cell[17553, 708, 48, 0, 32, "Text"], Cell[17604, 710, 56, 1, 27, "Input"] }, Open ]], Cell[17675, 714, 64, 0, 32, "Text"], Cell[17742, 716, 60, 1, 27, "Input"], Cell[CellGroupData[{ Cell[17827, 721, 94, 1, 42, "Subsubsection"], Cell[17924, 724, 67, 1, 27, "Input"], Cell[17994, 727, 99, 5, 32, "Text"], Cell[18096, 734, 64, 1, 27, "Input"], Cell[18163, 737, 40, 0, 32, "Text"], Cell[18206, 739, 54, 1, 27, "Input"], Cell[18263, 742, 85, 1, 27, "Input"], Cell[18351, 745, 135, 5, 32, "Text"], Cell[18489, 752, 83, 1, 27, "Input"], Cell[18575, 755, 52, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[18664, 761, 80, 1, 42, "Subsubsection"], Cell[18747, 764, 166, 6, 32, "Text"], Cell[18916, 772, 63, 1, 27, "Input"], Cell[CellGroupData[{ Cell[19004, 777, 36, 0, 32, "Text"], Cell[19043, 779, 74, 1, 27, "Input"] }, Open ]], Cell[19132, 783, 53, 1, 27, "Input"], Cell[CellGroupData[{ Cell[19210, 788, 51, 0, 32, "Text"], Cell[19264, 790, 81, 1, 27, "Input"] }, Open ]], Cell[19360, 794, 205, 9, 42, "Subsubsection"], Cell[19568, 805, 61, 1, 27, "Input"] }, Open ]], Cell[19644, 809, 127, 2, 27, "Input"], Cell[19774, 813, 108, 2, 27, "Input"], Cell[19885, 817, 90, 1, 27, "Input"], Cell[19978, 820, 64, 1, 42, "Subsubsection"], Cell[20045, 823, 105, 4, 32, "Text"], Cell[20153, 829, 67, 1, 27, "Input"], Cell[CellGroupData[{ Cell[20245, 834, 36, 0, 32, "Text"], Cell[20284, 836, 74, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[20395, 842, 94, 1, 42, "Subsubsection"], Cell[20492, 845, 72, 1, 27, "Input"], Cell[20567, 848, 129, 5, 32, "Text"], Cell[20699, 855, 141, 3, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[20877, 863, 27, 0, 61, "Section"], Cell[20907, 865, 427, 14, 50, "Text"], Cell[21337, 881, 128, 2, 27, "Input"], Cell[21468, 885, 255, 10, 32, "Text"], Cell[21726, 897, 126, 2, 27, "Input"], Cell[21855, 901, 69, 1, 27, "Input"], Cell[21927, 904, 119, 3, 32, "Text"], Cell[22049, 909, 86, 1, 27, "Input"], Cell[22138, 912, 105, 1, 42, "Subsubsection"], Cell[22246, 915, 151, 5, 32, "Text"], Cell[22400, 922, 130, 3, 27, "Input"] }, Open ]], Cell[22545, 928, 106, 2, 27, "Input"], Cell[22654, 932, 105, 3, 32, "Text"], Cell[22762, 937, 603, 8, 139, "Input"], Cell[23368, 947, 128, 4, 42, "Subsubsection"], Cell[23499, 953, 107, 2, 27, "Input"], Cell[23609, 957, 132, 3, 32, "Text"], Cell[23744, 962, 106, 2, 27, "Input"], Cell[23853, 966, 51, 1, 27, "Input"], Cell[CellGroupData[{ Cell[23929, 971, 46, 0, 61, "Section"], Cell[23978, 973, 846, 29, 68, "Text"], Cell[24827, 1004, 84, 1, 45, "Subsection"], Cell[CellGroupData[{ Cell[24936, 1009, 135, 3, 32, "Text"], Cell[CellGroupData[{ Cell[25096, 1016, 56, 1, 27, "Input"], Cell[25155, 1019, 130, 2, 27, "Input"], Cell[25288, 1023, 188, 3, 43, "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[25525, 1032, 91, 3, 32, "Text"], Cell[CellGroupData[{ Cell[25641, 1039, 277, 5, 59, "Input"], Cell[25921, 1046, 235, 4, 59, "Input"] }, Open ]] }, Open ]], Cell[26183, 1054, 93, 3, 32, "Text"], Cell[26279, 1059, 315, 5, 75, "Input"], Cell[26597, 1066, 101, 3, 32, "Text"], Cell[26701, 1071, 151, 3, 43, "Input"], Cell[26855, 1076, 54, 0, 32, "Text"], Cell[26912, 1078, 376, 7, 91, "Input"], Cell[27291, 1087, 53, 0, 32, "Text"], Cell[27347, 1089, 131, 2, 43, "Input"], Cell[27481, 1093, 104, 3, 32, "Text"], Cell[27588, 1098, 156, 2, 43, "Input"], Cell[27747, 1102, 104, 3, 32, "Text"], Cell[27854, 1107, 571, 12, 107, "Input"], Cell[28428, 1121, 161, 3, 27, "Input"], Cell[28592, 1126, 126, 2, 27, "Input"], Cell[28721, 1130, 553, 10, 123, "Input"], Cell[29277, 1142, 249, 5, 43, "Input"], Cell[29529, 1149, 78, 1, 45, "Subsection"], Cell[29610, 1152, 291, 8, 32, "Text"] }, Open ]], Cell[29916, 1163, 59, 1, 27, "Input"], Cell[29978, 1166, 64, 1, 27, "Input"], Cell[30045, 1169, 65, 1, 27, "Input"], Cell[30113, 1172, 354, 11, 50, "Text"], Cell[30470, 1185, 191, 3, 27, "Input"], Cell[30664, 1190, 51, 0, 32, "Text"], Cell[30718, 1192, 79, 1, 27, "Input"], Cell[30800, 1195, 91, 1, 42, "Subsubsection"], Cell[30894, 1198, 257, 10, 32, "Text"], Cell[31154, 1210, 120, 2, 27, "Input"], Cell[31277, 1214, 89, 1, 42, "Subsubsection"], Cell[31369, 1217, 151, 5, 32, "Text"], Cell[31523, 1224, 87, 1, 27, "Input"], Cell[31613, 1227, 49, 1, 27, "Input"], Cell[CellGroupData[{ Cell[31687, 1232, 74, 1, 42, "Subsubsection", CellTags->"tag1"], Cell[31764, 1235, 496, 9, 59, "Input", CellTags->{"tag1", "In[132]:="}], Cell[32263, 1246, 118, 2, 27, "Input", CellTags->{"tag1", "In[133]:="}], Cell[32384, 1250, 178, 3, 27, "Input"], Cell[32565, 1255, 146, 3, 27, "Input", CellTags->{"tag1", "In[135]:="}], Cell[32714, 1260, 154, 3, 27, "Input", CellTags->{"tag1", "In[136]:="}], Cell[32871, 1265, 335, 6, 47, "Input", CellTags->{"tag1", "In[137]:="}], Cell[33209, 1273, 123, 2, 27, "Input", CellTags->{"tag1", "In[138]:="}], Cell[33335, 1277, 202, 4, 27, "Input", CellTags->{"tag1", "In[139]:="}] }, Open ]], Cell[33552, 1284, 159, 2, 27, "Input"], Cell[33714, 1288, 63, 0, 45, "Subsection"], Cell[33780, 1290, 105, 1, 32, "Text"], Cell[33888, 1293, 77, 1, 27, "Input"], Cell[33968, 1296, 147, 2, 32, "Text"], Cell[34118, 1300, 102, 2, 27, "Input"], Cell[34223, 1304, 212, 8, 32, "Text"], Cell[34438, 1314, 89, 1, 27, "Input"], Cell[34530, 1317, 74, 0, 32, "Text"], Cell[34607, 1319, 89, 1, 27, "Input"], Cell[34699, 1322, 69, 1, 27, "Input"], Cell[34771, 1325, 112, 2, 31, "Input"], Cell[34886, 1329, 57, 0, 61, "Section"], Cell[34946, 1331, 321, 9, 50, "Text"], Cell[35270, 1342, 36, 1, 27, "Input"], Cell[35309, 1345, 68, 1, 27, "Input"], Cell[35380, 1348, 46, 1, 27, "Input"], Cell[35429, 1351, 78, 1, 27, "Input"], Cell[35510, 1354, 77, 1, 27, "Input"], Cell[35590, 1357, 307, 13, 32, "Text"], Cell[35900, 1372, 101, 2, 27, "Input"], Cell[36004, 1376, 47, 1, 27, "Input"], Cell[36054, 1379, 44, 1, 27, "Input"], Cell[36101, 1382, 45, 1, 27, "Input"], Cell[36149, 1385, 57, 1, 27, "Input"], Cell[36209, 1388, 55, 0, 61, "Section"], Cell[36267, 1390, 83, 1, 45, "Subsection"], Cell[36353, 1393, 361, 14, 32, "Text"], Cell[36717, 1409, 111, 2, 27, "Input"], Cell[36831, 1413, 103, 2, 27, "Input"], Cell[36937, 1417, 125, 5, 32, "Text"], Cell[37065, 1424, 92, 1, 27, "Input"], Cell[37160, 1427, 112, 2, 27, "Input"], Cell[37275, 1431, 73, 0, 61, "Section"], Cell[37351, 1433, 1262, 23, 251, "Input"], Cell[38616, 1458, 63, 1, 27, "Input"], Cell[38682, 1461, 52, 1, 27, "Input"], Cell[38737, 1464, 46, 1, 27, "Input"], Cell[38786, 1467, 51, 1, 27, "Input"], Cell[38840, 1470, 86, 1, 27, "Input"], Cell[38929, 1473, 70, 0, 61, "Section"], Cell[39002, 1475, 1538, 28, 347, "Input"], Cell[40543, 1505, 32, 0, 45, "Subsection"], Cell[40578, 1507, 82, 1, 27, "Input"], Cell[40663, 1510, 71, 1, 27, "Input"], Cell[40737, 1513, 162, 4, 43, "Input"], Cell[40902, 1519, 109, 2, 27, "Input"], Cell[41014, 1523, 41, 0, 61, "Section"], Cell[CellGroupData[{ Cell[41080, 1527, 40, 0, 45, "Subsection"], Cell[41123, 1529, 373, 10, 50, "Text"], Cell[41499, 1541, 461, 8, 59, "Input"], Cell[41963, 1551, 83, 1, 27, "Input"], Cell[42049, 1554, 76, 0, 32, "Text"], Cell[42128, 1556, 81, 1, 27, "Input"], Cell[42212, 1559, 43, 1, 27, "Input"], Cell[42258, 1562, 43, 1, 27, "Input"], Cell[CellGroupData[{ Cell[42326, 1567, 115, 1, 42, "Subsubsection"], Cell[42444, 1570, 43, 1, 27, "Input"], Cell[42490, 1573, 60, 1, 27, "Input"], Cell[42553, 1576, 135, 6, 32, "Text"], Cell[42691, 1584, 119, 1, 42, "Subsubsection"], Cell[42813, 1587, 507, 13, 86, "Text"], Cell[43323, 1602, 52, 1, 27, "Input"], Cell[43378, 1605, 63, 1, 32, "Text"], Cell[43444, 1608, 67, 1, 27, "Input"], Cell[43514, 1611, 304, 11, 68, "Text"], Cell[43821, 1624, 62, 1, 27, "Input"], Cell[43886, 1627, 71, 1, 27, "Input"], Cell[43960, 1630, 217, 5, 32, "Text"], Cell[44180, 1637, 128, 3, 27, "Input"], Cell[44311, 1642, 200, 8, 32, "Text"], Cell[44514, 1652, 285, 11, 32, "Text"], Cell[44802, 1665, 86, 1, 27, "Input"], Cell[44891, 1668, 139, 6, 32, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[45067, 1679, 43, 0, 45, "Subsection"], Cell[45113, 1681, 175, 4, 50, "Text"], Cell[45291, 1687, 129, 2, 27, "Input"], Cell[45423, 1691, 74, 1, 27, "Input"], Cell[45500, 1694, 383, 6, 59, "Input"], Cell[45886, 1702, 70, 1, 27, "Input"], Cell[45959, 1705, 136, 5, 42, "Subsubsection"], Cell[46098, 1712, 207, 5, 50, "Text"], Cell[46308, 1719, 288, 5, 59, "Input"], Cell[46599, 1726, 208, 5, 104, "Text"], Cell[46810, 1733, 45, 0, 32, "Text"], Cell[46858, 1735, 266, 4, 59, "Input"], Cell[47127, 1741, 349, 9, 122, "Text"], Cell[CellGroupData[{ Cell[47501, 1754, 113, 4, 42, "Subsubsection"], Cell[47617, 1760, 444, 9, 104, "Text"], Cell[48064, 1771, 70, 1, 27, "Input"], Cell[48137, 1774, 218, 5, 158, "Text"], Cell[48358, 1781, 89, 3, 32, "Text"], Cell[48450, 1786, 82, 1, 27, "Input"], Cell[48535, 1789, 183, 3, 27, "Input"], Cell[48721, 1794, 109, 2, 27, "Input"], Cell[48833, 1798, 71, 0, 32, "Text"], Cell[48907, 1800, 195, 5, 50, "Text"] }, Open ]], Cell[49117, 1808, 79, 1, 42, "Subsubsection"], Cell[49199, 1811, 119, 2, 27, "Input"], Cell[49321, 1815, 163, 4, 50, "Text"], Cell[49487, 1821, 67, 1, 27, "Input"], Cell[49557, 1824, 150, 2, 43, "Input"], Cell[49710, 1828, 62, 0, 32, "Text"], Cell[49775, 1830, 73, 1, 27, "Input"], Cell[49851, 1833, 119, 2, 27, "Input"], Cell[49973, 1837, 67, 1, 27, "Input"], Cell[50043, 1840, 218, 4, 27, "Input"], Cell[50264, 1846, 62, 0, 32, "Text"], Cell[50329, 1848, 83, 1, 27, "Input"], Cell[50415, 1851, 119, 2, 27, "Input"], Cell[50537, 1855, 51, 1, 27, "Input"], Cell[50591, 1858, 48, 1, 27, "Input"], Cell[50642, 1861, 101, 2, 27, "Input"], Cell[50746, 1865, 110, 2, 27, "Input"], Cell[50859, 1869, 67, 1, 27, "Input"], Cell[50929, 1872, 235, 4, 43, "Input"], Cell[51167, 1878, 62, 0, 32, "Text"], Cell[51232, 1880, 78, 1, 27, "Input"], Cell[51313, 1883, 97, 3, 32, "Text"], Cell[51413, 1888, 70, 1, 27, "Input"], Cell[51486, 1891, 82, 1, 27, "Input"], Cell[CellGroupData[{ Cell[51593, 1896, 88, 1, 42, "Subsubsection"], Cell[51684, 1899, 196, 5, 50, "Text"], Cell[51883, 1906, 176, 3, 43, "Input"], Cell[52062, 1911, 54, 1, 27, "Input"], Cell[52119, 1914, 114, 2, 27, "Input"] }, Open ]], Cell[52248, 1919, 72, 1, 27, "Input"], Cell[52323, 1922, 80, 1, 27, "Input"], Cell[52406, 1925, 90, 1, 42, "Subsubsection"], Cell[52499, 1928, 181, 4, 43, "Input"], Cell[52683, 1934, 83, 1, 27, "Input"], Cell[52769, 1937, 79, 1, 27, "Input"], Cell[52851, 1940, 109, 2, 27, "Input"], Cell[52963, 1944, 62, 0, 32, "Text"], Cell[53028, 1946, 77, 1, 27, "Input"], Cell[53108, 1949, 53, 1, 27, "Input"], Cell[53164, 1952, 70, 1, 27, "Input"], Cell[53237, 1955, 106, 2, 27, "Input"], Cell[53346, 1959, 82, 1, 27, "Input"], Cell[53431, 1962, 123, 2, 27, "Input"], Cell[53557, 1966, 52, 1, 27, "Input"], Cell[53612, 1969, 77, 1, 27, "Input"], Cell[53692, 1972, 131, 3, 27, "Input"], Cell[53826, 1977, 65, 1, 27, "Input"], Cell[53894, 1980, 104, 2, 27, "Input"], Cell[54001, 1984, 266, 4, 59, "Input"], Cell[54270, 1990, 85, 1, 27, "Input"], Cell[54358, 1993, 49, 1, 27, "Input"], Cell[54410, 1996, 75, 1, 27, "Input"], Cell[54488, 1999, 68, 1, 27, "Input"], Cell[54559, 2002, 88, 1, 27, "Input"], Cell[54650, 2005, 52, 1, 27, "Input"], Cell[54705, 2008, 37, 1, 27, "Input"], Cell[54745, 2011, 107, 2, 27, "Input"], Cell[54855, 2015, 58, 1, 27, "Input"], Cell[54916, 2018, 35, 1, 27, "Input"], Cell[54954, 2021, 66, 1, 27, "Input"], Cell[55023, 2024, 64, 1, 27, "Input"], Cell[55090, 2027, 44, 1, 27, "Input"], Cell[55137, 2030, 70, 1, 27, "Input"], Cell[55210, 2033, 109, 2, 42, "Subsubsection"], Cell[55322, 2037, 1360, 55, 140, "Text"], Cell[56685, 2094, 505, 8, 139, "Input"], Cell[57193, 2104, 96, 3, 32, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[57326, 2112, 178, 3, 27, "Input"], Cell[57507, 2117, 111, 2, 27, "Input"], Cell[57621, 2121, 119, 2, 27, "Input"], Cell[57743, 2125, 300, 5, 47, "Input"], Cell[58046, 2132, 88, 1, 27, "Input"], Cell[58137, 2135, 153, 2, 27, "Input"] }, Open ]] }, Open ]], Cell[CellGroupData[{ Cell[58339, 2143, 67, 0, 61, "Section"], Cell[58409, 2145, 121, 3, 50, "Text"], Cell[58533, 2150, 129, 2, 27, "Input"], Cell[58665, 2154, 74, 1, 27, "Input"], Cell[58742, 2157, 344, 9, 104, "Text"], Cell[59089, 2168, 70, 1, 27, "Input"], Cell[59162, 2171, 161, 9, 158, "Text"], Cell[59326, 2182, 82, 1, 27, "Input"], Cell[59411, 2185, 183, 3, 27, "Input"], Cell[59597, 2190, 109, 2, 27, "Input"], Cell[59709, 2194, 71, 0, 32, "Text"], Cell[59783, 2196, 33, 0, 45, "Subsection"], Cell[59819, 2198, 195, 5, 50, "Text"], Cell[60017, 2205, 119, 2, 27, "Input"], Cell[60139, 2209, 163, 4, 50, "Text"], Cell[60305, 2215, 67, 1, 27, "Input"], Cell[60375, 2218, 150, 2, 43, "Input"], Cell[60528, 2222, 62, 0, 32, "Text"], Cell[60593, 2224, 73, 1, 27, "Input"], Cell[60669, 2227, 119, 2, 27, "Input"], Cell[60791, 2231, 67, 1, 27, "Input"], Cell[60861, 2234, 218, 4, 27, "Input"], Cell[61082, 2240, 62, 0, 32, "Text"], Cell[61147, 2242, 83, 1, 27, "Input"], Cell[61233, 2245, 119, 2, 27, "Input"], Cell[61355, 2249, 51, 1, 27, "Input"], Cell[61409, 2252, 383, 6, 59, "Input"], Cell[61795, 2260, 123, 2, 27, "Input"], Cell[61921, 2264, 110, 2, 27, "Input"], Cell[62034, 2268, 67, 1, 27, "Input"], Cell[62104, 2271, 235, 4, 43, "Input"], Cell[62342, 2277, 62, 0, 32, "Text"], Cell[62407, 2279, 78, 1, 27, "Input"], Cell[62488, 2282, 97, 3, 32, "Text"], Cell[62588, 2287, 70, 1, 27, "Input"], Cell[62661, 2290, 82, 1, 27, "Input"], Cell[CellGroupData[{ Cell[62768, 2295, 85, 1, 45, "Subsection"], Cell[62856, 2298, 196, 5, 50, "Text"], Cell[63055, 2305, 231, 5, 43, "Input"], Cell[63289, 2312, 62, 1, 27, "Input"], Cell[63354, 2315, 114, 2, 27, "Input"] }, Open ]], Cell[63483, 2320, 72, 1, 27, "Input"], Cell[63558, 2323, 80, 1, 27, "Input"], Cell[63641, 2326, 67, 1, 45, "Subsection"], Cell[63711, 2329, 181, 4, 43, "Input"], Cell[63895, 2335, 79, 1, 27, "Input"], Cell[63977, 2338, 109, 2, 27, "Input"], Cell[64089, 2342, 62, 0, 32, "Text"], Cell[64154, 2344, 77, 1, 27, "Input"], Cell[64234, 2347, 53, 1, 27, "Input"], Cell[64290, 2350, 106, 2, 27, "Input"], Cell[64399, 2354, 82, 1, 27, "Input"], Cell[64484, 2357, 123, 2, 27, "Input"], Cell[64610, 2361, 52, 1, 27, "Input"], Cell[64665, 2364, 77, 1, 27, "Input"], Cell[64745, 2367, 131, 3, 27, "Input"], Cell[64879, 2372, 65, 1, 27, "Input"], Cell[64947, 2375, 104, 2, 27, "Input"], Cell[65054, 2379, 266, 4, 59, "Input"], Cell[65323, 2385, 85, 1, 27, "Input"], Cell[65411, 2388, 49, 1, 27, "Input"], Cell[65463, 2391, 75, 1, 27, "Input"], Cell[65541, 2394, 68, 1, 27, "Input"], Cell[65612, 2397, 88, 1, 27, "Input"], Cell[65703, 2400, 52, 1, 27, "Input"], Cell[65758, 2403, 37, 1, 27, "Input"], Cell[65798, 2406, 107, 2, 27, "Input"], Cell[65908, 2410, 58, 1, 27, "Input"], Cell[65969, 2413, 35, 1, 27, "Input"], Cell[66007, 2416, 66, 1, 27, "Input"], Cell[66076, 2419, 64, 1, 27, "Input"], Cell[66143, 2422, 44, 1, 27, "Input"], Cell[66190, 2425, 70, 1, 27, "Input"], Cell[CellGroupData[{ Cell[66285, 2430, 83, 1, 45, "Subsection"], Cell[66371, 2433, 425, 9, 68, "Text"], Cell[66799, 2444, 383, 6, 59, "Input"], Cell[67185, 2452, 81, 1, 27, "Input"], Cell[67269, 2455, 106, 2, 27, "Input"] }, Open ]], Cell[67390, 2460, 568, 12, 140, "Text"], Cell[67961, 2474, 505, 8, 139, "Input"], Cell[68469, 2484, 96, 3, 32, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[68602, 2492, 36, 0, 61, "Section"], Cell[68641, 2494, 423, 8, 86, "Text"], Cell[69067, 2504, 70, 1, 32, "Text"], Cell[69140, 2507, 126, 4, 32, "Text"], Cell[CellGroupData[{ Cell[69291, 2515, 90, 1, 27, "Input"], Cell[69384, 2518, 156, 2, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[69577, 2525, 99, 1, 42, "Subsubsection"], Cell[69679, 2528, 658, 21, 338, "Text"], Cell[70340, 2551, 481, 8, 139, "Input"], Cell[CellGroupData[{ Cell[70846, 2563, 90, 1, 27, "Input"], Cell[70939, 2566, 156, 2, 27, "Input"] }, Open ]], Cell[71110, 2571, 122, 2, 27, "Input"] }, Open ]], Cell[71247, 2576, 119, 1, 42, "Subsubsection"], Cell[71369, 2579, 973, 39, 104, "Text"], Cell[72345, 2620, 140, 2, 27, "Input"], Cell[72488, 2624, 121, 3, 27, "Input"], Cell[72612, 2629, 61, 1, 42, "Subsubsection"], Cell[72676, 2632, 526, 17, 86, "Text"], Cell[73205, 2651, 178, 3, 27, "Input"], Cell[73386, 2656, 136, 3, 27, "Input"], Cell[73525, 2661, 92, 3, 32, "Text"], Cell[73620, 2666, 112, 2, 27, "Input"], Cell[73735, 2670, 75, 0, 32, "Text"], Cell[73813, 2672, 136, 3, 27, "Input"], Cell[73952, 2677, 52, 1, 27, "Input"], Cell[74007, 2680, 46, 1, 27, "Input"], Cell[74056, 2683, 172, 3, 27, "Input"], Cell[74231, 2688, 176, 3, 27, "Input"], Cell[74410, 2693, 42, 1, 27, "Input"], Cell[74455, 2696, 44, 1, 27, "Input"], Cell[74502, 2699, 49, 1, 27, "Input"], Cell[74554, 2702, 90, 1, 27, "Input"], Cell[74647, 2705, 38, 1, 27, "Input"], Cell[74688, 2708, 139, 3, 27, "Input"], Cell[74830, 2713, 46, 1, 27, "Input"], Cell[74879, 2716, 55, 1, 27, "Input"], Cell[74937, 2719, 134, 3, 27, "Input"], Cell[75074, 2724, 46, 1, 27, "Input"], Cell[75123, 2727, 73, 1, 27, "Input"], Cell[75199, 2730, 108, 2, 27, "Input"], Cell[75310, 2734, 110, 2, 27, "Input"], Cell[75423, 2738, 44, 1, 27, "Input"], Cell[75470, 2741, 88, 1, 27, "Input"], Cell[75561, 2744, 37, 1, 27, "Input"], Cell[CellGroupData[{ Cell[75623, 2749, 82, 1, 42, "Subsubsection"], Cell[75708, 2752, 234, 3, 59, "Input"], Cell[75945, 2757, 83, 1, 27, "Input"], Cell[76031, 2760, 55, 0, 32, "Text"] }, Open ]], Cell[76101, 2763, 69, 1, 27, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[76207, 2769, 99, 1, 42, "Subsubsection"], Cell[76309, 2772, 658, 21, 338, "Text"], Cell[76970, 2795, 481, 8, 139, "Input"], Cell[CellGroupData[{ Cell[77476, 2807, 90, 1, 27, "Input"], Cell[77569, 2810, 156, 2, 27, "Input"] }, Open ]], Cell[77740, 2815, 122, 2, 27, "Input"] }, Open ]], Cell[77877, 2820, 64, 0, 61, "Section"], Cell[77944, 2822, 587, 22, 50, "Text"], Cell[78534, 2846, 71, 1, 27, "Input"], Cell[78608, 2849, 316, 6, 59, "Input"], Cell[78927, 2857, 122, 2, 27, "Input"], Cell[79052, 2861, 91, 1, 27, "Input"], Cell[79146, 2864, 93, 1, 27, "Input"], Cell[79242, 2867, 181, 7, 32, "Text"], Cell[79426, 2876, 79, 1, 27, "Input"], Cell[79508, 2879, 229, 9, 32, "Text"], Cell[79740, 2890, 70, 1, 27, "Input"], Cell[79813, 2893, 104, 2, 27, "Input"], Cell[79920, 2897, 258, 6, 68, "Text"], Cell[80181, 2905, 68, 1, 27, "Input"], Cell[80252, 2908, 239, 9, 32, "Text"], Cell[80494, 2919, 71, 1, 27, "Input"], Cell[80568, 2922, 75, 1, 27, "Input"], Cell[80646, 2925, 70, 1, 27, "Input"], Cell[80719, 2928, 87, 1, 27, "Input"], Cell[80809, 2931, 86, 1, 27, "Input"], Cell[80898, 2934, 223, 8, 32, "Text"], Cell[81124, 2944, 138, 2, 27, "Input"], Cell[81265, 2948, 87, 1, 27, "Input"], Cell[81355, 2951, 39, 1, 27, "Input"], Cell[81397, 2954, 153, 3, 27, "Input"], Cell[81553, 2959, 82, 1, 27, "Input"], Cell[81638, 2962, 46, 1, 27, "Input"], Cell[81687, 2965, 74, 1, 27, "Input"], Cell[81764, 2968, 61, 1, 27, "Input"], Cell[81828, 2971, 116, 3, 27, "Input"], Cell[81947, 2976, 26, 0, 27, "Input"] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)