RulePlot[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}}]]
In[]:=
Out[]=
FindCanonicalHypergraph/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,2}],50,"StatesList"]
In[]:=
{{{1,2},{2,3}},{{1,2},{3,2}}}
Out[]=
FindTransientRepeat[%%,2]
In[]:=
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[FindCanonicalHypergraph/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,5}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[FindCanonicalHypergraph/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,10}]
In[]:=
$Aborted
Out[]=
fch[data_]:=fch[data]=
[◼]
FindCanonicalHypergraph
[data]
In[]:=
WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,5}],50,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,6}],50,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,7}],50,"StatesPlotsList"]
In[]:=
Out[]=
Graph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,7}],50,"StatesList"]
In[]:=
Out[]=
CanonicalGraph/@%152
In[]:=
Out[]=
FindTransientRepeat[%%,2]
In[]:=
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,7}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,10}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7},{6,0},{5,7},{2,6}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,14}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7},{6,0},{5,7},{2,6},{51,0},{7,8},{28,9},{5,14}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],100,"StatesList"],2],{n,14}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7},{6,0},{5,7},{2,6},{48,10},{7,8},{28,9},{5,14}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],100,"StatesList"],2],{n,20}]
In[]:=
$Aborted
Out[]=
states=Table[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],100,"StatesList"],{n,15,20}];
In[]:=
Map[Length,states,{2}]
In[]:=
Out[]=
ParallelMap[CanonicalGraph[Rule@@@#]&,states,{2}]
In[]:=
$Aborted
Out[]=
ParallelMap[TimeConstrained[CanonicalGraph[Rule@@@#],2]&,states,{2}]
In[]:=
$Aborted
Out[]=
ParallelMap[TimeConstrained[FindCanonicalHypergraph[#],2]&,states,{2}]
In[]:=
$Aborted
Out[]=
DelDup[list_List]:=Module[{alphabet},alphabet=DeleteDuplicates[Flatten[list]];list/.Thread[alphabetRange[Length[alphabet]]]];
In[]:=
MiserTermsInTuples[tup_List]:=Module[{gather,gat,size,seqs},​​gather=Gather[tup];​​size=Length[gather];​​seqs={#}&/@Range[size];​​gat=First/@gather;​​Do[​​seqs=Take[EchoFunction[Length]@Flatten[With[{grow=#,new=Complement[Range[size],#]},Append[grow,#]&/@new]&/@​​First[SplitBy[SortBy[seqs,Length[Union[Flatten[gat[[#]]]]]&],Length[Union[Flatten[gat[[#]]]]]&]],1],UpTo[500]],​​{k,1,size-1}];​​First[SplitBy[SortBy[Union[Flatten[gather[[#]],1]&/@seqs],DelDup[#]&],DelDup[#]&]]];
In[]:=
CanonicalizeParts[list_List]:=Module[{parts,canonicalparts},​​parts=GatherBy[ReverseSort[list],Length];​​canonicalparts=MiserTermsInTuples[#]&/@parts;​​Flatten[DelDup[First[SortBy[Tuples[canonicalparts],DelDup[Flatten[#]]&]]],1]];
In[]:=
FindCanonicalHypergraph[list_]:=CanonicalizeParts[list];
In[]:=
ParallelMap[TimeConstrained[FindCanonicalHypergraph[#],2]&,states,{2}]
In[]:=
Graph[Rule@@@#]&/@First[states]
In[]:=
Out[]=
CharacteristicPolynomial[AdjacencyMatrix[#],x]&/@First[states]
In[]:=
Out[]=
FindTransientRepeat[%,2]
In[]:=
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,14}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7},{6,0},{5,7},{2,6},{51,0},{7,8},{28,9},{5,14}}
Out[]=
data=ParallelTable[Length/@FindTransientRepeat[CharacteristicPolynomial[AdjacencyMatrix[Graph[Rule@@@#]],x]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],2],{n,14}]
In[]:=
{{1,0},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1},{0,1}}
Out[]=
With[{n=5},CharacteristicPolynomial[AdjacencyMatrix[Graph[Rule@@@#]],x]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"]]
In[]:=
{
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
}
Out[]=
With[{n=5},Graph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"]]
In[]:=
Out[]=
CharacteristicPolynomial[AdjacencyMatrix[#],x]&/@%186
In[]:=
{
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
}
Out[]=
CanonicalGraph/@%186
In[]:=
Out[]=
CharacteristicPolynomial[AdjacencyMatrix[#],x]&/@%
In[]:=
{
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
,
6
x
}
Out[]=
With[{n=5},UndirectedGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"]]
In[]:=
Out[]=

Undirected

states
In[]:=
Out[]=
ParallelMap[TimeConstrained[CanonicalGraph[UndirectedGraph[Rule@@@#]],2]&,states,{2}]
In[]:=

,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,

Out[]=
Map[Length,FindTransientRepeat[#,2]&/@%262,{2}]
In[]:=
{{31,6},{10,0},{39,15},{7,28},{101,0},{15,28}}
Out[]=