ManagingKnotData`

Introduction

This package provides a uniform interface to the Knot Atlas and the package KnotTheory`. In the future, it may encompass Livingston's knot tables, and other sources.

Implementation

\(\(BeginPackage["ManagingKnotData`", {"KnotTheory`", "WikiLink`"}];\)\)

FromWikiString;

Usage messages

LoadInvariantRules::usage = "LoadInvariantRules[pagename] loads \
definitions for invariants from the page pagename (using the current \
WikiLink` connection).";

InvariantDefinitionTable::usage = "InvariantDefinitionTable[rules] \
generates an html table representing rules, suitable for input via \
LoadInvariantRules.";

Invariants::usage = "Invariants[] returns a list of all invariant \
definitions currently known. Invariants[string_pattern] returns all invariant \
definitions with type matching string_pattern.";

InvariantNames::usage = "InvariantNames[rules] returns a list of \
the names of the invariants described by rules.";

RetrieveInvariant::usage = "RetrieveInvariant[invariant, knot, \
source] returns the value of the named invariant for the given knot, from the \
specified source. At present, the only sources understood are \"KnotAtlas\" \
and \"KnotTheory`\". More, like \"Livingston\", may come soon!";

RetrieveInvariants::usage = "RetrieveInvariants[invariantList, \
knotList, source] returns a list of triples, each of the form \
{\"InvariantName\", K, value}, from the specified source. At present, the \
only sources understood are \"KnotAtlas\" and \"KnotTheory`\". More, like \
\"Livingston\", may come soon!";

StoreInvariants::usage = "StoreInvariants[data, target] stores the \
data, given in the form produced by RetrieveInvariants, in the specified \
target. At present, the only target understood is \"KnotAtlas\". Perhaps soon \
they'll be a way to specify a Mathematica .m file as the target.";

FindDataDiscrepancies::usage = "FindDataDiscrepancies[data1, data2] \
returns a list of conflicts between the two lists of data. The conflicts are \
given in the form {\"InvariantName\", K, value1, value2}, where value1 is the \
value given in data1, and value2 is the value given in data2. See also \
FindMissingData.\n" <> "FindDataDiscrepancies[invariantList, knotList, \
source1, source2] first makes two calls to RetrieveInvariants to generate \
data1 and data2.";

