How to implement the Nagel-Schreckenberg model in Mathematica

Question

I want to implement the Nagel-Schreckenberg model with CellularAutomaton in Mathematica. I saw some code for the traffic model. But what I want is the most basic Nagel-Schreckenberg model. I hope someone will give me the code.

Answer 1

Here's my take on it. As far as I can tell, the type of rules that are involved in the Nagel-Schreckenberg model cannot be implemented with CellularAutomaton, so I had to resort to a different approach.

accelerate[map_] := Replace[
  map,
  speed_?NonNegative :> Min[5, speed + 1],
  {1}
  ]

slow[map_] := Replace[
  Partition[map, 6, 1, {1, 1}], {
   {v_?NonNegative, empty : Longest[-1 ...], ___} :> 
    Min[v, Length[{empty}]],
   {-1, ___} :> -1
   },
  {1}
  ]

slowRandom[map_, p_] := Replace[
  map,
  speed_?Positive :> RandomChoice[{1 - p, p} -> {speed, speed - 1}],
  {1}
  ]

move[map_, n_] := Module[{pos},
  pos = Position[Partition[map, n + 1, 1, {1, 1}], {n, -1 ..}];
  ReplacePart[
   map,
   Join[Thread[pos -> -1], Thread[Mod[pos + n, Length[map], 1] -> n]]
   ]
  ]

iterate[map_, p_] := RightComposition[
   accelerate,
   slow,
   slowRandom[#, p] &,
   Fold[move, #, Range[5]] &
   ]@map

Here is how you can run a simulation with density 0.35 and $p=0.3$, like in that image on Wikipedia:

map = RandomChoice[{0.65, 0.35} -> {-1, 0}, 100];
data = NestList[iterate[#, 0.3] &, map, 100];
ArrayPlot[data, ColorRules -> {-1 -> White, _ -> Black}]

In this picture, empty cells are white, and cars are black.

If you found this interesting, you may also want to check out my implementation of the Levine-Middleton-Biham traffic model, another cellular automaton, here.