Expected volume for 5_2: 2.8281220883.

<<  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}]]

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

Rels[K_]  :=  Rels[PD[K]];
\(Rels[pd_PD]\  := \ 
      Module[
{n, \ dt, z, e, u, v, j, im4, dm4, w, zz, xx, 
          yy, ab, merge, rels, x, y, a, b, c, d, d1, d2, d3, 
          eq}, 
im4[a_]\  := \ a + 1\  /. \ 5 -> 1; \ 
        dm4[a_]\  := \ a - 1\  /. \ 0\  -> 4; 
n = 
          Length[pd]; 
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[pd, \ 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]\)]]; 
Append[rels, \ 
            zl~EQ~\((EQ\  @@ \ 
                    Product[
\(z[k, 4]\)[0]*\(z[k, 4]\)[
                          1]*\(z[k, 3]\)[0]*\(z[k, 3]\)[
                          2]*
If[
                          pd[\([k, 4]\)] > pd[\([k, 2]\)]\  || \ 
                            pd[\([k, 2]\)] - pd[\([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_]\)[
              k_]\  :> \ 
            m[ToExpression["z" <> ToString[i] <> ToString[j]], \ 
              k]
]\)

rels = Rels[Knot[7, 2]]

rels = Delete[rels,  Position[rels,  zl][[1, 1]]]

Length  /@  rels

Plus  @@  len  /@  Length   /@  rels

RandomPermutation[l_List]  :=  
        Last  /@  Sort[{Random[], #} &  /@  
              l];
$Log  =  True;
m[z_, k1_][k2_]  :=  
        m[z,  (k1 + k2)~Mod~3];
\(\(RemoveTriangle[s_, \ 
          k_Integer]\  := \((Replace[s[\([\)\(k\)\(]\)], \ 
            EQ[m[Z1_, p1_], m[Z2_, p2_], \ 
                m[Z3_, p3_]]\  :> \ \((
$Log && 
                  Print[StringForm["Doing triangle: k=``; s[[k]]=``; s=``", \ k, s[\([\)\(k\)\(]\)], \ s]]; 
z1 = m[Z1, p1]; \ 
                z2 = m[Z2, p2]; \ 
                z3 = m[Z3, p3]; 
{w1, 
                    w2} = \(m[#, 0] &\)\  /@ \ 
                    Unique[{w, w}]; 
t\  = \ 
                  Delete[s, \ 
                      k]\  //. \ {
z3\  -> \ 
                        EQ[w1, w2], \ z2\  -> \ EQ[w1[2], w2[1]], \ 
                      z1\  -> \ 
                        EQ[w1[1], \ w2[2]], 
EQ[z3[1], \ 
                          z3[2]]\  -> \ 
                        EQ[\(-1\), \ w1[2], w2[1], w1[1], 
                          w2[2]], 
EQ[z2[1], \ 
                          z2[2]]\  -> \ 
                        EQ[\(-1\), \ w1, w2, w1[1], 
                          w2[2]], 
EQ[z1[1], \ 
                          z1[2]]\  -> \ 
                        EQ[\(-1\), \ w1, w2, w1[2], 
                          w2[1]], 
EQ[z1[2], \ 
                          z2[1]]\  -> \ w1, \ 
                      EQ[z1[1], \ z2[2]]\  -> \ w2, \ 
                      EQ[z2[2], \ z3[1]]\  -> \ 
                        w1[1], 
EQ[z3[1], \ 
                          z1[2]]\  -> \ w2[1], \ 
                      EQ[z3[2], \ z1[1]]\  -> \ w1[2], \ 
                      EQ[z2[1], \ z3[2]]\  -> \ 
                        w2[2], 
EQ[m[z_, 0], m[z_, 1], 
                          m[z_, 2]]\  -> \ EQ[\(-1\)], \ 
                      EQ[\(-1\), \(-1\)]\  -> \ 
                        EQ[]
}; 
If[
                  FreeQ[t, \ 
                    z123 = First[z1] | First[z2] | 
                        First[z3]], 
Return[
                    t], 
$Log && 
                    Print[StringForm["Failed triangle; t=``; problems at ``", \ t, \ Select[t, \ \(! FreeQ[#, \ 
                                z123]\) &]]]
]
)\)]; 
Return[
            Failed]
)\);\)\)
\(\(ContractDomino[s_, \ k1_Integer, \ 
          k2_Integer]\  := \ \((
Print[
            StringForm["{k1, k2} = {``, ``}; s[[{k1,k2}]]={``,``}", \ k1, 
              k2, s[\([k1]\)], \ s[\([k2]\)]]]; 
Replace[
            s[\([{k1, k2}]\)], 
{EQ[_, \ _, \ m[W1_, p1_], 
                  m[W2_, p2_]], \ 
                EQ[m[W1_, pa_], 
                  m[W2_, pb_], \ _, \ _]}\  :> \ \((
$Log && 
                    Print[StringForm["Found domino at k1=``, k2=``", \ 
                        k1, \ k2]]; 
w1 = m[W1, p1]; \ 
                  w2 = m[W2, p2]; 
{z1, z2, 
                      z3} = \(m[#, 0] &\)\  /@ \ 
                      Unique[{z, z, z}]; 
t = 
                    Append[
s\  //. \ {
EQ[w1, w2]\  -> \ z3, \ 
                          EQ[w1[2], w2[1]]\  -> \ z2, \ 
                          EQ[w1[1], \ w2[2]]\  -> \ 
                            z1, 
w1\  -> \ 
                            EQ[z1[2], \ z2[1]], \ 
                          w2\  -> \ EQ[z1[1], \ z2[2]], \ 
                          w1[1]\  -> \ 
                            EQ[z2[2], \ z3[1]], 
w2[
                              1]\  -> \ EQ[z3[1], \ z1[2]], \ 
                          w1[2]\  -> \ EQ[z3[2], \ z1[1]], \ 
                          w2[2]\  -> \ 
                            EQ[z2[1], \ 
                              z3[2]]
}, 
EQ[z1, z2, z3]
]; 
t = 
                    RemoveTriangle[RemoveTriangle[t, \ k2], \ 
                      k1]; 
$Log && \ 
                    Print["t=", \ t]; 
Return[
                    t]
)\) /; \ {p1, \ p2}\  == \ 
                  Mod[{pa + 1, \ pb + 2}, \ 
                    3]
]; 
Return[
            Failed]
)\);\)\)
\(Red[rels_List]\  := \ 
      Module[
{s = rels, \ ks, \ k, \ t, \ at, \ at1, \ 
          at2, \ k1, \ k2}, 
Label[Start]; \ 
        s = RandomPermutation[DeleteCases[s, \ EQ[]]]; 
For[
          k = 1, \ k ≤ Length[s], \ \(++k\), \ 
          Replace[s[\([k]\)], \ 
            EQ[m[Z1_, p1_], 
                m[Z2_, p2_]]\  :> \ \((
$Log && 
                  Print[StringForm["Doing bigon: k=``; s[[k]]=``; s=``", \ k, s[\([k]\)], \ s]]; 
z1 = m[Z1, p1]; \ 
                z2 = m[Z2, p2]; 
t\  = \ 
                  s\  //. \ {EQ[z1, z2]\  -> \ EQ[], \ 
                      EQ[z1[1], \ z2[2]] -> EQ[], \ 
                      EQ[z1[2], \ z2[1]]\  -> 
                        EQ[]}; 
at = \(Position[
                        t, \ # // First] &\)\  /@ \ {z1, 
                      z2}; 
If[\((Length\  /@ \ 
                        at)\)\  === \ {0, 0}, \ s = t; \ 
                  Goto[Start]]; 
If[\((Length\  /@ \ 
                        at)\)\  =!= \ {1, 1}\ , 
$Log && 
                    Print[StringForm["Bad bigon: at=``; t=``", \ at, \ 
                        t]], 
at1 = at[\([1, 1, 1]\)]; \ 
                  at2 = at[\([2, 1, 1]\)]; 
s = 
                    If[at1 == at2, 
$Log && 
                        Print["Equal ats ", \ t[\([at1]\)]]; \ 
                      t\  /. \ \ EQ[z1, \ z2]\  -> \ 
                          EQ[], 
Append[
                        Delete[t, \ {{at1}, \ {at2}}], \ 
                        EQ[t[\([at1]\)], t[\([at2]\)]]\  /. \ 
                          EQ[z1, \ z2]\  -> \ 
                            EQ[]]
]; 
\ 
                  Goto[Start]
]
)\)]]; 
Do[
          If[Failed\  =!= \ \((t = RemoveTriangle[s, \ k])\), \ s = t; \ 
            Goto[Start]], \ {k, \ Length[s]}]; 
$Log && 
          Print["Contracting dominos; s=", 
            s]; 
Do[
If[{4, 
                  4} == \((Length\  /@ \ s[\([{k1, k2}]\)])\)\  && \ 
              Failed\  =!= \ \((t = ContractDomino[s, \ k1, \ k2])\), \ 
            s = t; \ Goto[Start]], 
{k2, \ 2, \ 
            Length[s]}, \ {k1, \ 
            k2 - 1}]; 
s
]\)

{s = Red[rels],  Length  /@  s,  Length[s]}

MatchQ[
{EQ[m[z11, 0], m[z23, 0], m[z33, 0], 
          m[z41, 0]], 
        EQ[m[z13, 2], m[z31, 1], m[z33, 1], 
          m[z41, 2]]},  
{EQ[m[Z1_, p1_], m[Z2_, p2_],  
          m[W1_, pa_], m[W2_, pb_]],  
        EQ[m[W1_, pc_], m[W2_, pd_],  m[Z3_, p3_], 
          m[Z4_, p4_]]}
]

Length  /@  s

RandomPermutation[
      Flatten@Table[
          T[k, i, j],  {k,  Length[s]},  {i,  2,  
            Length[s[[k]]]},  {j,  i}]]

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

vars  =  
      Complement[
        Union[Cases[eqns,  _Symbol,  Infinity]],  {zl}]

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

sols  =  
      vars  /.  Solve[eqns  /.  zl  ->  1,  vars]

N[sols]

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

Mod[Range[10, 20][[{2, 3}]],  7]