Dror Bar-Natan: Odds, Ends, Unfinished:

The Manolescu-Ozsvath-Sarkar Complex

This Mathematica notebook contains and lightly documents a program I wrote in the summer of 2006. The program sets up the Manolescu-Ozsvath-Sarkar (MOS) complex and computes its homology, the "Knot Floer Homology". The comploex itself is described in detail in the article arXiv:math.GT/0607691 by Manolescu, Ozsvath and Sarkar.

The program is, as expected, a failure. The complexity of the MOS complex grows like n!, so only the Knot Floer homology of rather small knots can be computed. But thanks to the work of many other authors, the Knot Floer homology is known for all knots with up to 10 crossings and many bigger ones as well. So no new computations are available here. Yet the program is not pointless: I learned by writing it, you may learn by reading and using it, and parts of it are recyclable.

For a little while I plan to maintain, upgrade and update this notebook. Let T3 be the time now, let T2 be the time you downloaded this file and let T1 be the time defined below, in the first line of code. If (T3-T2)>(T2-T1), you should download a new copy from http: // www . math . toronto . 
                      edu/~drorbn/Misc/MOSComplex/
              MOSComplex . nb (or web-search for the current location).

T1 = Date[]

T0, the time stamp on the first version of this document, was {2006,8,1,20,41,33.442125}

Startup

To start, download the package KnotTheory` from The Knot Atlas site, save it on your system, change the path information as suits your system, and start executing this notebook.

\(\(AppendTo[$Path, \ "C:/drorbn/projects/KnotTheory/svn/trunk"];\)\)
<<  KnotTheory`

Producing Planar Grid Diagrams

First some definitions:

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[
          PlanarGridDiagram]  =  {Reduce  ->  
            Infinity};
