SubLink.m: Difference between revisions

From Knot Atlas
Jump to navigationJump to search
(New page: (* The program <code>SubLink</code>, documented in the page on Prime Links with a Non-Prime Component. It is not part of the package <code>KnotTheory`</code> but is designed to work w...)
 
No edit summary
Line 4: Line 4:
<pre>
<pre>
*)
*)
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[
SubLink[pd_PD, js_List] := Module[
{k, t0, t, t1, t2, S, P},
{k, t0, t, t1, t2, s0, s1},
t0 = Flatten[List @@@ Skeleton[pd][[js]]];
s0 = Skeleton[pd];
(* t0 contains the list of edges that should appear in the sublink *)
t = pd /. x_X :> Select[x, MemberQ[t0, #] &];
t = DeleteCases[t, X[]];
t0 = Flatten[List @@@ s0[[js]]];
(* t is pd with all edges not in t0 removed;
k = 1;
this means that some crossings will now involve just 0 or 2 edges. *)
While[
t = pd /. x_X :> Select[x, MemberQ[t0, #] &];
k <= Length[t],
(* Remove all "empty" crossings from t: *)
If[ Length[t[[k]]] < 4,
t = Delete[t, k] /. (Rule @@ t[[k]]), ++k];
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
];
];
t1 = List @@ Union @@ t;
t2 = Thread[(t1) -> Range[Length[t1]]];
S = t /. t2;
P = If[S != PD[] && Length[S] >= 3, S, PD[Knot[0, 1]], S]
];
SubLink[pd_PD, j_] := SubLink[pd, {j}];
SubLink[pd_PD, j_] := SubLink[pd, {j}];
SubLink[L_, js_] := SubLink[PD[L], js];
SubLink[L_, js_] := SubLink[PD[L], js];

Revision as of 14:13, 28 August 2010

(*

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/wiki/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];
(* 

*)