The Jones Polynomial: Difference between revisions

From Knot Atlas
Jump to navigationJump to search
m (Reverted edit of 220.70.247.148, changed back to last version by Drorbn)
No edit summary
Line 19: Line 19:
in = <nowiki>Jones[Knot[6, 1]][q]</nowiki> |
in = <nowiki>Jones[Knot[6, 1]][q]</nowiki> |
out= <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>}}
<!--END-->
<!--END-->
Line 29: Line 29:
in = <nowiki>Jones[Knot[9, 46]][q]</nowiki> |
in = <nowiki>Jones[Knot[9, 46]][q]</nowiki> |
out= <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>}}
Line 44: Line 44:
in = <nowiki>Jones[Link[8, Alternating, 6]][q]</nowiki> |
in = <nowiki>Jones[Link[8, Alternating, 6]][q]</nowiki> |
out= <nowiki> -(9/2) -(7/2) 3 3 4 3/2
out= <nowiki> -(9/2) -(7/2) 3 3 4 3/2
-q + q - ---- + ---- - ------- + 3 Sqrt[q] - 2 q +
-q q - ---- ---- - ------- 3 Sqrt[q] - 2 q
5/2 3/2 Sqrt[q]
5/2 3/2 Sqrt[q]
q q
q q
Line 58: Line 58:
in = <nowiki>PowerExpand[Jones[Link[8, Alternating, 6]][t^2]]</nowiki> |
in = <nowiki>PowerExpand[Jones[Link[8, Alternating, 6]][t^2]]</nowiki> |
out= <nowiki> -9 -7 3 3 4 3 5 7
out= <nowiki> -9 -7 3 3 4 3 5 7
-t + t - -- + -- - - + 3 t - 2 t + 2 t - t
-t t - -- -- - - 3 t - 2 t 2 t - t
5 3 t
5 3 t
t t</nowiki>}}
t t</nowiki>}}
<!--END-->
<!--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>:
The Jones polynomial attains <!--$all=Join[AllKnots[], AllLinks[]]; Length[Union[Jones[#][q]

<!--$$all = Join[AllKnots[], AllLinks[]];$$-->
<!--Robot Land, no human edits to "END"-->
{{In|
n = 7 |
in = <nowiki>all = Join[AllKnots[], AllLinks[]];</nowiki>}}
<!--END-->

<!--$$Length /@ {Union[Jones[#][q]& /@ all], all}$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 8 |
in = <nowiki>Length /@ {Union[Jones[#][q]& /@ all], all}</nowiki> |
out= <nowiki>{2110, 2226}</nowiki>}}
<!--END-->

<span id="How is the Jones polynomial computed?">
====How is the Jones polynomial computed?====
</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>:

{{Equation|KBDef|<math>
\langle\emptyset\rangle=1; \qquad
\langle\bigcirc L\rangle = (-A^2-B^2)\langle L\rangle; \qquad
\langle\slashoverback\rangle =
A\langle\hsmoothing\rangle + B\langle\smoothing\rangle;
</math>}}

<center><math> J(L) =
\left.(-A^3)^{w(L)}\frac{\langle L\rangle}{\langle\bigcirc\rangle}\right|_{A\to q^{1/4}},
</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 <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>

Just for concreteness, let us start by fixing <math>L</math> to be the trefoil knot shown above:

<!--$$L = PD[Knot[3, 1]]$$-->
<!--Robot Land, no human edits to "END"-->
{{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>}}
<!--END-->

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
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]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 10 |
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],
A P[2, 6] P[3, 5] + B P[2, 5] P[3, 6]]</nowiki>}}
<!--END-->

<!--$$t2 = Expand[Times @@ t1]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 11 |
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] +
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]</nowiki>}}
<!--END-->

In the above expression the product <tt>P[1,4] P[1,5] P[2,4] P[2,6] P[3,5] P[3,6]</tt> represents a path in which <tt>1</tt> is connected to <tt>4</tt>, <tt>1</tt> is connected to <tt>5</tt>, <tt>2</tt> is connected to <tt>4</tt>, etc. (see the right half of the figure above). We simplify such paths by repeatedly applying the rules <math>P_{ab}P_{bc}\to P_{ac}</math> and <math>P^2_{ab}\to P_{aa}</math>:

<!--$$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"-->
{{InOut|
n = 12 |
in = <nowiki>t3 = t2 //. {P[a_,b_]P[b_,c_] :> P[a,c], P[a_,b_]^2 :> P[a,a]}</nowiki> |
out= <nowiki> 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]</nowiki>}}
<!--END-->

