<<CliffMath10`

(* ⊙ denotes the Clifford product *)

(* (k^th) right-lowering operator *)
(Subscript[RightLower, k_])[u_]:=Module[{j},Sum[GradeKPart[ClExpand[GradeKPart[u,j]⊙(Subscript[e, {k}])],j-1],{j,1,MaxIndex}]];

(* (k^th) right-raising operator *)

(Subscript[RightRaise, k_])[u_]:=Module[{j},Sum[GradeKPart[ClExpand[GradeKPart[u,j]⊙(Subscript[e, {k}])],j+1],{j,0,MaxIndex-1}]];

(* kth (left) lowering operator *)

(Subscript[Lower, k_])[u_]:=Module[{j},Sum[GradeKPart[ClExpand[(Subscript[e, {k}])⊙GradeKPart[u,j]],j-1],{j,1,MaxIndex}]];

(* (k^th) (left) raising operator *)

(Subscript[Raise, k_])[u_]:=Module[{j},Sum[GradeKPart[ClExpand[(Subscript[e, {k}])⊙GradeKPart[u,j]],j+1],{j,0,MaxIndex-1}]];

(* x-Lowering *)
XLowering[u_,x_]:=Module[{j},Sum[x[[j]] (Subscript[Lower, j])[u],{j,1,Length[x]}]];

(* x-Raising *)
XRaising[u_,x_]:=Module[{j},Sum[x[[j]] (Subscript[Raise, j])[u],{j,1,Length[x]}]];

(* Canonical lowering *)
Lower[u_]:=Module[{j1},Sum[(Subscript[Lower, j1])[u],{j1,1,MaxIndex}]];

(* Canonical raising *)
Raise[u_]:=Module[{j1},Sum[(Subscript[Raise, j1])[u],{j1,1,MaxIndex}]];

XLower[u_,Λ_]:=Module[{j1},Sum[Λ[[j1]] (Subscript[Lower, j1])[u],{j1,1,MaxIndex}]];

XRaise[u_,Λ_]:=Module[{j1},Sum[Λ[[j1]] (Subscript[Raise, j1])[u],{j1,1,MaxIndex}]];

(* Matrix rep of (i^th) lowering *)ithLoweringRep[ith_]:=Module[{m,B,rw,co,mulvr,mpr,mprs,A},B=ClBasis;A=Table[0,{rw,1,(2^MaxIndex)},{co,1,(2^MaxIndex)}];For[rw=1,rw≤(2^MaxIndex),rw++,For[co=1,co≤rw,co++,mulvr=ClExpand[B[[rw]]⊙B[[co]]];If[mulvr==(Subscript[e, {ith}])||mulvr==-(Subscript[e, {ith}]),mpr=ClExpand[(Subscript[e, {ith}])⊙B[[rw]]];mprs=mpr/.{(Subscript[e, _])->1};If[mprs==1,A[[rw,co]]=1,A[[rw,co]]=-1];]]];Return[A];];

(* Matrix rep of (i^th) raising *)ithRaisingRep[ith_]:=Module[{m,B,rw,co,mulvr,mpr,mprs,A},B=ClBasis;A=Table[0,{rw,1,(2^MaxIndex)},{co,1,(2^MaxIndex)}];For[rw=1,rw≤(2^MaxIndex),rw++,For[co=rw,co≤(2^MaxIndex),co++,mulvr=ClExpand[B[[rw]]⊙ B[[co]]];If[mulvr==(Subscript[e, {ith}])||mulvr==-(Subscript[e, {ith}]),mpr=ClExpand[(Subscript[e, {ith}])⊙B[[rw]] ];mprs=mpr/.{(Subscript[e, _])->1};If[mprs==1,A[[rw,co]]=1,A[[rw,co]]=-1];]]];Return[A];];

(* Matrix rep of canonical lowering *)
CanonicalLoweringRep:=Module[{i},Return[Sum[ithLoweringRep[i],{i,1,MaxIndex}]];];

(* Matrix rep of canonical raising *)
CanonicalRaisingRep:=Module[{i},Return[Sum[ithRaisingRep[i],{i,1,MaxIndex}]];];

(* Matrix rep for λ-raising *)XRaisingRep[λ_]:=Module[{j},If[Length[λ]≠MaxIndex,Message[x::"length",MaxIndex];Abort[];,Sum[λ[[j]] ithRaisingRep[j],{j,1,Length[λ]}]]];

(* Matrix rep for x-lowering *)XLoweringRep[Λ_]:=Module[{j},If[Length[Λ]≠MaxIndex,Message[x::"length",MaxIndex];Abort[];,Sum[Λ[[j]] ithLoweringRep[j],{j,1,Length[Λ]}]]];

(* Return canonical lowering kernel as vector *)GetLoweringKernel:=Module[{CB,K,lp},CB=ClBasis;K=NullSpace[Transpose[CanonicalLoweringRep],Method->"OneStepRowReduction"];Return[Table[CB.K[[lp]],{lp,1,Length[K]}]];];

(* Return λ-lowering kernel as vector *)
GetXLoweringKernel[lambda_]:=Module[{lp,K,CB},CB=ClBasis;K=NullSpace[Transpose[XLoweringRep[lambda]],Method->"OneStepRowReduction"];Return[Table[CB.K[[lp]],{lp,1,Length[K]}]];]

(* Return canonical raising kernel as vector *)GetRaisingKernel:=Module[{CB,K,lp},CB=ClBasis;K=NullSpace[Transpose[CanonicalRaisingRep],Method->"OneStepRowReduction"];Return[Table[CB.K[[lp]],{lp,1,Length[K]}]];];

(* Return x-raising kernel as vector *)GetXRaisingKernel[lambda_]:=Module[{lp,K,CB},CB=ClBasis;K=NullSpace[Transpose[XRaisingRep[lambda]],Method->"OneStepRowReduction"];Return[Table[CB.K[[lp]],{lp,1,Length[K]}]];]

(* Print canonical lowering kernel *)
PrintLoweringKernel:=Module[{K,CB,lp},CB=ClBasis;K=NullSpace[Transpose[CanonicalLoweringRep]];
T=Table[Simplify[Expand[CB.K[[lp]]]],{lp,1,Length[K]}];
Print["In ",(Subscript[Cl, pPart,qPart]),", Ker(Λ) is spanned by :"];Print[T];
Print["-----------"];];

(* Print x-lowering kernel *)
PrintXLoweringKernel[λ_]:=Module[{K,lp},Print["In ",(Subscript[Cl, pPart,qPart]),", Ker((Subscript[Λ, x])) is spanned by :"];K=GetXLoweringKernel[λ];For[lp=1,lp≤Length[K],lp++,Print[K[[lp]]];] Print["-----------"];];

(* Print canonical raising kernel *)
PrintRaisingKernel:=Module[{CB,K,lp},CB=ClBasis;K=NullSpace[Transpose[CanonicalRaisingRep]];Print["In ",(Subscript[Cl, pPart,qPart]),",  Ker(Ξ) is spanned by :"];For[lp=1,lp≤Length[K],lp++,Print[CB.K[[lp]]];] Print["-----------"];];

(* Print x-raising kernel *)
PrintXRaisingKernel[A_]:=Module[{CB,K,lp},Print["In ",(Subscript[Cl, pPart,qPart]),", Ker((Subscript[Ξ, x])) is spanned by :"];K=GetXRaisingKernel[A];For[lp=1,lp≤Length[K],lp++,Print[K[[lp]]];] Print["-----------"];];

PlotLowering:=Module[{L,lasym,lsym},L=CanonicalLoweringRep;
lsym=Abs[L+Abs[L]]/2;
lasym=Abs[L-Abs[L]]/2;
GraphPlot3D[lsym,EdgeRenderingFunction->(Cylinder[#1,.04]&),VertexRenderingFunction->({ColorData["Atoms"][RandomInteger[{1,117}]],Sphere[#1,.1]}&),PlotStyle->Directive[Specularity[White,20]],PlotLabel->"No Sign Changes"]
GraphPlot3D[lasym,EdgeRenderingFunction->(Cylinder[#1,.04]&),VertexRenderingFunction->({ColorData["Atoms"][RandomInteger[{1,117}]],Sphere[#1,.1]}&),PlotStyle->Directive[Specularity[White,20]],PlotLabel->"Sign Changes"]];

PlotRaising:=Module[{R,rsym,rasym},R=CanonicalRaisingRep;
rsym=Abs[R+Abs[R]]/2;
rasym=Abs[R-Abs[R]]/2;
GraphPlot3D[rsym,EdgeRenderingFunction->(Cylinder[#1,.05]&),VertexRenderingFunction->({ColorData["Atoms"][RandomInteger[{1,117}]],Sphere[#1,.15]}&),PlotStyle->Directive[Specularity[White,20]],PlotLabel->"No Sign Changes", Method->"SpringElectricalEmbedding"]
GraphPlot3D[rasym,EdgeRenderingFunction->(Cylinder[#1,.05]&),VertexRenderingFunction->({ColorData["Atoms"][RandomInteger[{1,117}]],Sphere[#1,.15]}&),PlotStyle->Directive[Specularity[White,20]],PlotLabel->"Sign Changes", Method->"SpringElectricalEmbedding"]
];

RBPlotLowering:=Module[{L,i,j,VC,vrts,n,it,CB,x,vplt,EPC},L=CanonicalLoweringRep;n=MaxIndex;CB=ClBasis;VC=Table[{Cos[N[((2 π j)/(2^n))]],Sin[N[((2 π j)/(2^n))]]},{j,1,(2^n)}];
vrts=Table[{Cos[N[((2 π j)/(2^n))]],Sin[N[((2 π j)/(2^n))]]},{j,1,(2^n)}];
it=1;For[i=1,i≤(2^n),i++,For[j=1,j≤i,j++,If[L[[i,j]]==1,EPC[it]=ListPlot[{VC[[i]],VC[[j]]},PlotStyle->{RGBColor[1,0,0]},DisplayFunction->Identity,Joined->True,Axes->False];it++,If[L[[i,j]]==-1,EPC[it]=ListPlot[{VC[[i]],VC[[j]]},PlotStyle->{RGBColor[0,0,1]},DisplayFunction->Identity,Joined->True,Axes->False];it++,Null]]]];x=Table[EPC[j],{j,1,it-1}];Show[x,DisplayFunction->$DisplayFunction,BaseStyle->{FontFamily->Courier,FontSize->12},PlotRange->{{-2,2},{-1.4`,1.4`}}]];

RBPlotRaising:=Module[{R,n,i,j,VC,it,x,vplt,EPC},R=CanonicalRaisingRep;n=MaxIndex;VC:=Table[{Cos[N[((2 π j)/(2^n))]],Sin[N[((2 π j)/(2^n))]]},{j,1,(2^n)}];it=1;For[i=1,i≤(2^n),i++,For[j=i,j≤(2^n),j++,If[R[[i,j]]==1,EPC[it]=ListPlot[{VC[[i]],VC[[j]]},PlotStyle->{RGBColor[1,0,0]},DisplayFunction->Identity,Joined->True,Axes->False];it++,If[R[[i,j]]==-1,EPC[it]=ListPlot[{VC[[i]],VC[[j]]},PlotStyle->{RGBColor[0,0,1]},DisplayFunction->Identity,Joined->True,Axes->False];it++,Null]]]];x=Table[EPC[j],{j,1,it-1}];Show[x,DisplayFunction->$DisplayFunction,BaseStyle->{FontFamily->Courier,FontSize->12},PlotRange->{{-2,2},{-1.4`,1.4`}}]];

BladeLabel[n_]:=Module[{Binrep,Reftab,i,jl,A},Clear[Binrep,Reftab];If[n==0,Return[{0}],Binrep=Reverse[IntegerDigits[n,2]];Reftab=Table[i,{i,1,Length[Binrep]}] Binrep;A={};For[jl=1,jl≤Length[Reftab],jl++,If[Reftab[[jl]]≠0,A=Append[A,Reftab[[jl]]],Null];];Return[A];]];