<<MultiwaySystems/Multiway.m
XMWUEvolveList[{"A"->"A","A"->"AA"},{"A"},5]
{{A},{AA},{AAA},{AAAA},{AAAAA},{AAAAAA}}
​
XMWUEvolveList[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABBBABA"},5]
{{ABABBBABA},{ABBBABA,ABBABBBBABA,AAAAABAABA,ABABBBA,ABABBBABBAB},{BBABA,ABBBA,ABBBABBAB,BABBBBABA,ABBBBBABA,ABBABBBBA,ABBABBBBABBAB,AAAAAABA,AAAAABBABABA,AAAAABAA,AAAAABAABBAB,ABABBBBAB,ABABBBABB},{BBA,BBABBAB,ABBBBAB,ABBBABB,BBBBABA,BABBBBA,BABBBBABBAB,ABBBBBA,ABBBBBABBAB,ABBABBBBBAB,ABBABBBBABB,AAAAAA,AAAAAABBAB,AAAABABABA,AAAAABBABA,AAAAABBABBABBA,AAAAABBABABBAB,AAAAABABAB,AAAAABAABB,ABABBBB},{BBBAB,BBABB,ABBBB,BBBBA,BBBBABBAB,BABBBBBAB,BABBBBABB,ABBBBBBAB,ABBBBBABB,ABBABBBBB,AAAAABAB,AAAAAABB,AAAABABA,AAAABBABBABA,AAAABABBABBA,AAAABABABBAB,AAAAABBA,AAAAABBABBAB,AAAAABBBABBA,AAAAABBABBBA,AAAAABBABBABBBAB,AAAAABBABABB,AAAAABABBABB},{BBB,BBBBBAB,BBBBABB,BABBBBB,ABBBBBB,AAAAAB,AAAAABBABB,AAAABA,AAAABBABBA,AAAABABBAB,AAABABBABA,AAAABBBABA,AAAABBABBABBAB,AAAABBABBBABBA,AAAABABBBA,AAAABABBABBBAB,AAAABABABB,AAAAABBBAB,AAAAABBBBA,AAAAABBBABBBAB,AAAAABBABBBBAB,AAAAABBABBABBB,AAAAABBABBBABB,AAAAABABBB}}
XMWUEvolveTotals[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABBBABA"},25]
{1,5,13,20,23,24,26,31,39,48,60,72,81,88,104,137,210,331,520,785,1146,1606,2212,3007,4047,5444}
XMWUEvolveTotals[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABAB"},1000];
ListPlot[%24,PlotJoined->True];
ListPlot[Differences[%24],PlotJoined->True];
XMWUShortStrings[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABAB"},20,10]
{{{ABABAB},1,{6,6}},{{ABAB,ABBABBAB,ABABBABB},3,{4,8}},{{AB,ABBABB,BABBAB,ABBBAB,ABBABBBABB,ABABBB},6,{2,10}},{{,BABB,ABBB,BBAB,BABBBABB,ABBBBABB,ABBABBBB,AAAAABA},8,{0,8}},{{BB,BBBABB,BABBBB,ABBBBB,AAAAA,AAAAABBAB},6,{2,9}},{{BBBB,AAAABAB,AAAAABB},3,{4,7}},{{AAAAB,AAAABBABB},2,{5,9}},{{AAA,AAABABB,AAAABBB},3,{3,7}},{{AAABB,AAABBABBB},2,{5,9}},{{AAB,AABABBB,AAABBBB},3,{3,7}},{{A,AABBB,AABBABBBB,AAAAAABA},4,{1,9}},{{ABB,ABABBBB,AABBBBB,AAAAAA,AAAAAABBAB},5,{3,10}},{{B,ABBBB,ABBABBBBB,AAAAABAB,AAAAAABB},5,{1,9}},{{BBB,BABBBBB,ABBBBBB,AAAAAB,AAAAABBABB},5,{3,10}},{{BBBBB,AAAA,AAAABABB,AAAAABBB},4,{4,8}},{{AAAABB,AAAABBABBB},2,{6,10}},{{AAAB,AAABABBB,AAAABBBB},3,{4,8}},{{AA,AAABBB,AAABBABBBB,AAAAAAABA},4,{2,10}},{{AABB,AABABBBB,AAABBBBB,AAAAAAA},5,{4,11}},{{AABBBB,AABBABBBBB,AAAAAABAB,AAAAAAABB},4,{6,10}},{{ABABBBBB,AABBBBBB,AAAAAAB},4,{7,11}}}
StringToBits["ABABAB",{"A","B"}]
{6,{42}}
StringToNumber[s_]:=FromDigits[Prepend[Characters[s]/.{"A"->0,"B"->1},1],2]
StringToNumber["ABABAB"]
85
(StringToNumber/@First[#])&/@%27
{{85},{21,365,347},{5,91,109,93,1467,87},{1,27,23,29,443,379,367,130},{7,123,111,95,32,525},{31,133,131},{33,539},{8,139,135},{35,567},{9,151,143},{2,39,623,258},{11,175,159,64,1037},{3,47,735,261,259},{15,223,191,65,1051},{63,16,267,263},{67,1079},{17,279,271},{4,71,1135,514},{19,303,287,128},{79,1247,517,515},{351,319,129}}
XMWUShortStrings[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABAB"},200,6]
(StringToNumber/@First[#])&/@%36
{{85},{21},{5,91,109,93,87},{1,27,23,29},{7,123,111,95,32},{31},{33},{8},{35},{9},{2,39},{11,64},{3,47},{15,65},{63,16},{67},{17},{4,71},{19},{79},{},{},{},{127},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{},{}}
Flatten[%]
{85,21,5,91,109,93,87,1,27,23,29,7,123,111,95,32,31,33,8,35,9,2,39,11,64,3,47,15,65,63,16,67,17,4,71,19,79,127}
Union[%]
{1,2,3,4,5,7,8,9,11,15,16,17,19,21,23,27,29,31,32,33,35,39,47,63,64,65,67,71,79,85,87,91,93,95,109,111,123,127}
Length[%]
38
Does the rule generate exactly half of all strings? As soon as a rule has generated both a string and its complement, the rule can be rejected.
XMWUEvolveList[{"A"->"A","A"->"AA"},{"A"},5]
{{A},{AA},{AAA},{AAAA},{AAAAA},{AAAAAA}}
XMWUEvolveList[{"A"->"A","A"->"AB"},{"A"},5]
{{A},{AB},{ABB},{ABBB},{ABBBB},{ABBBBB}}
One way to do it: Generate all strings that start with an A. This will make a complete and consistent system......
On the tree of all possible strings, we never want the mirror image of a position to be occupied....
​
All strings that start with an A is exactly case (a) of neighbor-independent substitution systems....
Consistency means: there can never too much black (both thing and mirror image are black); completeness: there can never be too little black (both thing and mirror image are white).
​
So one can get a complete and consistent system by picking to the right of center line at random, then reflecting and complementing.....