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, |
{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. *) |
|||
⚫ | |||
⚫ | |||
⚫ | |||
(* 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: *) |
|||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
t = Delete[t, k] /. (Rule @@ t[[k]]), |
|||
(* else *) ++k |
|||
⚫ | |||
⚫ | |||
(* We have to manually "re-add" all skeleton components that "disappeared": *) |
|||
⚫ | |||
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]; |
|||
⚫ | |||
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]; (*
*)