2
$\begingroup$

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)

$\endgroup$

2 Answers 2

2
$\begingroup$

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.

$\endgroup$
3
  • $\begingroup$ I wanted actually a toy model for 'diffusion' and it's actually derived from problem 23 of "advent of code 2022" which the significantly different 2D version of this. I think it could be even interpreted as a model for phase transitions. I intend to submit the sequence for a certain infinite starting string to oeis (usind decimal encoding for the sequence elements. $\endgroup$ Dec 24, 2022 at 19:01
  • $\begingroup$ Thank you @BenIzd , this is the perfect answer! $\endgroup$ Dec 25, 2022 at 8:17
  • $\begingroup$ @RaphaelJ.F.Berger I'm glad it was helpful. $\endgroup$
    – Ben Izd
    Dec 25, 2022 at 20:09
3
$\begingroup$

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} *)
$\endgroup$
5
  • $\begingroup$ Thank you for trying! That seems not to work: dat={1,1,1,0,0,0}; dat /. rules; dat /. rules yields in the first and second iteration both times: {1,1,0,1,0,0}, while it should give {1,0,1,1,0,0} for the second round of rules. $\endgroup$ Dec 24, 2022 at 14:21
  • $\begingroup$ I have added an example to make it clearer how the rules shall be applied. $\endgroup$ Dec 24, 2022 at 14:33
  • $\begingroup$ If you apply the rules correctly, it will work. at={1,1,1,0,0,0}; dat=dat /. rules; dat= dat /. rules $\endgroup$ Dec 24, 2022 at 16:10
  • $\begingroup$ I am sorry @DanielHuber it does not work for me. Can you verify the sample sequence I have added to the question? $\endgroup$ Dec 24, 2022 at 16:34
  • 1
    $\begingroup$ dat = {1, 1, 1, 0, 0, 0};Print[dat = dat /. rules];Print[dat = dat /. rules];outputs: {1,1,0,1,0,0} and {1,0,1,1,0,0} MMA version 13.2 $\endgroup$ Dec 24, 2022 at 17:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.