(*******************************************************************
This file was generated automatically by the Mathematica front end.
It contains Initialization cells from a Notebook file, which
typically will have the same name as this file except ending in
".nb" instead of ".m".

This file is intended to be loaded into the Mathematica kernel using
the package loading commands Get or Needs.  Doing so is equivalent
to using the Evaluate Initialization Cells menu command in the front
end.

DO NOT EDIT THIS FILE.  This entire file is regenerated
automatically each time the parent Notebook file is saved in the
Mathematica front end.  Any changes you make to this file will be
overwritten.
***********************************************************************)







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])&
                  ]] /. 2h[_] \[Rule] 0
          ]
        ]
      ];

Options[ArcPresentation] = {Reduce \[Rule] 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_] \[RuleDelayed] (
                  k = Min[m,n];
                  ActiveVerts = Insert[ActiveVerts, ++vc, k];
                  ActiveVerts = Insert[ActiveVerts, ++vc, k+1];
                  If[k\[Equal]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_] \[RuleDelayed]  (
                  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_] \[RuleDelayed]  (
                  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_] \[RuleDelayed] (
                  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\[NotEqual]c && 
                      Slidable[a,b,{m}]) \[RuleDelayed] (
                  ++redsdone; AppendTo[UnneededVerts, b];
                  AP[l, m, {a,c}, r]
                  ),
              
              AP[l___, {b_, a_}, m___, {c_,b_}, 
                    r___] /; (a\[NotEqual]c && 
                      Slidable[a,b,{m}]) \[RuleDelayed] (
                  ++redsdone; AppendTo[UnneededVerts, b];
                  AP[l, m, {c, a}, r]
                  ),
              
              AP[l___, {b_, c_}, m___, {a_,b_}, 
                    r___] /; (a\[NotEqual]c && 
                      Slidable[a,b,{m}]) \[RuleDelayed] (
                  ++redsdone; AppendTo[UnneededVerts, b];
                  AP[l,  {a,c}, m, r]
                  ),
              
              AP[l___, {c_, b_}, m___, {b_,a_}, 
                    r___] /; (a\[NotEqual]c && 
                      Slidable[a,b,{m}]) \[RuleDelayed] (
                  ++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 \[Rule] 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[];































































