(***********************************************************************
This file was generated automatically by the Mathematica front end.
It contains Initialization cells from a Notebook file, which typically
will have the same name as this file except ending in ".nb" instead of
".m".

This file is intended to be loaded into the Mathematica kernel using
the package loading commands Get or Needs.  Doing so is equivalent to
using the Evaluate Initialization Cells menu command in the front end.

DO NOT EDIT THIS FILE.  This entire file is regenerated automatically 
each time the parent Notebook file is saved in the Mathematica front end.
Any changes you make to this file will be overwritten.
***********************************************************************)





SetAttributes[BracketingBar,Orderless]

SetAttributes[DoubleBracketingBar,{Flat,Orderless}]

tetra=\[LeftDoubleBracketingBar]1\[Rule]\[LeftBracketingBar]2,3,
          4\[RightBracketingBar],
      2\[Rule]\[LeftBracketingBar]1,3,4\[RightBracketingBar],
      3\[Rule]\[LeftBracketingBar]1,2,4\[RightBracketingBar],
      4\[Rule]\[LeftBracketingBar]1,2,
          3\[RightBracketingBar]\[RightDoubleBracketingBar];

asym=\[LeftDoubleBracketingBar]1\[Rule]\[LeftBracketingBar]2,8,
          7\[RightBracketingBar],
      2\[Rule]\[LeftBracketingBar]3,11,1\[RightBracketingBar],
      3\[Rule]\[LeftBracketingBar]2,11,4\[RightBracketingBar],
      4\[Rule]\[LeftBracketingBar]3,12,5\[RightBracketingBar],
      5\[Rule]\[LeftBracketingBar]4,12,6\[RightBracketingBar],
      6\[Rule]\[LeftBracketingBar]5,9,7\[RightBracketingBar],
      7\[Rule]\[LeftBracketingBar]6,8,1\[RightBracketingBar],
      8\[Rule]\[LeftBracketingBar]1,7,9\[RightBracketingBar],
      9\[Rule]\[LeftBracketingBar]6,8,10\[RightBracketingBar],
      10\[Rule]\[LeftBracketingBar]9,11,12\[RightBracketingBar],
      11\[Rule]\[LeftBracketingBar]2,3,10\[RightBracketingBar],
      12\[Rule]\[LeftBracketingBar]4,5,
          10\[RightBracketingBar]\[RightDoubleBracketingBar];

exrule=\[LeftDoubleBracketingBar]x1_\[Rule]\[LeftBracketingBar]x5_,x6_,
            x4_\[RightBracketingBar],
        x2_\[Rule]\[LeftBracketingBar]x7_,x8_,x4_\[RightBracketingBar],
        x3_\[Rule]\[LeftBracketingBar]x9_,x10_,x4_\[RightBracketingBar],
        x4_\[Rule]\[LeftBracketingBar]x1_,x2_,
            x3_\[RightBracketingBar]\[RightDoubleBracketingBar]\[RuleDelayed]\
\[LeftDoubleBracketingBar]x1\[Rule]\[LeftBracketingBar]x5,x6,
            x4\[RightBracketingBar],
        x3\[Rule]\[LeftBracketingBar]x9,x10,New[2]\[RightBracketingBar],
        x2\[Rule]\[LeftBracketingBar]x7,x8,New[1]\[RightBracketingBar],
        x4\[Rule]\[LeftBracketingBar]x1,New[1],New[2]\[RightBracketingBar],
        New[1]\[Rule]\[LeftBracketingBar]x4,x2,New[2]\[RightBracketingBar],
        New[2]\[Rule]\[LeftBracketingBar]New[1],x4,
            x3\[RightBracketingBar]\[RightDoubleBracketingBar];

UStep[urule_,state_]:=
  Block[{New},state/.urule/.New[n_]\[Rule]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["\[Alpha]","\[Omega]"],
              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]]&,\[LeftBracketingBar]i0\[RightBracketingBar],
        n],{1}]]

NeighborLists[g_,i0_:1]:=
  Module[{gp=Apply[List,g]},
    Apply[List,
      FixedPointList[
        Union[Flatten[#/.gp]]&,\[LeftBracketingBar]i0\[RightBracketingBar]],{\
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 \[Rule] List /. BracketingBar \[Rule] 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,\[Pi]}],{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\[LeftDoubleBracket]i, j\[RightDoubleBracket]], 
              Line[{{xv, 
                    i}, {xv + 
                      1, \(Position[next, 
                        nextp\[LeftDoubleBracket]i, 
                          j\[RightDoubleBracket]]\)\[LeftDoubleBracket]1, 
                      1\[RightDoubleBracket]}}], {}], {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], {\(-\[Pi]\)\/2, \[Pi]\/2}], {}], {i, 
              Length[next]}, {j, 3}]]; \(xv++\); last = next]; 
      Graphics[Flatten[gbag], PlotRange \[Rule] 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\[LeftDoubleBracket]i, j\[RightDoubleBracket]], 
              Line[{{xv, 
                    i}, {xv + 
                      1, \(Position[next, 
                        nextp\[LeftDoubleBracket]i, 
                          j\[RightDoubleBracket]]\)\[LeftDoubleBracket]1, 
                      1\[RightDoubleBracket]}}], {}], {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], {\(-\[Pi]\)\/2, \[Pi]\/2}], {}], {i, 
              Length[next]}, {j, 3}]]; \(xv++\); last = next]; 
      Graphics[Flatten[gbag], PlotRange \[Rule] All]]\)

OneD[n_]:=Apply[DoubleBracketingBar,
    Table[i\[Rule]\[LeftBracketingBar]Mod[i+2,n],Mod[i-2,n],
          Mod[If[EvenQ[i],i+1,i-1],n]\[RightBracketingBar],{i,0,n-1}]]

TwoD[n_]:=TwoD[{n,n}]

TwoD[{n_,m_}]:=
  Apply[DoubleBracketingBar,
      Flatten[Table[{i,
              j}\[Rule]\[LeftBracketingBar]{i,Mod[j+1,n]},{i,
                Mod[j-1,n]},{Mod[If[EvenQ[i+j],i+1,i-1],m],
                j}\[RightBracketingBar],{i,0, m-1},{j,0,n-1}]]]/.{i_,
        j_}\[Rule]i+m j

ThreeD[n_]:=ThreeD[{n,n,n}]

ThreeD[{xm_,ym_,
      zm_}]:=(Apply[DoubleBracketingBar,
          Flatten[Table[{x,y,
                  z}\[Rule]\[LeftBracketingBar]{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}]\[RightBracketingBar],{x,0,xm-1},{y,0,ym-1},{z,0,
                zm-1}]]]/.{x_,y_,z_}->x+xm(y+ym z))/;(IntegerQ[zm/4]&&
        IntegerQ[ym/2]&&IntegerQ[xm/2])