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[]:=
IconObject[{base1_,base2_},pts0_,r_]:=With[{base={base1,base2}},With[{pts=If[UnsameQ@@Quotient[2+#[[2]]&/@pts0,3],First/@pts0,With[{pos=Quotient[2+#[[2]]&/@pts0,3]/.{{x_,x_,x_}{1,2,3},{x_,x_,_}{1,2,0},{x_,_,x_}{1,0,2},{_,x_,x_}{0,1,2}}},If[(Cases[Last/@pts0,_Integer,1,1][[1]])(Select[Split[Sort[Cases[Quotient[2+#[[2]]&/@pts0,3],_Integer,1]]],Length[#]>1&][[1,1]]),With[{pt=pts0[[Position[pos,0][[1,1]],1]]},Map[repositionmultiples[base,pt,#.1]&,pos/.{2-1}]],With[{cors=If[Cases[Last/@pts0,_Integer,1,1][[1]]>Select[Split[Sort[Cases[Quotient[2+#[[2]]&/@pts0,3],_Integer,1]]],Length[#]>1&][[1,1]],pos,pos/.MapIndexed[##2[[1]]&,Reverse[Ordering[Mod[2+#[[2]]&/@pts0,3][[Flatten[Position[pos,1|2|3]]]]]]]]},MapIndexed[If[MatchQ[cors[[#2[[1]]]],0|2],#,repositionmultiples[base,#,Sign[cors[[#2[[1]]]]-2].1]]&,First/@pts0]]]]]},With[{uvecs=iconpoints3[Function[p,If[pbase,{1,0},(p-base)/Norm[p-base]]]/@pts]},With[{mids=MapThread[Plus,{uvecs,RotateLeft[uvecs]},1]/2},Table[{{Red,Green,Blue}[[i]],Polygon[{base,Offset[rmids[[i]],base],Offset[ruvecs[[i]],base],Offset[rmids[[Mod[i-1,3,1]]],base]}]},{i,3}]]]]]
In[]:=
repositionmultiples[p1_,p2_,d_]:=p2+d#/Norm[#]&[(p1-p2).{{0,1},{-1,0}}]
In[]:=
iconpoints3[{a_,b_,c_}]:=If[ab,{c.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},c.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}},c},If[ac,{b.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},b,b.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}}},If[bc,{a,a.{{Cos[2Pi/3],Sin[2Pi/3]},{-Sin[2Pi/3],Cos[2Pi/3]}},a.{{Cos[2Pi/3],-Sin[2Pi/3]},{Sin[2Pi/3],Cos[2Pi/3]}}},Nest[Map[#/Norm[#]&,#-RotateRight[#]&[Map[Max[0,(1.6-.8#)/#]&[Norm[#]]#&,{#[[1]]-#[[2]],#[[2]]-#[[3]],#[[3]]-#[[1]]}]]+#]&,{a,b,c},2]]]]
In[]:=
ColoredGraphPlot[ls_,opts___]:=Module[{graph,coordinates},graph=Graph[Sort[VertexList[Graph[GraphRules0[ls]]]],GraphRules0[ls]];coordinates=GraphEmbedding[graph,"SpringElectricalEmbedding"];Graph[graph,opts,VertexSizeSmall,VertexShapeFunctionFunction[{center,name,size},If[name≤Length[ls],IconObject[center,If[IntegerQ[#],{coordinates[[Quotient[2+#,3]]],#,name},{coordinates[[Length[ls]+First[#]]],#}]&/@ls〚name〛,0.2*^3Max[size]],Circle[center,Max[size]]]],PerformanceGoal"Quality",VertexCoordinatesThread[Range[VertexCount[graph]]coordinates],DirectedEdgesFalse,EdgeStyleDirective[Gray,Thick],VertexStyleDirective[Gray,Thick]]]
In[]:=
$arrow=FilledCurve[{{{0,2,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0},{0,1,0}}},{{{-1.,0.1848},{0.2991,0.1848},{-0.1531,0.6363},{0.109,0.8982},{1.,0.0034},{0.109,-0.8982},{-0.1531,-0.6363},{0.2991,-0.1848},{-1.,-0.1848},{-1.,0.1848}}}];
In[]:=
ColoredRulePlot[in_out_,padding_List:Automatic,opts:{{OptionsPattern[]},{OptionsPattern[]}}:{{},{}}]:=Module[{outCoordinates,inPlot,outPlot,plotRange,explicitPadding,finalPlots},outCoordinates=Take[GraphEmbedding[Echo@ColoredGraphPlot[out],"SpringElectricalEmbedding"],Length[Cases[in,_h,{2}]]];inPlot=ColoredGraphPlot[in,Sequence@@opts〚1〛,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesThread[Range[Length[in]+Length[outCoordinates]]ConstantArray[Automatic,Length[in]]~Join~outCoordinates]];outPlot=ColoredGraphPlot[out,Sequence@@opts〚2〛,GraphLayout"SpringElectricalEmbedding",VertexCoordinatesThread[Range[Length[out]+Length[outCoordinates]]ConstantArray[Automatic,Length[out]]~Join~outCoordinates]];explicitPadding=Replace[padding,Automatic{{0.2,0.2},{0.2,0.2}}];plotRange={{#〚1,1〛-explicitPadding〚1,1〛(#〚1,2〛-#〚1,1〛),#〚1,2〛+explicitPadding〚1,2〛(#〚1,2〛-#〚1,1〛)},{#〚2,1〛-explicitPadding〚2,1〛(#〚2,2〛-#〚2,1〛),#〚2,2〛+explicitPadding〚2,2〛(#〚2,2〛-#〚2,1〛)}}&@(MinMax/@Transpose[Catenate[AbsoluteOptions[#,VertexCoordinates]〚1,2〛&/@{inPlot,outPlot}]]);finalPlots=(Framed[Graph[#,PlotRangeplotRange,ImageSize128],FrameStyleGrayLevel[0.7]]&/@{inPlot,outPlot});Row[{finalPlots〚1〛,Graphics[{GrayLevel[0.65],$arrow},ImageSize0.22×128],finalPlots〚2〛}]]
In[]:=
ColoredGraphPlot[{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}},VertexLabelsAutomatic]
In[]:=
Out[]=
ColoredRulePlot[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]
In[]:=
»
Out[]=
Take[Range[10],-4]
In[]:=
{7,8,9,10}
Out[]=
ColoredRulePlot[{{2,1,4},{3,h[1],h[2]}}{{h[1],5,4},{3,2,h[2]}}]
In[]:=
Out[]=
RulePlot[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]]]
In[]:=
Out[]=
ColoredRulePlot[{{2,1,4},{3,h[1],h[2]}}{{h[1],5,4},{3,2,h[2]}},{{0.1,0.1},{0.7,0.3}},{{VertexSize0.4},{VertexSize0.3}}]
In[]:=
Out[]=
ColoredGraphPlot[{{2,1,4},{3,h[1],h[2]}}]ColoredGraphPlot[{{h[1],5,4},{3,2,h[2]}}]
In[]:=
Out[]=
ColoredGraphPlot[{{2,1,4},{3,h[1],h[2]}}]
In[]:=
Out[]=
ColoredGraphPlot[{{h[1],h[2],h[3]}}]
In[]:=
Out[]=
Graph[ColoredGraphPlot[{{h[1],h[2],6},{h[3],h[4],3}}]]
In[]:=
Out[]=
Graph[ColoredGraphPlot[{{6,9,12},{11,7,1},{5,10,2},{8,4,3}},GraphLayout"PlanarEmbedding",VertexCoordinatesAutomatic]]
In[]:=
Out[]=
SetOptions[RulePlot,FrameAutomatic];
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[]:=
Dynamic@hypergraphRuleToColored[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p4r},{p3g,p5g},{p4r,p3y},{p4y,p6y},{p5y,p6r},{p5g,p3g},{p6r,p5y},{p6y,p4y}}]
In[]:=
hypergraphRuleToColored[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,
p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p4r},{p3g,p5g},{p4r,p3y},{p4y,p6y},{p5y,p6r},{p5g,
p3g},{p6r,p5y},{p6y,p4y}}]
Out[]=
ColoredGraphPlot[hypergraphToColoredSpec[coloredSpecToHypergraph[EchoFunction[ColoredGraphPlot]@{{h[1],h[2],6},{h[3],h[4],3}}]]]
In[]:=
»
Out[]=
Dynamic[hypergraphToColoredSpec[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],1]["FinalState"]]]
In[]:=
hypergraphToColoredSpec[SetReplace`WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,
h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],
1][FinalState]]
Out[]=
ColoredGraphPlot[hypergraphToColoredSpec[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],1]["FinalState"]]]
In[]:=
Out[]=
WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],1]["FinalStatePlot",VertexLabelsAutomatic]
In[]:=
Out[]=
RulePlot[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]]]
In[]:=
Out[]=
WolframModelPlot[coloredSpecToHypergraph[{{6,9,12},{11,7,1},{5,10,2},{8,4,3}}]]
In[]:=
Out[]=
WolframModelPlot[coloredSpecToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}]]
In[]:=
Out[]=
IconGP[{{2,1,6},{5,4,3}}]
In[]:=
Out[]=
WolframModelPlot[coloredSpecToHypergraph[{{2,1,6},{5,4,3}}]]
In[]:=
Out[]=
Get["/Users/maxitg/Dropbox (Wolfram)/Physics/SW2004Material/Data/AllOrderedNetsTo4.m"];
In[]:=
Get["/Users/maxitg/Dropbox (Wolfram)/Physics/SW2004Material/Data/RewritesOrdered24h4.m"];
In[]:=
Row[Flatten[{Framed[NetRulePlot[RewritesOrdered24h4[[#1]],ImageSize40]],HighlightNetEvolveListPlotStepped[{RewritesOrdered24h4[[#1]]},AllOrderedNetsTo4[[2]][[1]],10,ImageSize90]," "}]]&@@{73}
In[]:=
Out[]=
RulePlot[WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]]]
In[]:=
Out[]=
ColoredGraphPlot[{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}},VertexLabelsAutomatic]
In[]:=
Out[]=
ColoredRulePlot[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}]
In[]:=
Out[]=
ColoredGraphPlot[{{h[1],h[2],6},{h[3],h[4],3}},ImageSize{Automatic,100}]ColoredGraphPlot[{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}},ImageSize{Automatic,100}]
In[]:=
Out[]=
WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],10]["StatesPlotsList"]
In[]:=
Out[]=
ColoredGraphPlot/@hypergraphToColoredSpec/@WolframModel[coloredRuleToHypergraph[{{h[1],h[2],6},{h[3],h[4],3}}{{6,h[1],h[2]},{8,7,1},{5,4,10},{9,h[3],h[4]}}],coloredSpecToHypergraph[{{4,5,6},{1,2,3}}],10]["StatesList"]
In[]:=
Out[]=
WolframModel[{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r}}{{p1g,p3y,p3g},{p4r,p4y,p1y},{p2g,p5y,p5g},{p6r,p6y,p2y},{p3y,p4r},{p3g,p5g},{p4r,p3y},{p4y,p6y},{p5y,p6r},{p5g,p3g},{p6r,p5y},{p6y,p4y}},{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r},{p1y,p2y},{p2y,p1y},{p1g,p2g},{p2g,p1g}},8]
In[]:=
Out[]=
WolframModel[coloredRuleToHypergraph[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}}]],{{p1r,p1y,p1g},{p2r,p2y,p2g},{p1r,p2r},{p2r,p1r},{p1y,p2y},{p2y,p1y},{p1g,p2g},{p2g,p1g}},8,"FinalStatePlot"]
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[]=
(Graph[#,VertexLabelsAutomatic]&)/@ColoredGraphPlot/@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[]:=
Out[]=
ColoredGraphPlot[{{h[3],h[2],h[1]}},VertexLabelsAutomatic]
In[]:=
Out[]=
ColoredGraphPlot[{{4,7,10},{1,8,11},{2,5,12},{3,6,9}}]
In[]:=
Out[]=
Graph[{12,13,15,24,26,34,37,48,56,57,68,78},GraphLayout"PlanarEmbedding",VertexLabelsAutomatic]
In[]:=
Out[]=
ColoredGraphPlot[{{4,7,13},{1,10,16},{2,11,19},{5,8,22},{3,17,20},{6,14,23},{9,15,24},{12,18,21}},VertexLabelsAutomatic]
In[]:=
Out[]=