PlanarGridDiagram[ml_MorseLink,  opts___Rule]  :=  
        Module[
{
ActiveVerts,  
            VertOrdering,  vc, out, m, n, k, p, b, c, br, bl, r,  l,  
            UnneededVerts,  PGD,  redsdone,  
            oldreds,  
red  =  Reduce  /.  {opts}  /.  Options[
                  PlanarGridDiagram]
}, 
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  =  (PGD  @@  
                    out)  /.  {
PGD[
                        l___,  {a_,  b_},  m___,  {b_, c_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
PGD[
                        l,  m,  {a, c},  
                        r]
), 
PGD[
                        l___,  {b_,  a_},  m___,  {c_, b_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
PGD[
                        l,  m,  {c,  a},  
                        r]
), 
PGD[
                        l___,  {b_,  c_},  m___,  {a_, b_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
PGD[
                        l,   {a, c},  m,  
                        r]
), 
PGD[
                        l___,  {c_,  b_},  m___,  {b_, a_},  
                        r___]  /;  (a ≠ c  &&  
                          Slidable[a, 
                            b, {m}])  :>  (
++redsdone;  
                      AppendTo[UnneededVerts,  b]; 
PGD[
                        l,   {c,  a},  m,  
                        r]
)
}
]; 
out  =  
            out  /.  Thread[
                Rule[Delete[Range[vc],  List  /@  UnneededVerts],  
                  Range[vc - 
                      Length[UnneededVerts]]]]; 
PlanarGridDiagram  @@  
            out
];
PlanarGridDiagram[K_,  opts___Rule]  :=  
        PlanarGridDiagram[MorseLink[K],  opts];

Let's compute the planar grid diagram of the trefoil knot:

PlanarGridDiagram[Knot[3, 1]]

Each pair above describes one horizontal line in the planar grid diagram, with the first element being the position of the white dot on that line and the second element the position of the black dot.

Drawing Planar Grid Diagrams

Definitions and then examples, no need for words.

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

Show[Draw[PlanarGridDiagram[Knot[3,  1]]]]

The converter program PlanarGridDiagram applies some simplification rules to the result it gets. It is amusing to watch that happen:

MillettUnknot = 
        PD[X[1, 10, 2, 11], X[9, 2, 10, 3], X[3, 7, 4, 6], X[15, 5, 16, 4], 
          X[5, 17, 6, 16], X[7, 14, 8, 15], X[8, 18, 9, 17], 
          X[11, 18, 12, 19], X[19, 12, 20, 13], 
          X[13, 20, 14, 1]];
Show[
      GraphicsArray[
        Partition[
Table[
Draw[
              PlanarGridDiagram[MillettUnknot,  
                Reduce  ->  k]], 
{k,  0,  
              17}
], 
3
]]]

The Minesweeper Matrix

The minesweeper matrix of a planar grid diagram is the matrix of winding numbers associated with it. The brilliant terminology is due to Ken Shan.

MinesweeperMatrix[pgd_PlanarGridDiagram]  :=  
        Module[
{l,  CurrentRow,  c1, c2, k, 
            s}, 
l = 
            Length[pgd]; 
CurrentRow  =  
            Table[0,  {l}]; 
Table[
{c1,  c2}  =  Sort[pgd[[k]]]; 
s = 
              Sign[{-1, 1} . 
                  pgd[[k]]]; 
Do[
CurrentRow[[c]] += 
                s, 
{c,  c1,  
                c2 - 1}
]; 
CurrentRow, 
{k, 
              l}
]
];
MinesweeperMatrix[K_]  :=  
        MinesweeperMatrix[PlanarGridDiagram[K]];

(t^MinesweeperMatrix[Knot[3, 1]])  //  Reverse  //  
      MatrixForm

Factor[Det[t^MinesweeperMatrix[Knot[10,  10]]]]

Alexander[Knot[10,  10]][t]

SetOptions[Draw,  
        OverlayMatrix  ->  
          MinesweeperMatrix];
Show[
      GraphicsArray[{
Draw[
            PlanarGridDiagram[Knot["K11n34"]]], 
Draw[
            PlanarGridDiagram[
              Knot["K11n42"]]]
}]]

Invariance Examples for the Alexander Polynomial

MOSAlexander[K_]  :=  Factor[Det[t^MinesweeperMatrix[K]]]

pgd  =  
      PlanarGridDiagram[K =  Knot["K11n11"]]
Draw[pgd]  //  Show;
{MOSAlexander[pgd],  Alexander[K][t]}

Cycling

pgd1 = RotateLeft[pgd]
Draw[pgd1]  //  Show;
MOSAlexander[pgd1]

Stabilization

pgd2 =  
      pgd  /.  {{10,  3}  ->  Sequence[{11,  7},  {7,  3}],  
          j_  /;  j ≥ 7  :>  
            j + 1}
Draw[pgd2]  //  Show;
MOSAlexander[pgd2]

Commutation

pgd3 =  
      pgd  /. {{9, 12}  ->  {4, 8},  {4, 8}  -> {9, 
              12}}
Draw[pgd3]  //  Show;
MOSAlexander[pgd3]

The MOS complex - States and Degrees

K = TorusKnot[4,  3];

Note that from here on the knot K must be fixed. Every time you change it, you must re-execute all the definitions below.

Show[Draw[PlanarGridDiagram[K]]]

Clear[
pgd,  n,  MM,  a,  PP,  WW,  
        AlexanderDegreeShift,  AlexanderDegree,  x0,  MaslovDegree,  
        Boundary,  AllStates,  BoundaryMatrix,  Rank,  Betti,  
        MOSHomology
];
pgd  =  PlanarGridDiagram[K]

n = Length[MM  =  MinesweeperMatrix[pgd]]

a[p1_,  
          p2_]  :=  a[p1,  
            p2]  =  -MM[[p1  /.  0  ->  n,  
                p2  /.  0  ->  
                    n]];
AlexanderDegreeShift  =  (1 - n)/2  -  
        1/8*Sum[
a[k,  pgd[[k,  1]]]  +  
              a[k,  pgd[[k,  1]] - 1]  +  
              a[k - 1,  pgd[[k,  1]]]  +  
              a[k - 1,  pgd[[k,  1]] - 1]
 +  
              a[k,  pgd[[k,  2]]]  +  
              a[k,  pgd[[k,  2]] - 1]  +  
              a[k - 1,  pgd[[k,  2]]]  +  
              a[k - 1,  pgd[[k,  2]] - 1], 
{k, 
              n}
]

AlexanderDegree[x_State]  :=  AlexanderDegree[x]  =  
          AlexanderDegreeShift  +  
            Sum[
a[k,  
                x[[k]]], 
{k,  
                n}
];

AlexanderDegree[State[7, 6, 5, 4, 3, 2, 1]]

x0 = 
      State  @@  RotateLeft[-1 + 
              First  /@  List  @@  pgd]  /.  
        0  ->  n

MaslovDegree[x0]  =  1 - n;
WW[{{i1_,  i2_},  {j1_,  
              j2_}}]  :=  WW[{{i1, i2},  {j1, j2}}]  =  
          Length[Select[
First  /@  (List  @@  
                      pgd)[[Range[i1 + 1,  
                      i2]]], 
(j1 < # ≤ 
                    j2) &
]];
PP[s_State,  {{i1_,  i2_},  {j1_,  j2_}}]  :=  
        Module[
{k, 
            l}, 
Sum[
l = 
              s[[k]]; 
If[i1 < k < i2,  1,  1/2]*
              Which[
j1 < l < j2,  
                1, 
j1 == l  ||  j2 == l,  
                1/2, 
True,  
                0
], 
{k, i1, 
              i2}
]
];
MaslovDegree[x_State]  :=  MaslovDegree[x]   =  
          Module[
{i1,  i2,  j1,  j2,  y,  r,  
              s}, 
i1  =  1;  
            While[x[[i1]]  ==  
                x0[[i1]],  ++i1]; 
j1  =  
              x[[i1]];  
            j2  =  x0[[i1]]; 
{{i2}}  =  
              Position[x,  
                j2]; 
r  =  {Sort[{i1, i2}],  
                Sort[{j1, j2}]}; 
s  =  
              Sign[i2 - i1]*Sign[j2 - j1]; 
y = x;  
            y[[i1]] = j2;  
            y[[i2]] = j1; 
MaslovDegree[y]  +  
              s (PP[x,  r]  +  PP[y,  r]  -  
                    2  WW[r])
];

MaslovDegree[State[7, 6, 5, 4, 1, 2, 3]]

AllStates[]  =  (State  @@  #) &  /@  
          Permutations[Range[n]];
AllStates[m_,  a_]  :=  
        Select[AllStates[],  (MaslovDegree[#] == m  &&  
                AlexanderDegree[#] == a) &];

Here are all states with Maslov Degree-5 and Alexander degree 0:

AllStates[-5,  0]

The MOS complex - The Differential

Boundary[x_State]  :=  Boundary[x]  =  
          Module[
{i1, i2,  j1,  j2,  i,  cyci,  
              cycj}, 
Sum[
j1  =  
                x[[i1]];  
              j2  =  x[[i2]]; 
y = x;  
              y[[i1]] = j2;  
              y[[i2]] = 
                j1; 
Sum[
i = 
                  1; 
While[
1 ≤ i ≤ 
                    n, 
cyci  =  ((s == 
                            Signature[{i1,  #,  
                                i2}]) &); 
cycj  =  ((s == Signature[{j1,  #,  
                                j2}]) &); 
If[
Or[
cyci[i]  &&  
                        cycj[x[[i]]], 
cyci[
                          i - 1/2]   &&  (cycj[
                              pgd[[i, 1]] - 1/2]  ||  
                            cycj[pgd[[i, 2]] - 
                                1/2])
], 
i = 
                      0,  ++i
]
]; 
If[i > n,  y,  0], 
{s,  -1,  
                  1,  2}
], 
{i1,  1,  
                n - 1}, 
{i2,  i1 + 1,  
                n}
]
];
Boundary[expr_]  :=  
        expr  /.  x_State  :>  Boundary[x];

bndry  =  Boundary[State[7, 6, 5, 4, 1, 2, 3]]

Boundary[bndry]

BoundaryMatrix[m_,  a_]  :=  
        Outer[
(Boundary[#2]  /.  #1  ->  
                    1  /.  _State  ->  
                  0) &, 
AllStates[m - 1,  a],  
          AllStates[m,  a]
];

BoundaryMatrix[-5,  0]  //  MatrixForm

Homological computations

Rank[m_,  a_] :=  Rank[m, a]  =  
          If[
 
            AllStates[m,  a] === {}  ||  
              AllStates[m - 1,  
                  a] === {} , 
0, 
MatrixRank[BoundaryMatrix[m,  a],  
              Modulus  ->  
                2]
];
Betti[m_,  a_]  :=  
        Length[AllStates[m, a]] - Rank[m, a] - 
          Rank[m + 1,  a];
MOSHomology[]  :=  
        Outer[
Betti, 
Union[
            MaslovDegree  /@  AllStates[]], 
Union[
            AlexanderDegree  /@  
              AllStates[]]
];
HFK[]  :=  
        Expand[Factor[
Total[
                Flatten[
                  Outer[
(m^#1 t^#2 Betti[#1,  #2]) &, 
Union[
                      MaslovDegree  /@  
                        AllStates[]], 
Union[
                      AlexanderDegree  /@  
                        AllStates[]]
]]] / (1 + 
                    1/(t m))^(n - 
                    1)
]];

Rank[-5,  0]

Betti[-5,  0]

Timing[MOSHomology[]  //  MatrixForm]

HFK[]