(* ::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_ := 0;
(\[Sigma]_S)[i_] := \[Sigma][i] = First@Cases[\[Sigma], P[i,j_] :> j];


ECP[\[Lambda]_List] := Module[{\[Rho], ec}, (* "Equivalence Class Projection" *)
ec=Fold[
(\[Rho] = First /@ Position[#1, #2];
Append[Delete[#1, List /@ \[Rho]], Union@@(#1[[\[Rho]]])])&,
\[Lambda], Union @@ \[Lambda]
] // SortBy[#, First]&;
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 *= Times @@ MapThread[If[#1==#2, 1, dot[#1]+dot[#2]]&,
{outs, outs/.p}];
law1=dot/@ins1; law1=Thread[law1->(law1/.p)];
law2=dot/@ins2; law2=Thread[law2->(law2/.p)];
{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] := 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[
{n\[Beta], n\[Tau], p, ijdot, ndots, x},
{n\[Beta], n\[Tau]} = m0[i,j] /@ {\[Beta], \[Tau]};
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[n\[Beta],n\[Tau]]];
If[\[Beta][i]==j && \[Tau][i]==j, Coefficient[ndots /. ijdot -> x, x], ndots]];


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


m[i_,j_][Kom[cs_, ds_]] := Kom[
Flatten /@ Map[m[i,j], cs, {2}],
Table[
If[Length[cs[[k]]]==0 || Length[cs[[k+1]]]==0, 0,
(* else *) Table[
m[i,j][Cob[cs[[k,b]]/. q -> 1, cs[[k+1, a]] /. q -> 1, ds[[k,a,b]]]],
{a, Length[cs[[k+1]]]}, {b, Length[cs[[k]]]}
] // ArrayFlatten  ],
{k,Length[ds]}]  ];


Contract[kom_Kom] := Module[{cs, ds, L, k, done, a, b, \[Phi], \[Gamma]\[Delta]},
{cs, ds} = List @@ kom; L=Length[ds];
For[k=1, k<=L, ++k,
done=False; While[!done, done=True;
For[a=1, a<=Length[cs[[k+1]]], ++a, For[b=1, b<=Length[cs[[k]]], ++b,
If[NumberQ[\[Phi]=ds[[k,a,b]]] && \[Phi]!=0 && cs[[k+1,a]]==cs[[k,b]],
done=False;
If[Length[cs[[k]]]>1 && Length[cs[[k+1]]]>1,
\[Gamma]\[Delta] = Table[
VC[Cob[cs[[k,d]], cs[[k+1,a]], ds[[k,a,d]]] /. q -> 1,
Cob[cs[[k,b]], cs[[k+1,c]], ds[[k,c,b]]] /. q -> 1],
{c, Length[cs[[k+1]]]}, {d, Length[cs[[k]]]} ];
ds[[k]] = Expand[Drop[ds[[k]]-\[Phi]^-1 \[Gamma]\[Delta], {a}, {b}]],
(* else *) ds[[k]]=0 ];
cs[[k]]=Drop[cs[[k]], {b}]; cs[[k+1]]=Drop[cs[[k+1]], {a}];
If[k>1,ds[[k-1]]=If[ds[[k-1]]===0, 0, Drop[ds[[k-1]], {b}]]];
If[k<L, ds[[k+1]] = If[ds[[k+1]]===0, 0, Drop[ds[[k+1]], {}, {a}]]];
If[a<=Length[cs[[k+1]]], --a]; b=Length[cs[[k]]]; ]  ]] ] ];
Kom[cs, ds]];


CFKh[L_] := Module[
{pd=PD[L], kom=Kom[{{S[]}},{}], inside={}, tp=0, pos},
While[Length[pd]>0,
pos = Last[Ordering[(Length[(List @@ #)\[Intersection]inside])& /@ pd]];
kom=kom*(pd[[pos]] /. {
X[i_,j_,k_,l_]/;(j-l==1||l-j>1) :>
Cob[q S[P[-i,j],P[k,-l]], q^2 S[P[-i,-l],P[j,k]],1],
X[i_,j_,k_,l_]/;(l-j==1||j-l>1) :>
(--tp; Cob[q^-2 S[P[-i,-j],P[k,l]], q^-1 S[P[-i,l],P[-j,k]], 1])
});
(kom = Contract[kom // m[#, -#]])& /@ ((List@@pd[[pos]])\[Intersection]inside);
inside = inside\[Union](List @@ pd[[pos]]); pd=Drop[pd, {pos}] ];
Expand[t^(tp-1+Range[Length[First[kom]]]).(List @@ Plus @@@ First @ kom) /. S[] -> 1] ]



