<<  c:/drorbn/projects/KAtlas/KnotTheory.m

<<  c:/drorbn/projects/KAtlas/KnotTheoryData.m

Lob[t_] := -NIntegrate[Log[Abs[2  Sin[u]]], {u, 0, t}];  
    Vol[z_] := Plus  @@  (Lob[Arg[#]] &  /@  {z, 1 - 1/z,  
              1/(1 - z)})

2  Vol[omega  =  1/2 + Sqrt[3]/2*I]

Pachner[z_, w_]  :=  {Vol[z],  Vol[w],  
        Vol[z] + Vol[w] + Vol[1/(z*w)] - 
          Vol[z (1 - w)/(1 - z*w)] - 
          Vol[w (1 - z)/(1 - z*w)]}

Pachner[Random[Real, {-1, 1}] + I*Random[Real, {-1, 1}],  
      Random[Real, {-1, 1}] + I*Random[Real, {-1, 1}]]

n = 4;

eqns  =  (# == 
                1) &  /@  (prods  =  {
z11 z21 z31 z41,  z12 z22 z32 z42,  
                z13 z23 z33 z43, 
z12 z14,  
                z34 z13 z31,  z24 z42 z23,  z21 z22 z44,  
                z41 z43,  
                z11 z33 z32, 
z32'' z11' z41'' z43' z13'' z31' z21'' z22',  
                z33'' z32' z22'' z44' z14'' z12' z42'' z23', 
z34'' z13' z43'' z41' z11'' z33' z23'' z24',  
                z24' z42'' z32' z11'' z21' z22'' z12' z14'', 
z41' z43'' z33' z32'' z42' z23'' z13' z31'',  
                z43' z41'' z31' z34'' z44' z21'' z11' z33'', 
z21' z31'' (z34'' z44')^(-1)
}) /.  {(z_)'  :>  
            1 - 1/z,  (z_)''  :>  
            1/(1 - z)}

1 - 1/(1 - 1/z) //  Simplify

vars  =  Union[Cases[eqns,  _Symbol,  Infinity]]

{
sol  =  
        FindRoot  @@  
          Join[{eqns},  ({#,  Exp[Random[] Pi I]} &  /@  
                vars),  {MaxIterations  ->  
                1000}], 
Max[
        Abs[((First  /@  eqns)  /.  sol) - 
            1]], 
Plus  @@  (Vol  /@  (vars  /.  
                sol))
}

SetAttributes[p,  Orderless];  
    SetAttributes[{EQs,  EQ},  {Orderless,  Flat}]

im4[a_]  :=  a + 1  /.  5 -> 1;  
    dm4[a_]  :=  a - 1  /.  0  -> 4

Expected volume for 5_2: 2.8281220883.

L = PD[Knot[4, 1]]

n = Length[L]

dt  =  
        EQs  @@  
            Flatten[
{
Table[
t[z[v, j], 3, {1, 2, 4}]~e~
                      t[z[v, im4@j], 4, {2, 1, 3}], 
{v, 
                      n}, {j, 
                      4}
], 
Table[
                        e @@ Position[L,  i],  {i, 2  n}]  /.  
                      e[x_, y_]  ->  {e[x, y], 
                          e[y, x]}  /.  {
e[{v_, 
                            a_}, {u_, b_}]  :>  
                        t[z[v, dm4@a], 2, {1, 3, 4}]~e~
                            t[z[u, b], 1, {2, 3, 4}] /;  
                          OddQ[a + b], 
e[{v_, a_}, {u_, 
                            b_}]  :>  
                        t[z[v, dm4@a], 2, {1, 3, 4}]~e~
                            t[z[u, b], 1, {2, 4, 3}] /;  
                          EvenQ[a + 
                              b]
}
}  /.  e[t[z_, a_, {c1_, c2_, c3_}],  
                    t[w_, b_, {d1_, d2_, 
                        d3_}]]  :>  {
t[z, a, 
                        c1]~p~t[w, b, d1],  t[z, a, c2]~p~t[w, b, d2],  
                    t[z, a, c3]~p~
                      t[w, b, 
                        d3]
}
]  /.  
          t[z[v_, j_],  a_,  b_]  :>  
            t[z[v, j]]~
                Join~(t[a, b]  /.  {3 -> 4,  4 -> 3}) /;  
              EvenQ[j];

rels  =  
        List  @@  Union[
dt  /.  
                      p[t[z_, a_, b_],  t[w_, c_, d_]]  :>  
                        EQs[t[z, a, b]~to~t[w, d, c],  
                          t[w, c, d]~to~
                            t[z, b, a]]  //.  (
EQs[
                          xx_. *(t[x_,  ab__]~to~t[y_, cd__]),  
                          zz_. *(t[y_, cd__]~to~
                                t[z_, 
                                  ef__])]
 :>  EQs[xx*y[cd]*zz*(t[x, ab]~to~
                                t[z, ef])]
)  /.  (t[z_, ab__]~to~t[z_, ab__])  :>  z[ab]  /.  (w_z)[
                    ab__]  :>  
                  Switch[Sort[{ab}], 
{1, 2} | {3, 4},  
                    w[0], 
{1, 3} | {2, 4},   w[
                      1], 
{1, 4} | {2, 3},  
                    w[2]
]
]  /.  
          eq_Times  :>  (EQ  @@  
                eq);
