Pensieve header: Roland’s notebook on Mat/Weave knots.

(*Please ignore*)
CF[ℰ_] := Module[{vs=Union@Cases[ℰ,(Subscript[g, __]),∞],ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> Factor[c](Times@@(vs^ps))] ];

(*The formulas*)
(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);
(Subscript[R, 1])[s_,i_,j_]=CF[s(1/2-(Subscript[g, 3,i,i])+(Subscript[T, 2]^s)(Subscript[g, 1,i,i])(Subscript[g, 2,j,i])-(Subscript[g, 1,i,i])(Subscript[g, 2,j,j])-((Subscript[T, 2]^s)-1)(Subscript[g, 2,j,i])(Subscript[g, 3,i,i])+2(Subscript[g, 2,j,j])(Subscript[g, 3,i,i])-(1-(Subscript[T, 3]^s))(Subscript[g, 2,j,i])(Subscript[g, 3,j,i])-(Subscript[g, 2,i,i])(Subscript[g, 3,j,j])-(Subscript[T, 2]^s)(Subscript[g, 2,j,i])(Subscript[g, 3,j,j])+(Subscript[g, 1,i,i])(Subscript[g, 3,j,j])+(((Subscript[T, 1]^s)-1)(Subscript[g, 1,j,i])((Subscript[T, 2]^(2s))(Subscript[g, 2,j,i])-(Subscript[T, 2]^s)(Subscript[g, 2,j,j])+(Subscript[T, 2]^s)(Subscript[g, 3,j,j]))+((Subscript[T, 3]^s)-1)(Subscript[g, 3,j,i])(1-(Subscript[T, 2]^s)(Subscript[g, 1,i,i])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])+(Subscript[g, 2,i,j])))/((Subscript[T, 2]^s)-1))];
θ[{s0_,i0_,j0_},{s1_,i1_,j1_}]:=CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))]
(Subscript[Γ, 1])[φ_,k_]=-φ/2+φ (Subscript[g, 3,k,k]);

(*The main program*)
θ[K_PD]:=θ[Rot[K]]
θ[{Cs_,φ_}]:=Module[{n,A,s,i,j,k,Δ,G,ν,α,β,gEval,c,z},
 n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
gEval[ℰ_]:=Factor[ℰ/.(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))];
z=gEval[(∑_(k1=1)^n)(∑_(k2=1)^n)θ[Cs[[k1]],Cs[[k2]]]];
z+=gEval[(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]]];
z+=gEval[(∑_(k=1)^(2n))(Subscript[Γ, 1])[φ[[k]],k]];
{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))z}//Factor ];

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

(*For plotting the output nicely*)
PolyPlot[{Δ_,θ_}]:=Module[{crs,m,m1,m2,maxc,minc,s,,rect,hex},GraphicsColumn[{
rect={{0,0},{1,0},{1,1},{0,1}};
hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
If[Expand[Δ]===0,Graphics[],
crs=CoefficientRules[(T^(m=-Exponent[Δ,T,Min]))Δ,{T}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[crs/.({x_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
Polygon[({x+m-1/2,0}+#)&/@rect] }, AspectRatio->1/5 ]
],
If[Expand[θ]===0,Graphics[{White,Disk[]}],
crs=CoefficientRules[(Subscript[T, 1]^(m1=-Exponent[θ,(Subscript[T, 1]),Min]))(Subscript[T, 2]^(m2=-Exponent[θ,(Subscript[T, 2]),Min]))θ,{(Subscript[T, 1]),(Subscript[T, 2])}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[{{White,Disk[{0,0},1+Cos[2π/12]Norm[{m1,m2}]/(Sqrt[2])]},
crs/.({x1_,x2_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
Polygon[((({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1-m1,x2-m2}+#)&/@hex] }
}]
]
},Spacings -> 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.

PositiveQ[X[a_,b_,c_,d_]]:=If[b<d,False,True]
Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
{xs/.{Xp[i_,j_]:>{+1,i,j}, Xm[i_,j_]:>{-1,i,j}},rots} ];
Rot[K_]:=Rot[PD[K]];

(*m,n, even, by default all xings positive.  The list negxs flips the sign of those crossings.*)
Mat[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*)
RandMat[m_,n_]:=Mat[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}}]}]

DrawMat[m_,n_,negxs_:{}]:=Graphics[{
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)}}]}

}]
DrawRandMat[m_,n_]:=DrawMat[m,n,RandomSample[Range[m n],RandomInteger[m n]]]

DrawMat[8,6]

DrawMat[8,6,{1,6}]
DrawRandMat[20,20]

DrawRandMat[50,50]

DrawRandMat[30,30]

RandMatPair[m_,n_]:=Module[{nxs=RandomSample[Range[m n],RandomInteger[m n]]},{DrawMat[m,n,nxs],PolyPlot@θ@Mat[m,n,nxs]}
]

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

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

(*The knots Mat[m,n] are both alternating and also positive, and thus fibered. 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.*)

GraphicsGrid@Table[{DrawMat[n,n],PolyPlot@θ@Mat[n,n]},{n,2,10,2}]