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
Using code from ColoredNetworks-06
Using code from ColoredNetworks-06
In[]:=
selected=rules[[{45,18,21,17,31}]]
Out[]=
In[]:=
all=ParallelMapMonitored[TimeConstrained[WolframModel[coloredRuleToHypergraph[#],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],4]["FinalState"],5]#&,selected/.OrderedNet[{_,x_}]x];
In[]:=
ParallelMapMonitored[OrderedGraphModelPlot[hypergraphToColoredSpec[First[#]],VertexShapeFunction"Circle"]Last[#]&,all]
Out[]=
In[]:=
coloredSpecToHypergraph[{{4,5,6},{1,2,3}}]
Out[]=
{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}}
In[]:=
inits=Get["/Users/sw/Dropbox/Physics/SW2004Material/Data/AllOrderedNetsTo4.m"];
In[]:=
inits[[2]][[1]]
Out[]=
OrderedNet[{{1,1},{{4,5,6},{1,2,3}}}]
In[]:=
coloredRuleToHypergraph/@(selected/.OrderedNet[{_,x_}]x)
Out[]=
TED rules
TED rules
In[]:=
Take[(rules[[Union[Range[50],{17,18,19,20,21,22,31,32,33,34,45,46,113,114,115,116,117,118,123,124,125,126,143,144,197,198,199,200,201,202,215,216,217,218,231,232}]]]/.(OrderedNet[{_,x_}]x)),5]
Out[]=
In[]:=
OrderedGraphModelPlot[#,Automatic,{{VertexSize.4},{VertexSize.5}}]&/@Take[(rules[[Union[Range[50],{17,18,19,20,21,22,31,32,33,34,45,46,113,114,115,116,117,118,123,124,125,126,143,144,197,198,199,200,201,202,215,216,217,218,231,232}]]]/.(OrderedNet[{_,x_}]x)),5]
Out[]=
In[]:=
coloredRuleToHypergraph/@Take[(rules[[Union[Range[50],{17,18,19,20,21,22,31,32,33,34,45,46,113,114,115,116,117,118,123,124,125,126,143,144,197,198,199,200,201,202,215,216,217,218,231,232}]]]/.(OrderedNet[{_,x_}]x)),5]
Out[]=
In[]:=
RulePlot[WolframModel[#]]&/@%
Out[]=
In[]:=
AllOrderedNetsTo4[[2]]
Out[]=
NetPlot[#,ImageSize45]&/@Select[AllOrderedNetsTo4[[2]],HairNumber[#]0&]
IconGP[#,ImageSize45]&/@Select[AllOrderedNetsTo4[[2]],HairNumber[#]0&]
In[]:=
IconGP[x:_[{_,ls_}],opts___]/;OptionQ[{opts}]:=IconGP[x,IconObject,opts]
In[]:=
IconGP[_[{_,ls_}],nodefunction_,opts___]:=Module[{gp=GraphPlot[GraphRules0[ls]],pts},pts=gp[[1,1,1]][[Ordering[VertexList[GraphRules0[ls]]]]];Graphics[{gp[[1]],MapIndexed[Function[{var,ind},nodefunction[var,If[IntegerQ[#],{pts[[Quotient[2+#,3]]],#,ind[[1]]},{pts[[Length[ls]+First[#]]],#}]&/@Extract[ls,ind]]],Take[pts,Length[ls]]]},Sequence@@Rest[gp],opts]]
In[]:=
GraphRules0[ls_]:=Join[Union[Select[#,SameQ@@#&]],Select[Flatten[MapIndexed[#2[[1]]Quotient[#+2,3]&,ls/.{h[n_]3(n+Length[ls])},{2}]],#[[1]]<#[[2]]&]]&[Flatten[MapIndexed[#2[[1]]Quotient[#+2,3]&,ls/.{h[n_]3(n+Length[ls])},{2}]]]
In[]:=
Take[rules[[Union[Range[50],{17,18,19,20,21,22,31,32,33,34,45,46,113,114,115,116,117,118,123,124,125,126,143,144,197,198,199,200,201,202,215,216,217,218,231,232}]]],5]
Out[]=
In[]:=
Map[IconGP,%,{2}]