CableComponent.m

(*

The program CableComponent, documented in the page on Cabling. It is not part of the package KnotTheory` but is designed to work with it. Use Import["http://katlas.org/w/index.php?title=CableComponent.m&action=raw"] to download into a mathematica session, or copy-paste the text below ignoring the *) on the first line and the (* on the last.

*)
CableComponent[BR[n_Integer, js_List], K_] :=
  Module[{BC, C0, C1, C2, CC1, CS1, CS2, L, S, a, e, h, i, i1, i2, j, 
    j1, j2, jss, k, k1, kjs, out, out0, out1, p, p1, pos, q, r, s, ss,
     t, t0, t1, t2, tj, v, w, writhe},
   L = PD[K];
    kjs = BR[L][[2]];
   For[i1 = 1; writhe = 0, i1 <= Length[kjs], i1++, 
    writhe = writhe + Sign[kjs[[i1]]]];
    For[i2 = 1; jss[0] = js, i2 <= n Abs[writhe], i2++, 
    jss[i2] = 
     Flatten[{jss[i2 - 1], Table[-Sign[writhe] e, {e, n - 1}]}]];
   k1 = Length[jss[n Abs[writhe]]];
    For[i = 1, i <= n, i++, s[i] = a[i] = i];
   For[
    j = 1, j <= k1, j++,
    p = Select[Range[n], Abs[jss[n Abs[writhe]][[j]]] == a[#] &][[
      1]];
    q = Select[Range[n], a[#] == a[p] + 1 &][[1]];
    If[jss[n Abs[writhe]][[j]] > 0, 
     K[j] = X[s[q], n + 2 j, n + 2 j - 1, s[p]], 
     K[j] = X[s[p], s[q], n + 2 j, n + 2 j - 1]];
    s[p] = n + 2 j;
    s[q] = n + 2 j - 1;
    a[p]++;
    a[q]--
    ];
   BC = Table[K[d], {d, k1}];
   If[Jones[L][q] === 1,
    For[j1 = 1, j1 <= Length[BC], j1++, 
     For[i = 1, i <= n, i++, BC[[j1]] = BC[[j1]] /. s[i] :> a[i]
      ]];
    If[BC == {}, BC = {Loop[1]}];
    out1 = PD @@ BC,
    For[j2 = 1, j2 <= Length[BC], j2++, 
     For[tj = 1, tj <= n, tj++, BC[[j2]] = BC[[j2]] /. tj :> 1[tj]]
     ];
    p1 = Select[Range[n], # != s[#] &];
    S = Select[L, MemberQ[#, 1] && MemberQ[#, 2] & ];
    pos = Position[S, 1][[1, 2]];
    r = Select[Table[i, {i, Length[L]}], L[[#]] == Flatten @@ S &][[
      1]];
    k = 0;
    out0 = L /. X[a_, b_, c_, d_] :> (
        ++k;
        Table[
           X[h[i, j - 1, k], v[i, j, k], h[i, j, k], v[i - 1, j, k]],
           {i, n}, {j, n}
           ] /. {h[i_, 0, _] :> a[i], h[i_, n, _] :> c[i]} /. If[
          d - b == 1 || b - d > 1,
          {v[0, j_, _] :> d[j], 
           v[n, j_, _] :> b[j]}, {v[0, j_, _] :> d[n + 1 - j], 
           v[n, j_, _] :> b[n + 1 - j]}
          ]
        );
    w = Flatten@out0[[r]];
    out = PD @@ Flatten[Join @@ out0];
    ss = Table[a[i], {i, n}][[p1]];
     CC1 = List @@ out;
    For[t0 = 1, t0 <= Length[ss], t0++, 
     C0[t0] = Select[w, MemberQ[#, 1[ss[[t0]]]] &]; 
     C1[t0] = 
      Select[C0[t0], 
       Mod[Position[#, 1[ss[[t0]]]][[1, 1]], 2] == Mod[pos, 2] &]; 
     C2[t0] = 
      C1[t0] /. 1[ss[[t0]]] :> 
        s[Select[Range[n], a[#] == ss[[t0]] &][[1]]]];
    
    CS1 = Flatten[Table[C1[t1], {t1, Length[ss]}]];
     CS2 = Flatten[Table[C2[t2], {t2, Length[ss]}]];
    For[i = 1, i <= Length[CS1], i++, 
     CC1 = DeleteCases[CC1, CS1[[i]]]];
    out1 = Union[BC, CC1, CS2];
    PD @@ out1;
    k = 0;
    out1 = 
     PD @@ ( out1 /. ((# -> ++k) & /@ (List @@ Union @@ out1)))]];
(* 

*)