(*******************************************************************
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.
***********************************************************************)





MWStep[rule_List,slist_List]:=
  Union[Flatten[Function[s,(MWStep1[#1,s]&)/@rule]/@slist]]

MWStep1[p_String\[Rule]q_String,
    s_String]:=(StringInsert[StringDrop[s,#1],q,First[#1]]&)/@
    StringPosition[s,p]



MWEvolveList[rule_List,init_List,t_Integer/;NonNegative[t]]:=
  NestList[MWStep[rule,#1]&,init,t]

MWEvolve[rule_List,init_List,t_Integer/;NonNegative[t]]:=
  Nest[MWStep[rule,#1]&,init,t]



MWStepT[rule_List,slist_List]:=
  Union[Flatten[Function[s,(MWStep1T[#1,s]&)/@rule]/@slist,2]]

MWStep1T[p_String\[Rule]q_String,
    s_String]:=({s,StringInsert[StringDrop[s,#1],q,First[#1]]}&)/@
    StringPosition[s,p]

MWStepTX[rule_List,slist_List,max_Integer]:=
  Union[Flatten[Function[s,(MWStep1TX[#1,s,max]&)/@rule]/@slist,2]]

MWStep1TX[p_String\[Rule]q_String,s_String,max_Integer]:=
  Select[({s,StringInsert[StringDrop[s,#1],q,First[#1]]}&)/@
      StringPosition[s,p],StringLength[#[[2]]]<max&]



MWEvolveListT[rule_List,init_List,t_Integer/;NonNegative[t]]:=
  NestList[MWStepT[rule,Union[Last/@#1]]&,({#1,#1}&)/@init,t]

MWEvolveListTX[rule_List,init_List,t_Integer/;NonNegative[t],max_Integer]:=
  NestList[MWStepTX[rule,Union[Last/@#1],max]&,({#1,#1}&)/@init,t]



MWRulesUsed[rule_List,slist_List]:=
  Function[x,Plus@@Length/@(StringPosition[#1,x]&)/@slist]/@First/@rule



nodepos[hist_]:=
  Module[{nodes,np,nnp},nodes=Union[Flatten[hist]];
    np=({Position[hist,#1,\[Infinity],1]\[LeftDoubleBracket]1,
                1\[RightDoubleBracket],#1}&)/@nodes;
    nnp=Map[Last,
        Table[Cases[Sort[np],{n,_}],{n,
            Length[hist]}],{2}];(Position[nnp,#1,\[Infinity],
              1]\[LeftDoubleBracket]1\[RightDoubleBracket]&)/@nodes]

nodeup[name_,{nodes_,np_}]:=
  np\[LeftDoubleBracket]Position[nodes,name]\[LeftDoubleBracket]1,
      1\[RightDoubleBracket]\[RightDoubleBracket]

\!\(MWNetGraphic[hist_] := 
    Module[{np, nodes, arrows, selfarrows}, np = nodepos[hist]; 
      nodes = Union[Flatten[hist]]; 
      arrows = Flatten[
          Map[{{1, \(-1\)}\ Reverse[
                    nodeup[#1\[LeftDoubleBracket]1\[RightDoubleBracket], \
{nodes, np}]], {1, \(-1\)}\ Reverse[
                    nodeup[#1\[LeftDoubleBracket]2\[RightDoubleBracket], \
{nodes, np}]]} &, hist, {2}], 1]; 
      selfarrows = First /@ Cases[arrows, {x_, x_}]; 
      arrows = DeleteCases[arrows, {x_, x_}]; 
      Graphics[{AbsolutePointSize[ .8], \((Point[{1, \(-1\)}\ Reverse[#1]] &)\
\) /@ np, \((Circle[#1 + {0, 1\/4}, 1\/4] &)\) /@ 
            selfarrows, \((Arrow[#1,  .2] &)\) /@ arrows}, 
        AspectRatio \[Rule] Automatic]]\)



rowblock2[s_String,{x_,y_}]:=
  Table[EdgedRectangle[{i+x-1,y},{i+x,y+1},mwcolor[StringTake[s,{i}]],
      GrayStyle],{i,StringLength[s]}]

mwcolor[x_]:=
  If[MemberQ[First/@mwcolormap,x],x/.mwcolormap,
    Print["Missing entry in mwcolormap."];Abort[]]

mwcolormap={"A"\[Rule]GrayLevel[.85],"B"\[Rule]GrayLevel[0]};



\!\(MWGraphicNonMerged[hist_] := 
    Module[{hh, rp, arrows, t1}, hh = Map[Last, hist, {2}]; 
      rp = MapIndexed[{\((#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 
                      1)\)\ 1.2 + \[Sum]\+\(i = \
1\)\%\(#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 1\)StringLength[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket], 
                      i\[RightDoubleBracket]], \(-4.4\)\ \((#2\
\[LeftDoubleBracket]1\[RightDoubleBracket] - 1)\)} &, hh, {2}]; 
      arrows = Flatten[
          Table[t1 = \(Position[
                  Last /@ hist\[LeftDoubleBracket]y - 1\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 1\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 
                1\[RightDoubleBracket]; {rp\[LeftDoubleBracket]y - 1, 
                  t1\[RightDoubleBracket] + {1\/2\ StringLength[
                      hh\[LeftDoubleBracket]y - 1, 
                        t1\[RightDoubleBracket]], \(- .3\)}, 
              rp\[LeftDoubleBracket]y, 
                  x\[RightDoubleBracket] + {1\/2\ StringLength[
                      hh\[LeftDoubleBracket]y, x\[RightDoubleBracket]], 
                  1.3}}, {y, 2, Length[hist]}, {x, 1, 
              Length[hist\[LeftDoubleBracket]y\[RightDoubleBracket]]}], 1]; 
      Graphics[{MapThread[rowblock2, {Flatten[hh, 1], Flatten[rp, 1]}], 
          AbsoluteThickness[ .3], \((Arrow[#1,  .5] &)\) /@ arrows}, 
        AspectRatio \[Rule] Automatic]]\)

MWStringSortQ[x_String,y_String]:=
  If[StringLength[x]==StringLength[y],OrderedQ[{x,y}],
    StringLength[x]<StringLength[y]]

\!\(MWGraphic[hist_] := 
    Module[{hh, rp, arrows, t1, t2}, 
      hh = \(Sort[#, MWStringSortQ] &\) /@ \(Union /@ Map[Last, hist, {2}]\); 
      rp = MapIndexed[{\((#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 
                      1)\)\ 1.2 + \[Sum]\+\(i = \
1\)\%\(#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 1\)StringLength[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket], 
                      i\[RightDoubleBracket]], \(-4.4\)\ \((#2\
\[LeftDoubleBracket]1\[RightDoubleBracket] - 1)\)} &, hh, {2}]; 
      arrows = Flatten[
          Table[t1 = \(Position[
                  hh\[LeftDoubleBracket]y - 1\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 1\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 1\[RightDoubleBracket]; 
            t2 = \(Position[hh\[LeftDoubleBracket]y\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 2\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 
                1\[RightDoubleBracket]; {rp\[LeftDoubleBracket]y - 1, 
                  t1\[RightDoubleBracket] + {1\/2\ StringLength[
                      hh\[LeftDoubleBracket]y - 1, 
                        t1\[RightDoubleBracket]], \(- .3\)}, 
              rp\[LeftDoubleBracket]y, 
                  t2\[RightDoubleBracket] + {\(1\/2\) 
                    StringLength[
                      hh\[LeftDoubleBracket]y, t2\[RightDoubleBracket]], 
                  1.3}}, {y, 2, Length[hist]}, {x, 1, 
              Length[hist\[LeftDoubleBracket]y\[RightDoubleBracket]]}], 1]; 
      Graphics[{MapThread[
            rowblock2, {Flatten[hh, 1], 
              Flatten[rp, 
                1]}], \((Arrow[#1,  .5, 
                  ArrowStyle \[Rule] AbsoluteThickness[ .25]] &)\) /@ 
            arrows}, AspectRatio \[Rule] Automatic]]\)

\!\(MWGraphic[hist_, rightcutoff_:  \[Infinity], opts___] := 
    Module[{hh, rp, arrows, t1, t2, ellipses, hhc, rpc, arrowsc}, 
      hh = \(Sort[#, MWStringSortQ] &\) /@ \(Union /@ Map[Last, hist, {2}]\); 
      rp = MapIndexed[{\((#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 
                      1)\)\ 1.2 + \[Sum]\+\(i = \
1\)\%\(#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 1\)StringLength[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket], 
                      i\[RightDoubleBracket]], \(-4.4\)\ \((#2\
\[LeftDoubleBracket]1\[RightDoubleBracket] - 1)\)} &, hh, {2}]; 
      rpc = \(Cases[#, {{x_, y_}, {w_, z_}} /; 
                  x + StringLength[
                        hh\[LeftDoubleBracket]w, z\[RightDoubleBracket]] + 
                      If[z < Length[
                            hh\[LeftDoubleBracket]w\[RightDoubleBracket]], 
                        2.2, 0] \[LessEqual] rightcutoff \[Rule] {x, y}] &\) /@ 
          MapIndexed[List, rp, {2}]; 
      hhc = MapIndexed[Take[#, Length[Extract[rpc, #2]]] &, hh]; 
      ellipses = 
        Flatten[MapIndexed[
            If[Length[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket]\[RightDoubleBracket]] \[Equal] 
                  Length[#], {}, \
{rp\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\[RightDoubleBracket], 
                    Length[#] + 1\[RightDoubleBracket]}] &, hhc], 1]; 
      arrows = Flatten[
          Table[t1 = \(Position[
                  hh\[LeftDoubleBracket]y - 1\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 1\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 1\[RightDoubleBracket]; 
            t2 = \(Position[hh\[LeftDoubleBracket]y\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 2\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 
                1\[RightDoubleBracket]; {rp\[LeftDoubleBracket]y - 1, 
                  t1\[RightDoubleBracket] + {1\/2\ StringLength[
                      hh\[LeftDoubleBracket]y - 1, 
                        t1\[RightDoubleBracket]], \(- .3\)}, 
              rp\[LeftDoubleBracket]y, 
                  t2\[RightDoubleBracket] + {\(1\/2\) 
                    StringLength[
                      hh\[LeftDoubleBracket]y, t2\[RightDoubleBracket]], 
                  1.3}}, {y, 2, Length[hist]}, {x, 1, 
              Length[hist\[LeftDoubleBracket]y\[RightDoubleBracket]]}], 1]; 
      arrowsc = 
        Cases[
          arrows, {{w_, x_}, {y_, z_}} /; 
              w \[LessEqual] rightcutoff || 
                y \[LessEqual] rightcutoff \[RuleDelayed] 
            If[w > rightcutoff, 
              Arrow[{{rightcutoff, 
                    z + \((x - z)\) \((rightcutoff - y)\)/\((w - y)\)}, {y, 
                    z}},  .5, ArrowStyle \[Rule] AbsoluteThickness[ .25]], 
              If[y > rightcutoff, 
                Line[{{w, x}, {rightcutoff, 
                      x + \((z - x)\) \((rightcutoff - w)\)/\((y - w)\)}}], 
                Arrow[{{w, x}, {y, z}},  .5, 
                  ArrowStyle \[Rule] AbsoluteThickness[ .25]]]]]; 
      Graphics[{MapThread[
            rowblock2, {Flatten[hhc, 1], 
              Flatten[rpc, 1]}], \({AbsolutePointSize[ .5], GrayLevel[0], 
                Point[# + {0,  .5}], Point[# + { .5,  .5}], 
                Point[# + {1,  .5}]} &\) /@ ellipses, arrowsc}, opts, 
        AspectRatio \[Rule] Automatic]]\)





MWCharRuleGraphic[rule_List]:=
  FramedGraphicsRow[(MWRG2[First[#1],Last[#1]]&)/@rule]

MWRG2[s0_String,s1_String]:=
  Graphics[{Table[{EdgedRectangle[{i,0},{i+1,1},mwcolor[StringTake[s0,{i}]],
            GrayStyle],GrayLevel[0]},{i,StringLength[s0]}],
      Table[EdgedRectangle[{i,-2},{i+1,-1},mwcolor[StringTake[s1,{i}]],
          GrayStyle],{i,StringLength[s1]}],{AbsoluteThickness[0.25],
        GrayLevel[0],Line[{{1,0},{1,-1}}],
        Line[{{StringLength[s0]+1,0},{StringLength[s1]+1,-1}}]}},
    AspectRatio\[Rule]Automatic,
    PlotRange\[Rule]{{0,Max[StringLength[s1],StringLength[s0]]+2},{-2.96,
          1.96}},Frame\[Rule]False,FrameTicks\[Rule]None,
    FrameStyle\[Rule]HairlineStyle]



\!\(MWEvolGraphicNonMerged[hist_] := 
    Module[{hh, rp, arrows, t1}, hh = Map[Last, hist, {2}]; 
      rp = MapIndexed[{\((#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 
                      1)\)\ 1.2 + \[Sum]\+\(i = \
1\)\%\(#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 1\)Length[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket], 
                      i\[RightDoubleBracket]], \(-4.4\)\ \((#2\
\[LeftDoubleBracket]1\[RightDoubleBracket] - 1)\)} &, hh, {2}]; 
      arrows = Flatten[
          Table[t1 = \(Position[
                  Last /@ hist\[LeftDoubleBracket]y - 1\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 1\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 
                1\[RightDoubleBracket]; {rp\[LeftDoubleBracket]y - 1, 
                  t1\[RightDoubleBracket] + {1\/2\ Length[
                      hh\[LeftDoubleBracket]y - 1, 
                        t1\[RightDoubleBracket]], \(- .3\)}, 
              rp\[LeftDoubleBracket]y, 
                  x\[RightDoubleBracket] + {1\/2\ Length[
                      hh\[LeftDoubleBracket]y, x\[RightDoubleBracket]], 
                  1.3}}, {y, 2, Length[hist]}, {x, 1, 
              Length[hist\[LeftDoubleBracket]y\[RightDoubleBracket]]}], 1]; 
      Graphics[{MapThread[rowblock, {Flatten[hh, 1], Flatten[rp, 1]}], 
          AbsoluteThickness[ .3], \((Arrow[#1,  .5] &)\) /@ arrows}, 
        AspectRatio \[Rule] Automatic]]\)

\!\(MWEvolGraphic[hist_] := 
    Module[{hh, rp, arrows, t1, t2}, hh = Union /@ Map[Last, hist, {2}]; 
      rp = MapIndexed[{\((#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 
                      1)\)\ 1.2 + \[Sum]\+\(i = \
1\)\%\(#2\[LeftDoubleBracket]2\[RightDoubleBracket] - 1\)Length[
                    hh\[LeftDoubleBracket]#2\[LeftDoubleBracket]1\
\[RightDoubleBracket], 
                      i\[RightDoubleBracket]], \(-4.4\)\ \((#2\
\[LeftDoubleBracket]1\[RightDoubleBracket] - 1)\)} &, hh, {2}]; 
      arrows = Flatten[
          Table[t1 = \(Position[
                  hh\[LeftDoubleBracket]y - 1\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 1\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 1\[RightDoubleBracket]; 
            t2 = \(Position[hh\[LeftDoubleBracket]y\[RightDoubleBracket], 
                  hist\[LeftDoubleBracket]y, x, 2\[RightDoubleBracket], 1, 
                  1]\)\[LeftDoubleBracket]1, 
                1\[RightDoubleBracket]; {rp\[LeftDoubleBracket]y - 1, 
                  t1\[RightDoubleBracket] + {1\/2\ Length[
                      hh\[LeftDoubleBracket]y - 1, 
                        t1\[RightDoubleBracket]], \(- .3\)}, 
              rp\[LeftDoubleBracket]y, 
                  t2\[RightDoubleBracket] + {\(1\/2\) 
                    Length[hh\[LeftDoubleBracket]y, t2\[RightDoubleBracket]], 
                  1.3}}, {y, 2, Length[hist]}, {x, 1, 
              Length[hist\[LeftDoubleBracket]y\[RightDoubleBracket]]}], 1]; 
      Graphics[{MapThread[
            rowblock, {Flatten[hh, 1], 
              Flatten[rp, 
                1]}], \((Arrow[#1,  .5, 
                  ArrowStyle \[Rule] AbsoluteThickness[ .25]] &)\) /@ 
            arrows}, AspectRatio \[Rule] Automatic]]\)

rowblock[list_,{x_,y_}]:=
  Table[EdgedRectangle[{i+x-1,y},{i+x,y+1},
      GrayLevel[.85 (1-list\[LeftDoubleBracket]i\[RightDoubleBracket])],
      GrayStyle],{i,Length[list]}]



ToChars[rule_]:=
  rule/.x:{___Integer}\[RuleDelayed]StringJoin@@(x/.{0\[Rule]"A",1\[Rule]"B"})

FromChars[rule_]:=
  rule/.x_String\[RuleDelayed](Characters[x]/.{"B"\[Rule]1,"A"\[Rule]0})

MWCharGrowth[{rule_,init_},t_,maxsize_:1000]:=
  MPGrowth[FromChars[rule],FromChars[init],t,0,maxsize]



MWRuleGraphic[rule_List,k_Integer:2]:=
  GraphicsRow[(MWRG1[First[#1],Last[#1],k]&)/@rule,0]

MWRG1[s0_List,s1_List,k_Integer]:=
  Graphics[{Table[{EdgedRectangle[{i,0},{i+1,1},
            GrayLevel[
              If[s0\[LeftDoubleBracket]i\[RightDoubleBracket]==1,0,.85]],
            GrayStyle],GrayLevel[0]},{i,Length[s0]}],
      Table[EdgedRectangle[{i,-2},{i+1,-1},
          GrayLevel[
            If[s1\[LeftDoubleBracket]i\[RightDoubleBracket]==1,0,.85]],
          GrayStyle],{i,Length[s1]}],{AbsoluteThickness[.25],GrayLevel[0],
        Line[{{1,0},{1,-1}}],Line[{{Length[s0]+1,0},{Length[s1]+1,-1}}]}},
    AspectRatio\[Rule]Automatic,
    PlotRange\[Rule]{{0,Max[Length[s1],Length[s0]]+2},{-2.6,1.6}},
    Frame\[Rule]True,FrameTicks\[Rule]None,FrameStyle\[Rule]HairlineStyle]



ToSemigroup[rules_]:=Union[Join[rules,Reverse/@rules]]

(** What follows is older material **)

(* NetworkStep does replacements in parallel at all possible points in the
list;  NetworkFrontStep does only the first such replacement, for each of the
possible replacements. *)
(** The latter is effectively a multipath SSS **)

(*
NetworkStep0[rules_, list_] :=
		Flatten[ Module[{ri, i, j, jp, pl},
			Table[ri = rules[[i]]; If[ri === {}, {},
			pl = Partition[list, i, 1] ;
			Flatten[Table[Flatten[MapAt[Replace[#, ri[[j]]]&, pl, jp]],
				{j, Length[ri]}, {jp, Length[pl]}], 1]], {i, Length[rules]}]
		], 1]
*)

NetworkStep0[rules_,list_]:=
  Flatten[Module[{ri,i,j,jp,pl},
      Table[ri=rules\[LeftDoubleBracket]i\[RightDoubleBracket];
        If[ri==={},{},
          Table[Flatten[{Take[list,i1],
                Replace[Take[list,{i1+1,i1+i}],
                  ri\[LeftDoubleBracket]j\[RightDoubleBracket]],
                Take[list,{i1+i+1,-1}]}],{i1,0,Length[list]-i},{j,
              Length[ri]}]],{i,Length[rules]}]],2]

NetworkStep[rules_,list_]:=Union[Flatten[(NetworkStep0[rules,#1]&)/@list,1]]

PrepRules[rules_List]:=
  Module[{max},max=Max[(Length[First[#1]]&)/@rules];
    Table[Select[rules,Length[First[#1]]==i&],{i,max}]]

NetworkEvolveList[rules_,list_List,t_Integer]:=
  With[{pr=PrepRules[rules]},NestList[NetworkStep[pr,#1]&,list,t]]

NetworkEvolve[rules_,list_List,t_Integer]:=
  With[{pr=PrepRules[rules]},Nest[NetworkStep[pr,#1]&,list,t]]

NetworkFrontStep0[rules_,list_]:=
  Flatten[Module[{ri,i,j,jp,pl},
      Table[ri=rules\[LeftDoubleBracket]i\[RightDoubleBracket];
        If[ri==={},{},
          DeleteCases[
            Table[If[Length[list]<i,Null,
                Flatten[{Replace[Take[list,i],
                      ri\[LeftDoubleBracket]j\[RightDoubleBracket]],
                    Take[list,{i+1,-1}]}]],{j,Length[ri]}],Null]],{i,
          Length[rules]}]],1]

NetworkFrontStep[rules_,list_]:=
  Union[Flatten[(NetworkFrontStep0[rules,#1]&)/@list,1]]

NetworkFrontEvolveList[rules_,list_List,t_Integer]:=
  With[{pr=PrepRules[rules]},NestList[NetworkFrontStep[pr,#1]&,list,t]]

\!\(NetworkLengths[list_List, k_Integer:  2] := 
    Module[{ll, max}, ll = Map[Length, list, {2}]; 
      max = Max[ll]; \((Table[N[Count[#1, i]\/k\^i], {i, max}] &)\) /@ ll]\)

NetworkLengthGraphics[list_List,k_Integer:2]:=
  DensityGraphics[Transpose[NetworkLengths[list,k]],PlotRange\[Rule]{0,1},
    ColorFunction\[Rule](GrayLevel[1-#1]&)]

\!\(StringCoordinate[list_List, k_:  2] := 
    Length[list] + FromDigits[list, k]\/k\^Length[list]\)

NetworkEvolveGraphic[rules_,list_List,t_Integer,k_:2]:=
  Module[{cl,i,pr},cl=NetworkEvolveList[rules,list,t-1];pr=PrepRules[rules];
    Graphics[{AbsoluteThickness[.3],
        Table[NEG0[pr,cl\[LeftDoubleBracket]i\[RightDoubleBracket],i,k],{i,
            Length[cl]}]},PlotRange\[Rule]All]]

NEG0[pr_,list_,i_,k_]:=(NEG1[pr,#1,i,k]&)/@list

NEG1[pr_,list_,i_,k_]:=
  With[{pt={i,
          StringCoordinate[list,k]}},({Point[#1],
            Line[{pt,#1}]}&)/@({i+1,StringCoordinate[#1,k]}&)/@
        NetworkStep0[pr,list]]

NetworkFrontEvolveGraphic[rules_,list_List,t_Integer,k_:2]:=
  Module[{cl,i,pr},cl=NetworkFrontEvolveList[rules,list,t-1];
    pr=PrepRules[rules];
    Graphics[{AbsoluteThickness[.3],
        Table[NFEG0[pr,cl\[LeftDoubleBracket]i\[RightDoubleBracket],i,k],{i,
            Length[cl]}]},PlotRange\[Rule]All]]

NFEG0[pr_,list_,i_,k_]:=(NFEG1[pr,#1,i,k]&)/@list

NFEG1[pr_,list_,i_,k_]:=
  With[{pt={i,
          StringCoordinate[list,k]}},({Point[#1],
            Line[{pt,#1}]}&)/@({i+1,StringCoordinate[#1,k]}&)/@
        NetworkFrontStep0[pr,list]]

Differences[list_List]:=Apply[#2-#1&,Partition[list,2,1],{1}]

makanin=ToSemigroup[{"CCBB"\[Rule]"BBCC","BCCCBB"\[Rule]"CBBBCC",
        "ACCBB"\[Rule]"BBA","ABCCCBB"\[Rule]"CBBA",
        "BBCCBBBBCC"\[Rule]"BBCCBBBBCCA"}];



StringToBits[s_String,letters_List,intsize_:32]:=
    Module[{chunk=Ceiling[Log[2,Length[letters]]],
        c=Flatten[Position[letters,#]&/@Characters[s]]-1,
        n},{StringLength[s]*chunk,
        If[#>=2^(intsize-1),#-2^intsize,#]&/@
          Reverse[IntegerDigits[FromDigits[Reverse[c],2^chunk],2^intsize]]}];

BitsToString[{n_Integer,bits_List},letters_List,intsize_:32]:=
    Module[{chunk=Ceiling[Log[2,Length[letters]]],
        b=If[#<0,#+2^intsize,#]&/@bits,f},
      If[(f=FromDigits[Reverse[b],2^intsize])>=2^n,Print["Error: ",{n,b}]];
      StringJoin[
        letters\[LeftDoubleBracket]#+1\[RightDoubleBracket]&/@
          Reverse[IntegerDigits[f,2^chunk,n/chunk]]]];

FSM[lhs_List,chunk_Integer,intsize_:32]:=
  Block[{lh=
        MapIndexed[{First[#2],#1\[LeftDoubleBracket]1\[RightDoubleBracket],
              FromDigits[
                Reverse[#1\[LeftDoubleBracket]2\[RightDoubleBracket]],
                2^intsize]}&,lhs],ch=chunk,states,new,match={},index,index2,m,
      n=0,q},states={lh};FSMRecurse[1,1];m=Length[states]-1;
    Do[q=First/@
          Cases[states\[LeftDoubleBracket]i\[RightDoubleBracket],{_,0,0}];
      If[Length[q]>0,match=Append[match,q-1];index[n]=i;index2[i]=n;n++,
        index[m]=i;index2[i]=m;m--],{i,
        Length[states]}];{Table[{index2[#\[LeftDoubleBracket]1\
\[RightDoubleBracket]],index2[#\[LeftDoubleBracket]2\[RightDoubleBracket]]}&@
          new[index[i]],{i,0,Length[states]-1}],match}]

FSMRecurse[s_Integer,c_Integer]:=
    Module[{state=states\[LeftDoubleBracket]s\[RightDoubleBracket],newstate,
        next,newc=If[c==ch,1,c+1],p},
      Do[newstate={};
        Do[If[state\[LeftDoubleBracket]j,2\[RightDoubleBracket]>0,
            If[Xor[OddQ[state\[LeftDoubleBracket]j,3\[RightDoubleBracket]],
                i==0],newstate=
                Append[newstate,{state\[LeftDoubleBracket]j,
                      1\[RightDoubleBracket],
                    state\[LeftDoubleBracket]j,2\[RightDoubleBracket]-1,
                    Floor[state\[LeftDoubleBracket]j,3\[RightDoubleBracket]/
                        2]}]]],{j,Length[state]}];
        If[c==ch,newstate=Join[newstate,lh]];p=Position[states,newstate,{1}];
        If[Length[p]>0,next[i]=p\[LeftDoubleBracket]1,1\[RightDoubleBracket],
          states=Append[states,newstate];next[i]=Length[states];
          FSMRecurse[Length[states],newc]],{i,0,1}];new[s]={next[0],next[1]}];

MWToBits[rules_List,init_List,intsize_:32]:=
    Module[{letters=Union[Flatten[Characters[{Apply[List,#]&/@rules,init}]]]},
      If[Length[letters]==1,
        letters=Append[letters,
            If[letters\[LeftDoubleBracket]1\[RightDoubleBracket]=="A","B",
              "A"]]];{Map[StringToBits[#,letters,intsize]&,rules,{2}],
        StringToBits[#,letters,intsize]&/@init,letters,
        Ceiling[Log[2,Length[letters]]]}];



MWBits[rules_List,init_List,maxlevel_Integer,outflag_Integer,maxlen_Integer:0,
    intsize_Integer:32]:=
  MWBitsX[maxlevel,outflag,
        maxlen,{Function[
              x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,
                  2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
          FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}]&@
    MWToBits[rules,init,intsize]



XMWUEvolveList[rules_List,init_List,maxlevel_Integer,intsize_Integer:32]:=
  Map[Function[y,
          BitsToString[y,#\[LeftDoubleBracket]3\[RightDoubleBracket],
            intsize]],
        MWBitsX[maxlevel,0,
          0,{Function[
                x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,
                    2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
            FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}],{2}]&@
    MWToBits[rules,init,intsize]



XMWUEvolveListBits[rules_List,init_List,maxlevel_Integer,intsize_Integer:32]:=
  MWBitsX[maxlevel,0,
        0,{Function[
              x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,
                  2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
          FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}]&@
    MWToBits[rules,init,intsize]



XMWUEvolveLengthsList[rules_List,init_List,maxlevel_Integer,
    intsize_Integer:32]:=
  Map[Function[y,y/#\[LeftDoubleBracket]4\[RightDoubleBracket]],
        MWBitsX[maxlevel,1,
          0,{Function[
                x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,
                    2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
            FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}],{2}]&@
    MWToBits[rules,init,intsize]



XMWUEvolveLengths[rules_List,init_List,maxlevel_Integer,intsize_Integer:32]:=
  Map[Function[
          y,{y\[LeftDoubleBracket]1\[RightDoubleBracket]/#\[LeftDoubleBracket]\
4\[RightDoubleBracket],y\[LeftDoubleBracket]2\[RightDoubleBracket]}],
        MWBitsX[maxlevel,3,
          0,{Function[
                x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,
                    2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
            FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}],{2}]&@
    MWToBits[rules,init,intsize]

Map[({#[[1]]+1,#[[2]]})&,{{{3,5},{2,8},{4,6}},{{2,1}}},{2}]





XMWUEvolveTotals[rules_List,init_List,maxlevel_Integer,intsize_Integer:32]:=
  MWBitsX[maxlevel,2,
        0,{Function[
              x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                x\[LeftDoubleBracket]2,
                  2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
          FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}]&@
    MWToBits[rules,init,intsize]



XMWUShortStrings[rules_List,init_List,maxlevel_Integer,maxlen_Integer,
    intsize_Integer:32]:=
  Map[Function[y,
          Function[w,
              If[Length[y]\[Equal]2,w,
                Append[w,
                  y\[LeftDoubleBracket]3\[RightDoubleBracket]/#\
\[LeftDoubleBracket]4\[RightDoubleBracket]]]]@{Function[z,
                  BitsToString[z,#\[LeftDoubleBracket]3\[RightDoubleBracket],
                    intsize]]/@(y\[LeftDoubleBracket]1\[RightDoubleBracket]),
              y\[LeftDoubleBracket]2\[RightDoubleBracket]}],
        MWBitsX[maxlevel,4,
          maxlen*#\[LeftDoubleBracket]4\[RightDoubleBracket],{Function[
                x,{x\[LeftDoubleBracket]1,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,1\[RightDoubleBracket],
                  x\[LeftDoubleBracket]2,
                    2\[RightDoubleBracket]}]/@#\[LeftDoubleBracket]1\
\[RightDoubleBracket],#\[LeftDoubleBracket]2\[RightDoubleBracket],
            FSM[First/@#\[LeftDoubleBracket]1\[RightDoubleBracket],#\
\[LeftDoubleBracket]4\[RightDoubleBracket],intsize]}]]&@
    MWToBits[rules,init,intsize]

$MWLink=Install["MultiwaySystems`mwlink`"];





MWBigGraphic[rr_,init_,t_,rs_:0.2]:=
  RHInset[Surround[MWGraphic[MWEvolveListT[rr,init,t]]],
    MWCharRuleGraphic[rr],{rs,.04}]

XMWEvolveTotals[rr_,{ini_String},t_,maxsize_:1000]:=
  MWCharGrowth[{rr,ini},t,maxsize]

XMWEvolveSequences[rr_,{ini_String},t_,retain_Integer:0,maxsize_Integer:1000]:=
  MPSequences[FromChars[rr],FromChars[ini],t,retain,maxsize]

$MPLink=Install["MultiwaySystems`MPLink`"];

ReInstall:=(Uninstall/@{$MWLink,$MPLink};$MWLink=
      Install["MultiwaySystems`mwlink`"];$MPLink=
      Install["MultiwaySystems`MPLink`"];)



StringToInteger[s_,k_:2]:=
  FromDigits[Prepend[Characters[s]/.{"A"->0,"B"->1},1],2]

PositionData[history_]:=
  Flatten[MapIndexed[Function[{e,p},{StringToInteger[#],First[p]}&/@First[e]],
      history],1]

XMWUPositionData[rr_,init_,t_,maxlen_:10]:=
  PositionData[XMWUShortStrings[rr,init,t,maxlen]]

ProofLengthGraphic[list_,max_]:=
  Graphics[{GrayLevel[.5],Rectangle[{#[[1]]-1,#[[2]]},{#[[1]],max+1}]&/@list,
      GrayLevel[0],Rectangle[{#[[1]]-1,#[[2]]},{#[[1]],#[[2]]+1}]&/@list},
    Frame\[Rule]True,FrameStyle\[Rule]HairlineStyle,PlotRange\[Rule]All]