Pensieve header: Weave knots computations.

Following Roland’s MatTheta3.nb.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Theta"];
<<Theta.m

(*Example calculation*)
ThetaTrefoil=Θ[{{{1,1,4},{1,5,2},{1,3,6}},{0,0,0,-1,0,0,0}}]

PolyPlot[ThetaTrefoil]

Some more complicated knots

A mat-shaped knot based on an m by n rectangular grid. The integers m,n should be even and the crossings can be chosen arbitrarily.
Probably all knots can be brought into this form.

(*m,n, even, by default all xings positive.  The list negxs flips the sign of those crossings.*)
Weave[m_,n_,negxs_:{}]:=Module[{pd},pd=(Flatten@Table[
Switch[
{EvenQ[x],EvenQ[y]},
{True,True},
X[m n+y m+m-x-1,n x+y+1,m n+y m+m-x,n x+y],
{True,False},
X[n x +y,m n+y m+x+1,n x+y+1,m n+y m+x],
{False,True},
X[n x+n-y-1,m n+y m+m-x,n x+n-y,m n+y m+m-x-1],
{False,False},
X[m n+y m+x,n x+n-y,m n+y m+x+1,n x+n-y-1]
]
,{x,0,m-1},{y,0,n-1}]
)/.{X[a_,b_,c_,d_]:>X[a+1,b+1,c+1,d+1]};
Do[pd[[i]]=(pd[[i]]/.{X[a_,b_,c_,d_]:>X[d,a,b,c]}),{i,negxs}];
PD@@pd
]
(*Randomly assign signs to all crossings*)
RandWeave[m_,n_]:=Weave[m,n,RandomSample[Range[m n],RandomInteger[{0,m n}]]]

DrawXing[x_,y_,cut_]:=If[cut==="v",{Line[{{x,y-(1/2)},{x,y-(1/4)}}],Line[{{x,y+(1/4)},{x,y+(1/2)}}],Line[{{x-(1/2),y},{x+(1/2),y}}]},{Line[{{x,y-(1/2)},{x,y+(1/2)}}],Line[{{x-(1/2),y},{x-(1/4),y}}],Line[{{x+(1/4),y},{x+(1/2),y}}]}]

DrawWeave[m_,n_,negxs_:{}]:=Graphics[{Thickness[0.1/Max[m,n]],
Table[
Switch[
{EvenQ[x],EvenQ[y]},
{True,True},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"v","h"]],
{True,False},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"h","v"]],
{False,True},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"h","v"]],
{False,False},
DrawXing[x,y,If[MemberQ[negxs,y m+x+1],"v","h"]]
]
,{x,0,m-1},{y,0,n-1}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{x,((-1)/2)},{x,-1},{x+1,-1},{x+1,((-1)/2)}}]]},{x,1,m-3,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{x,n-(1/2)},{x,n},{x+1,n},{x+1,n-(1/2)}}]]},{x,0,m-2,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{((-1)/2),y},{-1,y},{-1,y+1},{((-1)/2),y+1}}]]},{y,0,n-2,2}],
Table[{Arrowheads[{{0,.7}}],Arrow[BezierCurve[{{m+((-1)/2),y},{m,y},{m,y+1},{m+((-1)/2),y+1}}]]},{y,1,n-3,2}],
BezierCurve[{{m-1,((-1)/2)},{m-1,-1},{m,0},{m-(1/2),0}}],
{Arrowheads[{{0,1}}],Arrow[{{m-(1/2),n-1},{m,n-1}}]},
{Arrowheads[{{0,0.5}}],Arrow[{{0,-1},{0,((-1)/2)}}]}

}]
DrawRandWeave[m_,n_]:=DrawWeave[m,n,RandomSample[Range[m n],RandomInteger[m n]]]

DrawWeave[8,6]

DrawWeave[8,6,{1,6}]
DrawRandWeave[20,20]

DrawRandWeave[50,50]

DrawRandWeave[30,30]

RandWeavePair[m_,n_]:=Module[{nxs=RandomSample[Range[m n],RandomInteger[m n]]},{DrawWeave[m,n,nxs],PolyPlot@Θ@Weave[m,n,nxs]}]

GraphicsGrid[Table[RandWeavePair[4,2],{j,7}]//Transpose]

GraphicsGrid[Table[RandWeavePair[6,8],{j,7}]//Transpose]

(*The knots Weave[m,n] are both alternating and also positive. This seems to make their theta look especially simple. The sides of the hexagon (i.e. the coefficient of the maximal power of (Subscript[T, 2])) are in this case conjectured to be always equal to half the signature times the Alexander polynomial in (Subscript[T, 1]). Below we print the first few square ones.*)

SquareWeaves=GraphicsGrid@Transpose@Table[{DrawWeave[n,n],PolyPlot@Θ@Weave[n,n]},{n,4,12,2}]

Export["figs/SquareWeaves.pdf",SquareWeaves]

Select[Range[100], Random[]<0.5&]

RandomWeave=With[{m=12,n=12},
Module[{nxs=Select[Range[m n], Random[]<0.5&]},GraphicsRow[{DrawWeave[m,n,nxs],PolyPlot@Θ@Weave[m,n,nxs]}]]
]

Export["figs/RandomWeave.pdf",RandomWeave]

GraphicsRow[Table[
ImageCompose[
PolyPlot[Θ[Weave[n,n]], ImageSize->480],
Show[DrawWeave[n,n], ImageSize->240],
{Right,Bottom},{Right,Bottom}],
{n,2,10,2}]]