Cellular Automaton with larger rules

Question

I want to implement a Cellular Automaton with the following rules:

00011
 010

01011
 110

10011
 010

11000
 010

11010
 011

11001
 010

All remaining patterns shall stay "the same", like:

abcde
 bcd

A valid example sequence based on these rules would be:

111110000
111101000
111011000
111010100
110110100
110101100
101110010

Another way to state the rules is: "110" -> "101" and "011" -> "101", except "11011" occurs then neither of the first two rules is applied on the central three elements.

As these are "larger" rules as compared to the normal nearest neighbour rules I have no idea how to best implement these. Also the should operate on "larger" starting strings like maybe 128 bits long.

Any suggestions welcome. Especially short code is appreciated. (Merry X-max to all)

Answer 1

You have an interesting problem that with a little manipulation can be modelled with SubstitutionSystem like below:

rules = {"00011" -> "00101",
   "01011" -> "01101",
   "10011" -> "10101",
   "11000" -> "10100",
   "11010" -> "10110",
   "11001" -> "10101"};


SubstitutionSystem[rules, "111110000", 6]

(* Out (without quotation): 

111110000
111101000
111011000
111010100
110110100
110101100
101101100

*)

But to preserve the string, the left and right sides of rules should be the same size which in some special cases can override themselves and lead to an incorrect result.

---

Since your rules are the same, we can easily write a general case for them like the one below:

ClearAll[CustomSubstitutionSystem];

CustomSubstitutionSystem[text_String, rules_Association] := 
  Last @ CustomSubstitutionSystem[text, rules, 1];

CustomSubstitutionSystem[text_String, rules_Association, 
  iterations_Integer] := Module[{textResult = text
   , textLength = StringLength @ text
   , ruleLength = StringLength @ First @ Keys @ rules
   , textSlice, textOriginal},
  
  Prepend[text]@
  Table[
   textOriginal = textResult;
   
   Do[
    textSlice = 
     StringTake[
      textOriginal, {startIndex, startIndex + ruleLength - 1}];

    If[KeyExistsQ[rules, textSlice],

     textResult = StringReplacePart[textResult
        , rules[textSlice]
        , {startIndex + 1, startIndex + ruleLength - 2}];
     
     ], {startIndex, textLength - ruleLength + 1}];
   textResult
   
   , {iterations}]
  ]

The first argument is the text, the second is the rules as Association and the third is optional, the number of iterations to apply.

The left and right sides of all the rules should be the same size.

Basically, we take a slice from the text and look at whether it's in the rules or not, if yes, replace part of our copy and check for the next slice.

Since the rules can replace more than one character, the next slice still can override part of the current slice if they both have a rule. The order of replacement is from left to the right.

rules = Association @ {"00011" -> "010",
    "01011" -> "110",
    "10011" -> "010",
    "11000" -> "010",
    "11010" -> "011",
    "11001" -> "010"};

CustomSubstitutionSystem["111110000", rules, 6]

(* Out (without quotation):

111110000
111101000
111011000
111010100
110110100
110101100
101110100

*)

Note the last row is different from the SubstitutionSystem result and your example.

It should work for any case like yours where rules in format k -> v, have StringLength[k] == StringLength[v] + 2 attribute.

Answer 2

I assume that 5 element patterns replaces only the middle 3 elements. With this we can define a the following rules:

rules0 =
  {PatternSequence[0, 0, 0, 1, 1] -> {0, 0, 1, 0, 1},
   PatternSequence[0, 1, 0, 1, 1] -> {0, 1, 1, 0, 1},
   PatternSequence[1, 0, 0, 1, 1] -> {1, 0, 1, 0, 1},
   PatternSequence[1, 1, 0, 0, 0] -> {1, 0, 1, 0, 0},
   PatternSequence[1, 1, 0, 1, 0] -> {1, 0, 1, 1, 0},
   PatternSequence[1, 1, 0, 0, 1] -> {1, 0, 1, 0, 1}};
rules = {x1___, #[[1]], x2___} -> {x1, Sequence @@ #[[2]], x2} & /@ 
   rules0;

To test this we create some bit string:

SeedRandom[1];
dat = RandomInteger[{0, 1}, 20]
(* {1, 1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1} *)

and apply the rules repeatedly (because of overlap):

dat //. rules
(* {1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 1, 0, 1} *)