箱玉系（ソリトン Cellular Automaton）

import Data.List (span)


main = mapM_ (putStrLn . draw) . take 20 . iterate step . initialize $ dat
  where draw = map (\n -> if n == 0 then ' ' else '■')
        dat = [1,2,3,7,8,12,13,18]


initialize :: [Int] -> [Int]
initialize = ini [] (-1)
  where ini acc _ [] = reverse acc
        ini acc prev (x:xs) = ini (make (x-prev)++acc) x xs
        make n = (1:) . take (n-1) . repeat $ 0

step ns = step' [] ns 
  where step' acc [] = reverse acc
        step' acc (x:xs) = case x of
          0 -> step' (0:acc) xs
          2 -> step' (1:acc) xs
          1 -> step' (0:acc) $ balls ++ (2:drop 1 boxes)
            where (balls,boxes) = span (/= 0) xs

実行結果

 ■■■   ■■   ■■    ■
    ■■■  ■■   ■■   ■
       ■■  ■■■  ■■  ■
         ■■   ■■  ■■ ■■
           ■■   ■■  ■  ■■■
             ■■   ■■ ■    ■■■
               ■■   ■ ■■     ■■■
                 ■■  ■  ■■      ■■■
                   ■■ ■   ■■       ■■■
                     ■ ■■   ■■        ■■■
                      ■  ■■   ■■         ■■■
                       ■   ■■   ■■          ■■■
                        ■    ■■   ■■           ■■■
                         ■     ■■   ■■            ■■■
                          ■      ■■   ■■             ■■■
                           ■       ■■   ■■              ■■■
                            ■        ■■   ■■               ■■■
                             ■         ■■   ■■                ■■■
                              ■          ■■   ■■                 ■■■
                               ■           ■■   ■■                  ■■■