simpleclosedcurvenumber = 1; loop = {}; simple = {}; current = {}; admitpreserve = 0; NotebookWrite[CreateDocument[], "drawcurve[]"]; twistpallete[4]; 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, -6}], Inset[Button["preserve", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["preserve", "Input"], All]; SelectionEvaluate[InputNotebook[]]], {0, -8.1}], Inset[Button["drawcurve", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["drawcurve[]", "Input"], All]], {0, -10.2}], Inset[Button["twist", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["twistCurrentAlongSimple[]", "Input"], All]], {0, -12.3}], Inset[Button["picture", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["picture[simple[[]]]", "Input"], All]], {0, -14.4}], Inset[Button["\[Pi]_1 action", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["action[{simple[[]],1}]", "Input"], All]], {0, -16.5}], Inset[Button["computations", SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell["computations[{simple[[]],1}]", "Input"], All]], {0, -18.6}]}, ImageSize -> 150]} ]; twistpallete[n_]:=Module[{pal,i}, pal={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}], Inset[Button[StringForm["D3+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[12]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {5,-1}], Inset[Button[StringForm["D3-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-12]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {5,-1.5}], Inset[Button[StringForm["A4+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[13]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,0}], Inset[Button[StringForm["A4-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-13]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,-0.5}], Inset[Button[StringForm["B4+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[14]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,-1}], Inset[Button[StringForm["B4-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-14]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,-1.5}], Inset[Button[StringForm["C4+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[15]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,-2}], Inset[Button[StringForm["C4-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-15]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {6,-2.5}], Inset[Button[StringForm["D4+"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[16]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {7,-1}], Inset[Button[StringForm["D4-"], SelectionMove[InputNotebook[], Next, Cell]; NotebookWrite[InputNotebook[], Cell[StringForm["tw[-16]"], "Input"], All]; SelectionEvaluate[InputNotebook[]]], {7,-1.5}]}; CreatePalette[Graphics[pal, ImageSize -> 400 + 50 n]] ] 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}], Line[{{0, 3}, {6 shusuu - 3, 3}}], Line[{{0, -3}, {6 shusuu - 3, -3}}], Table[Text[n, {6 n - 6, 0}], {n, 1, shusuu}]} ] ] cellcoord[cellno_] := If[Abs[cellno] == 1, {-1.5, -1.5 (Re[cellno] - Im[cellno])}, {6 Abs[cellno] - 9, -2 Sign[Re[cellno] - Im[cellno]]}] neededgenus2[kyo_] := Module[{i}, Max[Append[Table[Abs[kyo[[2i - 1]]], {i, 1, (Length[kyo] + 1)/2}],4]] ] drawcurve[cpx_] := Module[{pt}, now = cpx; kyokusen = {now}; pt = cellcoord[cpx]; Dynamic[Show[drawloop[from2to5[kyokusen],1], Graphics[pictureofsurface[neededgenus2[kyokusen]]], PlotRange -> {{-4, 6 neededgenus2[kyokusen]-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[now === 1 || now === -1, kyokusen = Join[kyokusen, {now*10, -now*I}]; now = -now*I, now === I || now === -I, 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[{}, If[Re[now] != 0, kyokusen = Join[kyokusen, {10 now + 5 Sign[now], now + Sign[now]}]; now = now + Sign[now], kyokusen = Join[kyokusen, {10 now + 5 I*Sign[Im[now]], now + I*Sign[Im[now]]}]; now = now + I*Sign[Im[now]] ] ] 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[{}, If[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 ], 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[{}, If[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 ], 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[neededgenus2[lockyokusen]]], PlotRange -> {{-4, 6 neededgenus2[lockyokusen]-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] ] ] ] ] (*This function is based on Ahara's algorithm*) bezier[init_, foreback_, term_, clrno_] := Module[{ini, fb, ter, s, 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]]}]}]}] ] ] 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*) 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}, 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} ] ] (*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]]}] ] kasaneru[a_] := Which[OddQ[Im[a]], a*I, Im[a] < 0, -a, True, a] neededgenus[kyo_] := Module[{i, n}, Max[Table[Abs[kyo[[5 i - 4]]], {i, 1, (Length[kyo] - 1)/5}]] ] picture[loopdata_] := drawpicture[{loopdata}] drawpicture[looplist_] := Module[{noofcurves, i, edgenumlist, loophyo, subloop, num1, num2, num3, refedge}, 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[ Max[Table[neededgenus[loophyo[[i]]], {i, noofcurves}]]]]; Show[Join[{surface}, Table[drawloop[loophyo[[i]], Mod[i, 3] + 1], {i, noofcurves}]], AspectRatio -> Automatic, PlotRange -> All, DisplayFunction -> $DisplayFunction] ] 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, (*Print["curve3=",curve,curve[[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] ] ] tubusu[a_] := Which[OddQ[Im[a]], a*I, Im[a] < 0, -a, True, a] (*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 ] ] subfunc[pre_, nowa_, next_] := Module[{n2}, subsub[li1_, li2_] := Module[{vxy, vyz, vxz}, junban[a_, b_] := Module[{ks, c}, ks[c_] := Which[OddQ[Im[c]], c*I, Im[c] < 0, -c, True, c]; (*Print["li1,a"];Print[li1];Print[a];Print[b];*) 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, nowa]; vyz = junban[nowa, next]; vxz = junban[pre, next]; -vxy*vxz*vyz ]; n2 = nowa[[2]]; (*Print[nowa];*) Which[(Im[n2] != 0 && EvenQ[Im[n2]]), If[Re[nowa[[1]]] - Im[nowa[[1]]] > 0, -1, 1], Mod[Abs[n2], 10] == 5, If[Re[nowa[[1]]] - Im[nowa[[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}], Re[n2] > 0, subsub[{Abs[nowa[[1]]]*10 I, Abs[nowa[[1]]]*10 + 3, Abs[nowa[[1]]]*10 + 5, Abs[nowa[[1]]]*10, Abs[nowa[[1]]]*10 - 5, Abs[nowa[[1]]]*10 - 2}, {1, 1, -1, 1, 1, 1}], True, -subsub[{Abs[nowa[[1]]]*10 I, -Abs[nowa[[1]]]*10 - 3, -Abs[nowa[[1]]]*10 - 5, -Abs[nowa[[1]]]*10, -Abs[nowa[[1]]]*10 + 5, -Abs[nowa[[1]]]*10 + 2}, {1, -1, -1, -1, 1, -1}] ] ] 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], 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), 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]]]] == 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 - 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}, (*The 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 > 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 > 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_] := Module[{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_] := Module[{sccno, autpi1, autinvpi1, genus, pialpha, pibeta, num, i, j, k, pinum, edge2word, cell2, cell1}, sccno = Length[scclist]/2; genus = Max[Table[neededgenus[scclist[[2 i - 1]]], {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} ] aorb[numb_]:=If[OddQ[numb], a, b] renum2[numb_]:=If[OddQ[numb], (1 + numb)/2, numb/2] JohnsonHom[autFn_, autFninv_] := Module[{spmatrix, genus2, classicalrep, theta, foxderivation, abelianization, makePower, sptoL2H, npolynL2H, normalpolynomial, num, auto, wordofFn, outputusually, zpower}, genus2 = Length[autFn]; spmatrix = classicalrep[autFn]; classicalrep[auto_] := Module[{i, j}, Table[Count[auto[[j]], i] - Count[auto[[j]], -i], {i, genus2}, {j, genus2}] ]; zpower[num_]:=If[OddQ[num], z^(num + 1), -z^(num - 1)]; theta[wordofFn_] := Module[{i}, Expand[Sum[foxderivation[wordofFn, i]*y^i, {i, genus2}]] ]; foxderivation[wordofFn_, num_] := Module[{wordlength, i, polyn = 0}, wordlength = Length[wordofFn]; For[i = 1, i <= wordlength, i++, Switch[wordofFn[[i]], num, polyn = polyn + abelianization[Take[wordofFn, i - 1]], -num, polyn = polyn - abelianization[Take[wordofFn, i]] ] ]; polyn ]; abelianization[wordofFn_] := If[Length[wordofFn] == 0, 0, Apply[Plus, Map[makePower, wordofFn]] ]; makePower[num_] := If[num > 0, x^(num), -x^(-num)]; sptoL2H[monomial1_ + monomial2_] := sptoL2H[monomial1] + sptoL2H[monomial2]; sptoL2H[monomial_] := Module[{const, px, py, i, j}, const = monomial /. {x -> 1, y -> 1}; If[const == 0, 0, px = Sum[spmatrix[[i, Exponent[monomial, x]]]*(x^i), {i, 1, genus2}]; py = Sum[spmatrix[[j, Exponent[monomial, y]]]*(y^j), {j, 1, genus2}]; Expand[const*px*py] ] ]; npolynL2H[monomial1_ + monomial2_] := npolynL2H[monomial1] + npolynL2H[monomial2]; npolynL2H[monomial_] := Module[{const, sgn, belist, aflist}, const = monomial /. {x -> 1, y -> 1}; If[const == 0, 0, belist = {Exponent[monomial, x], Exponent[monomial, y]}; sgn = (belist[[1]] - belist[[2]]); If[sgn == 0, 0, aflist = Sort[belist]; sgn = sgn/(aflist[[1]] - aflist[[2]]); const*sgn*(x^(aflist[[1]])*y^(aflist[[2]])) ] ] ]; normalpolynomial[monomial1_ + monomial2_] := normalpolynomial[monomial1] + normalpolynomial[monomial2]; normalpolynomial[monomial_] := Module[{const, sgn, belist, aflist}, const = monomial /. {x -> 1, y -> 1, z -> 1}; If[const == 0, 0, belist = {Exponent[monomial, x], Exponent[monomial, y], Exponent[monomial, z]}; sgn = (belist[[1]] - belist[[2]])*(belist[[1]] - belist[[3]])*(belist[[2]] - belist[[3]]); If[sgn == 0, 0, aflist = Sort[belist]; sgn = sgn/((aflist[[1]] - aflist[[2]])*(aflist[[1]] - aflist[[3]])*(aflist[[2]] - aflist[[3]])); const*sgn*(x^(aflist[[1]])*y^(aflist[[2]])*z^(aflist[[3]])) ] ] ]; outputusually[monomial1_ + monomial2_] := outputusually[monomial1] + outputusually[monomial2]; outputusually[monomial_] := Module[{const, t}, const = monomial /. {x -> 1, y -> 1, z -> 1}; If[const == 0, 0, t = {Exponent[monomial, x], Exponent[monomial, y], Exponent[monomial, z]}; const*(SubscriptBox[aorb[t[[1]]], renum2[t[[1]]]]\[Wedge]SubscriptBox[aorb[t[[2]]], renum2[t[[2]]]]\[Wedge]SubscriptBox[aorb[t[[3]]], renum2[t[[3]]]]) ] ]; Module[{i}, Print[MatrixForm[basischange[spmatrix]]]; outputusually[Expand[normalpolynomial[ Expand[Sum[-(npolynL2H[ sptoL2H[npolynL2H[theta[autFninv[[i]]]]]])*(zpower[i])/2, {i, genus2}]]]/3] ] // DisplayForm ] ] narabikae[n_, genus_]:=If[n <= genus, 2n-1, 2(n-genus)]; basischange[matrix_]:= Table[matrix[[narabikae[i, Length[matrix]/2], narabikae[j,Length[matrix]/2]]], {i, Length[matrix]}, {j, Length[matrix]}] computations[map_] := Module[{aaaaa, l, i, pi1action}, l = Length[map]/2; aaaaa = Table[map[[2 i - 1]], {i, l}]; Print[drawpicture[aaaaa]]; pi1action = actiononpi1[map]; Print[pi1action[[1]]]; JohnsonHom[pi1action[[1]], pi1action[[2]]] ] 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, Print["tw[n] is now defined for 1[LessEqual]|n|"];, 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] ] ] action[map_] := actiononpi1[map][[1]] twistCurrentAlongSimple[n_] := If[Abs[n] < simpleclosedcurvenumber && n != 0, dehntwist[simple[[Abs[n]]], Sign[n], current], Print[StringForm["We have not defined simple[[``]] yet", n]] ] 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} ] ]