In[]:=
<<SetReplace`
In[]:=
init[width_?EvenQ,height_?EvenQ]:=Catenate@Table[Catenate@{{{v[i,1],v[i,2]},{v[i,2],v[i,3]},{v[i,3],v[i,1]}},If[EvenQ[i+Ceiling[i/width]],{If[i-width≥1,{v[i,1],v[i-width,3]},Nothing],If[i+width≤widthheight,{v[i,2],v[i+width,1]},Nothing],If[Mod[i,width]≠0,{v[i,3],v[i+1,2]},Nothing]},{If[i-width≥1,{v[i,1],v[i-width,2]},Nothing],If[Mod[i,width]≠1,{v[i,2],v[i-1,3]},Nothing],If[i+width≤widthheight,{v[i,3],v[i+width,1]},Nothing]}]},{i,1,widthheight}]
In[]:=
stRule={{1,a},{a,c},{c,1},{1,2},{2,1},{2,d},{d,b},{b,2}}{{3,b},{b,a},{a,3},{3,4},{4,3},{4,c},{c,d},{d,4}};
In[]:=
suRule={{1,a},{a,c},{c,1},{1,2},{2,1},{2,d},{d,b},{b,2}}{{3,d},{d,a},{a,3},{3,4},{4,3},{4,c},{c,b},{b,4}};
In[]:=
SetOptions[RulePlot,FrameAutomatic];
In[]:=
WolframModelPlot[init[8,8]]
Out[]=
In[]:=
RulePlot[WolframModel[stRule]]
Out[]=
In[]:=
RulePlot[WolframModel[suRule]]
Out[]=
In[]:=
WolframModel[stRule,init[8,8],10]
Out[]=
In[]:=
WolframModel[stRule,init[8,8],10,"StatesPlotsList"]
Out[]=
In[]:=
WolframModel[stRule,init[6,6],20,"FinalStatePlot"]
Out[]=
In[]:=
WolframModel[stRule,init[10,10],40,"FinalStatePlot"]
Out[]=
In[]:=
WolframModel[suRule,init[10,10],40,"FinalStatePlot"]
Out[]=
In[]:=
PlanarGraphQ[Graph[DirectedEdge@@@WolframModel[stRule,init[10,10],40,"FinalState"]]]
Out[]=
True
In[]:=
SeedRandom[100];PlanarGraphQ[Graph[DirectedEdge@@@WolframModel[stRule,init[10,10],<|"MaxEvents"1|>,"FinalState","EventOrderingFunction""Random"]]]
Out[]=
True
In[]:=
SeedRandom[100];PlanarGraphQ[Graph[DirectedEdge@@@WolframModel[suRule,init[10,10],<|"MaxEvents"1|>,"FinalState","EventOrderingFunction""Random"]]]
Out[]=
False
In[]:=
WolframModelPlot[SeedRandom[100];nonPlanarInit=WolframModel[suRule,init[10,10],<|"MaxEvents"1|>,"FinalState","EventOrderingFunction""Random"]]
Out[]=
In[]:=
WolframModel[stRule,nonPlanarInit,40]
Out[]=
In[]:=
PlanarGraphQ[Graph[DirectedEdge@@@#]]&/@%["StatesList"]
Out[]=
{False,True,False,False,False,False,True,False,True,False,True,True,True,True,True,True,True,True,True,True,False,True,False,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True}
In[]:=
WolframModel[stRule,init[8,8],<|"MaxEvents"1000|>,"FinalStatePlot","EventOrderingFunction""Random"]
Out[]=
Neighboring highlighted vertices show non-planarity, but might not be a necessary condition.