Init

Dependencies

getResourceFunction[filename_]:=NotebookEvaluate[FileNameJoin[filename],EvaluationElements"InitializationCell"]
In[]:=
getResourceFunction[FileNameJoin[{$Dropbox,"Physics/CodeDevelopment/FunctionRepositorySources",#<>".nb"}]]&/@{"OrderedGraphModelPlot","ParallelMapMonitored"};
In[]:=
getResourceFunction[FileNameJoin[{$Dropbox,"Physics/WorkingMaterial/2020",#<>".nb"}]]&/@{"UnorderedHypergraphs-01"};
In[]:=
GraphNeighborhoodVolumes=ResourceFunction["GraphNeighborhoodVolumes"];
In[]:=

Data

rules=Get[FileNameJoin[{$Dropbox,"Physics/SW2004Material/Data/RewritesOrdered24h4.m"}]];
In[]:=

Model Translation

coloredSpecPattern={{___}...};
In[]:=
coloredSpecToHypergraph[spec:coloredSpecPattern]:=TakeList[Range[Length[Catenate[spec]]],Length/@spec]~Join~Select[FreeQ[h]]@Transpose[{Range[Length[Catenate[spec]]],Catenate[spec]}]
In[]:=
coloredRuleToHypergraph[in:coloredSpecPatternout:coloredSpecPattern]:=Module[{hairPositions,hairRules,outIndexToHair,hairToInIndex,outToInMapping},hairPositions=Position[Catenate[#],_h,{1}]〚All,1〛&/@{in,out};hairRules=Thread[Catenate[{in,out}〚#〛]〚hairPositions〚#〛〛hairPositions〚#〛]&/@{1,2};outIndexToHair=Association[Reverse/@hairRules〚2〛];hairToInIndex=Association[hairRules〚1〛];​​outToInMapping=Association[(#+Length[Catenate[in]])hairToInIndex[outIndexToHair[#]]&/@Keys[outIndexToHair]];coloredSpecToHypergraph[in](coloredSpecToHypergraph[out]+Length[Catenate[in]]/.outToInMapping)]
In[]:=
hypergraphToColoredSpec[edges_,hairVertices_:Automatic]:=Module[{threeEdges,verticesToIndices,twoEdges,indexRelations,hairlessSpec,hairPositions,hairs},threeEdges=Cases[edges,{_,_,_},{1}];verticesToIndices=Association[Thread[Catenate[threeEdges]Range[Length[Catenate[threeEdges]]]]];twoEdges=Cases[edges,{_,_},{1}];indexRelations=Select[OrderedQ]@Map[verticesToIndices,twoEdges,{2}];hairlessSpec=Partition[Permute[Range[Length[Catenate[threeEdges]]],Cycles[indexRelations]],3];​​hairPositions=If[hairVertices===Automatic,Position[Partition[Range[Length[Catenate[threeEdges]]],3]-hairlessSpec,0],Position[threeEdges,#]〚1〛&/@hairVertices];​​hairs=h/@Range[Length[hairPositions]];​​ReplacePart[hairlessSpec,Thread[hairPositionshairs]]]
In[]:=
hypergraphRuleToColored[in_out_]:=With[{hairVertices=Intersection[Catenate[in],Catenate[out]]},Rule@@(hypergraphToColoredSpec[#,hairVertices]&/@{in,out})]
In[]:=
unorderedToOrderedHypergraph[edges_]:=Catenate@MapIndexed[Thread[{e[#2〚1〛],#}]&,edges]
In[]:=

Exploration

rules=Get["/Users/sw/Dropbox/Physics/SW2004Material/Data/RewritesOrdered24h4.m"];
In[]:=
OrderedGraphModelPlot[#,Automatic,{{VertexSize.3},{VertexSize.3}}]&/@(Take[rules,4]/.OrderedNet[{_,x_}]x)
In[]:=
Out[]=
allres=ParallelMapMonitored[TimeConstrained[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],4]["FinalState"],5]&,rules/.OrderedNet[{_,x_}]x];
In[]:=
allplots=ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[#],VertexShapeFunction"Circle"]&,allres];
In[]:=
GraphicsGrid[Partition[ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[#],VertexShapeFunction"Circle"]&,allres],UpTo[15]]]
In[]:=
Out[]=
allres2=ParallelMapMonitored[TimeConstrained[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],2]["FinalState"],5]&,rules/.OrderedNet[{_,x_}]x];
In[]:=
allplots2=ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[#],VertexShapeFunction"Circle"]&,allres2];
In[]:=
DeleteDuplicates[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots2,IsomorphicGraphQ];
In[]:=
$Aborted
Out[]=
DeleteDuplicatesBy[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots2,Sort[Values[GraphNeighborhoodVolumes[UndirectedGraph[#]]]]&]
In[]:=
Out[]=
DeleteDuplicatesBy[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots,Sort[Values[GraphNeighborhoodVolumes[UndirectedGraph[#]]]]&];
In[]:=
Length[%]
In[]:=
21
Out[]=
%223
In[]:=
Out[]=
Graph[#,GraphLayout"SpringElectricalEmbedding"]&/@%
In[]:=
Out[]=
SortValuesGraphNeighborhoodVolumesUndirectedGraph

In[]:=
Out[]=
Take[%207,4]
In[]:=
Out[]=
DeleteDuplicates[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots,SameTest->IsomorphicGraphQ]
IsomorphicGraphQ
,

In[]:=
$Aborted
Out[]=
VertexCount

In[]:=
80
Out[]=
Length[%]
In[]:=
264
Out[]=
Length[%]
In[]:=
264
Out[]=
Graph[Rule@@@%199[[-3]]]
In[]:=
Out[]=
Graph[Rule@@@%199[[-5]]]
In[]:=
Out[]=
IsomorphicGraphQ[%,%%]
In[]:=
True
Out[]=
DeleteDuplicates[allplots,SameTestIsomorphicGraphQ];
In[]:=
Length[%]
In[]:=
264
Out[]=
IsomorphicGraphQ[,
]
In[]:=
IsomorphicGraphQ
:The generalized
IsomorphicGraphQ[Graph[<32>, <48>], Graph[<32>, <48>]]
is not implemented.
Out[]=
​
DeleteDuplicates[allres,SameTest->ResourceFunction["IsomorphicHypergraphQ"]]
In[]:=
Length[%191]
In[]:=
264
Out[]=
Length/@allres
In[]:=
Out[]=
Counts[%]
In[]:=
128144,10412,8812,4072,9624
Out[]=
Length[%192]
In[]:=
264
Out[]=
dedplicatedAllPlots=DeleteDuplicates[allplots,IsomorphicGraphQ@@SimpleGraph/@{##}&];
In[]:=
GraphicsGrid[Partition[dedplicatedAllPlots,UpTo[15]]]
In[]:=
Out[]=
GraphicsGrid[Partition[dedplicatedAllPlots,UpTo[7]]]
In[]:=
Out[]=