The Jones Polynomial: Difference between revisions
DrorsRobot (talk | contribs) No edit summary |
No edit summary |
||
(62 intermediate revisions by 8 users not shown) | |||
Line 1: | Line 1: | ||
{{Todo-launch}} <!-- fix \slashoverback, \bigcirc, \smoothing, \hsmoothing --> |
|||
{{Manual TOC Sidebar}} |
{{Manual TOC Sidebar}} |
||
{{Startup Note}} |
{{Startup Note}} |
||
<!--$$?Jones$$--> |
<!--$$?Jones$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{HelpLine| |
|||
{{Help1|n=2|s=Jones}} |
|||
n = 2 | |
|||
Jones[L][q] computes the Jones polynomial of a knot or link L as a function of the variable q. |
|||
in = <nowiki>Jones</nowiki> | |
|||
{{Help2}} |
|||
out= <nowiki>Jones[L][q] computes the Jones polynomial of a knot or link L as a function of the variable q.</nowiki>}} |
|||
<!--END--> |
<!--END--> |
||
Line 16: | Line 14: | ||
<!--$$Jones[Knot[6, 1]][q]$$--> |
<!--$$Jones[Knot[6, 1]][q]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 3 | |
|||
Jones[Knot[6, 1]][q] |
|||
in = <nowiki>Jones[Knot[6, 1]][q]</nowiki> | |
|||
{{InOut2|n=3}}<pre style="border: 0px; padding: 0em"><nowiki> -4 -3 -2 2 2 |
|||
out= <nowiki> -4 -3 -2 2 2 |
|||
2 + q - q + q - - - q + q |
2 + q - q + q - - - q + q |
||
q</nowiki> |
q</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
<!--$$Jones[Knot[9, 46]][q]$$--> |
<!--$$Jones[Knot[9, 46]][q]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 4 | |
|||
Jones[Knot[9, 46]][q] |
|||
in = <nowiki>Jones[Knot[9, 46]][q]</nowiki> | |
|||
{{InOut2|n=4}}<pre style="border: 0px; padding: 0em"><nowiki> -6 -5 -4 2 -2 1 |
|||
out= <nowiki> -6 -5 -4 2 -2 1 |
|||
2 + q - q + q - -- + q - - |
2 + q - q + q - -- + q - - |
||
3 q |
3 q |
||
q</nowiki> |
q</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
{{Knot Image|L8a6|gif}} |
|||
The Jones polynomial attains <!--$all=Join[AllKnots[], AllLinks[]]; Length[Union[Jones[#][q]& /@ all]]$--><!--The content to END was generated by WikiSplice: do not edit; see manual.-->2110<!--END--> values on the <!--$Length[all]$--><!--The content to END was generated by WikiSplice: do not edit; see manual.-->2226<!--END--> knots and links known to <code>KnotTheory`</code>: |
|||
On links with an even number of components the Jones polynomial is a function of <math>\sqrt{q}</math>, and hence it is often more convenient to view it as a function of <math>t</math>, where <math>t^2=q</math>: |
|||
<!--$$Jones[Link[8, Alternating, 6]][q]$$--> |
|||
<!--Robot Land, no human edits to "END"--> |
|||
{{InOut| |
|||
n = 5 | |
|||
in = <nowiki>Jones[Link[8, Alternating, 6]][q]</nowiki> | |
|||
out= <nowiki> -(9/2) -(7/2) 3 3 4 3/2 |
|||
-q + q - ---- + ---- - ------- + 3 Sqrt[q] - 2 q + |
|||
5/2 3/2 Sqrt[q] |
|||
q q |
|||
5/2 7/2 |
|||
2 q - q</nowiki>}} |
|||
<!--END--> |
|||
<!--$$PowerExpand[Jones[Link[8, Alternating, 6]][t^2]]$$--> |
|||
<!--Robot Land, no human edits to "END"--> |
|||
{{InOut| |
|||
n = 6 | |
|||
in = <nowiki>PowerExpand[Jones[Link[8, Alternating, 6]][t^2]]</nowiki> | |
|||
out= <nowiki> -9 -7 3 3 4 3 5 7 |
|||
-t + t - -- + -- - - + 3 t - 2 t + 2 t - t |
|||
5 3 t |
|||
t t</nowiki>}} |
|||
<!--END--> |
|||
The Jones polynomial attains <!--$all=Join[AllKnots[], AllLinks[]]; Length[Union[Jones[#][q]& /@ all]]$--><!--Robot Land, no human edits to "END"-->2110<!--END--> values on the <!--$Length[all]$--><!--Robot Land, no human edits to "END"-->2226<!--END--> knots and links known to <code>KnotTheory`</code>: |
|||
<!--$$all = Join[AllKnots[], AllLinks[]];$$--> |
<!--$$all = Join[AllKnots[], AllLinks[]];$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{In| |
||
n = 7 | |
|||
all = Join[AllKnots[], AllLinks[]]; |
|||
in = <nowiki>all = Join[AllKnots[], AllLinks[]];</nowiki>}} |
|||
{{In2}} |
|||
<!--END--> |
<!--END--> |
||
<!--$$Length /@ {Union[Jones[#][q]& /@ all], all}$$--> |
<!--$$Length /@ {Union[Jones[#][q]& /@ all], all}$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 8 | |
|||
Length /@ {Union[Jones[#][q]& /@ all], all} |
|||
in = <nowiki>Length /@ {Union[Jones[#][q]& /@ all], all}</nowiki> | |
|||
{{InOut2|n=6}}<pre style="border: 0px; padding: 0em"><nowiki>{2110, 2226}</nowiki></pre> |
|||
out= <nowiki>{2110, 2226}</nowiki>}} |
|||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
<span id="How is the Jones polynomial computed?"> |
<span id="How is the Jones polynomial computed?"> |
||
==How is the Jones polynomial computed?== |
====How is the Jones polynomial computed?==== |
||
</span> |
</span> |
||
(See also: [[The Kauffman Bracket using Haskell]]) |
|||
The Jones polynomial is so simple to compute using Mathematica that it's worthwhile pause and see how this is done, even for readers with limited prior programming experience. First, recall (say from {{ref|Kauffman}}) the definition of the Jones polynomial using the Kauffman bracket <math>\langle\cdot\rangle</math>: |
The Jones polynomial is so simple to compute using Mathematica that it's worthwhile pause and see how this is done, even for readers with limited prior programming experience. First, recall (say from {{ref|Kauffman}}) the definition of the Jones polynomial using the Kauffman bracket <math>\langle\cdot\rangle</math>: |
||
{{Equation|KBDef|<math> |
|||
\langle\emptyset\rangle=1; \qquad |
\langle\emptyset\rangle=1; \qquad |
||
\langle\ |
\langle\bigcirc L\rangle = (-A^2-B^2)\langle L\rangle; \qquad |
||
\langle\ |
\langle\slashoverback\rangle = |
||
A\langle\ |
A\langle\hsmoothing\rangle + B\langle\smoothing\rangle; |
||
</math> |
</math>}} |
||
<center><math> J(L) = |
<center><math> J(L) = |
||
\left.(-A^3)^{w(L)}\frac{\langle L\rangle}{\langle\ |
\left.(-A^3)^{w(L)}\frac{\langle L\rangle}{\langle\bigcirc\rangle}\right|_{A\to q^{1/4}}, |
||
</math></center> |
</math></center> |
||
here <math>A</math> is a commutative variable, <math>B=A^{-1}</math>, and <math>w(L)</math> is the ''writhe'' of <math>L</math>, the difference <math>n_+-n_-</math> where <math>n_+</math> and <math>n_-</math> count the positive |
here <math>A</math> is a commutative variable, <math>B=A^{-1}</math>, and <math>w(L)</math> is the ''writhe'' of <math>L</math>, the difference <math>n_+-n_-</math> where <math>n_+</math> and <math>n_-</math> count the positive <math>(\overcrossing)</math> and negative <math>(\undercrossing)</math> crossings of <math>L</math> respectively. |
||
<center>[[Image:PDForTrefoil.gif|none|frame|<tt><nowiki>PD[X[1,4,2,5], X[3,6,4,1], X[5,2,6,3]]</nowiki></tt> and <tt>P[1,4] P[1,5] P[2,4] P[2,6] P[3,5] P[3,6]</tt>]]</center> |
<center>[[Image:PDForTrefoil.gif|none|frame|<tt><nowiki>PD[X[1,4,2,5], X[3,6,4,1], X[5,2,6,3]]</nowiki></tt> and <tt>P[1,4] P[1,5] P[2,4] P[2,6] P[3,5] P[3,6]</tt>]]</center> |
||
Line 77: | Line 106: | ||
<!--$$L = PD[Knot[3, 1]]$$--> |
<!--$$L = PD[Knot[3, 1]]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 9 | |
|||
in = <nowiki>L = PD[Knot[3, 1]]</nowiki> | |
|||
out= <nowiki>PD[X[1, 4, 2, 5], X[3, 6, 4, 1], X[5, 2, 6, 3]]</nowiki>}} |
|||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
Our first task is to perform the replacement <math>\langle\ |
Our first task is to perform the replacement <math>\langle\slashoverback\rangle\to A\langle\hsmoothing\rangle + B\langle\smoothing\rangle</math> on all crossings of |
||
<math>L</math>. By our conventions (see [[Planar Diagrams]]) the edges |
<math>L</math>. By our conventions (see [[Planar Diagrams]]) the edges |
||
around a crossing <math>X_{abcd}</math> are labeled <math>a</math>, <math>b</math>, <math>c</math> and <math>d</math>: <math>{}^c_d\ |
around a crossing <math>X_{abcd}</math> are labeled <math>a</math>, <math>b</math>, <math>c</math> and <math>d</math>: <math>{}^c_d\slashoverback{}_a^b</math>. Labeling the smoothings <math>(\hsmoothing, \ \smoothing)</math> in the same way, <math>{}^c_d\hsmoothing{}_a^b</math> and <math>{}^c_d\smoothing{}_a^b</math>, we are lead to the symbolic replacement rule <math>X_{abcd}\to AP_{ad}P_{bc}+BP_{ab}P_{cd}</math>. Let us apply this rule to <math>L</math>, switch to a multiplicative notation and expand: |
||
<!--$$t1 = L /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + B P[a,b] P[c,d]$$--> |
<!--$$t1 = L /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + B P[a,b] P[c,d]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 10 | |
|||
t1 = L /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + B P[a,b] P[c,d] |
|||
in = <nowiki>t1 = L /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + B P[a,b] P[c,d]</nowiki> | |
|||
out= <nowiki>PD[A P[1, 5] P[2, 4] + B P[1, 4] P[2, 5], |
|||
B P[1, 4] P[3, 6] + A P[1, 3] P[4, 6], |
|||
{{InOut3}} |
|||
A P[2, 6] P[3, 5] + B P[2, 5] P[3, 6]]</nowiki>}} |
|||
<!--END--> |
<!--END--> |
||
<!--$$t2 = Expand[Times @@ t1]$$--> |
<!--$$t2 = Expand[Times @@ t1]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{InOut| |
||
n = 11 | |
|||
t2 = Expand[Times @@ t1] |
|||
in = <nowiki>t2 = Expand[Times @@ t1]</nowiki> | |
|||
out= <nowiki> 2 |
|||
A B P[1, 4] P[1, 5] P[2, 4] P[2, 6] P[3, 5] P[3, 6] + |
A B P[1, 4] P[1, 5] P[2, 4] P[2, 6] P[3, 5] P[3, 6] + |
||
Line 108: | Line 140: | ||
A B P[1, 4] P[2, 5] P[2, 6] P[3, 5] P[3, 6] + |
A B P[1, 4] P[2, 5] P[2, 6] P[3, 5] P[3, 6] + |
||
2 |
2 2 |
||
A B P[1, 4] P[1, 5] P[2, 4] P[2, 5] |
A B P[1, 4] P[1, 5] P[2, 4] P[2, 5] P[3, 6] + |
||
3 2 2 2 |
|||
B P[1, 4] P[2, 5] P[3, 6] + |
|||
3 |
3 |
||
Line 121: | Line 156: | ||
2 2 |
2 2 |
||
A B P[1, 3] P[1, 4] P[2, 5] P[3, 6] P[4, 6]</nowiki> |
A B P[1, 3] P[1, 4] P[2, 5] P[3, 6] P[4, 6]</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
Line 128: | Line 162: | ||
<!--$$t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]}$$--> |
<!--$$t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]}$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{InOut| |
|||
{{InOut1|n=10}} |
|||
n = 12 | |
|||
t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]} |
|||
in = <nowiki>t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]}</nowiki> | |
|||
{{InOut2|n=10}}<pre style="border: 0px; padding: 0em"><nowiki> 3 2 3 2 |
|||
out= <nowiki> 3 2 |
|||
B P[1, 1] P[2, 2] P[3, 3] + A B P[2, 2] P[4, 4] + |
|||
2 2 |
3 2 2 |
||
A P[3, 3] P[4, 4] + A B P[3, 3] P[4, 4] + 3 A B P[5, 5] + |
|||
{{InOut3}} |
|||
2 |
|||
A B P[1, 1] P[5, 5]</nowiki>}} |
|||
<!--END--> |
<!--END--> |
||
Line 142: | Line 179: | ||
<!--$$t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]$$--> |
<!--$$t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{InOut| |
|||
{{InOut1|n=11}} |
|||
n = 13 | |
|||
t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A] |
|||
in = <nowiki>t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]</nowiki> | |
|||
{{InOut2|n=11}}<pre style="border: 0px; padding: 0em"><nowiki> -9 1 3 7 |
|||
out= <nowiki> -9 1 3 7 |
|||
-A + - + A + A |
-A + - + A + A |
||
A</nowiki> |
A</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
Line 156: | Line 193: | ||
Expand[Times @@ pd /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + 1/A P[a,b] P[c,d]] |
Expand[Times @@ pd /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + 1/A P[a,b] P[c,d]] |
||
//. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a], P[a_,a_] -> -A^2-1/A^2}]$$--> |
//. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a], P[a_,a_] -> -A^2-1/A^2}]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{ |
{{In| |
||
n = 14 | |
|||
KB0[pd_] := Expand[ |
|||
in = <nowiki>KB0[pd_] := Expand[ |
|||
Expand[Times @@ pd /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + 1/A P[a,b] P[c,d]] |
Expand[Times @@ pd /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + 1/A P[a,b] P[c,d]] |
||
//. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a], P[a_,a_] -> -A^2-1/A^2}] |
//. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a], P[a_,a_] -> -A^2-1/A^2}]</nowiki>}} |
||
{{In2}} |
|||
<!--END--> |
<!--END--> |
||
<!--$$t4 = KB0[PD[Knot[3, 1]]]$$--> |
<!--$$t4 = KB0[PD[Knot[3, 1]]]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{InOut| |
|||
{{InOut1|n=13}} |
|||
n = 15 | |
|||
t4 = KB0[PD[Knot[3, 1]]] |
|||
in = <nowiki>t4 = KB0[PD[Knot[3, 1]]]</nowiki> | |
|||
{{InOut2|n=13}}<pre style="border: 0px; padding: 0em"><nowiki> -9 1 3 7 |
|||
out= <nowiki> -9 1 3 7 |
|||
-A + - + A + A |
-A + - + A + A |
||
A</nowiki> |
A</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
Line 177: | Line 214: | ||
<!--$$(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand$$--> |
<!--$$(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{InOut| |
|||
{{InOut1|n=14}} |
|||
n = 16 | |
|||
(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand |
|||
in = <nowiki>(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand</nowiki> | |
|||
{{InOut2|n=14}}<pre style="border: 0px; padding: 0em"><nowiki> -4 -3 1 |
|||
out= <nowiki> -4 -3 1 |
|||
-q + q + - |
-q + q + - |
||
q</nowiki> |
q</nowiki>}} |
||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
{{Knot Image|L11a548|gif}} |
|||
\begin{figure} |
|||
\htmlimage{} |
|||
\centering{ |
|||
\includegraphics[height=3cm]{figs/L11a548.eps} |
|||
} |
|||
\caption{ |
|||
The link \hlink{../Links/11a548.html}{L11a548}. |
|||
} |
|||
\end{figure} |
|||
At merely 3 lines of code, our program is surely nice and elegant. But it is very slow: |
|||
%<* InOut@"Timing[KB0[PD[Link[11, Alternating, 548]]]]"; *> |
|||
<!--$$time0 = Timing[KB0[PD[Link[11, Alternating, 548]]]]$$--> |
|||
At merely 3 lines of code, our program is surely nice and elegant. But at |
|||
<!--Robot Land, no human edits to "END"--> |
|||
<* time1=Out[0][[1,1]] *> seconds for an 11 crossing link, it is very slow: |
|||
{{InOut| |
|||
n = 17 | |
|||
in = <nowiki>time0 = Timing[KB0[PD[Link[11, Alternating, 548]]]]</nowiki> | |
|||
out= <nowiki> -23 5 10 -3 5 13 17 21 25 |
|||
{1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A } |
|||
15 7 |
|||
A A</nowiki>}} |
|||
<!--END--> |
|||
Here's the much faster alternative employed by <code>KnotTheory`</code>: |
|||
<* InOut[0] *> |
|||
\vskip 6pt |
|||
<!--$$KB1[pd_PD] := KB1[pd, {}, 1]; |
|||
Here's the much faster alternative employed by {\tt KnotTheory`}: |
|||
KB1[pd_PD, inside_, web_] := Module[ |
|||
{pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]}, |
|||
<!--$$ |
|||
pd[[pos]] /. X[a_,b_,c_,d_] :> KB1[ |
|||
KB1[pd_PD] := KB1[pd, {}, 1];\n |
|||
Delete[pd, pos], |
|||
KB1[pd_PD, inside_, web_] := Module[\n |
|||
Union[inside, {a,b,c,d}], |
|||
{pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]},\n |
|||
Expand[web*(A P[a,d] P[b,c]+1/A P[a,b] P[c,d])] //. { |
|||
P[e_,f_]P[f_,g_] :> P[e,g], P[e_,_]^2 :> P[e,e], P[e_,e_] -> -A^2-1/A^2 |
|||
Delete[pd, pos],\n |
|||
} |
|||
Union[inside, {a,b,c,d}],\n |
|||
] |
|||
Expand[web*(A P[a,d] P[b,c]+1/A P[a,b] P[c,d])] //. {\n |
|||
]; |
|||
P[e_,f_]P[f_,g_] :> P[e,g], P[e_,_]^2 :> P[e,e], P[e_,e_] -> -A^2-1/A^2\n |
|||
KB1[PD[],_,web_] := Expand[web]$$--> |
|||
}\n |
|||
<!--Robot Land, no human edits to "END"--> |
|||
]\n |
|||
{{In| |
|||
];\n |
|||
n = 18 | |
|||
KB1[PD[],_,web_] := Expand[web]"$$--> |
|||
in = <nowiki>KB1[pd_PD] := KB1[pd, {}, 1]; |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
KB1[pd_PD, inside_, web_] := Module[ |
|||
{{InOut1|n=15}} |
|||
{pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]}, |
|||
pd[[pos]] /. X[a_,b_,c_,d_] :> KB1[ |
|||
KB1[pd_PD] := KB1[pd, {}, 1];\n |
|||
Delete[pd, pos], |
|||
KB1[pd_PD, inside_, web_] := Module[\n |
|||
Union[inside, {a,b,c,d}], |
|||
{pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]},\n |
|||
Expand[web*(A P[a,d] P[b,c]+1/A P[a,b] P[c,d])] //. { |
|||
P[e_,f_]P[f_,g_] :> P[e,g], P[e_,_]^2 :> P[e,e], P[e_,e_] -> -A^2-1/A^2 |
|||
Delete[pd, pos],\n |
|||
} |
|||
Union[inside, {a,b,c,d}],\n |
|||
] |
|||
Expand[web*(A P[a,d] P[b,c]+1/A P[a,b] P[c,d])] //. {\n |
|||
]; |
|||
P[e_,f_]P[f_,g_] :> P[e,g], P[e_,_]^2 :> P[e,e], P[e_,e_] -> -A^2-1/A^2\n |
|||
KB1[PD[],_,web_] := Expand[web]</nowiki>}} |
|||
}\n |
|||
]\n |
|||
];\n |
|||
KB1[PD[],_,web_] := Expand[web]" |
|||
{{InOut2|n=15}}<pre style="border: 0px; padding: 0em"><nowiki>$Failed</nowiki></pre> |
|||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
<!--$$Timing[KB1[PD[Link[11, Alternating, 548]]]]$$--> |
<!--$$time1 = Timing[KB1[PD[Link[11, Alternating, 548]]]]$$--> |
||
<!--Robot Land, no human edits to "END"--> |
|||
<!--The lines to END were generated by WikiSplice: do not edit; see manual.--> |
|||
{{InOut| |
|||
{{InOut1|n=16}} |
|||
n = 19 | |
|||
Timing[KB1[PD[Link[11, Alternating, 548]]]] |
|||
in = <nowiki>time1 = Timing[KB1[PD[Link[11, Alternating, 548]]]]</nowiki> | |
|||
{{InOut2|n=16}}<pre style="border: 0px; padding: 0em"><nowiki>{0. Second, KB1[PD[X[6, 1, 7, 2], X[2, 5, 3, 6], X[18, 11, 19, 12], X[10, 3, 11, 4], |
|||
out= <nowiki> -23 5 10 -3 5 13 17 21 |
|||
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - |
|||
15 7 |
|||
A A |
|||
25 |
|||
X[20, 16, 21, 15], X[12, 17, 9, 18]]]}</nowiki></pre> |
|||
A }</nowiki>}} |
|||
{{InOut3}} |
|||
<!--END--> |
<!--END--> |
||
(So on [[L11a548]] <code>KB1</code> is <!--$time0[[1,1]]$--><!--Robot Land, no human edits to "END"--> -23 5 10 -3 5 13 17 21 25 |
|||
(So on the link \hlink{../Links/11a548.html}{L11a548} \verb"KB1" is |
|||
{1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }[[1,1]] |
|||
$<*time1*>/<*time2=Out[0][[1,1]]*>\sim<*Round[time1/time2]*>$ times |
|||
15 7 |
|||
faster than \verb"KB0".) |
|||
A A<!--END-->/<!--$time1[[1,1]]$--><!--Robot Land, no human edits to "END"--> -23 5 10 -3 5 13 17 21 25 |
|||
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }[[1,1]] |
|||
15 7 |
|||
A A<!--END--> ~ <!--$Round[time0[[1,1]]/time1[[1,1]]]$--><!--Robot Land, no human edits to "END"--> -23 5 10 -3 5 13 17 21 25 |
|||
{1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }[[1,1]] |
|||
15 7 |
|||
A A |
|||
Round[--------------------------------------------------------------------------------] |
|||
-23 5 10 -3 5 13 17 21 25 |
|||
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }[[1,1]] |
|||
15 7 |
|||
A A<!--END--> times faster than <code>KB0</code>.) |
|||
The idea here is to maintain a |
The idea here is to maintain a "computation front", a planar domain |
||
which starts empty and gradualy increases until the whole link diagram is |
which starts empty and gradualy increases until the whole link diagram is |
||
enclosed. Within the front, the rules defining the Kauffman bracket, |
enclosed. Within the front, the rules defining the Kauffman bracket, |
||
Equation |
Equation {{Equation Ref|KBDef}}, are applied and the result is expanded as much |
||
as possible. Outside of the front the link diagram remains untouched. At |
as possible. Outside of the front the link diagram remains untouched. At |
||
every step we choose a crossing outside the front with the most legs |
every step we choose a crossing outside the front with the most legs |
||
inside and |
inside and "conquer" it -- apply the rules of {{Equation Ref|KBDef}} and |
||
expand again. As our new outpost is maximally connected to our old |
expand again. As our new outpost is maximally connected to our old |
||
territory, the length of the boundary is increased in a minimal way, and |
territory, the length of the boundary is increased in a minimal way, and |
||
hence the size of the |
hence the size of the "web" within our front remains as small as |
||
possible and thus quick to manipulate. |
possible and thus quick to manipulate. |
||
In further detail, the routine |
In further detail, the routine <code>KB1[pd, inside, web]</code> computes the |
||
Kauffman bracket assuming the labels of the edges inside the front are in |
Kauffman bracket assuming the labels of the edges inside the front are in |
||
the variable |
the variable <code>inside</code>, the already-computed inside of the front is in |
||
the variable |
the variable <code>web</code> and the part of the link diagram yet untouched is |
||
<code>pd</code>. The single argument <code>KB1[pd]</code> simply calls |
|||
<code>KB1[pd, inside, web]</code> with an empty <code>inside</code> and with <code>web</code> set to 1. The three argument <code>KB1[pd, inside, web]</code> finds the position of the crossing maximmally connected to the front using the somewhat |
|||
set to 1. The three argument \verb"KB1[pd, inside, web]" finds the position |
|||
of the crossing maximmally connected to the front using the somewhat |
|||
cryptic assignment |
cryptic assignment |
||
pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]} |
|||
\begin{verbatim} |
|||
pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]} |
|||
\end{verbatim} |
|||
<code>KB1[pd, inside, web]</code> then recursively calls |
|||
itself with that crossing removed from |
itself with that crossing removed from <code>pd}, with its legs |
||
added to the |
added to the <code>inside</code>, and with <code>web</code> updated in accordance |
||
with |
with {{Equation Ref|KBDef}}. Finally, when <code>pd</code> is empty, the output is |
||
simply the value of |
simply the value of <code>web</code>. |
||
{{note|Kauffman}} L. H. Kauffman, ''On knots'', Princeton Univ. Press, Princeton, 1987. |
{{note|Kauffman}} L. H. Kauffman, ''On knots'', Princeton Univ. Press, Princeton, 1987. |
Latest revision as of 19:53, 8 August 2013
(For In[1] see Setup)
|
In Naming and Enumeration we checked that the knots 6_1 and 9_46 have the same Alexander polynomial. Their Jones polynomials are different, though:
In[3]:=
|
Jones[Knot[6, 1]][q]
|
Out[3]=
|
-4 -3 -2 2 2
2 + q - q + q - - - q + q
q
|
In[4]:=
|
Jones[Knot[9, 46]][q]
|
Out[4]=
|
-6 -5 -4 2 -2 1
2 + q - q + q - -- + q - -
3 q
q
|
L8a6 |
On links with an even number of components the Jones polynomial is a function of , and hence it is often more convenient to view it as a function of , where :
In[5]:=
|
Jones[Link[8, Alternating, 6]][q]
|
Out[5]=
|
-(9/2) -(7/2) 3 3 4 3/2
-q + q - ---- + ---- - ------- + 3 Sqrt[q] - 2 q +
5/2 3/2 Sqrt[q]
q q
5/2 7/2
2 q - q
|
In[6]:=
|
PowerExpand[Jones[Link[8, Alternating, 6]][t^2]]
|
Out[6]=
|
-9 -7 3 3 4 3 5 7
-t + t - -- + -- - - + 3 t - 2 t + 2 t - t
5 3 t
t t
|
The Jones polynomial attains 2110 values on the 2226 knots and links known to KnotTheory`
:
In[7]:=
|
all = Join[AllKnots[], AllLinks[]];
|
In[8]:=
|
Length /@ {Union[Jones[#][q]& /@ all], all}
|
Out[8]=
|
{2110, 2226}
|
How is the Jones polynomial computed?
(See also: The Kauffman Bracket using Haskell)
The Jones polynomial is so simple to compute using Mathematica that it's worthwhile pause and see how this is done, even for readers with limited prior programming experience. First, recall (say from [Kauffman]) the definition of the Jones polynomial using the Kauffman bracket :
[KBDef] |
here is a commutative variable, , and is the writhe of , the difference where and count the positive Failed to parse (SVG (MathML can be enabled via browser plugin): Invalid response ("Math extension cannot connect to Restbase.") from server "https://wikimedia.org/api/rest_v1/":): {\displaystyle (\overcrossing)} and negative Failed to parse (SVG (MathML can be enabled via browser plugin): Invalid response ("Math extension cannot connect to Restbase.") from server "https://wikimedia.org/api/rest_v1/":): {\displaystyle (\undercrossing)} crossings of respectively.
Just for concreteness, let us start by fixing to be the trefoil knot shown above:
In[9]:=
|
L = PD[Knot[3, 1]]
|
Out[9]=
|
PD[X[1, 4, 2, 5], X[3, 6, 4, 1], X[5, 2, 6, 3]]
|
Our first task is to perform the replacement Failed to parse (SVG (MathML can be enabled via browser plugin): Invalid response ("Math extension cannot connect to Restbase.") from server "https://wikimedia.org/api/rest_v1/":): {\displaystyle \langle\slashoverback\rangle\to A\langle\hsmoothing\rangle + B\langle\smoothing\rangle} on all crossings of . By our conventions (see Planar Diagrams) the edges around a crossing are labeled , , and : Failed to parse (unknown function "\slashoverback"): {\displaystyle {}^c_d\slashoverback{}_a^b} . Labeling the smoothings Failed to parse (unknown function "\hsmoothing"): {\displaystyle (\hsmoothing, \ \smoothing)} in the same way, Failed to parse (unknown function "\hsmoothing"): {\displaystyle {}^c_d\hsmoothing{}_a^b} and Failed to parse (SVG (MathML can be enabled via browser plugin): Invalid response ("Math extension cannot connect to Restbase.") from server "https://wikimedia.org/api/rest_v1/":): {\displaystyle {}^c_d\smoothing{}_a^b} , we are lead to the symbolic replacement rule . Let us apply this rule to , switch to a multiplicative notation and expand:
In[10]:=
|
t1 = L /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + B P[a,b] P[c,d]
|
Out[10]=
|
PD[A P[1, 5] P[2, 4] + B P[1, 4] P[2, 5],
B P[1, 4] P[3, 6] + A P[1, 3] P[4, 6],
A P[2, 6] P[3, 5] + B P[2, 5] P[3, 6]]
|
In[11]:=
|
t2 = Expand[Times @@ t1]
|
Out[11]=
|
2
A B P[1, 4] P[1, 5] P[2, 4] P[2, 6] P[3, 5] P[3, 6] +
2 2
A B P[1, 4] P[2, 5] P[2, 6] P[3, 5] P[3, 6] +
2 2
A B P[1, 4] P[1, 5] P[2, 4] P[2, 5] P[3, 6] +
3 2 2 2
B P[1, 4] P[2, 5] P[3, 6] +
3
A P[1, 3] P[1, 5] P[2, 4] P[2, 6] P[3, 5] P[4, 6] +
2
A B P[1, 3] P[1, 4] P[2, 5] P[2, 6] P[3, 5] P[4, 6] +
2
A B P[1, 3] P[1, 5] P[2, 4] P[2, 5] P[3, 6] P[4, 6] +
2 2
A B P[1, 3] P[1, 4] P[2, 5] P[3, 6] P[4, 6]
|
In the above expression the product P[1,4] P[1,5] P[2,4] P[2,6] P[3,5] P[3,6] represents a path in which 1 is connected to 4, 1 is connected to 5, 2 is connected to 4, etc. (see the right half of the figure above). We simplify such paths by repeatedly applying the rules and :
In[12]:=
|
t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]}
|
Out[12]=
|
3 2
B P[1, 1] P[2, 2] P[3, 3] + A B P[2, 2] P[4, 4] +
3 2 2
A P[3, 3] P[4, 4] + A B P[3, 3] P[4, 4] + 3 A B P[5, 5] +
2
A B P[1, 1] P[5, 5]
|
To complete the computation of the Kauffman bracket, all that remains is to replace closed cycles (paths of the form by , to replace by , and to simplify:
In[13]:=
|
t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]
|
Out[13]=
|
-9 1 3 7
-A + - + A + A
A
|
We could have, of course, combined the above four lines to a single very short program, that compues the Kauffman bracket from the beginning to the end:
In[14]:=
|
KB0[pd_] := Expand[
Expand[Times @@ pd /. X[a_,b_,c_,d_] :> A P[a,d] P[b,c] + 1/A P[a,b] P[c,d]]
//. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a], P[a_,a_] -> -A^2-1/A^2}]
|
In[15]:=
|
t4 = KB0[PD[Knot[3, 1]]]
|
Out[15]=
|
-9 1 3 7
-A + - + A + A
A
|
We will skip the uninteresting code for the computation of the writhe here; it is a linear time computation, and if that's all we ever wanted to compute, we wouldn't have bothered to purchase a computer. For our the result is , and hence the Jones polynomial of is given by
In[16]:=
|
(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand
|
Out[16]=
|
-4 -3 1
-q + q + -
q
|
L11a548 |
At merely 3 lines of code, our program is surely nice and elegant. But it is very slow:
In[17]:=
|
time0 = Timing[KB0[PD[Link[11, Alternating, 548]]]]
|
Out[17]=
|
-23 5 10 -3 5 13 17 21 25
{1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }
15 7
A A
|
Here's the much faster alternative employed by KnotTheory`
:
In[18]:=
|
KB1[pd_PD] := KB1[pd, {}, 1];
KB1[pd_PD, inside_, web_] := Module[
{pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]},
pd[[pos]] /. X[a_,b_,c_,d_] :> KB1[
Delete[pd, pos],
Union[inside, {a,b,c,d}],
Expand[web*(A P[a,d] P[b,c]+1/A P[a,b] P[c,d])] //. {
P[e_,f_]P[f_,g_] :> P[e,g], P[e_,_]^2 :> P[e,e], P[e_,e_] -> -A^2-1/A^2
}
]
];
KB1[PD[],_,web_] := Expand[web]
|
In[19]:=
|
time1 = Timing[KB1[PD[Link[11, Alternating, 548]]]]
|
Out[19]=
|
-23 5 10 -3 5 13 17 21
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A -
15 7
A A
25
A }
|
(So on L11a548 KB1
is -23 5 10 -3 5 13 17 21 25
{1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }1,1
15 7 A A/ -23 5 10 -3 5 13 17 21 25
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }1,1
15 7 A A ~ -23 5 10 -3 5 13 17 21 25 {1., A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }1,1 15 7 A A
Round[--------------------------------------------------------------------------------]
-23 5 10 -3 5 13 17 21 25
{0.015, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A + 4 A - A }1,1
15 7
A A times faster than KB0
.)
The idea here is to maintain a "computation front", a planar domain which starts empty and gradualy increases until the whole link diagram is enclosed. Within the front, the rules defining the Kauffman bracket, Equation [KBDef], are applied and the result is expanded as much as possible. Outside of the front the link diagram remains untouched. At every step we choose a crossing outside the front with the most legs inside and "conquer" it -- apply the rules of [KBDef] and expand again. As our new outpost is maximally connected to our old territory, the length of the boundary is increased in a minimal way, and hence the size of the "web" within our front remains as small as possible and thus quick to manipulate.
In further detail, the routine KB1[pd, inside, web]
computes the
Kauffman bracket assuming the labels of the edges inside the front are in
the variable inside
, the already-computed inside of the front is in
the variable web
and the part of the link diagram yet untouched is
pd
. The single argument KB1[pd]
simply calls
KB1[pd, inside, web]
with an empty inside
and with web
set to 1. The three argument KB1[pd, inside, web]
finds the position of the crossing maximmally connected to the front using the somewhat
cryptic assignment
pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]}
KB1[pd, inside, web]
then recursively calls
itself with that crossing removed from pd}, with its legs
added to the
inside
, and with web
updated in accordance
with [KBDef]. Finally, when pd
is empty, the output is
simply the value of web
.
[Kauffman] ^ L. H. Kauffman, On knots, Princeton Univ. Press, Princeton, 1987.