\(\(FindMissingData::usage = "FindMissingData[data1, data2] returns a sublist of data1 consisting of items for which there is no corresponding value in data2. See also FindDataDiscrepancies.
" <> "FindMissingData[invariantList, knotList, source1, source2] first makes two calls to RetrieveInvariants to generate data1 and data2.";\)\)

Begin["`Private`"];

Reading invariant definitions from a table

\(\(namePattern = "<!-- Invariant name -->" ~~ \(WhitespaceCharacter ...  ~~ \("<td>" ~~ \(n : 
                    ShortestMatch[__] ~~ "</td>"\)\)\) :> 
          n;\)\)

\(\(linePattern = "<!-- " ~~ \(t : \((WordCharacter .. )\) ~~ \(" =" ~~ \(ShortestMatch[__] ~~ \("<td>" ~~ \(v : 
                        ShortestMatch[___] ~~ "</td>"\)\)\)\)\) :> \((t -> v)\);\)\)

expressionTags = {"ReadWiki", "KnotTheory"};

\(ConstructInvariantRule[S_String] := 
      Module[{names = StringCases[S, namePattern]}, 
        If[Length[names] ≠ 1, 
          Return[$Failed]]; 
names[[1]] -> 
            DeleteCases[
              StringCases[S, 
                linePattern], _ -> ""] /. \((t_String?\((MemberQ[
                        expressionTags, #] &)\) -> 
                s_String)\) :> \((t -> 
                ToExpression[s])\)]\)

LoadInvariantRules[pagename_String] := AllInvariants = 
        ConstructInvariantRule /@ 
          Drop[StringSplit[WikiGetPageText[pagename], "<tr>"], 
            2]

Saving invariant definitions to a table

InvariantTags[rules_] := 
      Union @@ (rules /. (_ -> L_List) :> 
              First /@ L)

TableHeader[rules_] := "<tr>\n<th>Invariant name</th>\n" <> 
        StringJoin @@ ("   <th>" <> # <> "</th>\n" & /@ 
              InvariantTags[rules]) <> "</tr>\n"

whitespaces[n_] := StringJoin @@ Table[" ", {n}]

\(TableRow[rules_, i_] := "<tr>
<!-- Invariant name --> <td>" <> 
        rules[[i, 1]] <> "</td>
" <> 
        StringJoin @@ \((\("<!-- " <> # <> " =" <> 
                  whitespaces[20 - StringLength[#]] <> "--> <td>" <> 
                  ToString[\(# /. 
                        rules[[i, 
                          2]]\) /. {# -> ""}] <> "</td>
" &\) /@ InvariantTags[rules])\) <> "</tr>
"\)

\(InvariantDefinitionTable[
        rules_] := "{{Invariant Definition Table Warning}}
" <> "<table width="100%">
" <> TableHeader[rules] <> 
        StringJoin @@ 
          Table[TableRow[rules, i], {i, 1, 
              Length[rules]}] <> "</table>"\)

Selecting invariants by type

\(Invariants[S_] := 
      Select[AllInvariants, 
        StringMatchQ[\(("Type" /. #[[2]])\), S] &]\)

Invariants[] := Invariants[__]

\(Invariants["KnotTheory` Knot Invariants"] := 
      Invariants["Navigation" | "Knot Presentations" | "Link Presentations" | "3D Invariant" | "Polynomial Invariant" | "Vassiliev Invariant"]\)

Invariants["KnotTheory` Link Invariants"] := 
      Invariants["Navigation" | "Link Presentations" | "Polynomial \
Invariant"]

Code for uploading, downloading, and comparing data

FromWikiString[S_String] /; 
        StringMatchQ[S, "<math>" ~~ __ ~~ "</math>"] := 
      ToExpression[
        StringReplace[
          S, "<math>" ~~ X__ ~~ "</math>" :> X], 
        TeXForm]

FromWikiString[S_String] := ToExpression[S]

InvariantNames[L_List] := 
      Cases[L, (S_String -> _List) :> S]

InvariantRule[I_String] := 
      Module[{rule}, 
        rule = I /. AllInvariants; 
If[rule == I, 
          Print["I don't recognise the invariant " <> I <> "."]; 
          Return[$Failed], rule]]

\(RetrieveInvariant[I_String, K_, "KnotTheory"] := 
      Module[{rule = InvariantRule[I], KnotTheory}, 
        If[rule == $Failed, 
          Return[$Failed]]; 
KnotTheory = "KnotTheory" /. \((I /. AllInvariants)\); 
If[
          KnotTheory == "KnotTheory", 
          Print["Sorry, I don't know how to calculate the invariant " <> 
              I <> " using KnotTheory`."]; 
          Return[$Failed]]; 
KnotTheory[K]]\)

RetrieveInvariants[Is : {__Rule}, Ks_List, source_String] := 
      RetrieveInvariants[InvariantNames[Is], Ks, source]

RetrieveInvariants[Is : {__String}, Ks_List, source_String] := 
      Flatten[Outer[{#1, #2, RetrieveInvariant[#1, #2, source]} &, Is, Ks], 
        1]

\(RetrieveInvariant[I_String, K_, "KnotAtlas"] := 
      Module[{rule = InvariantRule[I], WikiPage, WikiResult, ReadWiki}, 
        If[rule == $Failed, 
          Return[$Failed]]; 
WikiPage = "WikiPage" /. \((I /. AllInvariants)\); 
If[
          WikiPage == "WikiPage", 
          Print["Sorry, I don't know how to retrieve the invariant " <> 
              I <> " from the Knot Atlas."]; 
          Return[$Failed]]; 
ReadWiki = "ReadWiki" /. \((I /. AllInvariants)\); 
If[
          ReadWiki == "ReadWiki", 
          Print["Sorry, I don't know how to translate the invariant " <> 
              I <> " from its textual representation in the Knot Atlas."]; Return[$Failed]]; 
WikiResult = 
          WikiGetPageText["Data:" <> NameString[K] <> "/" <> 
              WikiPage]; 
ReadWiki[WikiResult]]\)

RetrieveInvariants[Is : {__Rule}, Ks_List, "KnotAtlas"] := 
      RetrieveInvariants[InvariantNames[Is], Ks, "KnotAtlas"]

This is hideously inefficient; we really should override RetrieveInvariants, and batch the requests together!

RetrieveInvariants[Is : {__String}, Ks_List, "KnotAtlas"] := 
      Flatten[Outer[{#1, #2, RetrieveInvariant[#1, #2, "KnotAtlas"]} &, 
          Is, Ks], 1]

Clear[WikiPageForInvariant];
\(WikiPageForInvariant[I_String] := \(WikiPageForInvariant[I] = 
        Module[{rule = InvariantRule[I], wikiPage}, 
          If[rule == $Failed, 
            Return[$Failed]]; 
wikiPage = "WikiPage" /. \((I /. AllInvariants)\); 
If[
            wikiPage == "WikiPage", 
            Print["Sorry, I don't know how to store the invariant " <> 
                I <> " in the Knot Atlas."]; Return[$Failed], 
            Return[wikiPage]];]\)\)

Options[StoreInvariants] = {Write -> True};

\(StoreInvariants[D : {{_String, _, _} ... }, "KnotAtlas", opts___] := 
      Module[{invariants, unknownInvariants, wikiPages, uploadPairs}, 
        invariants = Union[Part[D, All, 1]]; 
wikiPages = 
          WikiPageForInvariant /@ invariants; 
If[
          MemberQ[wikiPages, $Failed], 
          Return[$Failed]]; 
uploadPairs = \({"Data:" <> 
                  NameString[#[[2]]] <> "/" <> WikiPageForInvariant[#[[1]]], 
                ToString[#[[3]], 
                  WikiForm]} &\) /@ 
            D; 
If[\(Write /. {opts}\) /. 
            Options[StoreInvariants], WikiSetPageTexts[uploadPairs], 
          uploadPairs]]\)

FindDataDiscrepancies[Is : {__Rule}, Ks_List, source1_String, 
        source2_String] := 
      FindDataDiscrepancies[InvariantNames[Is], Ks, source1, 
        source2]

FindDataDiscrepancies[Is : {__String}, Ks_List, source1_String, 
        source2_String] := 
      FindDataDiscrepancies[RetrieveInvariants[Is, Ks, source1], 
        RetrieveInvariants[Is, Ks, source2]]

FindDataDiscrepancies[D1 : {{_String, _, _} ... }, 
        D2 : {{_String, _, _} ... }] := 
      Module[{D1t, D2t, D, P, C},  (*Mark the data, 
          according to where it came from.*) 
          D1t = {#[[1]], #[[2]], 
                1, #[[3]]} & /@ 
            D1; 
D2t = {#[[1]], #[[2]], 
                2, #[[3]]} & /@ 
            D2; 
 (*Combine the data, 
          and split it into doublets (or singlets) corresponding to the same invariant and knot.*) D = 
          Split[Sort[D1t~Join~D2t], 
            SameQ[Take[#1, 2], 
                Take[#2, 
                  2]] &]; 
 (*Take only the pairs.*) P = 
          Select[D, 
            Length[#] == 
                2 &]; 
 (*Combine the pairs*) C = 
          P /. {{I_, K_, 1, V1_}, {I_, K_, 2, V2_}} :> {I, K, V1, 
                V2}; 
Select[
          C, #[[3]] =!= #[[4]] &]]

FindMissingData[D1 : {{_String, _, _} ... }, 
        D2 : {{_String, _, _} ... }] := 
      Complement[D1, D2, 
        SameTest -> SameQ[Take[#1, 2], Take[#2, 2]] &]

End[];

EndPackage[];