IdentifyWithin.m

(*

The program IdentifyWithin, documented in the page on Identifying Knots within a List. It is not part of the package KnotTheory` but is designed to work with it. Use Import["http://katlas.org/wiki/IdentifyWithin.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.

*)
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, {}
    ]
   ];
(* 

*)