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
Init
Init
Dependencies
Dependencies
In[]:=
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"];
Data
Data
In[]:=
rules=Get[FileNameJoin[{$Dropbox,"Physics/SW2004Material/Data/RewritesOrdered24h4.m"}]];
Model Translation
Model Translation
In[]:=
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:coloredSpecPatternout: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[hairPositionshairs]]]
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]
Exploration
Exploration
In[]:=
rules=Get["/Users/sw/Dropbox/Physics/SW2004Material/Data/RewritesOrdered24h4.m"];
In[]:=
OrderedGraphModelPlot[#,Automatic,{{VertexSize.3},{VertexSize.3}}]&/@(Take[rules,4]/.OrderedNet[{_,x_}]x)
Out[]=
In[]:=
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]]]
Out[]=
In[]:=
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];
Out[]=
$Aborted
In[]:=
DeleteDuplicatesBy[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots2,Sort[Values[GraphNeighborhoodVolumes[UndirectedGraph[#]]]]&]
Out[]=
In[]:=
DeleteDuplicatesBy[Graph[Rule@@@unorderedToOrderedHypergraph[List@@@EdgeList[#]]]&/@allplots,Sort[Values[GraphNeighborhoodVolumes[UndirectedGraph[#]]]]&];
In[]:=
Length[%]
Out[]=
21