Using pattern-matching based representation


,,
x_x_,x_,x_,

,,,
xx,x,x,
SetAttributes[BracketingBar,Orderless]
SetAttributes[DoubleBracketingBar,{Flat,Orderless}]
tetra=12,3,4,21,3,4,31,2,4,41,2,3;
asym=12,8,7,23,11,1,32,11,4,43,12,5,54,12,6,65,9,7,76,8,1,81,7,9,96,8,10,109,11,12,112,3,10,124,5,10;
exrule=x1_x5_,x6_,x4_,x2_x7_,x8_,x4_,x3_x9_,x10_,x4_,x4_x1_,x2_,x3_x1x5,x6,x4,x3x9,x10,New[2],x2x7,x8,New[1],x4x1,New[1],New[2],New[1]x4,x2,New[2],New[2]New[1],x4,x3;
UStep[urule_,state_]:=Block[{New},state/.urule/.New[n_]n+Apply[Max,First/@state]]
TrivalentQ[g_]:=Module[{nodes},nodes=Sort[Apply[List,First/@g]];Sort[Flatten[Apply[List,Last/@g,{0,1}]]]===Sort[Flatten[{nodes,nodes,nodes}]]]
RewriteRules[rule_]:=Module[{s},s=Union[Cases[Level[rule,{-1}],_Symbol]];rule/.Apply[Rule,Transpose[{s,Take[ToExpression/@CharacterRange["α","ω"],Length[s]]}],{1}]]
NeighborCounts[g_,i0_,n_]:=Map[Length,Module[{gp=Dispatch[NetworkToRuleList[g]]},NestList[Union[Flatten[{#,#/.gp}]]&,{i0},n]]]
NeighborCounts[g_,i0_:1]:=Map[Length,Module[{gp=Dispatch[NetworkToRuleList[g]]},FixedPointList[Union[Flatten[{#,#/.gp}]]&,{i0}]]]
NeighborLists[g_,i0_,n_]:=Module[{gp=Apply[List,g]},Apply[List,NestList[Union[Flatten[#/.gp]]&,i0,n],{1}]]
NeighborLists[g_,i0_:1]:=Module[{gp=Apply[List,g]},Apply[List,FixedPointList[Union[Flatten[#/.gp]]&,i0],{1}]]
ShortestPath[g_,{i0_,i1_}]:=Module[{gp=Dispatch[NetworkToRuleList[g]],d=0,nn={i0}},While[!MemberQ[nn,i1],nn=Union[Flatten[nn/.gp]];d++];d]
NetworkToList[g_]:=Module[{nodes},nodes=First/@g;Map[Position[nodes,#][[1,1]]&,Apply[List,Last[#]]&/@Apply[List,g],{2}]]
NetworkToRuleList[g_]:=g/.DoubleBracketingBarList/.BracketingBarList
CirclePicture[g_]:=With[{gmap=NetworkToList[g]},Graphics[{{GrayLevel[.5],AbsoluteThickness[1],Line[{{1,0},{Length[gmap],0}}]},{AbsolutePointSize[.5],Table[Point[{i,0}],{i,Length[gmap]}]},Table[Circle[{(i+gmap[[i,j]])/2,0},Abs[gmap[[i,j]]-i]/2,{0,π}],{i,Length[gmap]},{j,3}]},AspectRatio->Automatic,PlotRange->All]]
NeighborsPicture[g_,init_]:=Module{gp=NetworkToRuleList[g],already=init,next,xv=0,gbag={},last,lastp},last=init;While(nextp=last/.gp;next=Complement[Flatten[nextp],already])=!={},AppendTo[gbag,Table[If[MemberQ[next,nextp〚i,j〛],Line[{{xv,i},{xv+1,Position[next,nextp〚i,j〛]〚1,1〛}}],{}],{i,Length[last]},{j,3}]];already=Flatten[{already,next}];nextp=next/.gp;AppendTogbag,TableIfMemberQ[next,nextp[[i,j]]],p=Position[next,nextp[[i,j]]][[1,1]];Circlexv+1,
(i+p)
2
,N
ArcTan[#]
2
,#&
Abs[p-i]
2
,
-π
2
,
π
2
,{},{i,Length[next]},{j,3};xv++;last=next;Graphics[Flatten[gbag],PlotRangeAll]
NeighborsPicture[g_]:=NeighborsPicture[g,{Min[First/@g]}]
NeighborsPictureR[g_,init_:{1}]:=Module{gp=NetworkToRuleList[g],already=init,next,xv=0,gbag={},last,lastp},last=init;While(nextp=last/.gp;next=Complement[Flatten[nextp],already])=!={},wts=(First/@Position[nextp,#])&/@next;wts=(Apply[Plus,#]/Length[#])&/@wts;wts=Transpose[{wts,next}];next=Last/@Sort[wts];AppendTo[gbag,Table[If[MemberQ[next,nextp〚i,j〛],Line[{{xv,i},{xv+1,Position[next,nextp〚i,j〛]〚1,1〛}}],{}],{i,Length[last]},{j,3}]];already=Flatten[{already,next}];nextp=next/.gp;AppendTogbag,TableIfMemberQ[next,nextp[[i,j]]],p=Position[next,nextp[[i,j]]][[1,1]];Circlexv+1,
(i+p)
2
,N
ArcTan[#]
2
,#&
Abs[p-i]
2
,
-π
2
,
π
2
,{},{i,Length[next]},{j,3};xv++;last=next;Graphics[Flatten[gbag],PlotRangeAll]
OneD[n_]:=Apply[DoubleBracketingBar,Table[iMod[i+2,n],Mod[i-2,n],Mod[If[EvenQ[i],i+1,i-1],n],{i,0,n-1}]]
TwoD[n_]:=TwoD[{n,n}]
TwoD[{n_,m_}]:=Apply[DoubleBracketingBar,Flatten[Table[{i,j}{i,Mod[j+1,n]},{i,Mod[j-1,n]},{Mod[If[EvenQ[i+j],i+1,i-1],m],j},{i,0,m-1},{j,0,n-1}]]]/.{i_,j_}i+mj
ThreeD[n_]:=ThreeD[{n,n,n}]
ThreeD[{xm_,ym_,zm_}]:=(Apply[DoubleBracketingBar,Flatten[Table[{x,y,z}{x,y,Mod[z+1,zm]},{x,y,Mod[z-1,zm]},If[EvenQ[z],{Mod[If[EvenQ[z/2+x+y],x+1,x-1],xm],y,z},{x,Mod[If[EvenQ[Floor[z/2+x+y]],y+1,y-1],ym],z}],{x,0,xm-1},{y,0,ym-1},{z,0,zm-1}]]]/.{x_,y_,z_}->x+xm(y+ymz))/;(IntegerQ[zm/4]&&IntegerQ[ym/2]&&IntegerQ[xm/2])