You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
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//ClearAllOptions[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=lineGraphag,VertexShapeFunction->FunctionInsetFramedAggregationEventPlot[rule][#2,ImageSize->#3],BackgroundDirectiveOpacity[0.2`],,FrameMargins{{2,2},{0,0}},FrameStyle,#1,EdgeStyle->,(*GraphLayout->"SpringElectricalEmbedding",*)VertexSize->100,AspectRatio->13,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[]=