Introduction

During the summer of my junior year, I participated in the Wolfram Summer Camp, a program which gave me the unique opportunity to learn and explore the Wolfram Language. After completing a project on predicting the trends of the Housing Price Index, I was so fascinated by the unimaginably powerful capabilities of the Wolfram Language that I began looking for other opportunities to further explore in this amazing language.

Through the Wolfram Mentorship program, I have been able to continue doing so. Interested in computational mathematics, I began working on the "Probabilistic Cellular Automata" project with the objective of creating the most efficient Mathematica program that can output cellular automaton based on eight predetermined probabilities.

Cellular Automaton

A traditional cellular automaton function has three basic components: the initial list, the rule, and the number of iterations. For those who are unfair with this concept, the initial list is simply a list of 0's and 1's which correspond to white and black, respectively. The rule is essentially a function that takes a sequence of three digits and outputs a 0 or 1. For example, for rule 30, the list {0,0,0} gives 0, {0,0,1} gives 1, {0,1,0} give 1, etc. Since there are eight possible three digit sequences of zeros and ones, there are 2^8 = 256 rules. The number of iterations is just the number of times we apply the same rule to the new list.

One can see that the traditional cellular automaton function is limited to only 256 possibilities and that the sequences or images are predetermined. To address these shortcomings, I have created a Probabilistic Cellular Automaton function in which the output of a given list of three digits will be based on a probability. For example, the sequence {1,0,1} will output 1 80% of the time and 0 the other 20% of the time.

Initial Coding

Creating a function that performs accurate iterations is not a difficult task. One only needs to consider the probabilities for each of the eight possible three-term sequences. Such code is shown below:

PCA[{p7_, p6_, p5_, p4_, p3_, p2_, p1_, p0_}, init_, t_] := NestList[
  Replace[Partition[#, 3, 1, 2], {{1, 1, 1} :>
      RandomChoice[{p7, 1 - p7} -> {1, 0}], {1, 1, 0} :>
      RandomChoice[{p6, 1 - p6} -> {1, 0}], {1, 0, 1} :>
      RandomChoice[{p5, 1 - p5} -> {1, 0}], {1, 0, 0} :>
      RandomChoice[{p4, 1 - p4} -> {1, 0}], {0, 1, 1} :>
      RandomChoice[{p3, 1 - p3} -> {1, 0}], {0, 1, 0} :>
      RandomChoice[{p2, 1 - p2} -> {1, 0}], {0, 0, 1} :>
      RandomChoice[{p1, 1 - p1} -> {1, 0}], {0, 0, 0} :>
      RandomChoice[{p0, 1 - p0} -> {1, 0}]}, {1}] &, init, t]

While this code will compute the result, it is inefficient for large iterations.After creating my first working function, I experimented with several other functions and compared their efficiency through the Repeated Timing function. Some of the other codes I created are listed below:

PCAUnitStep[{p7_, p6_, p5_, p4_, p3_, p2_, p1_, p0_}, init_, t_] := 
 NestList[
  Replace[
    Partition[#, 3, 1, 
     2], {{1, 1, 1} :> UnitStep[RandomReal[1] - (1 - p7)]
     , {1, 1, 0} :>
      UnitStep[RandomReal[1] - (1 - p6)], {1, 0, 1} :>
      UnitStep[RandomReal[1] - (1 - p5)], {1, 0, 0} :>
      UnitStep[RandomReal[1] - (1 - p4)], {0, 1, 1} :>
      UnitStep[RandomReal[1] - (1 - p3)], {0, 1, 0} :>
      UnitStep[RandomReal[1] - (1 - p2)], {0, 0, 1} :>
      UnitStep[RandomReal[1] - (1 - p1)], {0, 0, 0} :>
      UnitStep[RandomReal[1] - (1 - p0)]}, {1}] &, init, t]

Using FoldList and another function:

f[probabilities_, list_] := 
 probabilities[[FromDigits[#, 2] + 1]] & /@ Partition[list, 3, 1, 2]
PCAUnitStep2[{p7_, p6_, p5_, p4_, p3_, p2_, p1_, p0_}, init_, t_] := 
 FoldList[f[#2, #1] &, init, 
  Table[{UnitStep[-RandomReal[1] + (p7)], 
    UnitStep[-RandomReal[1] + p6], UnitStep[-RandomReal[1] + p5], 
    UnitStep[-RandomReal[1] + (p4)], UnitStep[-RandomReal[1] + (p3)], 
    UnitStep[-RandomReal[1] + (p2)], UnitStep[-RandomReal[1] + (p1)], 
    UnitStep[-RandomReal[1] + (p0)]}, t]]

Using NestList and Partition:

PCA3[prob_, init_, t_] := 
 NestList[UnitStep[-RandomReal[1, Length[init]] + (prob[[
       FromDigits[#, 2] + 1 & /@ Partition[#, 3, 1, 2]]])] &, init, t]

And using FoldList and Partition:

PCA4[prob_, init_, t_] :=
 FoldList[
  UnitStep[-#2 + (prob[[
       FromDigits[#, 2] + 1 & /@ Partition[#1, 3, 1, 2]]])] &, init, 
  RandomReal[1, {t, Length[init]}]]

Through trial and error, I eventually arrived at the most efficient code (of the ones I've tried). The code is shown below:

PCA5[prob_, init_, t_] :=
 FoldList[
  UnitStep[-#2 + (prob[[ListConvolve[{1, 2, 4}, #1, 2] + 1]])] &, 
  init, RandomReal[1, {t, Length[init]}]]

Probabilistic Cellular Automaton versus Traditional Cellular Automaton

Below are the arrays plots of two cellular automaton. The first one is generated using rule 126 while the second one uses probabilities that are really close to rule 126 but differs by 1% when generating black squares.

It is interesting to see how even though the codes are more than 99% alike, the images can differ so drastically.

Challenges Faced

This project was more difficult in the beginning since I was still inexperienced with many of Mathematica's functions. It took me a long time to figure out how to properly use each one and also my knowledge was limited to only what I had learned through the Wolfram Summer Camp. Overall, the most difficult aspect of the project was finding functions that could make my code more efficient.

Conclusion

From this project, I have learned how to use several functions in Mathematica and have gleaned valuable insights into programming. This experience helped me understand the seemingly easy yet actually complex process behind creating an efficient function and showed me that simple changes could lead to widely varied results.

Links:

Wolfram Summer Camp

Wolfram Mentorship Program

Cellular Automaton