Definitions

<<  KnotTheory`

BeginPackage["KnotTheory`"];

ArcPresentation;  Draw;  MorseLink;  Cup;  Cap;  X;  Over;  
    Under;  Reduce;  PD;  OverlayMatrix;  Up;  
    Down;

ArcPresentation::usage  =  "ArcPresentation[{a1,b1}, {a2, b2}, \
..., {an,bn}] is an arc presentation of a knot (as often used in the realm of \
Heegaard-Floer homologies), where the horizontal arc at row i connects column \
ai to column bi. ArcPresentation[K] returns an arc presentation of the knot \
K. ArcPresentation[K, Reduce -> r] attemps at most r reduction steps (using a \
naive reduction algorithm) following a naive creation of some arc \
presentation for K.";

Draw::usage  =  "Draw[ap] draws the Arc Presentation ap. Draw[ap, \
OverlayMatrix -> M] overlays the matrix M on top of that draw.";

Begin["`ArcPresentation`"];

InterlacedQ[{a_, b_},  {c_, 
            d_}]  :=  (Signature[{a, b}] Signature[{c, d}] 
              Signature[{a, b, c, 
                  d}] === -1);
Slidable[a_, b_, m_List]  :=  
        Module[
{h}, 
Or[
! (Or  @@  (InterlacedQ[{a, b},  #] &  /@  
                      m)), 
SameQ[
              0, 
Total[
                  h  /@  Select[
Sort[
                        Flatten[
                          m]], 
(Min[a, b] < # < 
                            Max[a, b]) &
]]  /.  
                2  h[_]  ->  
                  0
]
]
];

Options[
          ArcPresentation]  =  {Reduce  ->  
            Infinity};
ArcPresentation[ml_MorseLink,  opts___Rule]  :=  
        Module[
{
ActiveVerts,  
            VertOrdering,  vc, out, m, n, k, p, b, c, br, bl, r,  l,  
            UnneededVerts,  AP,  redsdone,  
            oldreds,  
red  =  Reduce  /.  {opts}  /.  Options[
                  ArcPresentation]
}, 
ActiveVerts = {};  VertOrdering = {};  
          vc = 0; 
out  =  (List  @@  
                    ml)  /.  {
Cup[m_, 
                      n_]  :>  (
k  =  
                        Min[m, n]; 
ActiveVerts  =  
                        Insert[ActiveVerts,  ++vc,  
                          k]; 
ActiveVerts  =  
                        Insert[ActiveVerts,  ++vc,  
                          k + 1]; 
If[
                        k == 
                          1, 
VertOrdering = {vc - 1,  vc}~
                            Join~VertOrdering, 
{{p}}  =  
                          Position[VertOrdering,  
                            ActiveVerts[[k - 
                                  1]]]; 
VertOrdering  =  Insert[VertOrdering,  vc - 1,  
                            p + 1]; 
VertOrdering  =  
                          Insert[VertOrdering,   vc,  
                            p + 2];
]; 
{m, n} - k + vc - 
                        1 
), 
X[n_,  
                      Under,  b_,  
                      c_]  :>   (
bl = 
                        ActiveVerts[[n]]; 
ActiveVerts  =  Insert[Delete[ActiveVerts,   n],  ++vc,  
                          n + 1]; 
{{p}}  =  
                        Position[VertOrdering,  
                          ActiveVerts[[n]]]; 
VertOrdering  =  
                        Insert[VertOrdering,   vc,  
                          p + 1]; 
If[
                        b === Up,  {bl,  vc},  {vc, 
                          bl}]
), 
X[
                      n_,  Over,  b_,  
                      c_]  :>   (
br = 
                        ActiveVerts[[n + 
                              1]]; 
ActiveVerts  =  
                        Insert[Delete[ActiveVerts,   n + 1],  ++vc,  
                          n]; 
{{p}}  =  
                        Position[VertOrdering,  
                          ActiveVerts[[n + 
                                1]]]; 
VertOrdering  =  
                        Insert[VertOrdering,   vc,  
                          p]; 
If[
                        c === Up,  {br,  vc},  {vc, 
                          br}]
), 
Cap[
                      m_,  n_]  :>  (
r = {ActiveVerts[[m]],  
                          ActiveVerts[[n]]}; 
ActiveVerts  =  
                        Delete[
                          ActiveVerts,  {{m},  {n}}]; 
r
)
}  /.  
              Thread[Rule[VertOrdering,  
                  Range[Length[
                      VertOrdering]]]]; 
redsdone = 0;  
          oldreds = -1;  
          UnneededVerts = {}; 
While[
            redsdone  <  red  &&  
              redsdone  >  oldreds, 
oldreds = 
              redsdone; 
out  =  (AP  @@  
                    out)  /.  {
AP[
                        l___,  {a_,  b_},  m___,  {b_, c_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
AP[
                        l,  m,  {a, c},  
                        r]
), 
AP[
                        l___,  {b_,  a_},  m___,  {c_, b_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
AP[
                        l,  m,  {c,  a},  
                        r]
), 
AP[
                        l___,  {b_,  c_},  m___,  {a_, b_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
AP[
                        l,   {a, c},  m,  
                        r]
), 
AP[
                        l___,  {c_,  b_},  m___,  {b_, a_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
AP[
                        l,   {c,  a},  m,  
                        r]
)
}
]; 
out  =  
            out  /.  Thread[
                Rule[Delete[Range[vc],  List  /@  UnneededVerts],  
                  Range[vc - 
                      Length[UnneededVerts]]]]; 
ArcPresentation  @@  
            out
];
ArcPresentation[K_,  opts___Rule]  :=  
        ArcPresentation[MorseLink[K],  opts];

Options[
          Draw]  =  {OverlayMatrix  ->  
            Null};
Draw[ap_ArcPresentation,  opts___Rule]   :=  
      Module[
{
l, p1, p2, k,  
          V, 
om  =  OverlayMatrix  /.  {opts}  /.  Options[Draw]
}, 
l  =  
          Length[ap]; 
Graphics[
          Flatten[{
{Thickness[1/10/
                    Length[ap]]}, 
Table[
Line[{{ap[[k,  1]],  
                      k},  {ap[[k, 2]],  k}}], 
{k, 
                  l}
], 
{Thickness[
                  0.45/Length[ap]],  
                GrayLevel[
                  1]}, 
Table[
{{p1}}  =  Position[First  /@  ap,  k]; 
{{p2}}  =  
                  Position[Last  /@  ap,  k]; 
{p1,  
                    p2}  =  
                  Sort[{p1, p2}]; 
Line[{{k,  
                      p1 + 0.5},  {k,  
                      p2 - 0.5}}], 
{k,  
                  l}
], 
{Thickness[1/
                      10/Length[ap]],  
                GrayLevel[
                  0]}, 
Table[
{{p1}}  =  Position[First  /@  ap,  k]; 
{{p2}}  =  
                  Position[Last  /@  ap,  
                    k]; 
Line[{{k,  p1},  {k,  
                      p2}}], 
{k,  
                  l}
], 
If[
                om === Null,  {}, 
MapIndexed[
Text[#1,  0.5 + #2] &, 
Transpose[
                    om],  {2}
]
]
}]]
]

SwapAt[l_List,  j_Integer]  :=  
        Join[
Take[l,  j - 1],  l[[{j + 1,  j}]],  
          Drop[l,  j + 1]
];
ArcPresentation  /:  MorseLink[ap_ArcPresentation]  :=  
        Module[
{
ml = {},   (* 
              
              holds the MorseLink under construction *) 
strands = {},   (* 
              the ArcPresentation numbering of the active strands *) 
dirs  =  {},   (* 
              the orientations of the active strands *) 
k,  cur,  fr,  to,  type,  frind,  toind,  
            start,  end,  
            j
}, 
AddXings[start_,  
              end_]  :=  
            If[end > 
                start, 
Do[
AppendTo[
                  ml,  X[j,  Under,  dirs[[j]],  
                    dirs[[j + 1]]]]; 
strands = 
                  SwapAt[strands,  j]; 
dirs  =  
                  SwapAt[dirs,  j], 
{j,  start,  
                  end - 1}
], 
Do[
AppendTo[ml,  
                  X[j - 1,  Over,  dirs[[j - 1]],  
                    dirs[[j]]]]; 
strands = 
                  SwapAt[strands,  j - 1]; 
dirs  =  
                  SwapAt[dirs,  j - 1], 
{j,  start,  
                  end + 1,  -1}
]
]; 
Do[
{
{fr,  
                  to}  =  cur  =  
                  ap[[k]], 
{frind,  
                  toind}  =  (1 + 
                        Count[strands,  i_  /;  i < #]) &  /@  
                  cur, 
type  =  {MemberQ[
                        strands,  #] &  /@  cur,  
                  Sign[to - 
                      fr]}
}; 
Switch[
              type, 
{{False,  
                  False},  +1},  (
AppendTo[ml,  
                  Cup[frind,  frind + 1]]; 
strands  =  
                  Flatten[
                    Insert[strands,  {fr,  to},  
                      frind]]; 
dirs  =  
                  Flatten[
                    Insert[dirs,  {Down,  Up},  
                      frind]]; 
AddXings[frind + 1,  
                  toind + 
                    1]
), 
{{False,  
                  True},  +1},  (
strands[[toind]]  =  fr; 
AddXings[toind,  
                  frind]
), 
{{True,  
                  
                  False},  +1},  (
strands[[frind]] = to; 
AddXings[
                  frind,  
                  toind - 
                    1]
), 
{{True,  
                  True},  +1},  (
AddXings[frind,  
                  toind - 1]; 
AppendTo[ml,  
                  Cap[toind - 1,  toind]]; 
strands  =  
                  Delete[strands,  {{toind - 
                          1},  {toind}}]; 
dirs  =  
                  Delete[dirs,  {{toind - 
                          1},  {toind}}]
), 
{{False,  
                  False},  -1},  (
AppendTo[ml,  
                  Cup[frind + 1,  frind]]; 
strands  =  
                  Flatten[
                    Insert[strands,  {to,  fr},  
                      frind]]; 
dirs  =  
                  Flatten[
                    Insert[dirs,  {Up,  Down},  
                      frind]]; 
AddXings[frind,  
                  toind]
), 
{{False,  
                  True},  -1},  (
strands[[toind]] = fr; 
AddXings[toind,  
                  frind - 
                    1]
), 
{{True,  
                  False},  -1}, (
strands[[frind]] = to; 
AddXings[
                  frind,  
                  toind]
), 
{{True,  
                  True},  -1},  (
AddXings[frind,  
                  toind + 1]; 
AppendTo[ml,  
                  Cap[toind + 1,  toind]]; 
strands  =  
                  Delete[strands,  {{toind + 
                          1},  {toind}}]; 
dirs  =  
                  Delete[dirs,  {{toind + 
                          1},  {toind}}]
)
], 
{k, 
              Length[ap]}
]; 
MorseLink  @@  ml
];
PD[ap_ArcPresentation]  :=  (ml = MorseLink[ap];  
          PD[ml]);

End[];  EndPackage[];

Presentation

?ArcPresentation

ap = ArcPresentation["K11n11"]

Draw[ap]

ap0 = ArcPresentation["K11n11",  Reduce  ->  0]

Draw[ap0]

br=BR[ap]

BraidPlot[br]

Reflect[ap_ArcPresentation]  :=  
      ArcPresentation  @@  (
(Last  /@  
                  Sort[Reverse  /@  Position[ap,  #]]) &  /@  
            Range[Length[ap]]
)

Reflect[ap]  //  Draw

MinesweeperMatrix[ap_ArcPresentation]  :=  
      Module[
{l,  CurrentRow,  c1, c2, k, 
          s}, 
l = 
          Length[ap]; 
CurrentRow  =  
          Table[0,  {l}]; 
Table[
{c1,  
              c2}  =  Sort[ap[[k]]]; 
s = 
            Sign[{-1, 1} . 
                ap[[k]]]; 
Do[
CurrentRow[[c]] += s, 
{c,  
              c1,  c2 - 
                1}
]; 
CurrentRow, 
{k, 
            l}
]
];

?Draw

Draw[ap,  OverlayMatrix  -> MinesweeperMatrix[ap]]

{Det[t^MinesweeperMatrix[ap]],  Alexander[ap][t]}  //  
      Factor

Further Testing

Test[
        K_]  :=  (K  ->  Jones[K][
              q]  ==  Jones[ArcPresentation[K]][q])

test =  Test  /@  AllKnots[10]

Total[Last  /@  test]