Identifying Knots within a List: Difference between revisions

From Knot Atlas
Jump to navigationJump to search
No edit summary
No edit summary
Line 156: Line 156:
];</nowiki>}}
];</nowiki>}}
<!--END-->
<!--END-->

<!--$$SubLink[pd_PD, js_List] := Module[
{k, t0, t, t1, t2, S, P},
t0 = Flatten[List @@@ Skeleton[pd][[js]]];
t = pd /. x_X :> Select[x, MemberQ[t0, #] &];
t = DeleteCases[t, X[]];
k = 1;
While[
k <= Length[t],
If[ Length[t[[k]]] < 4,
t = Delete[t, k] /. (Rule @@ t[[k]]), ++k];
];
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[L_, js_] := SubLink[PD[L], js];$$-->





Revision as of 10:41, 8 November 2007


IdentifyWithin[L,H] returns those elements from the list of knots , whose invariant matches that of the knot . It can also recognize mirrors and connected sums of the knots in the list. Its options include turning off (on) the search for connected sums with ConnectedSum->False (True) and choosing the invariants to be used in identification by selecting, for example, Invariants->{Jones[#][q]&, HOMFLYPT[#][a,z]&}. IdentifyWithin can be used together with SubLink to determine the components of a link. For the second component of link L11n150, for instance, we get:

(For In[1] see Setup)

In[3]:= Options[IdentifyWithin] = { Invariants -> {Jones[#][q] &, HOMFLYPT[#][a, z] &, Kauffman[#][a, z] &}, ConnectedSum -> "True"}; IdentifyWithin[L_, H_List, opts___Rule] := Module[ {div, j = 1, l, i = 1, u, mu, t, mt, out = {}, out1 = {}, nk, mnk, mnk1, p, mp, m, p1, invariants = (Invariants /. {opts} /. Options[IdentifyWithin]), connectedsum = (ConnectedSum /. {opts} /. Options[IdentifyWithin])}, NormalizeP[poly_] := Module[{t1, i1}, (For[i1 = 1 ; t1 := FactorList[poly], i1 <= Length[Variables[poly]], i1++, t1 = DeleteCases[t1, {Variables[poly][[i1]], _Integer} | {1, 1}]]; Times @@ Power @@@ t1 )]; l := Length[invariants]; u[0] = mu[0] = H; While[i <= l && ! Length[out] === 1, t[i] = invariants[[i]][L]; mt[i] = invariants[[i]][Mirror[L]]; u[i] = Select[u[i - 1], t[i] == invariants[[i]][#] &]; mu[i] = Select[mu[i - 1], mt[i] == invariants[[i]][#] &]; out = Flatten[{u[i], Mirror /@ mu[i]}]; i++]; Which[ Length[out] >= 2, DeleteCases[out, Mirror[Knot[0, 1]]], Length[out] == 1, out = If[u[i - 1] != {}, u[i - 1], Mirror /@ mu[i - 1]], connectedsum === "True", i = 1; nk[0] = mnk[0] = H; While[Length[out1] != 1 && i <= l, p[i] = NormalizeP[t[i]]; mp[i] = NormalizeP[mt[i]]; nk[i] = Select[nk[i - 1], (p1 = NormalizeP[invariants[[i]][#]]; z = 3; PolynomialRemainder[p[i], p1, Variables[p[i]][[1]]] === 0 ) &]; mnk[i] = Select[mnk[i - 1], (p1 = NormalizeP[invariants[[i]][#]]; z = 3; PolynomialRemainder[mp[i], p1, Variables[p[i]][[1]]] === 0 ) &]; Clear[z]; mnk1[i] = Mirror /@ mnk[i]; div = Flatten[{nk[i], mnk1[i]}]; div = DeleteCases[div, Knot[0, 1] | Mirror[Knot[0, 1]]]; If[div == {}, out1 = {}, For[m = 1; W[0] = CS[0] = Select[ Flatten /@ Flatten[Outer[List, div, div, 1], 1], OrderedQ], Length[W[m - 1][[1]]] < 4, m++, W[m] = Select[ Flatten /@ Flatten[Outer[List, div, W[m - 1], 1], 1], OrderedQ]; CS[m] = Flatten[{CS[m - 1], W[m]}, 1]; ]; out1 = Select[CS[m - 1], Expand[Times @@ invariants[[i]] /@ #] == t[i] &]; ]; i++]; If[out1 == {}, {}, ConnectedSum @@@ out1], True, {} ] ];


In[2]:= IdentifyWithin[SubLink[Link["L11n150"], 2], AllKnots[]]
Out[2]= {Knot[5, 2]}


L11n150.gif
L11n150
5 2.gif
5_2


Unfortunately, the program does not provide absolute identification when all the used invariants cannot distinguish between two or more different knots. In that case, a list of possible candidates for is returned.