FindTransientRepeat[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,5}],20,"StatesList"],2]
In[]:=
Out[]=
Length/@%
In[]:=
{5,6}
Out[]=
Length/@FindTransientRepeat[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,5}],50,"StatesList"],3]
In[]:=
{5,6}
Out[]=
Table[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],3],{n,10}]
In[]:=
{{1,0},{2,0},{2,0},{4,0},{4,3},{2,4},{4,7},{6,0},{5,7},{2,6}}
Out[]=
Table[Length/@FindTransientRepeat[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],3],{n,10}]
CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,4}],20,"StatesList"]
In[]:=
Out[]=
Table[Length/@FindTransientRepeat[CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"],3],{n,10}]
In[]:=
CanonicalGraph[Rule@@@#]&/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,n}],50,"StatesList"]
TestPeriod[rule_,n_,tmax_:50,rpt_:3]:=If[Length[#]<tmax,{Length[#]-1,1},FindTransientRepeat[#,rpt]]&@(CanonicalGraph[Rule@@@#]&/@WolframModel[rule,Table[{i,i+1},{i,n}],tmax,"StatesList"])
In[]:=
TestPeriodX[rule_,n_,tmax_:50,rpt_:3]:=If[Length[#]<tmax,{Length[#]-1,1},FindTransientRepeat[#,rpt]]&@(FindCanonicalHypergraph/@WolframModel[rule,Table[{i,i+1},{i,n}],tmax,"StatesList"])
In[]:=
ParallelMapMonitored[Function[n,Echo[n->TestPeriod[{{1,2},{2,3}}{{2,1},{3,1}},n,50]]],Range[20]]
In[]:=
>> 1{0,1}
(kernel 68)
>> 2{1,1}
(kernel 67)
>> 3{1,1}
(kernel 66)
>> 4{3,1}
(kernel 65)
>> 8{5,1}
(kernel 61)
>> 5
,
,
,
,
,
,
(kernel 64)
>> 6
,
,
,
,
,
(kernel 63)
>> 7
,
,
,
,
,
,
,
,
,
,
(kernel 62)
>> 9
,
,
,
,
,
,
,
,
,
,
,
(kernel 60)
>> 10
,
,
,
,
,
,
,
(kernel 59)
>> 11
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,,,,,,{}
(kernel 58)
>> 12
,
,
,
,
,
,
,
,
,
,
,
,
,
,
(kernel 57)
>> 13
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,{}
(kernel 56)
>> 14
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
(kernel 55)
>> 16{9,1}
(kernel 53)
>> 15
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,,
,
,
,
,
,
,
,
,
,
,
(kernel 54)
>> 17
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,{}
(kernel 52)
TestPeriod[{{1,2},{2,3}}{{2,1},{3,1}},n,50]
ParallelMapMonitored[Function[n,EchoFunction[First[#]Length/@Last[#]&][n->TestPeriodX[{{1,2},{2,3}}{{2,1},{3,1}},n,50]]],Range[10]]
In[]:=
>> 4{0,0}
(kernel 65)
>> 2{0,0}
(kernel 67)
>> 3{0,0}
(kernel 66)
>> 1{0,0}
(kernel 68)
>> 5{4,3}
(kernel 64)
>> 8{0,0}
(kernel 61)
>> 6{2,4}
(kernel 63)
>> 7{4,7}
(kernel 62)
>> 9{5,7}
(kernel 60)
$Aborted
Out[]=
WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,9}],20,"StatesList"]
In[]:=
Out[]=
FindCanonicalHypergraph/@%
In[]:=
Out[]=
Length/@FindTransientRepeat[%,2]
In[]:=
{5,7}
Out[]=
raw11=Sort/@WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},Table[{i,i+1},{i,11}],50,"StatesList"];
In[]:=
ParallelMapMonitored[FindCanonicalHypergraph,raw11]
In[]:=
Out[]=
Length/@FindTransientRepeat[%%,2]
In[]:=
{51,0}
Out[]=
Length[Union[Flatten[#]]]&/@raw11
In[]:=
{12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12,12}
Out[]=
Length/@FindTransientRepeat[%,3]
In[]:=
{51,0}
Out[]=
State Transition Diagram
State Transition Diagram
Length[%2]
In[]:=
928
Out[]=
all42=EnumerateHypergraphs[{{4,2}}];
In[]:=
ParallelMapMonitored[#->FindCanonicalHypergraph[Last[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},#,1,"StatesList"]]]&,all42]
In[]:=
Out[]=
Graph[%]
In[]:=
Out[]=
all32=EnumerateHypergraphs[{{3,2}}];
In[]:=
Length[%]
In[]:=
32
Out[]=
res32=ParallelMapMonitored[#->FindCanonicalHypergraph[Last[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},#,1,"StatesList"]]]&,all32]
In[]:=
Out[]=
panelLabel[lbl_]:=Panel[lbl,FrameMargins0,BackgroundLighter[Yellow,0.7]]
In[]:=
Graph[res32,VertexLabels((First[#]->Placed[HypergraphPlot[First[#],ImageSize20],Center,panelLabel]&/@res32)),PerformanceGoal"Quality"]
In[]:=
Out[]=
all52=EnumerateHypergraphs[{{5,2}}];
In[]:=
Length[all52]
In[]:=
928
Out[]=
res52=ParallelMapMonitored[#->FindCanonicalHypergraph[Last[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},#,1,"StatesList"]]]&,all52];
In[]:=
Graph[res52,EdgeStyleDarker[Green,.6],VertexStyle->Lighter[Blue,0.9],AspectRatio1/2]
In[]:=
Out[]=
Length/@FindFundamentalCycles[UndirectedGraph[%32]]
In[]:=
{1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,5,1,1,1,1,1,1,1,1,1,1,4,1,1,1,1,1,1,1,1,1,4,1,1,1,1,1,1,1,1,1,1,1,4,1,1,1,1,1,1,1,1,1,4,3,1,1,1}
Out[]=
all62=EnumerateHypergraphs[{{6,2}}];
In[]:=
$Aborted
Out[]=
res52=ParallelMapMonitored[#->FindCanonicalHypergraph[Last[WolframModel[{{1,2},{2,3}}{{2,1},{3,1}},#,1,"StatesList"]]]&,all62];
Graph[res52,EdgeStyleDarker[Green,.6],VertexStyle->Lighter[Blue,0.9]]
In[]:=
Graph Enumeration
Graph Enumeration
ManipulatePane[Module[{op,combinedops,index,g},op=Table[RandomSample[Range[1,v],2],{m}];combinedops=Combine@@@op;index=Combine@@combinedops;g=Rule@@@pair2edges[index,m];Labeled[GraphPlot[g,DirectedEdges->True,VertexLabeling->True,AspectRatio->1/6,ImageSize->600,Background->ColorData["CoffeeTones"][0.6]],Text@Grid[{{"edges\nto paired integers",Grid[{Rule@@@op,combinedops},Dividers->All]},{"iterative\npairing\nof paired integers",Short[#,1]&/@CombineList@@combinedops}},Dividers->All,Alignment->Left,BaseStyle->{FontSize->9},Background->ColorData["CoffeeTones"][0.8]]]],{600,420}],{{v,6,"number of vertices"},Range[2,9],ControlType->RadioButton},{{m,10,"number of edges"},Range[5,16],ControlType->RadioButton},TrackedSymbols->Manipulate,Initialization:>$MaxExtraPrecision=50000(*thisisneeded!*);pair[x_,y_]:=+x+2xy+3y+(*theSzudzikpairingfunction*);unpair[z_]:=Withi=-+,i(3+i)-z,-i(1+i)+z(*Szudzik'sunpairingfunction*);Combine[sequence__]:=Fold[pair[#2,#1]&,First@{sequence},Rest@{sequence}];CombineList[sequence__]:=FoldList[pair[#2,#1]&,First@{sequence},Rest@{sequence}];Uncombine[number__,numParams_]:=Reverse[Nest[Flatten[{Most@Flatten@{#},unpair[Last[Flatten@{#}]]}]&,Last@{number},numParams-1]];code[number_,list_]:=Pick[list,IntegerDigits[number,2,Length[list]],1];edges2pair[e:List[{_,_}...]]:=Combine@@Combine@@@e;pair2edges[n_Integer,m_Integer]:=Uncombine[#,2]&/@Uncombine[n,m];SeedRandom[41508];
2
x
2
y
2
1
2
1+8z
2
1
2
1
2
<<Combinatorica`
In[]:=
ListGraphs[6,12]
In[]:=
Out[]=
Quit
In[]:=