simpleclosedcurvenumber = 1; loop = {}; simple = {}; GENUS = 3; current = {}; admitpreserve = 0; NotebookWrite[CreateDocument[], "drawcurve[]"]; CreatePalette[Graphics[{ Inset[Button[StringForm["A1+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[1]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,0}], Inset[Button[StringForm["A1-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-1]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,-0.5}], Inset[Button[StringForm["B1+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[2]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,-1}], Inset[Button[StringForm["B1-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-2]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,-1.5}], Inset[Button[StringForm["C1+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[3]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,-2}], Inset[Button[StringForm["C1-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-3]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0,-2.5}], Inset[Button[StringForm["D1+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[4]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {1,-1}], Inset[Button[StringForm["D1-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-4]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {1,-1.5}], Inset[Button[StringForm["A2+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[5]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,0}], Inset[Button[StringForm["A2-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-5]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,-0.5}], Inset[Button[StringForm["B2+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[6]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,-1}], Inset[Button[StringForm["B2-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-6]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,-1.5}], Inset[Button[StringForm["C2+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[7]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,-2}], Inset[Button[StringForm["C2-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-7]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {2,-2.5}], Inset[Button[StringForm["D2+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[8]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {3,-1}], Inset[Button[StringForm["D2-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-8]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {3,-1.5}], Inset[Button[StringForm["A3+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[9]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,0}], Inset[Button[StringForm["A3-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-9]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,-0.5}], Inset[Button[StringForm["B3+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[10]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,-1}], Inset[Button[StringForm["B3-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-10]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,-1.5}], Inset[Button[StringForm["C3+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[11]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,-2}], Inset[Button[StringForm["C3-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-11]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {4,-2.5}]}, ImageSize -> 400] ]; CreatePalette[{"Choose direction:", Graphics[{Circle[{0,0},4], Inset[Button["\[UpArrow]", north], {0, 4}], Inset[Button["\[RightArrow]", east], {4, 0}], Inset[Button["\[DownArrow]", south], {0, -4}], Inset[Button["\[LeftArrow]", west], {-4, 0}], Inset[Button["\[UpperLeftArrow]", nw], {-2.84, 2.3}], Inset[Button["\[UpperRightArrow]", ne], {2.84, 2.3}], Inset[Button["\[LowerLeftArrow]", sw], {-2.84, -2.3}], Inset[Button["\[LowerRightArrow]", se], {2.84, -2.3}], Inset[Button["setthecurve", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["setthecurve", "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0, -7}], Inset[Button["preserve", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["preserve", "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0, -9.1}], Inset[Button["drawcurve", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["drawcurve[]", "Input"], All]], {0, -11.2}], Inset[Button["twist", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["twistCurrentAlongSimple[]", "Input"], All]], {0, -13.3}], Inset[Button["picture", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["picture[simple[[]]]", "Input"], All]], {0, -15.4}]}, ImageSize -> 150]}]; pictureofsurface[shusuu_] := Module[{n}, Join[{AbsoluteThickness[2]}, Table[Circle[{6 n, 0}, 1], {n, 0, shusuu - 1}], {Circle[{0, 0}, 3, {\[Pi]/2, 3 \[Pi]/2}], Circle[{6 shusuu - 6, 0}, 3, {-\[Pi]/2, \[Pi]/2}], Line[{{0, 3}, {6 shusuu - 6, 3}}], Line[{{0, -3}, {6 shusuu - 6, -3}}], Table[Text[n, {6 n - 6, 0}], {n, 1, shusuu}]} ] ] cellcoord[cellno_] := Which[Abs[cellno] == 1, {-1.5, -1.5 (Re[cellno] - Im[cellno])}, Abs[cellno] == GENUS + 1, {6 GENUS - 4.5, -1.5 Sign[Re[cellno] - Im[cellno]]}, True, {6 Abs[cellno] - 9, -2 Sign[Re[cellno] - Im[cellno]]} ] drawcurve[cpx_] := Module[{pt}, now = cpx; kyokusen = {now}; pt = cellcoord[cpx]; Dynamic[Show[drawloop[from2to5[kyokusen],1], Graphics[pictureofsurface[GENUS]], PlotRange -> {{-4, 6 GENUS-2}, {-4, 4}}, ImageSize -> 700]] ] north := Module[{}, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I ] ] south := Module[{}, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I ] ] west := Module[{}, Which[Abs[Re[now]] == 1, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, Abs[Im[now]] == 1, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I, Re[now] != 0, kyokusen = Join[kyokusen, {10 now - 5 Sign[now], now - Sign[now]}]; now = now - Sign[now], Im[now] != 0, kyokusen = Join[kyokusen, {10 now - 5 I*Sign[Im[now]], now - I*Sign[Im[now]]}]; now = now - I*Sign[Im[now]], True, Print["error at west now="]; Print[now]; Abort[] ] ] east := Module[{}, Which[Abs[Re[now]] == GENUS + 1, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, Abs[Im[now]] == GENUS + 1, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I, Re[now] != 0, kyokusen = Join[kyokusen, {10 now + 5 Sign[now], now + Sign[now]}]; now = now + Sign[now], Im[now] != 0, kyokusen = Join[kyokusen, {10 now + 5 I*Sign[Im[now]], now + I*Sign[Im[now]]}]; now = now + I*Sign[Im[now]], True, Print["error at east now="]; Print[now]; Abort[] ] ] nw := Module[{}, Which[Re[now] - Im[now] < 0, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I ], now == 1, kyokusen = Join[kyokusen, {10, -I}]; now = -I, now == -I, kyokusen = Join[kyokusen, {10, 1}]; now = 1, True, kyokusen = Join[kyokusen, {Abs[now]*10 - 2, -now*I*Sign[Re[now] + Im[now]]}]; now = -now*I*Sign[Re[now] + Im[now]] ] ] ne := Module[{}, Which[Re[now] - Im[now] < 0, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I ], now == GENUS + 1, kyokusen = Join[kyokusen, {(GENUS + 1)*10, -(GENUS + 1)*I}]; now = -(GENUS + 1)*I, now == -(GENUS + 1)*I, kyokusen = Join[kyokusen, {(GENUS + 1)*10, GENUS + 1}]; now = GENUS + 1, True, kyokusen = Join[kyokusen, {Abs[now]*10 + 3, -now*I*Sign[Re[now] + Im[now]]}]; now = -now*I*Sign[Re[now] + Im[now]] ] ] sw := Module[{}, Which[Re[now] - Im[now] > 0, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I ], now == I, kyokusen = Join[kyokusen, {-10, -1}]; now = -1, now == -1, kyokusen = Join[kyokusen, {-10, I}]; now = I, True, kyokusen = Join[kyokusen, {-Abs[now]*10 + 2, now*I*Sign[Re[now] + Im[now]]}]; now = now*I*Sign[Re[now] + Im[now]] ] ] se := Module[{}, Which[Re[now] - Im[now] > 0, If[Re[now] + Im[now] > 0, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, kyokusen = Join[kyokusen, {now*10 I, now*I}]; now = now*I ], now == (GENUS + 1)*I, kyokusen = Join[kyokusen, {-(GENUS + 1)*10, -GENUS - 1}]; now = -GENUS - 1, now == -GENUS - 1, kyokusen = Join[kyokusen, {-(GENUS + 1)*10, (GENUS + 1)*I}]; now = (GENUS + 1)*I, True, kyokusen = Join[kyokusen, {-Abs[now]*10 - 3, now*I*Sign[Re[now] + Im[now]]}]; now = now*I*Sign[Re[now] + Im[now]] ] ] setthecurve := Module[{l, rw, lockyokusen}, lockyokusen=kyokusen; kyokusen={1}; Print["Input curve:"]; Print[Show[drawloop[from2to5[lockyokusen],1], Graphics[pictureofsurface[GENUS]], PlotRange -> {{-4, 6 GENUS-2}, {-4, 4}}]]; l = Length[lockyokusen]; If[lockyokusen[[1]] != lockyokusen[[l]], Print["This is not a closed curve!"], rw = wordreduce[lockyokusen]; If[Length[rw] == 1, Print["This curve is homotopic to a point!"], rw = simplicitycheck[rw]; admitpreserve = rw[[1]]; (*Print[rw];*) If[rw[[1]] == 1, Print["This defines a SCC."]; Print["current:"]; current = rw[[2]]; picture[current], Print["This curve is NOT homotopic to some SCC!"]; current = rw[[2]]; picture[current] ] ] ] ] f[t_, b_] := (2 b[[1]] - 2 b[[2]] + b[[3]] + b[[4]])*(t^3) + (3 b[[2]] - 3 b[[1]] - 2 b[[3]] - b[[4]])*(t^2) + b[[3]]*t + b[[1]] (*This function is based on Ahara's algorithm*) bezier[init_, foreback_, term_, clrno_] := Module[{ini, fb, ter, t, s, b, clromote, clrura}, (*These are the lists of colors*) clromote = {1, 0, 0, 0, 0, 1, 0, 1, 0}; clrura = {1, 0.8, 0, 0.8, 0, 1, 0.5, 1, 0.9}; fb = foreback; ini = init; ter = term; Which[Re[fb] + Im[fb] > 0, (*omote*) ParametricPlot[{f[s, {ini[[1]], ter[[1]], ini[[3]], ter[[3]]}], f[s, {ini[[2]], ter[[2]], ini[[4]], ter[[4]]}]}, {s, 0, 1}, DisplayFunction -> Identity, PlotStyle -> {RGBColor[clromote[[3 clrno - 2]], clromote[[3 clrno - 1]], clromote[[3 clrno]]], AbsoluteThickness[2]}], Re[fb] + Im[fb] < 0, (*ura*) ParametricPlot[{f[s, {ini[[1]], ter[[1]], ini[[3]], ter[[3]]}], f[s, {ini[[2]], ter[[2]], ini[[4]], ter[[4]]}]}, {s, 0, 1}, DisplayFunction -> Identity, PlotStyle -> {RGBColor[clrura[[3 clrno - 2]], clrura[[3 clrno - 1]], clrura[[3 clrno]]], AbsoluteThickness[2]}], True, (*midpoint of the bezier curve*) Graphics[{AbsolutePointSize[5], Point[{f[0.5, {ini[[1]], ter[[1]], ini[[3]], ter[[3]]}], f[0.5, {ini[[2]], ter[[2]], ini[[4]], ter[[4]]}]}]}] ] ] (*This function is based on Ahara's algorithm*) naibunten[edgenumber_, sousuu_, bangou_, orientation_] := Module[{en, so, ba, pa, si, co, a}, en = edgenumber; so = sousuu; ba = bangou; pa = orientation; si[a_] := Sin[a*Degree]; co[a_] := Cos[a*Degree]; Which[Abs[Re[en]] == 10, {3*co[225 + 45 Sign[en] - (90*ba)/(so + 1)], 3*si[225 + 45 Sign[en] - (90*ba)/(so + 1)], 3*pa*co[135 + 45 Sign[en] - (90*ba)/(so + 1)], 3*pa*si[135 + 45 Sign[en] - (90*ba)/(so + 1)]}, Abs[Im[en]] == 10, {-3 + (2 ba/(so + 1)), 0, 0, (-3 + (2 ba/(so + 1)))*pa}, Abs[Re[en]] == (GENUS + 1)*10, {6 GENUS - 6 + 3*co[45 - 45 Sign[en] - (90*ba)/(so + 1)], 3*si[45 - 45 Sign[en] - (90*ba)/(so + 1)], 3*pa*co[-45 - 45 Sign[en] - (90*ba)/(so + 1)], 3*pa*si[-45 - 45 Sign[en] - (90*ba)/(so + 1)]}, Abs[Im[en]] == (GENUS + 1)*10, {6 GENUS - 3 - (2 ba/(so + 1)), 0, 0, (-3 + (2 ba/(so + 1)))*pa}, Mod[Abs[en], 10] == 5, {6 Quotient[Abs[en], 10] - 6, (-3 + (2 ba/(so + 1)))Sign[Re[en] - Im[en]], (3 - (2 ba/(so + 1))) Sign[Re[en] - Im[en]]*pa, 0}, Mod[Abs[en], 5] == 3, {6 Quotient[Abs[en], 10] - 6 + co[45 ((Sign[en] + 2) (2 Mod[en, 2] - 1) + 1) + (90 ba/(so + 1))], si[45 ((Sign[en] + 2) (2 Mod[en, 2] - 1) + 1) + (90 ba/(so + 1))], 1.5 co[45 ((Sign[en] + 2) (2 Mod[en, 2] - 1) + 3) + (90 ba/(so + 1))]*pa, 1.5 si[45 ((Sign[en] + 2) (2 Mod[en, 2] - 1) + 3) + (90 ba/(so + 1))]*pa}, Re[en] != 0, {6 Quotient[Abs[en], 10] - 9 + (3 - 6 ba/(so + 1)) Sign[en], -3 Sign[en], -3 Sign[en]*pa, 0}, True, {6 Quotient[Abs[en], 10] - 11 + (4 ba/(so + 1)), 0, 0, -3*pa} ] ] kasaneru[a_] := Which[OddQ[Im[a]], a*I, Im[a] < 0, -a, True, a] (*This function is based on Ahara's algorithm*) from2to5[from_] := Module[{to, evenli, edgeno, i}, to = {}; edgeno = (Length[from] - 1)/2; evenli = Table[kasaneru[from[[2 i]]], {i, 1, edgeno}]; i = 1; While[i <= edgeno, to = Join[to, {from[[2 i - 1]], from[[2 i]], Count[evenli, evenli[[i]]], Count[Take[evenli, i], evenli[[i]]], 1}]; i = i + 1; ]; Join[to, {from[[2 edgeno + 1]]}] ] picture[loopdata_] := drawpicture[{loopdata}] tubusu[a_] := Which[OddQ[Im[a]], a*I, Im[a] < 0, -a, True, a] drawloop[curvedata_, clrnum_] := Module[{l, surface, endpt, startpt, firstedge, lastedge, k, curve, bezierpath}, curve = tangentialorientation[curvedata]; (*curve has length of 5x+1*) l = Length[curve]; Which[l == 1, Graphics[{RGBColor[1, 0, 0], AbsolutePointSize[5], Point[cellcoord[curve[[1]]]]}], curve[[1]] != curve[[l]], (*This is the case of NOT-closed curve*) startpt = Graphics[{AbsolutePointSize[5], Point[cellcoord[curve[[1]]]]}]; If[Re[curve[[1]]] + Im[curve[[1]]] > 0, firstedge = Graphics[{RGBColor[1, 0, 0], AbsoluteThickness[2], Line[{cellcoord[curve[[1]]], Take[naibunten[curve[[2]], curve[[3]], curve[[4]], curve[[5]]], 2]}]}], firstedge = Graphics[{RGBColor[1, 0.8, 0], AbsoluteThickness[2], Line[{cellcoord[curve[[1]]], Take[naibunten[curve[[2]], curve[[3]], curve[[4]], curve[[5]]], 2]}]}]]; endpt = Graphics[{AbsolutePointSize[5], Point[cellcoord[curve[[l]]]]}]; If[Re[curve[[l]]] + Im[curve[[l]]] > 0, lastedge = Graphics[{RGBColor[1, 0, 0], AbsoluteThickness[2], Line[{cellcoord[curve[[l]]], Take[naibunten[curve[[l - 4]], curve[[l - 3]], curve[[l - 2]], curve[[l - 1]]], 2]}]}], lastedge = Graphics[{RGBColor[1, 0.8, 0], AbsoluteThickness[2], Line[{cellcoord[curve[[l]]], Take[naibunten[curve[[l - 4]], curve[[l -3]], curve[[l - 2]], curve[[l - 1]]], 2]}]}] ]; k = 1; bezierpath = {}; While[5 k - 3 <= l - 9, bezierpath = Join[bezierpath, {bezier[naibunten[curve[[5 k - 3]], curve[[5 k - 2]], curve[[5 k - 1]], curve[[5 k]]], curve[[5 k + 1]], naibunten[curve[[5 k + 2]], curve[[5 k + 3]], curve[[5 k + 4]], curve[[5 k + 5]]], 1]}]; k = k + 1 ]; Join[{startpt, firstedge, endpt, lastedge}, bezierpath], True, (*This is the case of closed curve*) k = 1; bezierpath = {}; While[5 k - 3 <= l - 9, bezierpath = Join[bezierpath, {bezier[naibunten[curve[[5 k - 3]], curve[[5 k - 2]], curve[[5 k - 1]], curve[[5 k]]], curve[[5 k + 1]], naibunten[curve[[5 k + 2]], curve[[5 k + 3]], curve[[5 k + 4]], curve[[5 k + 5]]], clrnum]}]; k = k + 1 ]; bezierpath = Join[bezierpath, {bezier[naibunten[curve[[l - 4]], curve[[l - 3]], curve[[l - 2]], curve[[l - 1]]], curve[[l]], naibunten[curve[[2]], curve[[3]], curve[[4]], curve[[5]]], clrnum]}]; startpt = bezier[naibunten[curve[[l - 4]], curve[[l - 3]], curve[[l - 2]], curve[[l - 1]]], 0, naibunten[curve[[2]], curve[[3]], curve[[4]], curve[[5]]], clrnum]; Join[{startpt}, bezierpath] ] ] drawpicture[looplist_] := Module[{noofcurves, i, edgenumlist, loophyo, subloop, num1, num2, num3, refedge, clrnum}, noofcurves = Length[looplist]; (*Print["noofcurves=",noofcurves];*) edgenumlist = Table[(Length[looplist[[i]]] - 1)/5, {i, noofcurves}]; (*Print["edgenumlist=",edgenumlist];*) num1 = 1; refedge = {}; While[num1 <= noofcurves, num2 = 1; While[num2 <= edgenumlist[[num1]], (*Print["{num1,num2}=",{num1,num2}];*) refedge = Join[refedge, {tubusu[looplist[[num1, 5 num2 - 3]]]}]; (*Print["m_refedge=",refedge];*) num2 = num2 + 1 ]; num1 = num1 + 1 ]; (*Print["refedge=",refedge];*) num1 = 1; loophyo = {}; While[num1 <= noofcurves, num2 = 1; subloop = {}; While[num2 <= edgenumlist[[num1]], (*Print["{num1,num2}=",{num1,num2}];*) subloop = Join[subloop, {looplist[[num1, 5 num2 - 4]], looplist[[num1, 5 num2 - 3]], Count[refedge, tubusu[looplist[[num1, 5 num2 - 3]]]], looplist[[num1, 5 num2 - 1]] + Count[Take[refedge, Apply[Plus, Take[edgenumlist, num1 - 1]]], tubusu[looplist[[num1, 5 num2 - 3]]]], 1}]; num2 = num2 + 1 ]; subloop = Join[subloop, {looplist[[num1, 5 num2 - 4]]}]; (*Print["{num1,subloop}",{num1,subloop}];*) loophyo = Join[loophyo, {subloop}]; (*Print["m-loophyo",loophyo];*) num1 = num1 + 1 ]; (*Print["loophyo=",loophyo];*) surface = Graphics[pictureofsurface[GENUS]]; Show[Join[{surface}, Table[drawloop[loophyo[[i]], Mod[i, 3] + 1], {i, noofcurves}]], AspectRatio -> Automatic, PlotRange -> All, DisplayFunction -> $DisplayFunction] ] subfunc[pre_, now_, next_] := Module[{n2, li1, li2, subsub}, subsub[li1_, li2_] := Module[{vxy, vyz, vxz, junban, a, b}, junban[a_, b_] := Module[{ks, c}, ks[c_] := Which[OddQ[Im[c]], c*I, Im[c] < 0, -c, True, c]; (*Print[StringForm["{li1,li2}=``",{li1,li2}]];*) (*Print[ks[a[[2]]][[1,1]]];*) (*Print[StringForm["{a[[2]],ks[a[[2]]]}=``",{a[[2]],ks[a[[2]]]}]];*) Which[ Position[li1, ks[a[[2]]]][[1, 1]] - Position[li1, ks[b[[2]]]][[1, 1]] > 0, 1, Position[li1, ks[a[[2]]]][[1, 1]] - Position[li1, ks[b[[2]]]][[1, 1]] < 0, -1, True, If[(a[[4]] - b[[4]])*li2[[Position[li1, ks[a[[2]]]][[1, 1]]]] > 0, 1, -1] ] ]; vxy = junban[pre, now]; vyz = junban[now, next]; vxz = junban[pre, next]; (*Print[StringForm["{pre,now,next}=``",{pre,now,next}]];*) (*Print[StringForm["{vxy,vxz,vyz}=``",{vxy,vxz,vyz}]];*) -vxy*vxz*vyz ]; n2 = now[[2]]; (*Print[now];*) Which[(Im[n2] != 0 && EvenQ[Im[n2]]), If[Re[now[[1]]] - Im[now[[1]]] > 0, -1, 1], Mod[Abs[n2], 10] == 5, If[Re[now[[1]]] - Im[now[[1]]] < Re[next[[1]]] - Im[next[[1]]], 1, -1], (n2 == 10 || n2 == 13), subsub[{10 I, 13, 15, 10}, {1, 1, -1, 1}], (n2 == -13 || n2 == -10), subsub[{-10, -15, -13, 10 I}, {1, 1, 1, -1}], (n2 == -10 GENUS - 10 || n2 == -10 GENUS - 8), (*Print["here"];*) (*Print[n2];*) -subsub[{10 (GENUS + 1) I, -10 GENUS - 10, -(10 GENUS + 5), -10 GENUS - 8}, {-1, -1, 1, -1}], (n2 == 10 GENUS + 10 || n2 == 10 GENUS + 8), subsub[{10 GENUS + 5, 10 GENUS + 8, 10 (GENUS + 1) I, 10 (GENUS + 1)}, {1, 1, -1, 1}], Re[n2] > 0, subsub[{Abs[now[[1]]]*10 I, Abs[now[[1]]]*10 + 3, Abs[now[[1]]]*10 + 5, Abs[now[[1]]]*10, Abs[now[[1]]]*10 - 5, Abs[now[[1]]]*10 - 2}, {1, 1, -1, 1, 1, 1}], True, -subsub[{Abs[now[[1]]]*10 I, -Abs[now[[1]]]*10 - 3, -Abs[now[[1]]]*10 - 5, -Abs[now[[1]]]*10, -Abs[now[[1]]]*10 + 5, -Abs[now[[1]]]*10 + 2}, {1, -1, -1, -1, 1, -1}] ] ] (*This function is based on Ahara's algorithm*) tangentialorientation[list_] := Module[{l, li, i}, li = list; l = Length[li]; If[l <= 6, li, Which[li[[1]] == li[[l]], li[[5]] = subfunc[ {li[[l - 5]], li[[l - 4]], li[[l - 3]], li[[l - 2]]}, {li[[1]], li[[2]], li[[3]], li[[4]]}, {li[[6]], li[[7]], li[[8]], li[[9]]}], (Im[li[[2]]] != 0 || Mod[Abs[li[[2]]], 10] == 5), If[cellcoord[li[[6]]][[1]]==cellcoord[li[[1]]][[1]], li[[5]]=Sign[cellcoord[li[[1]]][[2]]], li[[5]]=Sign[cellcoord[li[[1]]][[1]]-cellcoord[li[[6]]][[1]]]* Sign[cellcoord[li[[1]]][[2]]] ], True, li[[5]] = 1 ]; i = 1; While[5 i + 5 <= l - 6, li[[5 i + 5]] = subfunc[ {li[[5 i - 4]], li[[5 i - 3]], li[[5 i - 2]], li[[5 i - 1]]}, {li[[5 i + 1]], li[[5 i + 2]], li[[5 i + 3]], li[[5 i + 4]]}, {li[[5 i + 6]], li[[5 i + 7]], li[[5 i + 8]], li[[5 i + 9]]}]; i = i + 1 ]; Which[li[[1]] == li[[l]], li[[l - 1]] = subfunc[ {li[[l - 10]], li[[l - 9]], li[[l - 8]], li[[l - 7]]}, {li[[l - 5]], li[[l - 4]], li[[l - 3]], li[[l - 2]]}, {li[[1]], li[[2]], li[[3]], li[[4]]}], (Im[li[[l - 4]]] != 0 || Mod[Abs[li[[l - 4]]], 10] == 5), If[cellcoord[li[[l]]][[1]]==cellcoord[li[[l - 5]]][[1]], li[[l - 1]]=Sign[cellcoord[li[[l-5]]][[2]]], li[[l - 1]]=Sign[cellcoord[li[[l-5]]][[1]]- cellcoord[li[[l]]][[1]]]*Sign[cellcoord[li[[l-5]]][[2]]]], True, li[[l - 1]] = 1 ]; li ] ] renum[num_, modulo_] := Module[{t}, t = Mod[num, modulo]; If[t == 0, modulo, t]] uragaeshi[num5_] := If[Mod[Abs[num5], 10] == 0, -num5, -I (Abs[num5]^2)/num5] intorext[num6_] := If[(Mod[Abs[num6], 10] == 5 || Im[num6] != 0), 1, 0] adjacent[intnum_, extnum_] := Which[Abs[Im[intnum]] == 10, If[Abs[extnum] < 14, 1, 0], Abs[Im[intnum]] == 10 (GENUS + 1), If[Abs[extnum] > 10 GENUS + 7, 1, 0], Mod[Abs[intnum], 10] == 5, If[MemberQ[Sign[Re[intnum] - Im[intnum]] (Abs[intnum] + {-5, -2, 3, 5}), extnum], 1, 0], True, If[MemberQ[(Abs[intnum] + {-2, -2, 3, 3})*{-1, 1, -1, 1}, extnum], 1, 0] ] crossroad[intnum2_, extnum2_] := Which[adjacent[intnum2, extnum2] == 0, Print[{intnum2, extnum2}]; Print["error"]; xx, Mod[Abs[intnum2], 10] == 5, If[Mod[Abs[extnum2], 10] == 0, {uragaeshi[intnum2], 2 (Re[intnum2] - Im[intnum2]) - extnum2}, {uragaeshi[intnum2], 2 (Re[intnum2] - Im[intnum2]) + Sign[Re[intnum2] - Im[intnum2]] - extnum2} ], True, {uragaeshi[intnum2], -extnum2} ] (*This function is based on Ahara's algorithm*) wordreduce[word_] := Module[{word4, word3, wordreduce2}, wordreduce2[word4_] := Module[{n, rewriting, i, result, rewrited, num2, relation}, result = word4; rewriting[num2_, word2_] := Module[{j = 1, subresult, l, k, nn, nn2, tt, tt2, sequencecheck, nextodd}, l = Length[word2]/2; subresult = word2; Switch[num2, 1, While[j <= l && rewrited == 0, If[subresult[[2 j - 1]] == subresult[[renum[2 j + 1, 2 l]]], rewrited = 1; subresult = Drop[subresult, {2 j - 1, 2 j}] (*;Print["w1"];Print[subresult]*) , j = j + 1]], 2, While[j <= l && rewrited == 0, If[subresult[[2 j]] == subresult[[renum[2 j + 2, 2 l]]], rewrited = 1; subresult[[renum[2 j + 1, 2 l]]] = subresult[[2 j - 1]] (*;Print["w2"];Print[subresult]*) , j = j + 1]], 3, While[j <= l && rewrited == 0, If[(Im[subresult[[2 j]]] != 0 || Mod[Abs[subresult[[2 j]]], 10] == 5), j = j + 1, k = renum[j + 1, l]; nextodd = 0; While[k != j && nextodd == 0, If[(Im[subresult[[2 k]]] != 0 || Mod[Abs[subresult[[2 k]]], 10] == 5), k = renum[k + 1, l], nextodd = 1] ]; Which[ Mod[subresult[[2 j]], 10]^2 + Mod[subresult[[2 k]], 10]^2 == 0, nn = nn2 = renum[j + 1, l]; sequencecheck = 1; While[nn != k, sequencecheck = sequencecheck* If[((Mod[Abs[subresult[[2 nn]]], 10] == 5) || (Abs[Im[subresult[[2 nn]]]] == 10) || (Abs[Im[subresult[[2 nn]]]] == 10 (GENUS + 1))), 1, 0]; nn = renum[nn + 1, l] ]; If[sequencecheck == 1, rewrited = 1; While[nn2 != k, subresult[[2 nn2 - 1]] = -I (Abs[subresult[[2 nn2 - 1]]]^2)/subresult[[2 nn2 - 1]]; subresult[[2 nn2]] = uragaeshi[subresult[[2 nn2]]]; nn2 = renum[nn2 + 1, l] ]; subresult[[2 k - 1]] = -I (Abs[subresult[[2 k - 1]]]^2)/subresult[[2 k - 1]] (*;Print["w3"];Print[subresult]*), j = j + 1], (Mod[subresult[[2 j]]*subresult[[2 k]], 10] != 0 && Quotient[Abs[subresult[[2 j]]], 10] == Quotient[Abs[subresult[[2 k]]], 10]), nn = nn2 = renum[j + 1, l]; tt = Quotient[Abs[subresult[[2 j]]], 10]; sequencecheck = 1; While[nn != k, sequencecheck = sequencecheck*If[ (10 tt <= Abs[subresult[[2 nn]]] <= 10 tt + 10), 1, 0]; nn = renum[nn + 1, l] ]; If[sequencecheck == 1, rewrited = 1; While[nn2 != k, subresult[[2 nn2 - 1]] = -I (Abs[subresult[[2 nn2 - 1]]]^2)/subresult[[2 nn2 - 1]]; subresult[[2 nn2]] = uragaeshi[subresult[[2 nn2]]]; nn2 = renum[nn2 + 1, l] ]; subresult[[2 k - 1]] = -I (Abs[subresult[[2 k - 1]]]^2)/subresult[[2 k - 1]] (*;Print["w3-2"];Print[subresult]*) , j = j + 1 ], True,(*Print["xxx"];Print[subresult];*)j = j + 1 ]; ]; ], 4, While[j <= l && rewrited == 0, If[ intorext[subresult[[2 j]]] + intorext[subresult[[renum[2 j + 2, 2 l]]]] != 1, j = j + 1, (*Print["here"];Print[j];*) Which[ (intorext[subresult[[2 j]]] == 1 && Re[subresult[[2 j]]] + Im[subresult[[2 j]]] < 0), (*Print["aaaa"]; Print[{subresult[[2j]],subresult[[renum[2j+2,2l]]]}];*) relation = adjacent[subresult[[2 j]], subresult[[renum[2 j + 2, 2 l]]]]; (*Print[relation];*) If[relation == 0, j = j + 1, rewrited = 1; (*Print["aaaaa"];*) (*Print[{subresult[[2j]],subresult[[renum[2j+2,2l]]]}];*) tt2 = crossroad[subresult[[2 j]], subresult[[renum[2 j + 2, 2 l]]]]; (*Print[tt2];*) subresult[[2 j]] = tt2[[2]]; subresult[[renum[2 j + 1, 2 l]]] = -I (Abs[subresult[[2 j - 1]]]^2)/subresult[[2 j - 1]]; subresult[[renum[2 j + 2, 2 l]]] = tt2[[1]]; (*Print["w4-1"];Print[subresult];*) ] , (intorext[subresult[[2 j]]] == 0 && Re[subresult[[renum[2 j + 2, 2 l]]]] + Im[subresult[[renum[2 j + 2, 2 l]]]] < 0), (*Print["bbbb"]; Print[{subresult[[renum[2j+2,2l]]],subresult[[2j]]}];*) relation = adjacent[subresult[[renum[2 j + 2, 2 l]]], subresult[[2 j]]]; (*Print[relation];*) If[relation == 0, j = j + 1, rewrited = 1; (*Print["bbbbb"];*) tt2 = crossroad[subresult[[renum[2 j + 2, 2 l]]], subresult[[2 j]]]; subresult[[2 j]] = tt2[[1]]; subresult[[renum[2 j + 1, 2 l]]] = -I (Abs[subresult[[renum[2 j + 3, 2 l]]]]^2)/ subresult[[renum[2 j + 3, 2 l]]]; subresult[[renum[2 j + 2, 2 l]]] = tt2[[2]]; (*Print["w4-2"];Print[subresult];*) ] , True,(*Print["ccccc"];*)j = j + 1 ](*end of Which*) ];(*end of If*) ], 5, While[j <= l && rewrited == 0, If[(subresult[[2 j - 1]] == subresult[[renum[2 j + 3, 2 l]]] && subresult[[renum[2 j + 1, 2 l]]] == -I (Abs[subresult[[2 j - 1]]]^2)/ subresult[[2 j - 1]] && intorext[subresult[[renum[2 j + 4, 2 l]]]] == 1 && adjacent[subresult[[renum[2 j + 4, 2 l]]], subresult[[2 j]]] == 1 && adjacent[subresult[[renum[2 j + 4, 2 l]]], subresult[[renum[2 j + 2, 2 l]]]] == 1), (*Print["type5"];*) If[((Mod[Abs[subresult[[renum[2 j + 4, 2 l]]]], 10] == 5 && Mod[Abs[subresult[[renum[2 j + 2, 2 l]]]], 10] == 0) || (Mod[Abs[subresult[[renum[2 j + 4, 2 l]]]], 10] == 0 && Abs[subresult[[renum[2 j + 2, 2 l]]]] == Abs[subresult[[renum[2 j + 4, 2 l]]]] - 2 && Abs[subresult[[renum[2 j + 4, 2 l]]]] < 10 (GENUS + 1)) || (Abs[ subresult[[renum[2 j + 4, 2 l]]]] == Abs[subresult[[renum[2 j + 2, 2 l]]]] == 10 (GENUS + 1)) || (Abs[subresult[[renum[2 j + 4, 2 l]]]] == Abs[subresult[[renum[2 j + 2, 2 l]]]] == 10)) , (*rewriting*) rewrited = 1; Module[{x1, x2, x3}, x1 = subresult[[renum[2 j + 4, 2 l]]]; x2 = crossroad[subresult[[renum[2 j + 4, 2 l]]], subresult[[2 j]]][[2]]; x3 = crossroad[subresult[[renum[2 j + 4, 2 l]]], subresult[[renum[2 j + 2, 2 l]]]][[2]]; subresult[[2 j]] = x1; subresult[[renum[2 j + 1, 2 l]]] = subresult[[renum[2 j + 5, 2 l]]]; subresult[[renum[2 j + 2, 2 l]]] = x2; subresult[[renum[2 j + 3, 2 l]]] = -I (Abs[ subresult[[renum[2 j + 5, 2 l]]]]^2)/ subresult[[renum[2 j + 5, 2 l]]]; subresult[[renum[2 j + 4, 2 l]]] = x3; ] , j = j + 1 ]; , (*Print["jjjjj"];*) j = j + 1 ](*end of If*) ], 6, While[j <= l && rewrited == 0, If[(subresult[[2 j - 1]] == subresult[[renum[2 j + 3, 2 l]]] && subresult[[renum[2 j + 1, 2 l]]] == -I (Abs[subresult[[2 j - 1]]]^2)/subresult[[2 j - 1]] && intorext[subresult[[renum[2 j - 2, 2 l]]]] == 1 && adjacent[subresult[[renum[2 j - 2, 2 l]]], subresult[[2 j]]] == 1 && adjacent[subresult[[renum[2 j - 2, 2 l]]], subresult[[renum[2 j + 2, 2 l]]]] == 1), (*Print["type6"];Print[subresult];Print[j];*) If[((Mod[Abs[subresult[[renum[2 j - 2, 2 l]]]], 10] == 5 && Mod[Abs[subresult[[2 j]]], 10] == 0) || (Mod[Abs[subresult[[renum[2 j - 2, 2 l]]]], 10] == 0 && Abs[subresult[[2 j]]] == Abs[subresult[[renum[2 j - 2, 2 l]]]] - 2 && Abs[subresult[[renum[2 j + 4, 2 l]]]] < 10 (GENUS + 1)) || (Abs[subresult[[renum[2 j - 2, 2 l]]]] == Abs[subresult[[renum[2 j, 2 l]]]] == 10 (GENUS + 1)) || (Abs[subresult[[renum[2 j - 2, 2 l]]]] == Abs[subresult[[2 j]]] == 10)), (*rewriting*) rewrited = 1; Module[{x1, x2, x3}, x1 = crossroad[subresult[[renum[2 j - 2, 2 l]]], subresult[[2 j]]][[2]]; x2 = crossroad[subresult[[renum[2 j - 2, 2 l]]], subresult[[renum[2 j + 2, 2 l]]]][[2]]; x3 = subresult[[renum[2 j - 2, 2 l]]]; subresult[[renum[2 j - 2, 2 l]]] = x1; subresult[[renum[2 j - 1, 2 l]]] = -I (Abs[subresult[[renum[2 j - 3, 2 l]]]]^2)/ subresult[[renum[2 j - 3, 2 l]]]; subresult[[renum[2 j, 2 l]]] = x2; subresult[[renum[2 j + 1, 2 l]]] = subresult[[renum[2 j - 3, 2 l]]]; subresult[[renum[2 j + 2, 2 l]]] = x3; ], j = j + 1 ](*end of If*), (*Print["kkkkk"];*) j = j + 1 ](*end of If*) ](*end of While*) ];(*end of Switch*) subresult ]; rewrited = 1; While[rewrited == 1, i = 1; rewrited = 0; While[i <= 6 && rewrited == 0, result = rewriting[i, result]; (*Print[i];Print[rewrited];*) i = i + 1; ]; ]; result ]; word3 = wordreduce2[Delete[word, -1]]; If[Length[word3] != 0, Join[word3, {word3[[1]]}], {word[[1]]}] ] kasaneru2[num1_] := Which[OddQ[Im[num1]], num1*I, Im[num1] < 0, -num1, True, num1] (*This function is based on Ahara's algorithm*) simplicitycheck[reducedword_] := Module[{branch, bn, modeno, complete, l, result, now, modelist, nextstep, failure, gonext, leftright, rireki, num1, num2, num3, num4, nocrossing, sccresult, aaa, bbb, num5, num6, slide}, slide[num1_, num_ 2] := Which[OddQ[Im[num1]], num2 + 2, Im[num1] < 0, num2 + 2, True, num2]; branch = Flatten[Position[Partition[reducedword, 2], {reducedword[[1]], reducedword[[2]]}]]; bn = Length[branch] - 1; modeno = 2^bn - 1; complete = 0; l = (Length[reducedword] - 1)/2; (*Print[{branch,bn,modeno,l}];*) While[modeno >= 0 && complete == 0, result = {reducedword[[1]], reducedword[[2]], 1/2, 0}; now = 2; (*Print["modeno=",modeno];*) modelist = IntegerDigits[modeno, 2, bn]; nextstep = 2^bn; failure = 0; While[now <= l && failure == 0, (*Print["now=",now];*) gonext = 0; If[MemberQ[branch, now], nextstep = nextstep/2; leftright = modelist[[Position[branch, now][[1, 1]] - 1]]; rireki = {0}; num1 = 1; While[num1 < now, If[result[[4 num1 - 2]] == reducedword[[2 now]], rireki = Join[rireki, {result[[4 num1 - 1]]}]; num1 = num1 + 1, num1 = num1 + 1] ]; rireki = Join[rireki, {1}]; (*Print["rireki_1 ",rireki];*) rireki = Apply[Plus, Partition[Sort[rireki], 2, 1], {1}]/2; num2 = 1; While[num2 <= Length[rireki] && gonext == 0, If[leftright/2 < rireki[[num2]] < 1/2 + leftright/2, (*Check whether it crosses with the line already drawn.*) (*Print["rireki_1_2=",rireki[[num2]]];*) (*num3=1;*) num3 = 2; nocrossing = 1; While[num3 < now && nocrossing == 1, If[result[[4 num3 - 3]] == reducedword[[2 now - 1]], nocrossing = nocrossing* crosscheck[reducedword[[2 now - 1]], {result[[4 now - 6]], result[[4 now - 5]]}, {reducedword[[2 now]], rireki[[num2]]}, {result[[4 num3 - 6]], result[[4 num3 - 5]]}, {result[[4 num3 - 2]], result[[4 num3 - 1]]}]; num3 = num3 + 1, num3 = num3 + 1] ]; (*Print["nocrossing1=",nocrossing];*) If[nocrossing == 1, gonext = 1, gonext = 0] ]; num2 = num2 + 1 ]; If[gonext == 0 , failure = 1], rireki = {0}; num1 = 1; While[num1 < now, If[result[[4 num1 - 2]] == reducedword[[2 now]], rireki = Join[rireki, {result[[4 num1 - 1]]}]; num1 = num1 + 1, num1 = num1 + 1] ]; rireki = Join[rireki, {1}]; rireki = Apply[Plus, Partition[Sort[rireki], 2, 1], {1}]/2; (*Print["rireki_2_sellect=",rireki];*) num2 = 1; While[num2 <= Length[rireki] && gonext == 0, (*whether crossed or not*) num3 = 2; nocrossing = 1; While[num3 < now && nocrossing == 1, If[result[[4 num3 - 3]] == reducedword[[2 now - 1]], nocrossing = nocrossing* crosscheck[reducedword[[2 now - 1]], {result[[4 now - 6]], result[[4 now - 5]]}, {reducedword[[2 now]], rireki[[num2]]}, {result[[4 num3 - 6]], result[[4 num3 - 5]]}, {result[[4 num3 - 2]], result[[4 num3 - 1]]}]; num3 = num3 + 1, num3 = num3 + 1] ]; (*Print["nocrossing2=",nocrossing];*) If[nocrossing == 1, gonext = 1, gonext = 0]; num2 = num2 + 1 ]; If[gonext == 0 , failure = 1] ]; If[gonext == 1, result = Join[result, {reducedword[[2 now - 1]], reducedword[[2 now]], rireki[[num2 - 1]], 0}]]; (*Print["result=",result];*) now = now + 1; ]; If[now == l + 1 && failure == 0, (*connected or not*) (*Print["lastcheck"];*) num3 = 2; nocrossing = 1; While[num3 <= l && nocrossing == 1, If[result[[4 num3 - 3]] == reducedword[[1]], nocrossing = nocrossing* crosscheck[ reducedword[[1]], {result[[4 l - 2]], result[[4 l - 1]]}, {reducedword[[2]], 1/2}, {result[[4 num3 - 6]], result[[4 num3 - 5]]}, {result[[4 num3 - 2]], result[[4 num3 - 1]]}]; num3 = num3 + 1, num3 = num3 + 1] ]; (*Print["nocrossing_last=",nocrossing];*) If[nocrossing == 1, complete = 1, modeno = modeno - nextstep] , modeno = modeno - nextstep ]; ]; If[complete != 1, (*draw closed curve*) {0, from2to5[reducedword]} ,(*draw SCC*) (*Print["result=",result];*) (*result has length of 4x*) (*rewrite to 5x+1*) sccresult = from2to5[reducedword]; (*Print["sccresult_1=",sccresult];*) num4 = 1; While[num4 <= Length[result]/4, If[result[[4 num4]] == 1, (*sccresult[[5num4-1]]=result[[4num4-1]];*) num4 = num4 + 1, aaa = {}; num5 = 1; While[num5 <= Length[result]/4, If[kasaneru2[result[[4 num4 - 2]]] == kasaneru2[result[[4 num5 - 2]]], aaa = Join[aaa, {num5, slide[result[[4 num5 - 2]], result[[4 num5 - 1]]]}]; num5 = num5 + 1, num5 = num5 + 1] ]; bbb = Sort[Table[aaa[[2 num6]], {num6, Length[aaa]/2}]]; num6 = 1; While[num6 <= Length[bbb], aaa[[2 num6]] = Position[bbb, aaa[[2 num6]]][[1, 1]]; num6 = num6 + 1 ]; num6 = 1; While[num6 <= Length[bbb], (*result[[4aaa[[2num6-1]]-1]]=aaa[[2num6]];*) (*The above row may be unnecessary*) sccresult[[5 aaa[[2 num6 - 1]] - 1]] = aaa[[2 num6]]; result[[4 aaa[[2 num6 - 1]]]] = 1; num6 = num6 + 1 ]; num4 = num4 + 1 ](*end of If*) ];(*end of While*) {1, sccresult} ] ] (*This function is based on Ahara's algorithm*) crosscheck[faceno_, ne1_, ne2_, ol1_, ol2_] := If[relation[faceno, ne1, ol1]*relation[faceno, ne1, ol2]* relation[faceno, ne2, ol1]*relation[faceno, ne2, ol2] > 0, 1, 0] (*This function is based on Ahara's algorithm*) relation[faceno_, edge1_, edge2_] := Module[{f, ks, edgeorder, edgeparity, a, b}, (*last variables are lists{edgeno,edgecoord}*) ks[c_] := Which[OddQ[Im[c]], c*I, Im[c] < 0, -c, True, c]; f = Re[faceno] - Im[faceno]; a = {ks[edge1[[1]]], edge1[[2]]}; b = {ks[edge2[[1]]], edge2[[2]]}; edgeorder = Which[f == 1, {10 I, 13, 15, 10}, f == -1, {10 I, -10, -15, -13}, f == GENUS + 1, {10 GENUS + 5, 10 GENUS + 8, 10 (GENUS + 1) I, 10 (GENUS + 1)}, f == -GENUS - 1, {10 (GENUS + 1) I, -10 GENUS - 8, -(10 GENUS + 5), -10 GENUS - 10}, f > 0, {f*10 I, 10 f + 3, 10 f + 5, 10 f, 10 f - 5, 10 f - 2}, True, {-f*10 I, 10 f + 2, 10 f + 5, 10 f, 10 f - 5, 10 f - 3}]; edgeparity = Which[f == 1, {1, 1, -1, 1}, f == -1, {-1, 1, 1, 1}, f == GENUS + 1, {1, 1, -1, 1}, f == -GENUS - 1, {1, 1, -1, 1}, f > 0, {1, 1, -1, 1, 1, 1}, True, {-1, 1, -1, 1, 1, 1}]; Which[Position[edgeorder, a[[1]]][[1, 1]] - Position[edgeorder, b[[1]]][[1, 1]] > 0, 1, Position[edgeorder, a[[1]]][[1, 1]] - Position[edgeorder, b[[1]]][[1, 1]] < 0, -1, True, If[(a[[2]] - b[[2]])* edgeparity[[Position[edgeorder, a[[1]]][[1, 1]]]] >= 0, 1, -1] ] ] (*This function is based on Ahara's algorithm*) dehntwist[scclist_, plusminus_, cclist_] := Module[{l, i}, i = 1; kyokusen2 = {}; l = (Length[cclist] - 1)/5; While[i <= l, kyokusen2 = Join[kyokusen2, {cclist[[5 i - 4]], cclist[[5 i - 3]]}]; i = i + 1 ]; (*Print[kyokusen2];*) kyokusen2 = twistmap[scclist, plusminus, Join[kyokusen2, {cclist[[5 l + 1]]}]]; aftertwist ] (*This function is based on Ahara's algorithm*) twistmap[scclist_, plusminus_, cclist_] := Module[{lscc, lcc, result, i, j, k, preorder, lpr, rewritingorder, leftest}, (*scclist has length of 5x+1*) (*cclist has length of 2x+1*) lscc = (Length[scclist] - 1)/5; lcc = (Length[cclist] - 1)/2; (*Print["{lscc,lcc}=",{lscc,lcc}];*) result = {cclist[[1]], cclist[[2]]}; i = 2; While[i <= lcc + 1, (*Print["{i,result}=",{i,result}];*) j = 1; preorder = {}; rewritingorder = {}; While[j <= lscc, If[cclist[[2 i - 1]] == scclist[[5 j - 4]], (*search edges on the same cell and crossing check*) If[crosscheck[cclist[[2 i - 1]], {scclist[[5 j - 3]], scclist[[5 j - 1]]/scclist[[5 j - 2]]}, {scclist[[renum[5 j - 8, 5 lscc]]], scclist[[renum[5 j - 6, 5 lscc]]]/scclist[[renum[5 j - 7, 5 lscc]]]}, {cclist[[2 i - 2]], 2}, {cclist[[renum[2 i, 2 lcc]]], 2}] == 0, (*crossed case*) (*Print["type1 {i,j}=",{i,j}];*) If[(*on the left*) relation[cclist[[2 i - 1]], {scclist[[5 j - 3]], scclist[[5 j - 1]]/scclist[[5 j - 2]]}, {cclist[[2 i - 2]], 2}]* relation[cclist[[2 i - 1]], {scclist[[5 j - 3]], scclist[[5 j - 1]]/scclist[[5 j - 2]]}, {scclist[[renum[5 j - 8, 5 lscc]]], scclist[[renum[5 j - 6, 5 lscc]]]/ scclist[[renum[5 j - 7, 5 lscc]]]}]* relation[cclist[[2 i - 1]], {cclist[[2 i - 2]], 2}, {scclist[[renum[5 j - 8, 5 lscc]]], scclist[[renum[5 j - 6, 5 lscc]]]/ scclist[[renum[5 j - 7, 5 lscc]]]}] < 0, preorder = Join[preorder, {j, scclist[[5 j - 3]], scclist[[5 j - 1]]/scclist[[5 j - 2]], 1}], preorder = Join[preorder, {j, scclist[[renum[5 j - 8, 5 lscc]]], scclist[[renum[5 j - 6, 5 lscc]]]/ scclist[[renum[5 j - 7, 5 lscc]]], -1}] ] (*,Print["type2 {i,j}=",{i,j}];*) (*if uncrossed, we do nothing*) ]; j = j + 1, (*Print["type3 {i,j}=",{i,j}];*) j = j + 1 ] ]; (*Print["preorder=",preorder];*) lpr = Length[preorder]/4; If[lpr == 0, If[i != lcc + 1, result = Join[result, {cclist[[2 i - 1]], cclist[[2 i]]}], result = Join[result, {cclist[[2 i - 1]]}]], (*sort of the right hand side*) While[Length[preorder] > 0, j = 2; leftest = 1; While[j <= Length[preorder]/4, If[relation[cclist[[2 i - 1]], {preorder[[4 j - 2]], preorder[[4 j - 1]]}, {preorder[[4 leftest - 2]], preorder[[4 leftest - 1]]}]* relation[cclist[[2 i - 1]], {preorder[[4 j - 2]], preorder[[4 j - 1]]}, {cclist[[2 i - 2]], 2}]* relation[cclist[[2 i - 1]], {preorder[[4 leftest - 2]], preorder[[4 leftest - 1]]}, {cclist[[2 i - 2]], 2}] < 0, j = j + 1, leftest = j; j = j + 1] ]; rewritingorder = Join[rewritingorder, {preorder[[4 leftest - 3]], plusminus* Sign[Re[cclist[[2 i - 1]]] + Im[cclist[[2 i - 1]]]]* preorder[[4 leftest]]}]; preorder = Drop[preorder, {4 leftest - 3, 4 leftest}] ]; (*Print["rewritingorder=",rewritingorder];*) (*watch out for rewriting, sign, plusminus, omoteura*) j = 1; While[j <= lpr, If[rewritingorder[[2 j]] == 1, result = Join[result, {scclist[[5 rewritingorder[[2 j - 1]] - 4]], scclist[[5 rewritingorder[[2 j - 1]] - 3]]}]; (*Print["result_a=",result];*) k = renum[rewritingorder[[2 j - 1]] + 1, lscc]; (*Print["{j,k}=",{j,k}];*) While[rewritingorder[[2 j - 1]] != k, result = Join[result, {scclist[[5 k - 4]], scclist[[5 k - 3]]}]; k = renum[k + 1, lscc] ], result = Join[result, {scclist[[5 rewritingorder[[2 j - 1]] - 4]], scclist[[renum[5 rewritingorder[[2 j - 1]] - 8, 5 lscc]]]}]; (*Print["result_b=",result];*) k = renum[rewritingorder[[2 j - 1]] - 1, lscc]; (*Print["{j,k}=",{j,k}];*) While[rewritingorder[[2 j - 1]] != k, result = Join[result, {scclist[[5 k - 4]], scclist[[renum[5 k - 8, 5 lscc]]]}]; k = renum[k - 1, lscc] ] ]; j = j + 1 ]; If[i != lcc + 1, result = Join[result, {cclist[[2 i - 1]], cclist[[2 i]]}], result = Join[result, {cclist[[2 i - 1]]}]] ]; i = i + 1 ]; result ] commutator[i_] := If[i > 0, {2 i - 1, 2 i, -2 i + 1, -2 i}, {-2 i, -2 i - 1, 2 i, 2 i + 1}] freewordreduce[freeword_] := Block[{wl, i, j, result}, j = 0; result = freeword; While[j == 0, wl = Length[result]; If[wl <= 1, j = 1, i = 1; While[(i < wl && result[[i]] + result[[i + 1]]) != 0, i = i + 1]; If[i == wl, j = 1, result = Drop[result, {i, i + 1}]] ] ]; result ] (*This function is based on Ahara's algorithm*) actiononpi1[scclist_] := Block[{sccno, autpi1, autinvpi1, genus, pialpha, pibeta, num, i, j, k, pinum, edge2word, freewordreduce, cell2, cell1}, sccno = Length[scclist]/2; genus = Max[Table[GENUS, {i, sccno}]]; pialpha[num_] := Flatten[Join[{genus + 1}, Table[{10*i + 5, i}, {i, genus, num, -1}], {num*10 I, num*I, (num*10 + 5) I, (num + 1) I, 10 I (num + 1), num + 1}, Table[{10*i + 5, i + 1}, {i, num + 1, genus}]]]; pibeta[num_] := Flatten[Join[{genus + 1}, Table[{10*i + 5, i}, {i, genus, num + 1, -1}], {10 (num + 1) I, (num + 1) I, -10 num - 10, -num - 1, -10 num - 8, (num + 1) I, 10 (num + 1) I, num + 1}, Table[{10*i + 5, i + 1}, {i, num + 1, genus}]]]; edge2word[cell2_, cell1_] := Module[{j}, Which[(Re[cell1] < 0 && Mod[Re[cell1], 10] == 0), (*-10,-20,,,*) If[Re[cell2] + Im[cell2] > 0, Flatten[Table[commutator[j], {j, 1 + Re[cell1]/10, -1}]], -Reverse[Flatten[Table[commutator[j], {j, 1 + Re[cell1]/10, -1}]]]], Mod[Abs[cell1], 5] == 3, (*13,18,-13,-18,,,*) If[Re[cell2] + Im[cell2] > 0, Flatten[Join[{-2 Quotient[Abs[cell1], 10]}, Table[commutator[j], {j, -Quotient[Abs[cell1], 10], -1}]]], -Reverse[Flatten[Join[{-2 Quotient[Abs[cell1], 10]}, Table[commutator[j], {j, -Quotient[Abs[cell1], 10], -1}]]]]], (Im[cell1] > 0 && Mod[Im[cell1], 10] == 5), (*15I,25I,,,*) If[10 Abs[cell2] < Abs[cell1], {(Im[cell1] - 5)/5 - 1}, -{(Im[cell1] - 5)/5 - 1}], (Re[cell1] < 0 && Mod[Re[cell1], 10] == 5), (*-15,-25,,,*) If[10 Abs[cell2] < Abs[cell1], Flatten[Join[If[cell1 == -15, {}, Table[commutator[j], {j, (-cell1 - 15)/10}]], {2 Quotient[Abs[cell1], 10] - 1}, Table[commutator[j], {j, (cell1 + 5)/10, -1}]]], -Reverse[Flatten[Join[If[cell1 == -15, {}, Table[commutator[j], {j, (-cell1 - 15)/10}]], {2 Quotient[Abs[cell1], 10] - 1}, Table[commutator[j], {j, (cell1 + 5)/10, -1}]]]] ], True, {} ] ]; autpi1 = Flatten[Table[{pialpha[j], pibeta[j]}, {j, genus}], 1]; autinvpi1 = Flatten[Table[{pialpha[j], pibeta[j]}, {j, genus}], 1]; j = 1; While[j <= sccno, pinum = 1; While[pinum <= genus, Do[autpi1[[2 pinum - 1]] = twistmap[scclist[[2 sccno - 2 j + 1]], Sign[scclist[[2 sccno - 2 j + 2]]], autpi1[[2 pinum - 1]]], {Abs[scclist[[2 sccno - 2 j + 2]]]}]; Do[autpi1[[2 pinum]] = twistmap[scclist[[2 sccno - 2 j + 1]], Sign[scclist[[2 sccno - 2 j + 2]]], autpi1[[2 pinum]]], {Abs[ scclist[[2 sccno - 2 j + 2]]]}]; Do[autinvpi1[[2 pinum - 1]] = twistmap[scclist[[2 j - 1]], -Sign[scclist[[2 j]]], autinvpi1[[2 pinum - 1]]], {Abs[scclist[[2 j]]]}]; Do[autinvpi1[[2 pinum]] = twistmap[scclist[[2 j - 1]], -Sign[scclist[[2 j]]], autinvpi1[[2 pinum]]], {Abs[scclist[[2 j]]]}]; pinum = pinum + 1 ]; (*Print["j=",{j}];*) (*Print["autpi1=",autpi1];*) (*Print["autinvpi1=",autinvpi1];*) j = j + 1 ]; (*rewrite edge word into word of free group*) (*Print["edge_{autpi1,autinvpi1}=",{autpi1,autinvpi1}];*) $RecursionLimit = 5000; j = 1; While[j <= 2 genus, autpi1[[j]] = freewordreduce[Flatten[ Table[edge2word[autpi1[[j, 2 k - 1]], autpi1[[j, 2 k]]], {k, (Length[autpi1[[j]]] - 1)/2}]]]; autinvpi1[[j]] = freewordreduce[Flatten[ Table[edge2word[autinvpi1[[j, 2 k - 1]], autinvpi1[[j, 2 k]]], {k, (Length[autinvpi1[[j]]] - 1)/2}]]]; j = j + 1 ]; $RecursionLimit = 256; {autpi1, autinvpi1} ] spAction[listOfTwists_] := Module[{aaaaa,i, j, auto, narabikae}, narabikae[n_]:=If[n <= GENUS, 2n-1, 2(n-GENUS)]; auto=actiononpi1[listOfTwists][[1]]; Print[drawpicture[Table[listOfTwists[[2 i - 1]], {i, Length[listOfTwists]/2}]]]; Table[Count[auto[[narabikae[j]]], narabikae[i]] - Count[auto[[narabikae[j]]], -narabikae[i]], {i, 2GENUS}, {j, 2GENUS}]//MatrixForm ]; aftertwist := Module[{l, rw}, l = Length[kyokusen2]; rw = wordreduce[kyokusen2]; rw = simplicitycheck[rw]; (*Print[rw];*) admitpreserve = rw[[1]]; If[rw[[1]] == 1, current = rw[[2]]; Print["current:"]; picture[current], Print["Error! This curve is NOT homotopic to some SCC !"]; ] ] preserve := Module[{}, If[admitpreserve == 0, Print["The curve on the picture is NOT homotopic to some SCC !"], Print[StringForm["This SCC is named simple[[``]]", simpleclosedcurvenumber]]; simple = Join[simple, {current}]; simpleclosedcurvenumber = simpleclosedcurvenumber + 1 ]; ] tw[n_] := Module[{g, k}, k = Abs[n]; If[(k == 0 || k > 4 GENUS - 1), Print[StringForm[ "tw[n] is now defined for 1\[LessEqual]|n|\[LessEqual]``", 4 GENUS - 1]], Switch[Mod[k, 4], 0, Print[StringForm["D````", k/4, If[n > 0, "+", "-"]]], 1, Print[StringForm["A````", (k + 3)/4, If[n > 0, "+", "-"]]], 2, Print[StringForm["B````", (k + 2)/4, If[n > 0, "+", "-"]]], 3, Print[StringForm["C````", (k + 1)/4, If[n > 0, "+", "-"]]] ]; dehntwist[lic[Abs[n]], Sign[n], current] ] ] involution :=Module[{to}, to = {}; edgeno = (Length[current] - 1)/5; i = 1; While[i <= edgeno, to = Join[to, {current[[5 i - 4]], current[[5 i - 3]]}]; i = i + 1]; kyokusen2 = -Join[to, {current[[5 edgeno + 1]]}]; aftertwist ] twistCurrentAlongSimple[n_] := If[Abs[n] < simpleclosedcurvenumber && n != 0, dehntwist[simple[[Abs[n]]], Sign[n], current], Print[StringForm["We have not defined simple[[``]] yet", simpleclosedcurvenumber]]; ] lic[n_] := Module[{g}, Switch[Mod[n, 4], 0, g = (n + 4)/4; {g, 10*g - 2, 1, 1, 1, -g I, 10 g + 3, 1, 1, 1, g}, 1, g = (n + 3)/4; {(g + 1)*I, -10*g - 8, 1, 1, 1, -(g + 1) , -10 (g + 1), 1, 1, 1, (g + 1)*I}, 2, g = (n + 2)/4; {g, 10 g I, 1, 1, 1, g I, (10 g + 5) I, 1, 1, 1, (g + 1) I, 10 (g + 1) I, 1, 1, 1, g + 1, 10 g + 5, 1, 1, 1, g}, 3, g = (n + 1)/4; {g + 1, 10*g + 8, 1, 1, 1, -(g + 1) I, 10 (g + 1), 1, 1, 1, g + 1} ] ] genuschange[n_] := If[IntegerQ[n] && n > 0, simpleclosedcurvenumber = 1; loop = {}; simple = {}; current = {}; admitpreserve = 0; GENUS = n; Print["genus=", GENUS], Print["?"] ]