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
SetAttributes[BracketingBar,Orderless]
SetAttributes[DoubleBracketingBar,{Flat,Orderless}]
tetra=12,3,4,21,3,4,31,2,4,41,2,3
12,3,4,21,3,4,31,2,4,41,2,3
asym=12,8,7,23,11,1,32,11,4,43,12,5,54,12,6,65,9,7,76,8,1,81,7,9,96,8,10,109,11,12,112,3,10,124,5,10
12,7,8,21,3,11,32,4,11,43,5,12,54,6,12,65,7,9,71,6,8,81,7,9,96,8,10,109,11,12,112,3,10,124,5,10
exrule=x1_x5_,x6_,x4_,x2_x7_,x8_,x4_,x3_x9_,x10_,x4_,x4_x1_,x2_,x3_x1x5,x6,x4,x3x9,x10,New[2],x2x7,x8,New[1],x4x1,New[1],New[2],New[1]x4,x2,New[2],New[2]New[1],x4,x3
x1_x4_,x5_,x6_,x2_x4_,x7_,x8_,x3_x10_,x4_,x9_,x4_x1_,x2_,x3_x1x5,x6,x4,x3x9,x10,New[2],x2x7,x8,New[1],x4x1,New[1],New[2],New[1]x4,x2,New[2],New[2]New[1],x4,x3
Note: with this representation, we automatically ensure that the hair vertices will be distinct. This would be more difficult to achieve with an edge-based representation.
UStep[urule_,state_]:=Block[{New},state/.urule/.New[n_]n+Apply[Max,First/@state]]
UStep[exrule,tetra]
12,3,4,21,3,5,31,2,6,41,5,6,52,4,6,63,4,5
exevol=NestList[UStep[exrule,#]&,tetra,5]
{12,3,4,21,3,4,31,2,4,41,2,3,12,3,4,21,3,5,31,2,6,41,5,6,52,4,6,63,4,5,12,7,8,21,3,5,32,6,7,45,6,8,52,4,6,63,4,5,71,3,8,81,4,7,12,7,8,21,9,10,36,7,9,45,6,8,54,6,10,63,4,5,71,3,8,81,4,7,92,3,10,102,5,9,12,11,12,21,9,10,36,7,9,45,6,8,54,6,10,63,4,5,73,8,11,84,7,12,92,3,10,102,5,9,111,7,12,121,8,11,12,11,12,21,13,14,36,7,9,45,6,8,54,6,10,63,4,5,73,8,11,84,7,12,93,10,13,105,9,14,111,7,12,121,8,11,132,9,14,142,10,13}
Length/@%
{4,6,8,10,12,14}
TrivalentQ[g_]:=Module[{nodes},nodes=Sort[Apply[List,First/@g]];Sort[Flatten[Apply[List,Last/@g,{0,1}]]]===Sort[Flatten[{nodes,nodes,nodes}]]]
TrivalentQ/@exevol
{True,True,True,True,True,True}
RewriteRules[rule_]:=Module[{s},s=Union[Cases[Level[rule,{-1}],_Symbol]];rule/.Apply[Rule,Transpose[{s,Take[ToExpression/@CharacterRange["α","ω"],Length[s]]}],{1}]]
RewriteRules[exrule]
α_ϵ_,ζ_,η_,γ_ϵ_,θ_,ι_,δ_β_,ϵ_,κ_,ϵ_α_,γ_,δ_αζ,η,ϵ,δκ,β,New[2],γθ,ι,New[1],ϵα,New[1],New[2],New[1]ϵ,γ,New[2],New[2]New[1],ϵ,δ
NeighborCounts[g_,i0_,n_]:=Map[Length,Module[{gp=Dispatch[NetworkToRuleList[g]]},NestList[Union[Flatten[{#,#/.gp}]]&,{i0},n]]]
NeighborCounts[g_,i0_:1]:=Map[Length,Module[{gp=Dispatch[NetworkToRuleList[g]]},FixedPointList[Union[Flatten[{#,#/.gp}]]&,{i0}]]]
NeighborCounts[Last[exevol],1,6]
{1,3,7,12,14,14,14}
NeighborLists[g_,i0_,n_]:=Module[{gp=Apply[List,g]},Apply[List,NestList[Union[Flatten[#/.gp]]&,i0,n],{1}]]
NeighborLists[g_,i0_:1]:=Module[{gp=Apply[List,g]},Apply[List,FixedPointList[Union[Flatten[#/.gp]]&,i0],{1}]]
NeighborLists[OneD[10]]
{{1},{0,3,9},{1,2,5,7,8},{0,3,4,5,6,7,9},{1,2,3,4,5,6,7,8,9},{0,1,2,3,4,5,6,7,8,9},{0,1,2,3,4,5,6,7,8,9}}
Note: the version below does not work properly at all.....
RandomNetwork[n_]:=Apply[DoubleBracketingBar,MapIndexed[First[#2]Apply[BracketingBar,#1]&,Partition[Last/@Sort[{Random[],#}&/@Join[#,#,#]&[Range[n]]],3]]]
RandomNetwork[4]
11,4,4,21,2,2,31,3,3,42,3,4
NetworkToList[g_]:=Module[{nodes},nodes=First/@g;Map[Position[nodes,#][[1,1]]&,Apply[List,Last[#]]&/@Apply[List,g],{2}]]
NetworkToRuleList[g_]:=g/.DoubleBracketingBarList/.BracketingBarList
Still to write:
NetworkToArcs[]
CirclePicture[g_]:=With[{gmap=NetworkToList[g]},Graphics[{{GrayLevel[.5],AbsoluteThickness[1],Line[{{1,0},{Length[gmap],0}}]},{AbsolutePointSize[.5],Table[Point[{i,0}],{i,Length[gmap]}]},Table[Circle[{(i+gmap[[i,j]])/2,0},Abs[gmap[[i,j]]-i]/2,{0,π}],{i,Length[gmap]},{j,3}]},AspectRatio->Automatic,PlotRange->All]]
Show[CirclePicture[tetra]]
⁃Graphics⁃
Show[CirclePicture[Last[exevol]]];
Show[GraphicsColumn[CirclePicture/@exevol]];
The following version reorders at each step:
Note: the cross-connections overlay the rest of the graph.