Equivalencing rules

A rule is a partitioning of a collection of possible blocks

In[]:=
Tuples[{0,1},3]
Out[]=
{{0,0,0},{0,0,1},{0,1,0},{0,1,1},{1,0,0},{1,0,1},{1,1,0},{1,1,1}}
In[]:=
PartitionsP[5]
Out[]=
7
In[]:=
IntegerPartitions[5]
Out[]=
{{5},{4,1},{3,2},{3,1,1},{2,2,1},{2,1,1,1},{1,1,1,1,1}}
In[]:=
Subsets[Range[4]]
Out[]=
{{},{1},{2},{3},{4},{1,2},{1,3},{1,4},{2,3},{2,4},{3,4},{1,2,3},{1,2,4},{1,3,4},{2,3,4},{1,2,3,4}}
In[]:=
ResourceFunction["SetPartitions"][Range[4]]
Out[]=
{{{1,2,3,4}},{{1},{2,3,4}},{{1,2},{3,4}},{{1,3,4},{2}},{{1,2,3},{4}},{{1,4},{2,3}},{{1,2,4},{3}},{{1,3},{2,4}},{{1},{2},{3,4}},{{1},{2,3},{4}},{{1},{2,4},{3}},{{1,2},{3},{4}},{{1,3},{2},{4}},{{1,4},{2},{3}},{{1},{2},{3},{4}}}
In[]:=
Length[%]
Out[]=
15
In[]:=
BellB[4]
Out[]=
15
In[]:=
Tuples[{2},2]
Out[]=
{{2,2}}
In[]:=
Framed[Graph[Flatten[#]]]&/@Map[(UndirectedEdge@@@Tuples[#,2])&,ResourceFunction["SetPartitions"][Range[4]],{2}]
Out[]=

,
,
,
,
,
,
,
,
,
,
,
,
,
,


Canonicalization

In[]:=
Map[#->Min[#]&,ResourceFunction["SetPartitions"][Range[4]],{2}]
Out[]=
{{{1,2,3,4}1},{{1}1,{2,3,4}2},{{1,2}1,{3,4}3},{{1,3,4}1,{2}2},{{1,2,3}1,{4}4},{{1,4}1,{2,3}2},{{1,2,4}1,{3}3},{{1,3}1,{2,4}2},{{1}1,{2}2,{3,4}3},{{1}1,{2,3}2,{4}4},{{1}1,{2,4}2,{3}3},{{1,2}1,{3}3,{4}4},{{1,3}1,{2}2,{4}4},{{1,4}1,{2}2,{3}3},{{1}1,{2}2,{3}3,{4}4}}
By just equivalencing subsets, all equivalencing happens in a single step... [at least for the basic blocks]
But equivalencing could also be a process

Equivalencing CA States

In[]:=
Graph[#->CellularAutomaton[30][#]&/@Tuples[{1,0},5]]
Out[]=
In[]:=
BellB[32]
Out[]=
128064670049908713818925644
In[]:=
BellB[8]
Out[]=
4140
Can equivalence smaller blocks, so not equivalencing everything at once... Then we have multi-step equivalences

How will the STGs collapse after equivalencing?

In[]:=
allrules2=Catenate/@Map[Function[u,#->First[Sort[u]]&/@u],ResourceFunction["SetPartitions"][Tuples[{0,1},2]],{2}]
Out[]=
{{{0,0}{0,0},{0,1}{0,0},{1,0}{0,0},{1,1}{0,0}},{{0,0}{0,0},{0,1}{0,1},{1,0}{0,1},{1,1}{0,1}},{{0,0}{0,0},{0,1}{0,0},{1,0}{1,0},{1,1}{1,0}},{{0,0}{0,0},{1,0}{0,0},{1,1}{0,0},{0,1}{0,1}},{{0,0}{0,0},{0,1}{0,0},{1,0}{0,0},{1,1}{1,1}},{{0,0}{0,0},{1,1}{0,0},{0,1}{0,1},{1,0}{0,1}},{{0,0}{0,0},{0,1}{0,0},{1,1}{0,0},{1,0}{1,0}},{{0,0}{0,0},{1,0}{0,0},{0,1}{0,1},{1,1}{0,1}},{{0,0}{0,0},{0,1}{0,1},{1,0}{1,0},{1,1}{1,0}},{{0,0}{0,0},{0,1}{0,1},{1,0}{0,1},{1,1}{1,1}},{{0,0}{0,0},{0,1}{0,1},{1,1}{0,1},{1,0}{1,0}},{{0,0}{0,0},{0,1}{0,0},{1,0}{1,0},{1,1}{1,1}},{{0,0}{0,0},{1,0}{0,0},{0,1}{0,1},{1,1}{1,1}},{{0,0}{0,0},{1,1}{0,0},{0,1}{0,1},{1,0}{1,0}},{{0,0}{0,0},{0,1}{0,1},{1,0}{1,0},{1,1}{1,1}}}
In[]:=
canonicalize[rule_,list_]:=FixedPoint[SequenceReplace[#,First[#]->Splice[Last[#]]&/@rule]&,list]
Note: this process may not be confluent....
In[]:=
Graph[Map[canonicalize[{{0,0}{0,0},{0,1}{0,1},{1,0}{0,1},{1,1}{1,1}},#]&,EdgeList[Graph[#->CellularAutomaton[30][#]&/@Tuples[{1,0},5]]],{2}]]
Out[]=

Reversible rules