Code from Brad
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
More code
In[]:=
grouprules[rules_]:=SubsetReplace[rules/.((x_->x_)->Nothing),{x_->y_,y_->x_}->(x<->y)]
Running
Running
In[]:=
sortedPairMaps
Out[]=
In[]:=
Length/@sortedPairMaps
Out[]=
1945,31260,5378,736,91
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[]=
76
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[]=
2 two-way rules
2 two-way rules