In[]:=
OneBitChanges[list_]:=list->MapAt[1-#&,list,#]&/@Most[Range[Length[list]]]
In[]:=
elemgraph=UndirectedGraph[Map[FromDigits[#,2]&,Catenate[OneBitChanges[#]&/@Select[Tuples[{1,0},8],Last[#]==0&]],{2}]]
Out[]=
In[]:=
GridGraph[Table[2,7]]
Out[]=
In[]:=
IsomorphicGraphQ[%38,%39]
Out[]=
True
In[]:=
VertexList[elemgraph]
Out[]=
{254,126,190,222,238,246,250,252,124,188,220,236,244,248,122,186,218,234,242,120,184,216,232,240,118,182,214,230,116,180,212,228,114,178,210,226,112,176,208,224,110,174,206,108,172,204,106,170,202,104,168,200,102,166,198,100,164,196,98,162,194,96,160,192,94,158,92,156,90,154,88,152,86,150,84,148,82,146,80,144,78,142,76,140,74,138,72,136,70,134,68,132,66,130,64,128,62,60,58,56,54,52,50,48,46,44,42,40,38,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0}
In[]:=
(v|->First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]])/@%45
Out[]=
{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8,0,0,0,0,0,0,0,0,0,3,8,0,0,0,0,0,0,0,0,0,0,3,5,8,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,8,0,0,0,0,0,0,3,5,0,0,0,0,0,0,0,0,0,0,0,3,0,2,0,2,0,0,0,0,0,0,0,0,0,0,0,3,0,2,0,2}
In[]:=
Graph[elemgraph,VertexSize->(v_:>First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]])]
Out[]=
In[]:=
Graph[elemgraph,VertexSize->(v_:>.3First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]])]
Out[]=
In[]:=
Select[VertexList[elemgraph],Function[v,First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]]>0]]
Out[]=
{224,104,168,96,160,192,72,136,64,128,40,36,32,8,4,0}
In[]:=
Subgraph[%50,%]
Out[]=
In[]:=
Graph[%54,VertexLabels->Placed[Automatic,Center]]
Out[]=
In[]:=
Subgraph[Graph[elemgraph,VertexSize->(v_:>.3Sqrt[First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]]])],Select[VertexList[elemgraph],Function[v,First[FirstPosition[Total/@CellularAutomaton[v,{{1,1,1,1,1,1,1},0},{20,All}],0,{0}]]>0]],VertexLabels->Placed[Automatic,Center]]
Out[]=
