Quit[]

(* Mathematica code and examples related to the paper 

Zeons, lattices of partitions, and free probability

*)

<<Combinatorica`

(* Define zeon multiplication *)
Unprotect[Times];(Subscript[ζ, a_])(Subscript[ζ, b_]):=If[Length[a⋂b]>0,0,(Subscript[ζ, a⋃b])];
Protect[Times];
Unprotect[Power];
(((x_/;!FreeQ[x,(Subscript[ζ, a_])]))^(n_Integer)):=Module[{y,f},y=Expand[x];Switch[EvenQ[n],True,If[n==0,Return[1],((Composition[Expand][Distribute[f[x,y]]/.f->Times])^(n/2))],False,If[n==1,Return[x],((Composition[Expand][Distribute[f[y,y]]/.f->Times])^((n-1)/2))x]]];
Protect[Power];Unprotect[Expand];
Expand[x_/;!FreeQ[x,(Subscript[ζ, _])]]:=DeleteCases[Distribute[x,Plus,Times],0.`(Subscript[ζ, _])];Protect[Expand];
Unprotect[Times];

(* Returns 1 if sets A and B are disjoint crossing blocks, 0 otherwise *)
Crossing[A_,B_]:=Module[{i,j,k,l},Return[If[Length[Intersection[A,B]]≠0,0,If[Sum[If[(A[[j]]<B[[i]]∧B[[i]]<A[[k]]∧A[[k]]<B[[l]])∨(A[[j]]>B[[i]]∧B[[i]]>A[[k]]∧A[[k]]>B[[l]]),1,0],{j,1,Length[A]},{i,1,Length[B]},{k,1,Length[A]},{l,1,Length[B]}]==0,0,1]]]]

(* Returns power set of {1,...,MaxIndex} *)
PowerSet[MaxIndex_]:=Module[{T,j},(T=Table[j,{j,1,MaxIndex}];Table[DeleteCases[Reverse[IntegerDigits[i-1,2,MaxIndex]] T,0],{i,2,(2^MaxIndex)}])];

(* Returns 1 if A and B are disoint overlapping blocks, 0 otherwise *)
Overlapping[A_,B_]:=Module[{},Return[If[Length[Intersection[A,B]]≠0,0,If[(Min[A]<Min[B]∧Min[B]<Max[A]∧Max[A]<Max[B])∨(Min[B]<Min[A]∧Min[A]<Max[B]∧Max[B]<Max[A]),1,0]]]]

(* Generate labeled graph with adjacency determined by crossing blocks.*) 
n=5;
A=Table[0,{i,1,(2^n)-1},{j,1,(2^n)-1}];
T=Table[j,{j,1,n}];
For[i=1,i≤(2^n)-1,i++,
For[j=i+1,j≤(2^n)-1,j++,
If[Intersection[DeleteCases[IntegerDigits[i,2,n]T,0],DeleteCases[IntegerDigits[j,2,n]T,0]]≠{},A[[i,j]]=A[[j,i]]=0,If[Crossing[DeleteCases[IntegerDigits[i,2,n]T,0],DeleteCases[IntegerDigits[j,2,n]T,0]]==1, A[[i,j]]=A[[j,i]]=1,0]]]]
A1=Table[1,{i,1,(2^n)-1},{j,1,(2^n)-1}]-IdentityMatrix[(2^n)-1]-A;
h=FromAdjacencyMatrix[A];
vertlabels=PowerSet[n];
edgelabels=Table[Style[j, {Bold, RGBColor[0,0,0],FontSize->12}] ,{j,n+1,n+((Tr[A.Transpose[A]])/2)}];

ShowGraph[h,EdgeLabel->edgelabels,EdgeLabelPosition->UpperRight,VertexLabel->vertlabels,PlotRange->All, AspectRatio->1]

