Init

User Policies

excludeUser[username_]:=Function[expr,If[$UserName=!=username,expr],HoldAll]
In[]:=
excludeStephen=excludeUser["sw"];
In[]:=

Dependencies

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"};
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

Length[rules]
In[]:=
264
Out[]=
Select[{{_h,_,_},{_h,_,_},{_h,_,_},{_h,_,_}}][Last/@Select[First@#==={{4,h[1],h[2]},{1,h[3],h[4]}}&]@rules〚All,All,1,2〛]
In[]:=
{}
Out[]=
Counts[Last/@Select[MatchQ[First@#,{{_,_h,_h},{_,_h,_h}}]&]@rules〚All,All,1,2〛/.{_hh,_Integer0}]
In[]:=
Out[]=
{{_h,_,_},{_h,_,_},{_h,_,_},{_h,_,_}}
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}}]
In[]:=
{}
Out[]=
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[]=
dedplicatedAllPlots=DeleteDuplicates[allplots,IsomorphicGraphQ@@SimpleGraph/@{##}&];
In[]:=
GraphicsGrid[Partition[dedplicatedAllPlots,UpTo[7]]]
In[]:=
Out[]=
rules〚1〛
In[]:=
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]}}}]
Out[]=
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
In[]:=
Out[]=
dedupx=DeleteDuplicatesBy[allplotsx,IsomorphicGraphQ@@SimpleGraph/@(First/@{##})&];
{#[[1,1]](OrderedGraphModelPlot[Last@#,Automatic,{{ImageSize50},{ImageSize50}}]&/@#)}&/@Take[gathered,4]
In[]:=
Out[]=
{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,8,h[1]},{1,11,h[2]},{10,2,h[3]},{7,5,h[4]}}/.{h[1]a,h[2]b,h[3]c,h[4]d}
In[]:=
{{4,a,b},{1,c,d}}{{4,8,a},{1,11,b},{10,2,c},{7,5,d}}
Out[]=
gathered[[1]]
In[]:=
#[[1,-1]]&/@gathered
In[]:=
Out[]=
ruleforms=rules/.OrderedNet[{_,x_}]x;
In[]:=
Take[ruleforms,10]
In[]:=
Out[]=
ruleforms[[{-1,1,14}]]
In[]:=
Out[]=
Map[OrderedGraphModelPlot[#,VertexShapeFunction"Circle",ImageSize80]&,{{{h[1],h[2],6},{h[3],h[4],3}}{{h[4],h[1],6},{8,7,3},{5,4,12},{h[2],h[3],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,8,h[1]},{1,11,h[2]},{10,2,h[3]},{7,5,h[4]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,9,h[4]},{1,12,h[2]},{h[1],11,2},{h[3],8,5}}},{2}]
In[]:=
Out[]=
OrderedGraphModelPlot[#]&/@{{{h[1],h[2],6},{h[3],h[4],3}}{{h[4],h[1],6},{8,7,3},{5,4,12},{h[2],h[3],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,8,h[1]},{1,11,h[2]},{10,2,h[3]},{7,5,h[4]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,9,h[4]},{1,12,h[2]},{h[1],11,2},{h[3],8,5}}}
In[]:=
Out[]=
Map[OrderedGraphModelPlot[#,VertexShapeFunction"Circle"]&,ruleforms,{2}]
In[]:=
Out[]=
Union[%]
In[]:=
Out[]=
GraphicsGrid[Partition[ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],8]["FinalState"]],VertexShapeFunction"Circle"]&,alldistinct],UpTo[6]],ImageSizeFull]
In[]:=
Out[]=
rules[[{45,18,21,17,31}]]/.OrderedNet[{_,x_}]x
In[]:=
Out[]=
ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],8]["FinalState"]],VertexShapeFunction"Circle"]&,{{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[4],7},{1,h[2],10},{3,11,h[1]},{6,8,h[3]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],7},{1,h[3],10},{3,h[4],12},{6,h[2],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],8},{1,h[3],11},{10,3,h[2]},{7,6,h[4]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],7},{1,h[3],10},{3,h[2],12},{6,h[4],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],9},{1,h[4],12},{10,h[2],3},{7,h[3],6}}}]
In[]:=
Out[]=
FindCanonicalWolframModel[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p1y,p4y,p4g},{p2g,p5y,p5g},{p2y,p6y,p6g},{p3y,p6g},{p3g,p4y},{p4y,p3g},{p4g,p5y},{p5y,p4g},{p5g,p6y},{p6y,p5g},{p6g,p3y}}]
In[]:=
{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{10,7},{8,13},{13,8},{9,12},{12,9},{11,14},{14,11}}
Out[]=
coloredRuleToHypergraph/@{{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[4],7},{1,h[2],10},{3,11,h[1]},{6,8,h[3]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],7},{1,h[3],10},{3,h[4],12},{6,h[2],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],8},{1,h[3],11},{10,3,h[2]},{7,6,h[4]}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],7},{1,h[3],10},{3,h[2],12},{6,h[4],9}},{{4,h[1],h[2]},{1,h[3],h[4]}}{{4,h[1],9},{1,h[4],12},{10,h[2],3},{7,h[3],6}}}
In[]:=
Out[]=
FindCanonicalWolframModel/@%176
In[]:=
Out[]=
Get["/Users/sw/Dropbox/Physics/SW2004Material/Data/AllOrderedNetsTo4.m"];
In[]:=
%[[2]][[1]]
In[]:=
OrderedNet[{{1,1},{{4,5,6},{1,2,3}}}]
Out[]=
OrderedGraphModelPlot[hypergraphToColoredSpec[WolframModel[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p1y,p4y,p4g},{p2g,p5y,p5g},{p2y,p6y,p6g},{p3y,p6g},{p3g,p4y},{p4y,p3g},{p4g,p5y},{p5y,p4g},{p5g,p6y},{p6y,p5g},{p6g,p3y}},coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],9]["FinalState"]]]
In[]:=
Out[]=
hypergraphRuleToColored[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p1y,p4y,p4g},{p2g,p5y,p5g},{p2y,p6y,p6g},{p3y,p6g},{p3g,p4y},{p4y,p3g},{p4g,p5y},{p5y,p4g},{p5g,p6y},{p6y,p5g},{p6g,p3y}}]
In[]:=
{{4,h[2],h[1]},{1,h[4],h[3]}}{{h[1],12,5},{h[2],3,8},{h[3],6,11},{h[4],9,2}}
Out[]=
rules〚All,All,1,2〛
In[]:=
Out[]=
Position[rules〚All,All,1,2〛,{{4,h[2],h[1]},{1,h[4],h[3]}}{{h[1],12,5},{h[2],3,8},{h[3],6,11},{h[4],9,2}}]
In[]:=
{}
Out[]=
Length[rules]
In[]:=
264
Out[]=
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}}]
In[]:=
{}
Out[]=
TODO: colors appear to be incorrect here.
OrderedGraphModelPlot[{{4,h[2],h[1]},{1,h[4],h[3]}}{{h[1],12,5},{h[2],3,8},{h[3],6,11},{h[4],9,2}},Automatic,{{VertexSizeLarge,VertexLabelsAutomatic},{VertexSizeLarge,VertexLabelsAutomatic}}]
In[]:=
Out[]=
coloredRuleToHypergraph[{{4,h[2],h[1]},{1,h[4],h[3]}}{{h[1],12,5},{h[2],3,8},{h[3],6,11},{h[4],9,2}}]
In[]:=
{{1,2,3},{4,5,6},{1,4},{4,1}}{{3,8,9},{2,11,12},{6,14,15},{5,17,18},{8,18},{9,11},{11,9},{12,14},{14,12},{15,17},{17,15},{18,8}}
Out[]=
RulePlot@WolframModel@coloredRuleToHypergraph[{{4,h[2],h[1]},{1,h[4],h[3]}}{{h[1],12,5},{h[2],3,8},{h[3],6,11},{h[4],9,2}}]
In[]:=
Out[]=
RulePlot@WolframModel[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p1y,p4y,p4g},{p2g,p5y,p5g},{p2y,p6y,p6g},{p3y,p6g},{p3g,p4y},{p4y,p3g},{p4g,p5y},{p5y,p4g},{p5g,p6y},{p6y,p5g},{p6g,p3y}}]
In[]:=
Out[]=