In[]:=
{rule,offsets}={Range[4],$NeighborhoodData[2,4]};​​forms=FilterTransforms[​​{rule,offsets}][​​LatticeTransforms[​​Length[First[offsets]]​​]];​​canonicalFunction=CanonicalizeGrowthData[forms,offsets];
ag=Graph[AddVertexArrayPlots[rule][AggregationMultiwayGraph[​​{rule,offsets},{{0,0}},​​4,"Canonicalize"->False],Padding->1],​​AspectRatio->1/3,VertexSize->1.5,​​GraphLayout->"LayeredDigraphEmbedding",​​VertexLabels->Placed[Automatic,Tooltip]];
In[]:=
AggregationEventPlot//ClearAll​​Options[AggregationEventPlot]=Options[ArrayPlot];​​AggregationEventPlot[rule_][src_tgt_,opts:OptionsPattern[]]:=Enclose@Block[{​​x=Boole@src["On"],​​y=Boole@tgt["On"],​​bounds,​​size,pad,​​arrayPlotOpts=FilterRules[{opts,Mesh->All},Options[ArrayPlot]]​​},​​bounds=CoordinateBounds@Keys[y];​​size=(#2-#1+1)&@@@bounds;​​(*size=Table[Max[Max[size]+1,5],2];​​y=CenterArray[SparseArray[Normal@KeyMap[#-bounds[[All,1]]+1&]@Join[y,KeyComplement[{y,x}]+1]],size];​​x=CenterArray[SparseArray[Normal@KeyMap[#-bounds[[All,1]]+1&]@x],size];*)​​y=PadRight[SparseArray[Normal@KeyMap[#-bounds[[All,1]]+1&]@Join[y,KeyComplement[{y,x}]+1]],size+1];​​x=PadRight[SparseArray[Normal@KeyMap[#-bounds[[All,1]]+1&]@Join[<|{0,0}->0|>,x]],size+1];​​x=PadLeft[x,size+2];​​y=PadLeft[y,size+2];​​pad=With[{p=Max[size+2]-#},If[EvenQ[p],{p,p}/2,(p+1)/2-Floor[size/Max[size]]]]&/@Dimensions[x];​​x=ArrayPad[x,pad];​​y=ArrayPad[y,pad];​​Column[{ArrayPlot[x,arrayPlotOpts],Framed[ArrayPlot[y,ColorRules->{1->Black,2->Red},arrayPlotOpts],OptionValue[PacletSymbol["Wolfram/Multicomputation","MultiEvaluate"],"EventFrameOptions"]]},OptionValue[PacletSymbol["Wolfram/Multicomputation","MultiEvaluate"],"EventColumnOptions"]]​​]
In[]:=
lineGraph[g_,opts:OptionsPattern[Graph]]:=Graph[EdgeList[g],DeleteDuplicates@Catenate[(v|->DirectedEdge@@@Tuples[{Cases[EdgeList[g],DirectedEdge[_,Verbatim[v],___]],Cases[EdgeList[g],DirectedEdge[Verbatim[v],__]]}])/@VertexList[g]],opts]
In[]:=
cg=lineGraphag,VertexShapeFunction->FunctionInsetFramedAggregationEventPlot[rule][#2,ImageSize->#3],BackgroundDirectiveOpacity[0.2`],
,FrameMargins{{2,2},{0,0}},FrameStyle
,#1,​​EdgeStyle->
,​​(*GraphLayout->"SpringElectricalEmbedding",*)​​VertexSize->100,​​AspectRatio->13,​​PerformanceGoal->"Quality"​​;
In[]:=
VertexDelete[cg,Select[VertexList[cg],VertexOutDegree[cg,#]==0&]]
Out[]=
In[]:=
SeedRandom[42];​​scg=TransitiveReductionGraph[EdgeDelete[​​TransitiveClosureGraph@lineGraph[EdgeAdd[#,<|"On"-><||>|>->First[VertexList[#]]]&@Graph[DirectedEdge@@@Partition[RandomAggregation[{rule,offsets},{{0,0}},100],2,1]]],​​DirectedEdge[DirectedEdge[KeyValuePattern["On"->fromSrc_],KeyValuePattern["On"->fromTgt_]],DirectedEdge[KeyValuePattern["On"->toSrc_],KeyValuePattern["On"->toTgt_]]]/;Or@@fromSrc&&ManhattanDistance[Complement[Keys[fromTgt],Keys[fromSrc]][[1]],Complement[Keys[toTgt],Keys[toSrc]][[1]]]>1​​],​​GraphLayout->"LayeredDigraphEmbedding"​​]
Out[]=
In[]:=
Graph[scg,GraphLayout->"SpringElectricalEmbedding"]
Out[]=
In[]:=
scg=Graph[scg,VertexShapeFunction->Function[Inset[Tooltip[Framed[AggregationEventPlot[rule][#2,ImageSize->#3],OptionValue[PacletSymbol["Wolfram/Multicomputation","MultiEvaluate"],"EventFrameOptions"]],Keys/@Through[#2["On"]]],#1]],​​EdgeStyle->ResourceFunction["WolframPhysicsProjectStyleData"]["EvolutionCausalGraph","CausalEdgeStyle"],​​GraphLayout->"LayeredDigraphEmbedding",​​VertexSize->64,​​AspectRatio->2,​​PerformanceGoal->"Quality"​​]
Out[]=