(* Zeon represenative of NC(n) obtained from graph generated above. *)
Γ=0;
For[j=1,j≤Length[vertlabels],j++,
ep=Flatten[Position[A[[j]],1]];
edgenos=Union[n+Flatten[Table[Position[Edges[h],{j,ep[[ell]]}],{ell,1,Length[ep]}]],n+Flatten[Table[Position[Edges[h],{ep[[ell]],j}],{ell,1,Length[ep]}]]];
γ=If[Length[edgenos]==0,(Subscript[ζ, vertlabels[[j]]]),(Subscript[ζ, Union[vertlabels[[j]],edgenos]])];
Γ=Γ+γ;];
Print["Zeon representative for NC(",n,"): "]
Print["Γ = ",Γ]

(* Zeon Berezin integral *)
ZeonBerezin[(Subscript[ζ, I_]), (Subscript[ζ, vars_])]:=If[Intersection[I,vars]==vars,(Subscript[ζ, Complement[I,vars]])/.{(Subscript[ζ, {}])->1},0];ZeonBerezin[a_ (Subscript[ζ, I_]),(Subscript[ζ, vars_])]:=Expand[a ZeonBerezin[(Subscript[ζ, I]),(Subscript[ζ, vars])]];
ZeonBerezin[x_+y_, (Subscript[ζ, vars_])]:=Expand[ZeonBerezin[x, (Subscript[ζ, vars])]]+Expand[ZeonBerezin[y,(Subscript[ζ, vars])]];

(* Projection onto (Subscript[Z, n]) *)
Proj[(Subscript[ζ, a_]),n_]:=(Subscript[ζ, Intersection[a,Table[i,{i,1,n}]]]);
Proj[x_ (Subscript[ζ, a_]),n_]:=Expand[x Proj[(Subscript[ζ, a]),n]];
Proj[x_+y_,n_]:=Expand[Proj[x,n]]+Expand[Proj[y,n]];

(* Count k-block noncrossing partitions of the n-set *)

Print["Γ = ",Γ]
For[k=1,k≤5,k++,
Print["When k = ",k,", (1/(k!)) ∫(Γ^k)(Subscript[ϵ, [5]])(Subscript[dζ, 1])...(Subscript[dζ, 5]) = ",ZeonBerezin[Proj[Expand[(Γ^k)/k!],5],(Subscript[ζ, {1,2,3,4,5}])]]]

(* Define function on blades/blocks *)
f[(Subscript[ζ, a_])]:=(Subscript[f, Intersection[a,Table[i,{i,1,5}]]]) (Subscript[ζ, a]);
f[x_ (Subscript[ζ, a_])]:=x f[(Subscript[ζ, a])];
f[x_+y_]:=f[x]+f[y]

(* Weighted zeon rep for NC(5) *)
Υ=f[Γ]

Print["Υ = ",Υ]
For[k=1,k≤5,k++,
Print["When k = ",k,",  ∫(Υ^k)(Subscript[ϵ, [5]])(Subscript[dζ, 1])...(Subscript[dζ, 5]) = ",ZeonBerezin[Proj[Expand[(Υ^k)],5], (Subscript[ζ, {1,2,3,4,5}])]]]

(* Canonical lowering *)
L[(Subscript[ζ, a_])]:=Expand[Sum[(Subscript[ζ, Delete[a,i]]),{i,1,Length[a]}]]/.{(Subscript[ζ, {}])->1};
L[x_ (Subscript[ζ, a_])]:=x Expand[L[(Subscript[ζ, a])]];
L[x_+y_]:=Expand[L[x]]+Expand[L[y]];

(* Iterated canonical lowering *)
PwrL[x_,n_]:=If[n==0, Return[x],If[n==1,Return[L[x]],Expand[L[PwrL[x,n-1]]]]]

(* Phi map *)
(Subscript[Φ, n_])[(Subscript[ζ, b_])]:=Expand[(Subscript[f, b])(Subscript[ζ, b])];
(Subscript[Φ, n_])[a_ (Subscript[ζ, b_])]:=Expand[a (Subscript[Φ, n])[(Subscript[ζ, b])]];
(Subscript[Φ, n_])[x_ + y_]:=Expand[(Subscript[Φ, n])[x]]+Expand[(Subscript[Φ, n])[y]];