merge  =  
        Position[Count[#,  z[n, _][__]] &  /@  rels,  
          4];
rels  =  
        Append[Delete[rels, merge],  
          EQ  @@  rels[[Join  @@  
                  merge]]];
rels  =  
      Append[rels,  
          EQ  @@  Product[
z[k, 4][0]*z[k, 4][
                    1]*z[k, 3][0]*z[k, 3][2]*
If[
                    L[[k, 4]] > L[[k, 2]]  ||  
                      L[[k, 2]] - L[[k, 4]] > 
                        1, 
z[k, 1][1]*z[k, 4][
                        2], 
z[k, 3][1]*z[k, 2][
                        2]
], 
{k, 
                  n}
]  //.  {EQ[z_[0], z_[1], 
                  z_[2]]  ->  EQ[-1],  
              EQ[-1, -1]  ->  EQ[]}
]  /.  
        z[i_, j_]  :>  
          ToExpression["z" <> ToString[i] <> ToString[j]]

Length  /@  rels

Plus  @@  len  /@  Length   /@  rels

pr[k_]  :=  (k + 1)~Mod~3 ; prpr[
          k_]  :=  (k + 2)~Mod~3 ;

\(s = 
      Module[{s = rels, \ t, \ at1, \ at2}, 
Label[
          Start]; \ 
        s = DeleteCases[s, \ EQ[]]; 
For[k = 1, \ 
          k ≤ Length[s], \ \(++k\), 
          Replace[s[\([k]\)], \ 
            EQ[z1_[p1_], 
                z2_[p2_]]\  :> \ \((
Print[
                  StringForm["Doing bigon: k=``; s[[k]]=``; s=``", \ k, 
                    s[\([k]\)], \ s]]; 
t\  = \ 
                  Delete[s, \ 
                      k]\  //. \ {EQ[z1[p1 // pr], \ 
                          z2[p2 // prpr]]\  -> EQ[], \ 
                      EQ[z1[p1 // prpr], \ z2[p2 // pr]]\  -> 
                        EQ[]}; 
If[
                  Length[at1\  = \ Position[t, \ z1]] ≠ 1\  || \ 
                    Length[at2\  = \ Position[t, \ z2]] ≠ 
                      1\ , 
Print[
                    StringForm["Bad bigon: at1=``; at2=``; t=``", \ 
                      at1, \ at2, \ t]], 
at1 = 
                    at1[\([1, 1]\)]; \ 
                  at2 = at2[\([1, 1]\)]; 
s = 
                    If[at1 == 
                        at2, 
Print["Equal ats", \ 
                        t[\([at1]\)]]; \ 
                      t\  /. \ \ EQ[z1[p1], \ z2[p2]]\  -> \ 
                          EQ[], 
Append[
                        Delete[t, \ {{at1}, \ {at2}}], \ 
                        EQ[t[\([at1]\)], t[\([at2]\)]]\  /. \ 
                          EQ[z1[p1], \ z2[p2]]\  -> \ 
                            EQ[]]
]; 
\ 
                  Goto[Start]
]
)\)]]; 
For[k = 1, \ k ≤ Length[s], \ \(++k\), 
          Replace[s[\([k]\)], \ 
            EQ[z1_[p1_], \ z2_[p2_], \ 
                z3_[p3_]]\  :> \ \((
Print[
                  StringForm["Doing triangle: k=``; s[[k]]=``; s=``", \ 
                    k, s[\([k]\)], \ s]]; 
{w1, w2} = 
                  Unique[{w, w}]; 
t\  = \ 
                  Delete[s, \ 
                      k]\  //. \ {
z3[p3]\  -> \ 
                        EQ[w1[0], w2[0]], \ 
                      z2[p2]\  -> \ EQ[w1[2], w2[1]], \ 
                      z1[p1]\  -> \ 
                        EQ[w1[1], \ w2[2]], 
EQ[
                          z3[p3 // pr], \ z3[p3 // prpr]]\  -> \ 
                        EQ[\(-1\), \ w1[2], w2[1], w1[1], 
                          w2[2]], 
EQ[z2[p2 // pr], \ 
                          z2[p2 // prpr]]\  -> \ 
                        EQ[\(-1\), \ w1[0], w2[0], w1[1], 
                          w2[2]], 
EQ[z1[p1 // pr], \ 
                          z1[p1 // prpr]]\  -> \ 
                        EQ[\(-1\), \ w1[0], w2[0], w1[2], 
                          w2[1]], 
EQ[z1[p1 // prpr], \ 
                          z2[p2 // pr]]\  -> \ w1[0], \ 
                      EQ[z1[p1 // pr], \ z2[p2 // prpr]]\  -> \ 
                        w2[0], 
EQ[z2[p2 // prpr], \ 
                          z3[p3 // pr]]\  -> \ w1[1], \ 
                      EQ[z3[p3 // pr], \ z1[p1 // prpr]]\  -> \ 
                        w2[1], 
EQ[z3[p3 // prpr], \ 
                          z1[p1 // pr]]\  -> \ w1[2], \ 
                      EQ[z2[p2 // pr], \ z3[p3 // prpr]]\  -> \ 
                        w2[2], 
EQ[z_[0], z_[1], 
                          z_[2]]\  -> \ EQ[\(-1\)], \ 
                      EQ[\(-1\), \(-1\)]\  -> \ 
                        EQ[]
}; 
If[
                  FreeQ[t, \ z1 | z2 | z3], 
s = t; \ 
                  Goto[Start], 
Print[
                    StringForm["Failed triangle; t=``; problems at ``", \ 
                      t, \ Select[
                        t, \ \(! FreeQ[#, \ 
                              z1 | z2 | 
                                z3]\) &]]]
]
)\)]]; 
s
]\)

Length  /@  s

eqns  =  (Times  @@  # == 1) &  /@  
          Rest[Reverse[s]]   /.  {w_[0]  :>  w,  
          w_[1]  :>  1 - 1/w,  
          w_[2]  :>  1/(1 - w)}

vars  =  Union[Cases[eqns,  _Symbol,  Infinity]]

{
sol  =  
        FindRoot  @@  
          Join[{eqns},  ({#,  Exp[Random[] Pi I/2]} &  /@  
                vars),  {MaxIterations  ->  
                1000}], 
Max[
        Abs[((First  /@  eqns)  /.  sol) - 
            1]], 
Plus  @@  (Vol  /@  (vars  /.  
                sol))
}

sols  =  vars  /.  Solve[eqns,  vars]

N[sols]

(Plus  @@  Vol  /@  #) &  /@  sols