CableLink.m

(* The program CableLink is documented on the page Threading a link by a polynomial. It is not part of the package KnotTheory` but is designed to work with it. Copy-paste the text below ignoring the *) on the first line and the (* on the last.

*)

(*Kauffman bracket*)
KB1[pd_PD] := KB1[pd, {}, 1];
KB1[pd_PD, inside_, web_] := 
  Module[{pos = 
     First[Ordering[Length[Complement[List @@ #, inside]] & /@ pd]]}, 
   pd[[pos]] /.  
    X[a_, b_, c_, d_] :> 
     KB1[Delete[pd, pos], Union[inside, {a, b, c, d}], 
      Expand[web*(A P[a, d] P[b, c] + 1/A P[a, b] P[c, d])] //. {P[e_,
            f_] P[f_, g_] :> P[e, g], P[e_, _]^2 :> P[e, e], 
        P[e_, e_] -> -A^2 - 1/A^2}]];
KB1[PD[], _, web_] := Expand[web]
(*Position of a strand at a crossing*)
strandAtCrossing[crossing_, s_] := Module[{pos},
   pos = Position[crossing, s];
   If[Length[pos] > 0, pos[[1, 1]], False]
   ];
(*Orientation of overstrand. Complicated by components with only two strand labels*)
orientationOfOverStrand[crossing_, link_] := Module[{otherCrossings},
   (*find the other crossings containing the strand labels of the \
overstrand crossing*)
   otherCrossings = 
    DeleteElements[
     Select[link, 
      ContainsAny[
        List[Delete[#, 0]], {crossing[[2]], 
         crossing[[4]]}] &], {crossing}];
   (*if the length of othercrossings is 1, 
   then the overstrand labels are part of a component with only two \
strand labels*)
   If[Length[otherCrossings] == 1,
    (*first check if a strand label is in the first position of the \
other crossing.*)
    Which[otherCrossings[[1, 1]] == crossing[[2]],
     True,
     otherCrossings[[1, 1]] == crossing[[4]],
     False,
     (*Otherwise, the strands are always overcrossings, 
     in which case we just choose to orient from small to large*)
     True,
     crossing[[2]] > crossing[[4]]
     ],
    (*otherwise, 
    the overcrossing is oriented from 4 to 2 if pos 2 is 1 more than \
pos 4, or if pos 4 is more than 1 greater than pos 2.*)
     crossing[[2]] - crossing[[4]] == 1 || 
     crossing[[4]] - crossing[[2]] > 1
    ]
   ];
(*crossing that a strand enters*)
findEnteringVertex[link_, s_] := 
  Module[{crossingsContainingS, firstCrossing, pos},
   (*find crossings containing s*)
   crossingsContainingS = 
    Select[link, IntegerQ[strandAtCrossing[#, s]] &];
   firstCrossing = crossingsContainingS[[1]];
   pos = strandAtCrossing[firstCrossing, s];
   Which[
    (*if pos is 1, then it is definitely an incoming strand*)
    pos == 1,
    firstCrossing,
    (pos == 2 && ! 
        orientationOfOverStrand[firstCrossing, link]) || (pos == 4 && 
       orientationOfOverStrand[firstCrossing, link]),
    firstCrossing,
    (*otherwise it must be the entering strand at the other vertex \
containing that label*)
    True,
    crossingsContainingS[[2]]
    ]
   ];
duplicateVertex[link_, crossing_, strands_] := 
  Module[{pos = strandAtCrossing[crossing, strands[[1]]], 
    newLabel = Length[link]*2 + 2, 
    newLink = DeleteElements[link, {crossing}], p1 = crossing[[1]], 
    p2 = crossing[[2]], p3 = crossing[[3]], p4 = crossing[[4]]},
   Which[
    (*pos is 1 and the upper strand is oriented from 4 to 2*)
    pos == 1  && orientationOfOverStrand[crossing, link],
    {Union[
      increaseStrandLabels[newLink, p4],
      PD[
       X[If[p1 < p2, p1, p1 + 1], p4 + 1, If[p3 < p2, p3, p3 + 1], 
        p4]],
      PD[X[newLabel, If[p2 > p4, p2 + 1, p2], newLabel + 1, p4 + 1]]
      ],
     Map[If[# <= p2, #, # + 1] &, Prepend[strands[[2 ;;]], p3]]
     },
    (*pos is 1 and the upper strand is oriented from 2 to 4*)
    pos == 1,
    {Union[
      increaseStrandLabels[newLink, p2],
      PD[
       X[If[p1 < p2, p1, p1 + 1], p2 + 1, If[p3 < p2, p3, p3 + 1], 
        If[p4 < p2, p4, p4 + 1]]],
      PD[X[newLabel, p2, newLabel + 1, p2 + 1]]
      ],
     Map[If[# <= p2, #, # + 1] &, Prepend[strands[[2 ;;]], p3]]
     },
    (*pos is 2*)
    pos == 2,
    {Union[
      increaseStrandLabels[newLink, p1],
      PD[
       X[p1, If[p2 < p1, p2, p2 + 1], p1 + 1, 
        If[p4 < p1, p4, p4 + 1]]],
      PD[X[p1 + 1, newLabel, If[p3 < p1, p3, p3 + 1], newLabel + 1]]
      ],
     Map[If[# <= p1, #, # + 1] &, Prepend[strands[[2 ;;]], p4]]
     },
    (*pos is 4*)
    True,
    {Union[
      increaseStrandLabels[newLink, p1],
      PD[
       X[p1 + 1, If[p2 < p1, p2, p2 + 1], If[p3 < p1, p3, p3 + 1], 
        If[p4 < p1, p4, p4 + 1]]],
      PD[X[p1, newLabel + 1, p1 + 1, newLabel]]
      ],
     Map[If[# <= p1, #, # + 1] &, Prepend[strands[[2 ;;]], p2]]
     }
    ]
   ];
deleteVertex[link_, crossing_, s_, strandList_] := 
 Module[{newCrossing = crossing, 
   newLink = DeleteElements[link, {crossing}], min, max, 
   pos = strandAtCrossing[crossing, s], outgoingStrandPos, 
   newStrandList = strandList},
  (*we create an unknot if the two labels of the other strand at the \
crossing are equal*)
  Which[(pos == 1 && crossing[[2]] == crossing[[4]]) , 
   newStrandList = 
    Replace[newStrandList, 
     crossing[[2]] -> 0, {1}], (pos == 2 || pos == 4 ) && 
    crossing[[1]] == crossing[[3]], 
   newStrandList = Replace[newStrandList, crossing[[1]] -> 0, {1}]];
  (*"
	we need to keep track of the outgoing strand label. There's actually \
two ways to know we're done:
	either the outgoing strand is the same as the incoming strand, or \
the whole vertex only involves 2 different labels.
"*)
  outgoingStrandPos = Which[pos == 1, 3, pos == 2, 4, True, 2];
  If[crossing[[outgoingStrandPos]] == s || 
    CountDistinct[{Delete[crossing, 0]}] < 3, 
   outgoingStrandPos = -1];
  (*adjust link after combining pos 1 and pos 3*)
  If[crossing[[1]] > crossing[[3]],
   newLink = 
    decreaseStrandLabels[
     Replace[newLink, crossing[[1]] -> crossing[[3]], {2}], 
     newCrossing[[1]]];
   newCrossing = 
    decreaseStrandLabels[{Replace[newCrossing, 
        crossing[[1]] -> crossing[[3]], {1}]}, newCrossing[[1]]][[
     1]];
   newStrandList = 
    Map[If[# > newCrossing[[1]], # - 1, #] &, 
     Replace[newStrandList, crossing[[1]] -> crossing[[3]], {1}]]
   ,
   newLink = decreaseStrandLabels[newLink, newCrossing[[1]]];
   newCrossing = 
    decreaseStrandLabels[{newCrossing}, newCrossing[[1]]][[1]];
   newStrandList = 
    Map[If[# > newCrossing[[1]], # - 1, #] &, newStrandList]
   ];
  (*adjust link after combining pos 2 and pos 4*)
  min = Min[newCrossing[[2]], newCrossing[[4]]];
  max = Max[newCrossing[[2]], newCrossing[[4]]];
  If[max - min > 1,
   newLink = 
    decreaseStrandLabels[Replace[newLink, max -> min, {2}], max];
   newCrossing = 
    decreaseStrandLabels[{Replace[newCrossing, max -> min, {1}]}, 
      max][[1]];
   newStrandList = 
    Map[If[# > max, # - 1, #] &, 
     Replace[newStrandList, max -> min, {1}]],
   newLink = decreaseStrandLabels[newLink, min];
   newCrossing = decreaseStrandLabels[{newCrossing}, min][[1]];
   newStrandList = Map[If[# > max, # - 1, #] &, newStrandList]
   ];
  {newLink, 
   If[outgoingStrandPos > 0, newCrossing[[outgoingStrandPos]], -1], 
   newStrandList}
  ]
increaseStrandLabels[link_, s_] := 
  Replace[link, n_?(# > s &) -> n + 1, {2}];
decreaseStrandLabels[link_, s_] := 
  Replace[link, n_?(# > s &) -> n - 1, {2}];
cableComponent[link_, s_, strandList_] := 
  Module[{initialStrands, newComponentLabel = 2 Length[link] + 1},
   initialStrands = Join[{s, s, newComponentLabel}, strandList];
   recurse[newLink_, strands_] := 
    Module[{currentStrand = strands[[1]], firstStrand = strands[[2]], 
      currentCrossing, updatedLink, 
      updatedStrands},(*copy the current crossing*)
     currentCrossing = findEnteringVertex[newLink, currentStrand];
     {updatedLink, updatedStrands} = 
      duplicateVertex[newLink, currentCrossing, strands];
     (*check if we've returned to the first strand*)
     If[updatedStrands[[1]] == updatedStrands[[2]],
      (*replace the largest strand label with the first strand label \
of the new component*)
      {Replace[updatedLink, 
        n_?(# == 2 Length[updatedLink] + 1 &) -> 
         updatedStrands[[3]], {2}], 
       updatedStrands[[4 ;;]]},(*keep adding crossings*)
      recurse[updatedLink, updatedStrands]]
     ];
   recurse[link, initialStrands]
   ];
deleteComponent[link_, s_, strandList_] := 
  Module[{newLink, currentStrand, newStrandList, currentCrossing},
   If[s <= 0,
    (*we're done deleting stuff*)
    {link, strandList},
    (*keep deleting*)
    currentCrossing = findEnteringVertex[link, s];
    {newLink, currentStrand, newStrandList} = 
     deleteVertex[link, currentCrossing, s, strandList];
    deleteComponent[newLink, currentStrand, newStrandList]
    ]
   ];
cableLinkMonomial[link_, strandList_, degreeList_] := 
  Module[{newLink = link, newStrandList, newDegreeList, coeff = 1},
   (*reorder so that we're deleting components first*)
   {newDegreeList, newStrandList} = {degreeList, strandList}[[All, 
     Ordering@degreeList]];
   (*start cabling*)
   Do[
    Which[
     newStrandList[[i]] == 0,
     (*it's an unknot*)
     coeff = coeff*(-A^2 - A^(-2))^newDegreeList[[i]],
     newDegreeList[[i]] == 0,
     (*we need to delete it*)
     {newLink, newStrandList} = 
      deleteComponent[newLink, newStrandList[[i]], newStrandList],
     True,
     (*cable the component*)
     Do[
      {newLink, newStrandList} = 
       cableComponent[newLink, newStrandList[[i]], newStrandList]
      , {j, 1, newDegreeList[[i]] - 1}]
     ]
    , {i, 1, Length[newStrandList]}
    ];
   coeff*KB1[newLink]
   ];
CableLink[link_, poly_, strandList_, vars_] := 
 Module[{monomials = CoefficientRules[poly, vars], temp},
  Total[
   Map[
    #[[2]]*cableLinkMonomial[link, strandList, #[[1]]] &
    , monomials]]
  ]

(* 

*)