<<KnotTheory`

Goeritz matrix from PD code (for alternating or nonlternating knots or links)

First argument is PD code of a knot or link.  Can use e.g. PD[DTcode[4,6,2]] as argument if DT code is given.
Optional arguments : second argument 0 or 1 determines colour choice (default is 0).  Third argument True or False determines whether to also return Gordon-Litherland mu value, for use in computing link signature.
Remark: as far as I know this should compute Goeritz of any nonsplit diagram.  The mu computation should be correct for any diagram all of whose components pass through at least 3 crossings.

Goeritz[pd__,colour_:0,returnmu_:False]:=  Module[{CCs,mucompare,mu,crossingnumber,vec,tempregions,regions,i,leadingedge,nextcrossing,pos,sqrteta,posplus,connected,newregion,newvec,foundleft,foundright,j,leftfound=0,rightfound=0,M,Gregions,G},  
(* written by Brendan Owens, 2015 *)
  
CCs=Table[pd[[i]][[j]],{i,Length[pd]},{j,4}];  (* CCs are crossing codes -- just repackaged PD in list of lists *)
If[colour==1,CCs=RotateRight/@CCs];
crossingnumber=Length[CCs];
vec[i_,x_]:=Normal[SparseArray[{i->x},crossingnumber]] ;(* makes a vector of length crossingnumber with one nonzero entry x in position i; for use in building the edge-region adjacency matrix *)
tempregions={{CCs[[1,1;;2]],vec[1,1]},{CCs[[1,3;;4]],vec[1,-1]}} ;
(* tempregions are the regions under construction, i.e. incomplete; each region has an associated vector which will give a column of the edge-region adjacency matrix *)
mucompare[a_,b_]:=If[Abs[b-a]==1,b-a,-Sign[b-a]];
mu=If[mucompare[CCs[[1,3]],CCs[[1,1]]]*mucompare[CCs[[1,2]],CCs[[1,4]]]>0, (* this condition determines if first crossing is type II s in Gordon-Litherland *)
1,0];
(* mu is the correction term from Gordon-Litherland for computing signature, i.e. sum over type II crossings of eta *)
regions={}; (* this list will hold regions and their edge-adjacency column vectors *)
CCs=Drop[CCs,1]; (* remove first crossing and `process' it *)
For[i=2,i≤crossingnumber,i++,
leadingedge=Last[tempregions[[1,1]]]; (* build region in clockwise direction *)
nextcrossing=Flatten[Select[CCs,MemberQ[#,leadingedge]&]]; (* the next crossing for this region *)
CCs=Complement[CCs,{nextcrossing}]; (* remove this crossing and `process' it *)
pos=First[Flatten[Position[nextcrossing,leadingedge]]];
sqrteta=If[OddQ[pos],1,I];
mu=mu+If[mucompare[nextcrossing[[3]],nextcrossing[[1]]]*mucompare[nextcrossing[[2]],nextcrossing[[4]]]*sqrteta^2>0,(* i.e. if Type II *)
sqrteta^2,0];
posplus=Mod[pos,4]+1;
AppendTo[tempregions[[1,1]],nextcrossing[[posplus]]];
tempregions[[1,2]]=tempregions[[1,2]]+vec[i,sqrteta];
(* now need to check if new crossing has any other connection to the regions we have so far
first check if it connects the current region to another *)
connected=False;
For[j=2,j<=Length[tempregions]&&Not[connected],j++,
If[nextcrossing[[posplus]]==First[tempregions[[j,1]]],
tempregions[[1,1]]=Join[tempregions[[1,1]],Drop[tempregions[[j,1]],1]];
tempregions[[1,2]]=tempregions[[1,2]]+tempregions[[j,2]];
tempregions=Drop[tempregions,{j}];
connected=True ]
];
(* then check if the new region from this crossing connects to any others *)
newregion={nextcrossing[[Mod[pos+1,4]+1]],nextcrossing[[Mod[pos+2,4]+1]]};
newvec=vec[i,-sqrteta];
foundleft=False;
foundright=False;
For[j=2,j<=Length[tempregions]&&Not[foundleft&&foundright],j++,
If[Not[foundleft]&&newregion[[1]]==Last[tempregions[[j,1]]],AppendTo[tempregions[[j,1]],newregion[[2]]];tempregions[[j,2]]=tempregions[[j,2]]+newvec;foundleft=True;leftfound=j];
If[Not[foundright]&&newregion[[2]]==First[tempregions[[j,1]]]&&Not[foundleft&&leftfound==j],PrependTo[tempregions[[j,1]],newregion[[1]]];tempregions[[j,2]]=tempregions[[j,2]]+newvec;foundright=True;rightfound=j]
]; (* end For[j=2 *)
If[Not[foundleft]&&Not[foundright],AppendTo[tempregions,{newregion,newvec}]];
(* if just joined two ends together check if closed up a region *)
If[foundleft && First[tempregions[[leftfound,1]]]==Last[tempregions[[leftfound,1]]],AppendTo[regions,tempregions[[leftfound]]];tempregions=Drop[tempregions,{leftfound}]];
(* if adjoined newregion to two different then join them together *)
If[foundleft&&foundright,tempregions[[leftfound,1]]=Join[tempregions[[leftfound,1]],tempregions[[rightfound,1,3;;-1]]];tempregions[[leftfound,2]]=tempregions[[leftfound,2]]+tempregions[[rightfound,2]]-newvec;tempregions=Drop[tempregions,{rightfound}]];
(* now check if first region is finished *)
If[ First[tempregions[[1,1]]]==Last[tempregions[[1,1]]],AppendTo[regions,tempregions[[1]]];tempregions=Drop[tempregions,{1}]];
]; (* end For[i=2 *)
Gregions=Drop[regions,{-1}]; (* drop a region *)
M=Gregions[[All,2]];
G=If[colour==0,M.Transpose[M],-M.Transpose[M]]; (* Goeritz *)
If[returnmu,{mu,G},G]
]

Goeritz[PD[Link[2,Alternating,1]],0]

Goeritz[PD[X[1,8,2,7],X[5,2,8,1],X[3,6,4,5],X[6,3,7,4]],0,True]

Components from PD code

Comps[pd__]:=Module[{CCs,crossingnumber,startarc,nextarc,nextcrossing,tempCCs,pos},

CCs=Table[pd[[i]][[j]],{i,Length[pd]},{j,4}];  (* CCs are crossing codes -- just repackaged PD in list of lists *)
crossingnumber=Length[CCs];
startarc=Min[Flatten[CCs]];nextarc=startarc;tempCCs=CCs;comps={};thiscomp={nextarc};
While[Length[Flatten[comps]]<2*crossingnumber,
nextcrossing=Select[tempCCs,MemberQ[#,nextarc]&][[1]];(* find a crossing containing nextarc *)
tempCCs=Complement[CCs,{nextcrossing}];(* temporarily remove this crossing *)
pos=First[Flatten[Position[nextcrossing,nextarc]]];
nextarc=nextcrossing[[Mod[pos+1,4]+1]];
If[nextarc==startarc,AppendTo[comps,thiscomp];startarc=Min[Complement[Flatten[CCs],Flatten[comps]]];nextarc=startarc;thiscomp={nextarc};tempCCs=CCs,AppendTo[thiscomp,nextarc]]
];comps]

Comps[PD[Link[10,NonAlternating,94]]]

Comps[PD[Link[4,Alternating,1]]]

Comps[PD[X[8,6,12,3],X[5,12,6,1],X[1,4,2,5],X[3,2,4,8]]]

pd=PD[Link[4,Alternating,1]]

Flatten[pd]

CCs=Table[pd[[i]][[j]],{i,Length[pd]},{j,4}]

Flatten[CCs]

Min[%]

CCs

CCs[[1,1]]

Quasiorientations from PD code

QuasiOr[pd__]:=Module[{QOs,thispd,comps,k,j,i,q,jthcomp,complength,compswitch},

QOs={pd};
comps=Comps[pd];
k=Length[comps];
thispd=pd;
For[i=1,i<2^(k-1),i++,
j=1;q=i;
While[IntegerQ[q],
jthcomp=comps[[j]];
complength=Length[jthcomp];
compswitch=Table[jthcomp[[i]]->jthcomp[[complength+1-i]],{i,complength}];
thispd=thispd/.compswitch;
q=q/2;j=j+1
];
AppendTo[QOs,thispd];
];
QOs
]

PD[Link[11,NonAlternating,334]]

QuasiOr[PD[Link[11,NonAlternating,334]]]

Signature and nullity of symmetric matrix

Uses method of counting “permanences of sign” of leading principal minors, after permuting basis to obtain regular matrix (see Burton W. Jones, Arithmetic Theory of Quadratic Forms, Chapter 1, Section 3).

matrixsignull[M__]:=Module[{sizeM,sigM,minor,subbasis,subrank,basis1,rankfound,zerominor,restofbasis,onefound,i,testbasis,testminor,nullity,secondelements},
  (* written by Brendan Owens, 2015 *)
sizeM=Length[M];
sigM=0; (* this will be the signature, which we will successively calculate for larger leading principal submatrices *)
subbasis={};(* this gives the basis of the leading principal submatrix considered so far *)
minor=1;(* this is the leading principal minor considered so far *)
restofbasis=Table[i,{i,sizeM}];(* this gives the original basis less the subbasis *)
subrank=0;(* this gives the rank of the leading principal submatrix considered so far *)
rankfound=False; (* this is true when we have a leading principal submatrix of maximal rank *)
While[Not[rankfound],
onefound=Catch[
Do[(* try to adjoin one more basis element to subbasis so corresponding principal minor is nonzero *)
testbasis=Join[subbasis,{i}];
testminor=Det[M[[testbasis,testbasis]]];
If[testminor!=0,(* if we have found a basis element to adjoin giving nonzero minor, then do so *)
subbasis=testbasis;subrank=subrank+1;
sigM=sigM+Sign[minor*testminor];(* adjust the signature accordingly -- see Jones *)
minor=testminor;
If[Length[subbasis]==sizeM,rankfound=True;nullity=0,restofbasis=Complement[restofbasis,{i}]];(* check if finished *)
Throw[True]
] (* end If[testminor!=0 *)
,{i,restofbasis}]; (* end Do[(* try to adjoin... *) *) 
Throw[False](* i.e. have not found one basis element to adjoin giving nonzero minor *)
]; (* end onefound=Catch[ *)
If[Not[onefound],(* getting a zero after adjoining any possible basis element to subbasis *)
If[Length[restofbasis]==1, (* we are finished in this case -- no pair of basis elements to try *)
nullity=1;rankfound=True,
(* now try all ways of adjoining two basis elements *)
secondelements=Drop[restofbasis,1];
twofound=Catch[
Do[(* go through 1st basis element to adjoin *)
Do[(* go through 2nd basis element to adjoin *)
testbasis=Join[subbasis,{i,j}];
testminor=Det[M[[testbasis,testbasis]]];
If[testminor!=0,(* if we have found a pair of basis elements to adjoin giving nonzero minor, then do so *)
subbasis=testbasis;subrank=subrank+2;(* note signature does not change -- pick up one eigenvalue of each sign -- see Jones *)
minor=testminor;
If[Length[subbasis]==sizeM,rankfound=True;nullity=0,restofbasis=Complement[restofbasis,{i,j}]];(* check if finished *)
Throw[True]
](* end If[testminor!=0 *)
,{j,secondelements}](* end Do[(* go through 2nd... *)*) 
,{i,restofbasis}]; (* end Do[(* go through 1st... *)*)
Throw[False]
](* end twofound=Catch[ *)
];(* end If[Length[restofbasis]==1 *) 
If[Not[twofound],(* getting zero minor after adjoining any possible pair to subbasis; conclude from Jones Lemma 2 we are finished *)
nullity=sizeM-subrank;
rankfound=True
] (* end If[Not[twofound]] *) 
] (* end If[Not[onefound]] *) 
]; (* end While[Not[rankfound] *)
{sigM,nullity}
]

G=(({{2, -1, 0, 0, -1, -1, 0, 0, 0}, {-1, 2, -1, 0, 0, 0, 0, 0, 0}, {0, -1, 3, -1, 0, 0, 0, 0, 0}, {0, 0, -1, 3, -2, 0, 0, 0, 0}, {-1, 0, 0, -2, 3, 0, 0, 0, 0}, {-1, 0, 0, 0, 0, 3, -1, 0, -1}, {0, 0, 0, 0, 0, -1, 2, -1, 0}, {0, 0, 0, 0, 0, 0, -1, 2, 0}, {0, 0, 0, 0, 0, -1, 0, 0, 2}}))

Det[G]

matrixsignull[G]

Eigenvalues[1.0*G]

G=(({{3, -1, -2, 1, 0}, {-1, 2, -1, 0, 0}, {-2, -1, 5, 0, 0}, {1, 0, 0, 3, -3}, {0, 0, 0, -3, 5}}))

Det[G]
matrixsignull[G]
Eigenvalues[1.0*G]

M={{-2,1,1,0,0,0,1,0,0,0},{1,-3,0,0,0,0,0,0,0,0},{1,0,-2,1,0,0,0,0,0,0},{0,0,1,-2,1,0,0,0,0,0},{0,0,0,1,-2,1,0,0,0,0},{0,0,0,0,1,-2,0,0,0,0},{1,0,0,0,0,0,-2,1,0,0},{0,0,0,0,0,0,1,-2,1,0},{0,0,0,0,0,0,0,1,-2,1},{0,0,0,0,0,0,0,0,1,-2}};
M//MatrixForm
Det[M]
matrixsignull[M]
Eigenvalues[1.0*M]

M={{-1,1,0,1,0,1,0},{1,-3,1,0,0,0,0},{0,1,-2,0,0,0,0},{1,0,0,-4,1,0,0},{0,0,0,1,-2,0,0},{1,0,0,0,0,-4,1},{0,0,0,0,0,1,-2}};
M//MatrixForm
Det[M]
matrixsignull[M]
Eigenvalues[1.0*M]

matrixsignull[{{1,1},{1,0}}]

G=Goeritz[PD[Link[11,NonAlternating,334]],0,True];
G//MatrixForm
matrixsignull[G]
Eigenvalues[1.0*G]

Determinant, signature and nullity of links (for all possible quasiorientations)

Remark : this computes determinant, nullity and signatures of a link using Gordon-Litherland formula.  Designed for use with diagrams all of whose components pass through 3 or more crossings.

SigNull[pd__]:=Module[{G,QOs,Gmu,sigG,nulG},

QOs=QuasiOr[pd];
Gmu=Goeritz[#,0,True]&/@QOs;(* this returns a Goeritz matrix together with Gordon-Litherland correction term mu for each quasiorientation *)
{sigG,nulG}=
matrixsignull[Gmu[[1,2]]];
{Abs[Det[Gmu[[1,2]]]],nulG,sigG-Gmu[[All,1]]}
]

SigNull[PD[Link[11,NonAlternating,334]]]

?ConnectedSum

HopfSumHopf=PD[ConnectedSum[Link[2,Alternating,1],Link[2,Alternating,1]]]

Goeritz[HopfSumHopf,0,True]

Data to compare with LinkInfo

Remarkably, the output below matches perfectly with that on LinkInfo.

name[link_]:="L"<>ToString[link[[1]]]<>If[ToString[link[[2]]]==ToString[Alternating],"a","n"]<>ToString[link[[3]]];
Do[signull=SigNull[PD[link]];
number=Length[signull[[3]]];
linkname=name[link];
For[i=1,i≤number,i++,
Print[{linkname,signull[[1]],signull[[3,i]],signull[[2]]}]]
,{link,AllLinks[{2,11}]}]

Miscellaneous

Show[DrawPD[Knot[3,1]]]

Show[DrawPD[Link[10,NonAlternating,71]]]

Show[DrawMorseLink[Link[10,NonAlternating,71]]]