WOLFRAM NOTEBOOK

In[]:=
$LifetimeData[2,2,"Symmetric"]
Out[]=
{0,65815}0,{276,285295007}1,{1048868,156317055}2,{1049892,3507586495}2,{139469092,424769023}3,{139473252,3646010879}3,{269484468,424769023}3,{1343260068,3646010879}3,{3222308132,3507602879}3,{1343260084,3646027263}4,{3360731492,3646027263}4,{269616548,4120108543}5,{269632932,4154449919}5,{613570916,4258528767}5,{2416985508,4189312511}5,{2551203236,4260494847}5,{35541860,2145386495}6,{204478820,1039367679}6,{269501860,4122205695}6,{303974308,4292870143}6,{749754724,4260494847}6,{2419066276,4122074623}6,{2419082660,4156415999}6,{70261092,494108159}7,{749738340,2113011199}7,{815792532,968316927}7,{947913108,1033330687}7,{1476690836,4187478015}7,{2419066292,4122074623}7,{2453424036,4294836223}7,{2961310100,4120371199}7,{1889699220,4260888575}8,{2555536804,4294967295}8,{336612772,4260625919}9,{2555405732,4260625919}9,{3970996580,4260494847}9,{716968804,4294967295}10,{335546772,1035427839}11,{336727476,4294967295}11,{2484211124,4294967295}11,{370806196,4294967295}12,{1823512932,4294967295}12,{2485258644,4294967295}12,{2489461140,4294967295}12,{2518289844,4294967295}12,{303695284,4290502143}13,{2451178932,4290502143}13,{2519337364,4294967295}13,{2623678868,4294967295}13,{3938227044,4294967295}13,{503843220,1069506559}14,{848954804,4160749567}14,{1445759892,4290764799}14,{3164735892,4260888575}14,{1344570260,4290764799}15,{2418147732,4160749567}16,{649615716,4294704639}17,{849086372,4294967295}17,{2452226452,4160749567}17,{3028421012,4294967295}18,{814745012,4294967295}19,{880937364,4156547071}19,{2486177204,4290764799}19,{2487363988,4160749567}19,{2585396644,4294967295}19,{848823732,4294967295}20,{2619476372,4294967295}21,{1514709396,4294967295}22,{438044596,4288667647}23,{3662193044,4294967295}23,{615536996,2147483647}25,{3029470644,4294967295}25,{2417100196,4294967295}28,{3392835940,4294967295}28,{3063549364,4294967295}39,{2417362868,4294967295}45,{2455381412,4294967295}64
In[]:=
Accumulate[Length/@Split[Values[$LifetimeData[2,2,"Symmetric"]]]]
Out[]=
{1,2,4,9,11,16,23,31,33,36,37,40,45,50,54,55,56,59,60,65,66,67,68,70,72,74,75,76,77}
Label the red lines with lifetimes
In[]:=
ArrayPlot[Map[IntegerDigits[#[[2]],2,32]&,Keys[$LifetimeData[2,2,"Symmetric"]]],GridLines->{None,(Last[#]-#)&[Accumulate[Length/@Split[Values[$LifetimeData[2,2,"Symmetric"]]]]]},GridLinesStyle->Directive[Red,Thick],Mesh->True]
Out[]=
Get labels right ; label the lifetimes
In[]:=
ArrayPlot[Map[IntegerDigits[#[[2]],2,32]+IntegerDigits[#[[1]],2,32]&,Keys[$LifetimeData[2,2,"Symmetric"]]],GridLines->{None,(Last[#]-#)&[Accumulate[Length/@Split[Values[$LifetimeData[2,2,"Symmetric"]]]]]},GridLinesStyle->Directive[Red,Thick],Mesh->True,ColorRules->{0->Gray,1->White,2->Black},Frame->True,FrameTicks->{{None,None},{MapIndexed[{First[#2]-.5,#}&,ArrayPlot[List/@#,Mesh->True,ImageSize->7]&/@Tuples[{1,0},5]],None}}]
Out[]=
Several columns are constant in many cases....
In[]:=
ListStepPlot[Lookup[Counts[#],{0,1,2},0],PlotTheme->"Minimal",ImageSize->40,GridLines->{Range[4],None}]&/@Transpose[Map[IntegerDigits[#[[2]],2,32]+IntegerDigits[#[[1]],2,32]&,Keys[$LifetimeData[2,2,"Symmetric"]]]]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
In[]:=
Counts/@Transpose[Map[IntegerDigits[#[[2]],2,32]+IntegerDigits[#[[1]],2,32]&,Keys[$LifetimeData[2,2,"Symmetric"]]]]
Out[]=
{014,128,235,011,152,214,012,143,222,02,119,256,016,137,224,014,134,229,032,121,224,01,176,012,143,222,024,142,211,020,129,228,02,253,122,032,121,224,028,138,211,019,233,125,177,011,152,214,05,157,215,024,142,211,04,158,215,014,134,229,02,139,236,028,138,211,11,276,02,119,256,04,158,215,02,253,122,137,240,01,176,11,276,177,177}
In[]:=
Counts/@Transpose[Map[IntegerDigits[#[[2]],2,32]+IntegerDigits[#[[1]],2,32]&,Keys[Select[$LifetimeData[2,2,"Symmetric"],#>10&]]]]
Out[]=
{03,114,223,02,131,27,127,213,235,15,124,211,05,222,118,02,118,220,140,127,213,09,125,26,123,216,01,117,223,02,118,220,131,03,26,115,225,140,02,131,27,138,22,09,125,26,135,25,222,118,122,218,131,03,26,240,235,15,135,25,117,223,231,19,140,240,140,140}
In[]:=
Map[Graphics[MapIndexed[{EdgeForm[Black],Association[1->Gray,2->White,3->Black][#2[[1]]],Rectangle[{#2[[1]],0},{#2[[1]]+1,#1}]}&,Lookup[Counts[#],{0,1,2},0]],AspectRatio->1/2,Axes->True,Ticks->None,ImageSize->40]&,Transpose[Map[IntegerDigits[#[[2]],2,32]+IntegerDigits[#[[1]],2,32]&,Keys[$LifetimeData[2,2,"Symmetric"]]]]]
Lifetime above 10:
Can compute simple entropy...
[[ What fraction of configurations give a lifetime at least as great as ____ ]] (or actually the log of this)
[[ This specifically plots the “number of free bits” allowed while still achieving that lifetime ]]

Use machine learning to predict lifetime (or evolvedness) from a bit pattern

Test evolvedness

Wolfram Cloud

You are using a browser not supported by the Wolfram Cloud

Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.


I understand and wish to continue anyway »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.