SubLink.m

(*

The program SubLink, documented in the page on Prime Links with a Non-Prime Component. It is not part of the package KnotTheory` but is designed to work with it. Use Import["http://katlas.org/w/index.php?title=SubLink.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.

*)
SubLink::usage = "SubLink[pd, js] returns the
  sublink of pd made out of the components of pd in the list js.";
SubLink[pd_PD, js_List] := Module[
   {k, t0, t, t1, t2, s0, s1},
   s0 = Skeleton[pd];
   (* t0 contains the list of edges that should appear in the sublink *)
   t0 = Flatten[List @@@ s0[[js]]];
   (* t is pd with all edges not in t0 removed;
   this means that some crossings will now involve just 0 or 2 edges. *)
   t = pd /. x_X :> Select[x, MemberQ[t0, #] &];
   (* Remove all "empty" crossings from t: *)
   t = DeleteCases[t, X[] | Loop[]];
   (* Remove all "valency 2" crossings from t,while also removing not-
   longer-necessary edge labels: *)
   k = 1;
   While[
    k <= Length[t],
    If[Length[t[[k]]] == 2,
      t = Delete[t, k] /. (Rule @@ t[[k]]),
      (* else *) ++k
      ];
    ];
   (* We have to manually "re-add" all skeleton components that "disappeared": *)
   s1 = Union[Flatten[List @@ List @@@ t]];
   Do[
    If[
     MemberQ[js, k] && (And @@ (FreeQ[s1, #] & /@ s0[[k]])), 
     AppendTo[t, Loop[s0[[k, 1]]]];
     AppendTo[s1, s0[[k, 1]]]
     ],
    {k, Length[s0]}
    ];
   (* t1 will have all edge-labels still appearing in t;
   it is used to relabel t so that the edge labels will be consecutive *)
   t1 = Sort[s1];
   t2 = Thread[(t1) -> Range[Length[t1]]];
   t /. t2
   ];
SubLink[pd_PD, j_] := SubLink[pd, {j}];
SubLink[L_, js_] := SubLink[PD[L], js];
(* 

*)