To complete the computation of the Kauffman bracket, all that remains is to replace closed cycles (paths of the form <math>P_{aa}</math> by <math>-A^2-B^2</math>, to replace <math>B</math> by <math>A^{-1}</math>, and to simplify:

<!--$$t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 13 |
in = <nowiki>t4 = Expand[t3 /. P[a_,a_] -> -A^2-B^2 /. B -> 1/A]</nowiki> |
out= <nowiki> -9 1 3 7
-A + - + A + A
A</nowiki>}}
<!--END-->

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:

<!--$$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}]$$-->
<!--Robot Land, no human edits to "END"-->
{{In|
n = 14 |
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]]
//. {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>}}
<!--END-->

<!--$$t4 = KB0[PD[Knot[3, 1]]]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 15 |
in = <nowiki>t4 = KB0[PD[Knot[3, 1]]]</nowiki> |
out= <nowiki> -9 1 3 7
-A + - + A + A
A</nowiki>}}
<!--END-->

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 <math>L</math> the result is <math>-3</math>, and hence the Jones polynomial of <math>L</math> is given by

<!--$$(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 16 |
in = <nowiki>(-A^3)^(-3) * t4 / (-A^2-1/A^2) /. A -> q^(1/4) // Simplify // Expand</nowiki> |
out= <nowiki> -4 -3 1
-q + q + -
q</nowiki>}}
<!--END-->

{{Knot Image|L11a548|gif}}

At merely 3 lines of code, our program is surely nice and elegant. But it is very slow:

<!--$$time0 = Timing[KB0[PD[Link[11, Alternating, 548]]]]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 17 |
in = <nowiki>time0 = Timing[KB0[PD[Link[11, Alternating, 548]]]]</nowiki> |
out= <nowiki> -23 5 10 -3 5 13 17
{1.594 Second, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A +
15 7
A A
21 25
4 A - A }</nowiki>}}
<!--END-->

Here's the much faster alternative employed by <code>KnotTheory`</code>:

<!--$$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]$$-->
<!--Robot Land, no human edits to "END"-->
{{In|
n = 18 |
in = <nowiki>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]</nowiki>}}
<!--END-->

<!--$$time1 = Timing[KB1[PD[Link[11, Alternating, 548]]]]$$-->
<!--Robot Land, no human edits to "END"-->
{{InOut|
n = 19 |
in = <nowiki>time1 = Timing[KB1[PD[Link[11, Alternating, 548]]]]</nowiki> |
out= <nowiki> -23 5 10 -3 5 13 17
{0.031 Second, A + --- + -- + A + 6 A + 6 A + 5 A - 5 A +
15 7
A A
21 25
4 A - A }</nowiki>}}
<!--END-->

(So on [[L11a548]] <code>KB1</code> is <!--$time0[[1,1]]$--><!--Robot Land, no human edits to "END"-->1.594<!--END-->/<!--$time1[[1,1]]$--><!--Robot Land, no human edits to "END"-->0.031<!--END--> ~ <!--$Round[time0[[1,1]]/time1[[1,1]]]$--><!--Robot Land, no human edits to "END"-->51<!--END--> times faster than <code>KB0</code>.)

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 {{Equation Ref|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 {{Equation Ref|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 <code>KB1[pd, inside, web]</code> computes the
Kauffman bracket assuming the labels of the edges inside the front are in
the variable <code>inside</code>, the already-computed inside of the front is in
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
cryptic assignment

pos = First[Ordering[Length[Complement[List @@ #, inside]]& /@ pd]]}

<code>KB1[pd, inside, web]</code> then recursively calls
itself with that crossing removed from <code>pd}, with its legs
added to the <code>inside</code>, and with <code>web</code> updated in accordance
with {{Equation Ref|KBDef}}. Finally, when <code>pd</code> is empty, the output is
simply the value of <code>web</code>.

{{note|Kauffman}} L. H. Kauffman, ''On knots'', Princeton Univ. Press, Princeton, 1987.

Revision as of 01:09, 1 July 2007


KnotTheory`/Navigation 

The Mathematica Package KnotTheory`

(For In[1] see Setup)

In[2]:= ?Jones
Jones[L][q] computes the Jones polynomial of a knot or link L as a function of the variable q.

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.gif
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

Retrieved from "https://katlas.org/index.php?title=The_Jones_Polynomial&oldid=58435"