(*******************************************************************
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]