<<Combinatorica`
(* these seven make up the annihilator construction *)
PPartition[n_,p_]:=If[n==0,{},With[{pull=Log[p,n]//Floor},Join[{p^pull},PPartition[n-p^pull,p]]]]
VisibleSplitsInt[n_,p_]:=With[{IntegerPart=PPartition[n,p]},{Plus@@#,Plus@@DeleteFromList[IntegerPart,#]}&/@Subsets[IntegerPart]//Rest//Most//Nub]
VisibleSplitsIndex[multiindex_,p_,n_]:=Join@@Table[Join[Take[multiindex,i-1],#,Take[multiindex,i-Length[multiindex]]]&/@VisibleSplitsInt[multiindex[[i]],p],{i,1,n}]
VisibleSplitsPoly[multiindex_,p_,n_]:=Join@@(VisibleSplitsIndex[#,p,n]&/@Permutations[multiindex])
Regather[image_]:=Nub[Sort[Join[DeleteFromList[image,#],{Plus@@#}],Greater]&/@{{image[[1]],image[[2]]},{image[[2]],image[[3]]}}]
Step[index_,char_]:=Nub[Join@@(Regather/@VisibleSplitsPoly[index,char,2])]
Support[index_,char_]:=Nub[Join[{index},FixedPoint[(SortBy[Nub[Join@@(Step[#,char]&/@#)],First]//Reverse)&,{index}]]]
(* two list deletion utility functions *)
DeleteElement[list_,ele_]:=If[list=={},{},If[First[list]==ele,Rest[list],Join[{First[list]},DeleteElement[Rest[list],ele]]]]
DeleteFromList[biglist_,targetlist_]:=Fold[DeleteElement[#1,#2]&,biglist,targetlist]
(* as in Haskell *)
Nub[list_]:=Fold[If[MemberQ[#1,#2],#1,Append[#1,#2]]&,{},list]

SubsetQ[s1_,s2_]:=Sort[Intersection[s1,s2]]==Sort[s1]
(* inserts a subset leaf into a subset tree *)
InsertLeaf[tree_,leaf_]:=With[{tests=Map[SubsetQ[leaf,Head[#]]&,Level[tree,{1}]]},If[Or@@tests,With[{pos=Position[tests,True,1][[1,1]]},Head[tree]@@Join[Drop[Level[tree,{1}],{pos}],{InsertLeaf[Level[tree,{1}][[pos]],leaf]}]],Head[tree]@@Join[Level[tree,{1}],{leaf[]}]]]
(* grabs the union of all the proper subsets of the top node *)
LookDown[tree_]:=Fold[Join[#1,Head[#2],LookDown[#2]]&,{},Level[tree,{1}]]

(* returns all the subsets *)
AnnihilatorClasses[n_,k_,p_]:=Nub[Sort/@Fold[If[MemberQ[#1,#2[[2]]],#1,Join[#1,{#2[[2]]}]]&,{},Sort[{#,Support[#,p]}&/@Select[Partitions[n],Length[#]==k&],Length[#1[[2]]]>Length[#2[[2]]]&]]]
(* puts them in a tree *)
AnnihilatorTree[n_,k_,p_]:=With[{begin=AnnihilatorClasses[n,k,p]},Fold[InsertLeaf[#1,#2]&,begin[[1]][],Rest[begin]]]
(* cleans the tree for display purposes *)
CleanedAnnihilatorTree[n_,k_,p_]:=With[{partial=MapIndexed[Complement[Head[#],LookDown[#]]@@Level[#,{1}]&,AnnihilatorTree[n,k,p],Infinity]},Complement[Head[partial],LookDown[partial]]@@Level[partial,{1}]]

(* divides the circle into n smaller regions {x, y, r}, each of which can contain a circle of radius r centered at x, y *)
SubdivideCircle[{cx_,cy_},radius_,n_]:=Which[n==1,{{cx,cy,radius}},n==2,{{cx,cy+radius/2,radius/2},{cx,cy-radius/2,radius/2}},True,With[{x1=cx,y1=cy,x2=#1[[1,1]],y2=#1[[1,2]],x3=#1[[2,1]],y3=#1[[2,2]]},With[{a=Sqrt[(y2-y3)^2+(x2-x3)^2],b=radius,c=radius},With[{ncx=(a x1+b x2+c x3)/(a+b+c),ncy=(a y1+b y2+c y3)/(a+b+c)},{ncx,ncy,1/2Sqrt[(b+c-a)(c+a-b)(a+b-c)/(a+b+c)]}]]]&/@With[{circlepoints=Table[{cx+radius Cos[2Pi i/n],cy+radius Sin[2Pi i/n]},{i,1,n}]},Thread[({##}&)[circlepoints,RotateRight[circlepoints]]]]]
(* uses newlines instead of commas to turn a list into a string *)
ListToString[list_]:=If[Length[list]==1,ToString[list[[1]]],ToString[First[list]]<>"\n"<>ListToString[Rest[list]]]
(* generates the circle/text graphics commands *)
GenerateGraphic[tree_,{cx_,cy_},radius_]:=With[{circles=SubdivideCircle[{cx,cy},radius,Length[Level[tree,{1}]]+1],children=Level[tree,{1}]},Join[{Hue[RandomReal[]],Disk[{cx,cy},radius],Black,Text[ListToString[Head[tree]],{First[circles][[1]],First[circles][[2]]}],Pink},Table[GenerateGraphic[children[[i]],{circles[[i+1,1]],circles[[i+1,2]]},circles[[i+1,3]]],{i,1,Length[children]}]]]

(* some samples.  the first three illustrate how this works on POsets that are trees, the last line gives a list of sets that don't form a tree *)
AnnihilatorClasses[12,3,3]//MatrixForm
CleanedAnnihilatorTree[12,3,3]//TreeForm
Graphics[Join[{EdgeForm[Thick]},GenerateGraphic[CleanedAnnihilatorTree[12,3,3],{0,0},1]]]

AnnihilatorClasses[2,2,2]

CartesianP[S_,T_]:=Join@@Table[{S[[i]],T[[j]]},{i,1,Length[S]},{j,1,Length[T]}]
IntermediateQ[rules_,I_,J_]:=Which[Count[rules,Sort[{I,J}]]>0,True,Length[I]≥Length[J],False,True,IntermediateQ[rules,I,#]&/@#[[1]]&/@Select[rules,#[[2]]==J&]]
CleanedSubsetPOSet[n_,k_,p_]:=With[{classes=AnnihilatorClasses[n,k,p]},With[{rules=Select[CartesianP[classes,classes],SubsetQ@@#&&#[[1]]≠#[[2]]&]},With[{match=Select[Subsets[rules,{2}],#[[1,1]]==#[[2,1]]&]},LayeredGraphPlot[#[[2]]->#[[1]]&/@Complement[rules,Union[#[[1,1]]&/@Select[{#,Or@@Flatten[{IntermediateQ[rules,#[[2,2]],#[[1,2]]]}]}&/@match,#[[2]]==True&]]],VertexLabeling->True]]]]
Manipulate[RenamedSubsetPOSet[n,k,p],{n,2,20,1},{k,2,6,1},{p,{2,3,5,7}}]
RenamedSubsetPOSet[n_,p_,k_]:=With[{classes=AnnihilatorClasses[n,p,k]},With[{rules=Select[CartesianP[classes,classes],SubsetQ@@#&&#[[1]]≠#[[2]]&]},With[{match=Select[Subsets[rules,{2}],#[[1,1]]==#[[2,1]]&]},With[{newrules=Complement[rules,Union[#[[1,1]]&/@Select[{#,Or@@Flatten[{IntermediateQ[rules,#[[2,2]],#[[1,2]]]}]}&/@match,#[[2]]==True&]]]},LayeredGraphPlot[#[[2]]->#[[1]]&/@(newrules/.Table[classes[[i]]->Fold[Complement[#1,#2]&,classes[[i]],#[[1]]&/@Select[newrules,#[[2]]==classes[[i]]&]],{i,1,Length[classes]}]),VertexLabeling->True]]]]]

Splits[index_,char_]:=Sort[#,Greater]&/@Select[Union[Table[If[index[[i]]≠1,Join[Drop[index,{i}],Table[index[[i]]/char,{j,char}]],{}],{i,1,Length[index]}]],#≠{}&]
StepSplittingTree[indices_,char_]:=Union[indices,With[{splits=Splits[#,char]&/@indices},If[Length[indices]==1,splits[[1]],Join@@splits]]]
SplittingTree[n_,char_]:=Fold[Join,{},With[{old=#},(old->#&)/@Splits[old,char]]&/@FixedPoint[StepSplittingTree[#,char]&,{PPartition[n,char]}]]
GetGathers[index_,count_]:=With[{gathers=Sort[#,Greater]&/@Union[Join[Delete[index,{{#[[1]]},{#[[2]]}}],{Plus@@index[[#]]}]&/@Subsets[Range[Length[index]],{2}]]},Which[count==1,gathers,count==0,{index},True,Union[Fold[Join,{},GetGathers[#,count-1]&/@gathers]]]]
GetGatherArrows[n_,char_]:=Join[Fold[Join,{},Table[GetGathers[#,i]->GetGathers[#,i+1],{i,0,char-3}]&/@DeleteFromList[FixedPoint[StepSplittingTree[#,char]&,{PPartition[n,char]}],{PPartition[n,char]}]],Table[GetGathers[PPartition[n,char],i]->GetGathers[PPartition[n,char],i+1],{i,0,Length[PPartition[n,char]]-3}]]
SplitGatherArrows[n_,char_]:=Join[GetGatherArrows[n,char],({First[#]}->{Last[#]})&/@SplittingTree[n,char]]
DigitalSum[n_,base_]:=Plus@@Most[DigitCount[n,base]*Range[1,base]]
VertexPositions[n_,char_]:=Fold[With[{temp=#1[[1]],vertices=#1[[2]],length=Length[#2[[1]]]},{Insert[Drop[temp,{length}],temp[[length]]+1,length],Join[vertices,{{temp[[length]]+If[Divisible[length-Length[PPartition[n,char]],char-1],2/3,0],-length}}]}]&,{Table[0,{i,n}],{}},Nub[Fold[Join,{},(#/.Rule->List)&/@SplitGatherArrows[n,char]]]][[2]]
DrawSplitGatherGraph[n_,char_]:=LayeredGraphPlot[SplitGatherArrows[n,char],VertexLabeling->True,EdgeRenderingFunction->(If[Length[First[#2][[1]]]<Length[Last[#2][[1]]],{Arrowheads[.1],Red,Arrow[#1]},{Arrowheads[.1],Blue,Arrow[#1]}]&),VertexCoordinateRules->VertexPositions[n,char]]
DrawSplitGatherGraph[12,3]