Wolfram Cloud Document

Code from Brad

In[]:=

sortedPairMaps=GroupBy[ParityPairings[Tuples[Range[0,2],2]],Total[Boole[SameQ@@@#],2]&];

In[]:=

PerturbRule[rule_,ind_]:=With[{paired=Rule@@@Union[Join[#,Reverse/@#]]&@DeleteCases[rule,{x_,x_}],id=Cases[rule,{x_,x_}:>x]},Join[paired,Map[#->#&,Complement[id,#[[All,1]]]],#]&/@Catenate[Outer[MapThread[#1->#2&,{#1,#2}]&,Subsets[id,{ind}],Tuples[Tuples[Reverse@Range[0,2],2],ind],1]]]

In[]:=

symmetricQ[rules_]:=Sort[Map[Reverse,rules,{2}]]===Sort[rules]

In[]:=

quiescentQ[rules_]:=SameQ[{0,0}/.rules,{0,0}]

In[]:=

filter=Function[{rules},And[symmetricQ[rules],quiescentQ[rules]]]

Out[]=

Function[{rules},symmetricQ[rules]&&quiescentQ[rules]]

More code

In[]:=

grouprules[rules_]:=SubsetReplace[rules/.((x_->x_)->Nothing),{x_->y_,y_->x_}->(x<->y)]

Running

In[]:=

sortedPairMaps

Out[]=

1{{{{0,0},{0,0}},{{0,1},{0,2}},{{1,0},{1,1}},{{1,2},{2,0}},{{2,1},{2,2}}},{{{0,0},{0,0}},{{0,1},{0,2}},{{1,0},{1,1}},{{1,2},{2,1}},{{2,0},{2,2}}},

⋯942⋯

,{{{0,0},{2,2}},{{0,1},{2,1}},{{0,2},{2,0}},{{1,0},{1,2}},{{1,1},{1,1}}}},3{

⋯1⋯

},5

⋯1⋯

,7{

⋯1⋯

},9{{{{0,0},{0,0}},

⋯7⋯

,{{2,2},{2,2}}}}

Full expression not available

(

original memory size:

6.2 MB)

In[]:=

Length/@sortedPairMaps

Out[]=

1945,31260,5378,736,91

In[]:=

sortedPairMaps[5][[10]]

Out[]=

{{{0,0},{0,0}},{{0,1},{0,1}},{{0,2},{0,2}},{{1,0},{1,0}},{{1,1},{2,1}},{{1,2},{1,2}},{{2,0},{2,2}}}

In[]:=

sortedPairMaps[3][[10]]

Out[]=

{{{0,0},{0,0}},{{0,1},{0,1}},{{0,2},{0,2}},{{1,0},{2,1}},{{1,1},{1,2}},{{2,0},{2,2}}}

In[]:=

grouprules[{{1,0}{2,1},{1,1}{1,2},{1,2}{1,1},{2,0}{2,2},{2,1}{1,0},{2,2}{2,0},{0,1}{0,1},{0,2}{0,2},{0,0}{2,1}}]

Out[]=

{{1,0}{2,1},{1,1}{1,2},{2,0}{2,2},{0,0}{2,1}}

ResourceFunction["InteractiveListSelector"][(ArrayPlot[ResourceFunction["BlockCellularAutomaton"][#,CenterArray[{2,1,2},60],40],ColorRules->{0->White,1->Lighter[Orange],2->Darker[Orange]}]->#)&/@Select[Catenate[PerturbRule[#,1]&/@sortedPairMaps[3]],filter]]

In[]:=

Select[Catenate[PerturbRule[#,1]&/@sortedPairMaps[3]],filter];

In[]:=

Length[%]

Out[]=

In[]:=

ResourceFunction["InteractiveListSelector"][(ArrayPlot[ResourceFunction["BlockCellularAutomaton"][#,CenterArray[{2,2},60],40],ColorRules->{0->White,1->Lighter[Orange],2->Darker[Orange]}]->#)&/@Select[Catenate[PerturbRule[#,1]&/@sortedPairMaps[3]],filter]]

Out[]=



Add



Clear

Copy

Code from Brad

More code

Running

2 two-way rules