(* Restriction mapping ψ:(Subscript[Z, n])->(Subscript[Z, n+|E|])*)
(* A is the adjacency matrix of the partition constraint graph *)
(Subscript[ψ, n_])[(Subscript[ζ, a_]),A_]:=Module[{j,h,ep,edgenos,vertlabels, edgelabels},
h=FromAdjacencyMatrix[A];
vertlabels=PowerSet[n];
edgelabels=Table[Style[j, {Bold, RGBColor[0,0,0],FontSize->12}] ,{j,n+1,n+((Tr[A.Transpose[A]])/2)}];
j=Flatten[Position[PowerSet[n],a]][[1]];
ep=Flatten[Position[A[[j]],1]];
edgenos=Union[n+Flatten[Table[Position[Edges[h],{j,ep[[ell]]}],{ell,1,Length[ep]}]],n+Flatten[Table[Position[Edges[h],{ep[[ell]],j}],{ell,1,Length[ep]}]]];
Return[If[Length[edgenos]==0,(Subscript[ζ, vertlabels[[j]]]),(Subscript[ζ, Union[vertlabels[[j]],edgenos]])]];];
(Subscript[ψ, n_])[x_ (Subscript[ζ, a_]),A_]:=x  (Subscript[ψ, n])[(Subscript[ζ, a]),A];
(Subscript[ψ, n_])[(x_+y_), A_]:=(Subscript[ψ, n])[x, A]+(Subscript[ψ, n])[y,A]

b={1,2,3,4,5};
j=3;
(Subscript[Φ, 5])[Expand[PwrL[(Subscript[ζ, b]),j]/j!]]

X=Expand[ Sum[ (Subscript[Φ, 5])[Expand[PwrL[(Subscript[ζ, b]),j]/j!]],{j,0,Length[b]-1}]]+t;
Y=Expand[ZeonBerezin[Expand[(X^5)/5!]/.{(t^5)->0},(Subscript[ζ, b])]];
Print["Y = ",Y]

labels=Join[{(("(∂^0)")/("∂(t^0)"))},Table[(("∂")/(("∂t")^k)),{k,1,4}]];
For[k=1,k≤5,k++,
Print[labels[[k]], "Y = ",D[Y,{t,k-1}]/.{t->0}]]

Print["(Subscript[D, [n]])[∫(t+Σ (1/j!)(Subscript[ζ, [n]])(L^j)Ψ)^n(Subscript[ϵ, [n]])(Subscript[dζ, 1])...(Subscript[dζ, n])]_(t = 0) = ",Sum[D[Y,{t,k-1}]/.{t->0},{k,1,5}]]

Sum[D[ZeonBerezin[Expand[Proj[Expand[(((t+Sum[Expand[(1/j!)(Subscript[ψ, 5])[f[PwrL[(Subscript[ζ, b]),j]],A]],{j,0,Length[b]-1}]))^5)/5!]/.{(t^5)->0},5]],(Subscript[ζ, b])],{t,k}]/.{t->0},{k,0,4}]

(* NO(n) *)
n=5;
A=Table[0,{i,1,(2^n)-1},{j,1,(2^n)-1}];
T=Table[j,{j,1,n}];
For[i=1,i≤(2^n)-1,i++,
For[j=i+1,j≤(2^n)-1,j++,
If[Intersection[DeleteCases[IntegerDigits[i,2,n]T,0],DeleteCases[IntegerDigits[j,2,n]T,0]]≠{},A[[i,j]]=A[[j,i]]=0,If[Overlapping[DeleteCases[IntegerDigits[i,2,n]T,0],DeleteCases[IntegerDigits[j,2,n]T,0]]==1, A[[i,j]]=A[[j,i]]=1,0]]]]
A1=Table[1,{i,1,(2^n)-1},{j,1,(2^n)-1}]-IdentityMatrix[(2^n)-1]-A;
h=FromAdjacencyMatrix[A];
vertlabels=Table[PowerSet[n][[k]],{k,1,(2^n)-1}];
edgelabels=Table[Style[j, {Bold, RGBColor[0,0,0],FontSize->12}] ,{j,n+1,n+((Tr[A.Transpose[A]])/2)}];
ShowGraph[h,EdgeLabel->edgelabels,EdgeLabelPosition->UpperRight,VertexLabel->vertlabels,PlotRange->All, AspectRatio->1]