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
User Policies
User Policies
In[]:=
excludeUser[username_]:=Function[expr,If[$UserName=!=username,expr],HoldAll]
In[]:=
excludeStephen=excludeUser["sw"];
Dependencies
Dependencies
In[]:=
excludeStephen[<<SetReplace`;Quiet[ParallelEvaluate[<<SetReplace`],CloudConnect::clver]];
In[]:=
getResourceFunction[filename_]:=excludeStephen@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"};
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[]:=
Length[rules]
Out[]=
264
In[]:=
Select[{{_h,_,_},{_h,_,_},{_h,_,_},{_h,_,_}}][Last/@Select[First@#==={{4,h[1],h[2]},{1,h[3],h[4]}}&]@rules〚All,All,1,2〛]
Out[]=
{}
In[]:=
Counts[Last/@Select[MatchQ[First@#,{{_,_h,_h},{_,_h,_h}}]&]@rules〚All,All,1,2〛/.{_hh,_Integer0}]
Out[]=
{{_h,_,_},{_h,_,_},{_h,_,_},{_h,_,_}}
In[]:=
Position[rules〚All,All,1,2〛,{{4,h[1],h[2]},{1,h[3],h[4]}}{{h[1],6,11},{h[2],9,2},{h[3],12,5},{h[4],3,8}}]
Out[]=
{}
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[]:=
dedplicatedAllPlots=DeleteDuplicates[allplots,IsomorphicGraphQ@@SimpleGraph/@{##}&];
In[]:=
GraphicsGrid[Partition[dedplicatedAllPlots,UpTo[7]]]
Out[]=
In[]:=
rules〚1〛
Out[]=
OrderedNet[{{1,1},{{4,h[1],h[2]},{1,h[3],h[4]}}}]OrderedNet[{{1,1,1,1},{{4,8,h[1]},{1,11,h[2]},{10,2,h[3]},{7,5,h[4]}}}]
In[]:=
allresx=ParallelMapMonitored[TimeConstrained[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],4]["FinalState"],5]#&,rules/.OrderedNet[{_,x_}]x];
In[]:=
allplotsx=ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[First[#]],VertexShapeFunction"Circle"]Last[#]&,allresx];
In[]:=
gathered=Gather[allplotsx,IsomorphicGraphQ@@SimpleGraph/@(First/@{##})&];
In[]:=
{First[#]OrderedGraphModelPlot[Last[#]]}&[First[#]]&/@gathered
Out[]=
TODO: colors appear to be incorrect here.