(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



SetAttributes[{P,S}, Orderless];
dot /: dot[_]^k_ /; k>=2 := 0;
(\[Sigma]_S)[i_] := \[Sigma][i] = First@Cases[\[Sigma], P[i,j_] :> j];


ECP[\[Lambda]_List] := Module[{\[Rho], ec=\[Lambda]}, (* "Equivalence Class Projection" *)
Do[ \[Rho] = First /@ Position[ec, i];
ec=Append[Delete[ec, List /@ \[Rho]], Union@@(ec[[\[Rho]]])],
{i, Union @@ \[Lambda]} ];
Union@@Replace[ec, c_ :> ((# -> First[c])& /@ c), {1}] ];
ECP[\[Lambda]__S] := ECP[Join[\[Lambda]] /. S|P->List];
ECR[\[Lambda]__] := Union[Last /@ ECP[\[Lambda]]]  (* "Equiv. Class Representatives" *);


VCLaw[\[Beta]_S, \[Mu]_S, \[Tau]_S] := VCLaw[\[Beta],\[Mu],\[Tau]]=Module[
{p, ins1, ins2, outs, \[Chi]s, h, law1, law2, dec} ,
p=ECP[\[Beta],\[Mu],\[Tau]];
ins1=ECR[\[Beta],\[Mu]]; ins2=ECR[\[Mu],\[Tau]]; outs=ECR[\[Beta],\[Tau]];
\[Chi]s = Times @@ (h/@ Join[ins1, ins2, outs] /. p)/ PowerExpand[(Times @@ (h /@ (Last /@ p)))^(1/2)];
dec = \[Chi]s /. h[i_]^\[Chi]_. :> (2dot[i])^((2-\[Chi])/2);
dec *= Product[If[i==(i/.p), 1, dot[i]+dot[i/.p]], {i,outs}];
law1=Table[dot[i]->dot[i/.p], {i,ins1}];
law2=Table[dot[i]->dot[i/.p], {i,ins2}];
{law1, law2, Expand[dec]}];
VC[Cob[\[Beta]_S, \[Mu]_S, dots1_], Cob[\[Mu]_S, \[Tau]_S, dots2_]] := Module[
{law1, law2, dec}, {law1, law2, dec} = VCLaw[\[Beta],\[Mu],\[Tau]];
Expand[dec*(dots1/.law1)(dots2/.law2)] ];


m0[i_,j_][\[Sigma]_S] := m0[i,j][\[Sigma]] = Which[
\[Sigma][i]!=j, Append[DeleteCases[\[Sigma], P[i,_]|P[_,j]], P[\[Sigma][i],\[Sigma][j]]],
\[Sigma][i]==j, DeleteCases[\[Sigma], P[i,j]]];
m[i_,j_][\[Sigma]_S] := m0[i,j][\[Sigma]]*If[\[Sigma][i]!=j, {1}, {q,q^-1}];
m[i_,j_][q^k_. \[Sigma]_S] := q^k m[i,j][\[Sigma]];


m[i_,j_][Cob[\[Beta]_S, \[Tau]_S, dots_]] := Module[{p, ijdot, ndots, x},
p=ECP[\[Beta],\[Tau]]; ijdot=dot[Min[i,j]];
ndots = Which[
\[Beta][i]!=j && \[Tau][i]!=j, {{If[(i/.p)!=(j/.p), 1, dot[\[Beta][i]]+dot[\[Tau][i]]]}},
\[Beta][i]==j && \[Tau][i]!=j, {{1, ijdot}},
\[Beta][i]!=j && \[Tau][i]==j, {{ijdot},{1}},
\[Beta][i]==j && \[Tau][i]==j, ({
 {ijdot, 0},
 {1, ijdot}
})];
ndots=Expand[dots*ndots] /. dot[k_] :> dot[k /. {i->\[Beta][i], j->\[Beta][j]} /. {i->\[Tau][i], j->\[Tau][j]} /. ECP[m0[i,j][\[Beta]],m0[i,j][\[Tau]]] ];
If[\[Beta][i]==j && \[Tau][i]==j, Coefficient[ndots /. ijdot -> x, x], ndots]];


m[i_,j_][Kom[\[CapitalOmega]_, d_]] := Kom[
Flatten /@ Map[m[i,j], \[CapitalOmega], {2}],
Table[
If[Length[\[CapitalOmega][[k]]]==0 || Length[\[CapitalOmega][[k+1]]]==0, 0,
Table[
m[i,j][Cob[\[CapitalOmega][[k,b]]/. q -> 1, \[CapitalOmega][[k+1, a]] /. q -> 1, d[[k,a,b]]]],
{a, Length[\[CapitalOmega][[k+1]]]}, {b, Length[\[CapitalOmega][[k]]]}
] // ArrayFlatten  ],
{k,Length[d]}]  ];


(Kom[\[CapitalOmega]_, d_]//Cob[q^p1_. \[Beta]_, q^p2_. \[Tau]_, 1]) := Module[{L, \[Rho], \[Delta], k},
L=Length[\[CapitalOmega]]; Subscript[\[Rho], k_] := Subscript[\[Rho], k]=Length[\[CapitalOmega][[k]]]; Subscript[\[Rho], 0]=Subscript[\[Rho], L+1]=0;
Kom[
MapThread[Join, List @@@ {
Append[\[CapitalOmega] /. \[Sigma]_S :> q^p1 Join[\[Beta],\[Sigma]], {}],
Prepend[\[CapitalOmega] /. \[Sigma]_S :> q^p2 Join[\[Tau],\[Sigma]], {}] }],
Table[
If[Subscript[\[Rho], k]+Subscript[\[Rho], k-1]==0 || Subscript[\[Rho], k+1]+Subscript[\[Rho], k]==0, 0,
\[Delta]=Table[0, {Subscript[\[Rho], k+1]+Subscript[\[Rho], k]}, {Subscript[\[Rho], k]+Subscript[\[Rho], k-1]}];
If[Subscript[\[Rho], k] Subscript[\[Rho], k+1]!=0, \[Delta][[1;;Subscript[\[Rho], k+1], 1;;Subscript[\[Rho], k]]]=d[[k]]];
If[Subscript[\[Rho], k]!=0, \[Delta][[Subscript[\[Rho], k+1]+1;;Subscript[\[Rho], k+1]+Subscript[\[Rho], k], 1;;Subscript[\[Rho], k]]]=(-1)^k IdentityMatrix[Subscript[\[Rho], k]]];
If[Subscript[\[Rho], k-1] Subscript[\[Rho], k]!=0, \[Delta][[Subscript[\[Rho], k+1]+1;;Subscript[\[Rho], k+1]+Subscript[\[Rho], k], Subscript[\[Rho], k]+1;;Subscript[\[Rho], k]+Subscript[\[Rho], k-1]]]=d[[k-1]]];
\[Delta]
], {k,L}   ] ] ]


Contract[kom_Kom] := Module[{\[CapitalOmega], d, L, \[Rho], k, done, a, b, \[Phi], \[Gamma]\[Delta]},
{\[CapitalOmega], d} = List @@ kom; L=Length[d];Subscript[\[Rho], k_] := Length[\[CapitalOmega][[k]]];
For[k=1, k<=L, ++k,
done=False; While[!done, done=True;
For[a=1, a<=Subscript[\[Rho], k+1], ++a, For[b=1, b<=Subscript[\[Rho], k], ++b,
If[NumberQ[\[Phi]=d[[k,a,b]]] && \[Phi]!=0 && \[CapitalOmega][[k+1,a]]==\[CapitalOmega][[k,b]],
done=False;
If[Subscript[\[Rho], k]<=1 || Subscript[\[Rho], k+1]<=1, d[[k]]=0,
\[Gamma]\[Delta] = Table[VC[
Cob[\[CapitalOmega][[k,n]], \[CapitalOmega][[k+1,a]], d[[k,a,n]]] /. q -> 1,
Cob[\[CapitalOmega][[k,b]], \[CapitalOmega][[k+1,m]], d[[k,m,b]]] /. q -> 1
], {m, Subscript[\[Rho], k+1]}, {n, Subscript[\[Rho], k]} ];
d[[k]] = Expand[Drop[d[[k]]-\[Phi]^-1 \[Gamma]\[Delta], {a}, {b}]] ];
\[CapitalOmega][[k]]=Drop[\[CapitalOmega][[k]], {b}]; \[CapitalOmega][[k+1]]=Drop[\[CapitalOmega][[k+1]], {a}];
If[k>1 && d[[k-1]]=!=0, d[[k-1]]= Drop[d[[k-1]], {b}]];
If[k<L && d[[k+1]]=!=0, d[[k+1]]= Drop[d[[k+1]], {}, {a}]];
If[a<=Subscript[\[Rho], k+1], --a]; b=Subscript[\[Rho], k]; ]  ]] ] ];
Kom[\[CapitalOmega], d] ];


Kom[] = Kom[{{S[]}},{}];
Cob[Xp[i_,j_,k_,l_]] := Cob[q S[P[-i,j],P[k,-l]], q^2 S[P[-i,-l],P[j,k]],1];
Cob[Xm[i_,j_,k_,l_]] := Cob[q^-2 S[P[-i,-j],P[k,l]], q^-1 S[P[-i,l],P[-j,k]], 1];
Cob[x_X] := Cob[If[PositiveQ[x],Xp@@x, Xm@@x]];


KhComplex[L_] := Module[
{pd=PD[L], kom=Kom[], inside={}, pos},
While[Length[pd]>0,
pos = Last[Ordering[(Length[(List @@ #)\[Intersection]inside])& /@ pd]];
kom=kom//Cob[pd[[pos]]];
(kom = Contract[kom // m[#, -#]])& /@ ((List@@pd[[pos]])\[Intersection]inside);
inside = inside\[Union](List @@ pd[[pos]]); pd=Drop[pd, {pos}] ];
kom ];
KhPoly[L_] := Expand[t^(-Length@Select[PD@L, NegativeQ]+Range[0,Crossings[L]]).(List @@ Plus @@@ First @ KhComplex[L]) /. S[] -> 1]



