HaskellでCyclic Cellular Automaton

循環的セル・オートマトン

twitterで見かけて興味を持ったので書いてみた糞コード。

セル・オートマトンについて調べていたら、「Cyclic Cellular Automata」というのに出くわしたんだけど、動画を見る限り、完全に頭おかしい挙動をしているので、是非実装してみたい…… https://t.co/WUTJDWS9gF

— えせはら(似非原重雄) (@esehara) 2015, 8月 22

CCAはセル・オートマトンの一種で、概ね次のようなものである：

1. セルはn段階の状態を持つ（n段階目の次の状態は第1段階に循環する）
2. 周囲に閾値以上の次段階セルがいるとき、自分も次ステップで次段階になる

したがって：

1. 近傍の種類（ムーア近傍かフォン・ノイマン近傍か）
2. 近傍の範囲
3. 閾値
4. セルの取りうる状態数

が指定されれば、このようなセル・オートマトンが決定される。
これに基づいてコード化されたCCAのカタログが以下にある

これにしたがって、ここでは "M 1 3 3" で「ムーア近傍、周囲1近傍、閾値3、状態数3」のCCAを表し、"N 1 1 14"で、「フォン・ノイマン近傍、周囲1近傍、閾値1、状態数14」のCCAを表すことにする。

適当に書く

Repaライブラリは使ってますが（repa, repa-algorithms, gloss, gloss-raster）、もの凄い適当なので

ghc -O3 -with-rtsopts="-N4 -H256m -K128m" -threaded CCA.hs

とかしてコンパイルしないとマトモな速度になりません。
セルはHSV色相環を状態数で均等分して色を決めRGBに変換して着色しています。

恒例のウンコード

CCA.hs

{-# LANGUAGE ScopedTypeVariables #-}
import Control.Monad.ST (runST)
import System.Random (getStdRandom,random)
import System.Environment (getArgs)
import Data.Array.Repa as Repa
import Data.Array.Repa.Algorithms.Randomish (randomishIntArray)
import Graphics.Gloss.Interface.Pure.Game
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Raster.Array

data Neighbour = Moore | Neumann deriving (Show, Eq)

data Rule = Rule { neighbour:: Neighbour
                 , range::Int
                 , threshold::Int
                 , types::Int } deriving (Show, Eq)

parse :: String -> Rule
parse str = parse' (words str)
parse' [w,x,y,z] = case w of
  "N" -> Rule {neighbour=Neumann, range=read x, threshold=read y, types=read z}
  "M" -> Rule {neighbour=Moore, range=read x, threshold=read y, types=read z}

type Field = Array U DIM2 Int

initialize :: (Int,Int) -> Rule -> IO Field
initialize (x,y) rule = do
  seed <- getStdRandom random
  return $ randomishIntArray (Z:.x:.y) 0 (types rule -1) seed

count :: Field -> DIM2 -> Rule -> Int
count f (Z :.x :.y) rule = case neighbour rule of
  Moore -> sum $ Prelude.map check
           [torus (i,j)|i<-[x-n..x+n],j<-[y-n..y+n]]
  Neumann -> sum $ Prelude.map check
           [torus (i,j)|i<-[x-n..x+n],j<-[y-n..y+n],(abs (x-i)+abs (y-j))<=n]
  where
      n = range rule
      (Z :.xmax :.ymax) = extent f
      torus (x,y) = ((mod x xmax),(mod y ymax))
      check (i,j) = if f!(Z:.i:.j) == mod (f!(Z:.x:.y)+1) (types rule) then 1 else 0

aggregate :: Field -> Rule -> Field
aggregate f r = runST $ do
  computeP $ Repa.traverse f id (\_ sh -> count f sh r)   

step :: Rule -> Field -> Field
step rule f = runST $ do
  computeP $ Repa.zipWith evolve f (aggregate f rule)
    where evolve x y = if y >= (threshold rule) then mod (x+1) (types rule) else x

toRGB :: Float -> Color
toRGB n = case (hIdx::Int) of
  0 -> makeColor v t p a
  1 -> makeColor q v p a
  2 -> makeColor p v t a
  3 -> makeColor p q v a
  4 -> makeColor t p v a
  5 -> makeColor v p q a
  _ -> error "hsvToRGB: hue outside of range [0..360]"
  where
  h = 360.0 * n
  s = 0.7
  v = 0.8
  a = 0.9
  hIdx = mod (floor (h / 60)) 6
  f    = h/60 - fromIntegral (hIdx::Int)
  p    = v*(1-s)
  q    = v*(1-s*f)
  t    = v*(1-s*(1-f))

render :: Rule -> Int -> Color
render r n = toRGB $ fromIntegral n /(fromIntegral $ types r)

main = do
  str <- getArgs
  let rule = parse $ str !! 0
  ini <- initialize (size,size) rule
  playArray dispmode (csize,csize) frq ini (Repa.map (render rule)) event (\_ -> step rule)
    where 
      dispmode =  (InWindow "Cyclic Cellular Automaton" fsize (40, 40))
      frq = 50
      size = 300
      csize = 1
      fsize = (csize*size,csize*size)
      event (EventKey (MouseButton LeftButton) Down  _ _ ) _ = undefined
      event  _ w = w

使い方

止めたいときは画面をクリックするとundefinedで例外を吐いて死にます（お手軽）。Escキーでも可（これはGlossライブラリの仕様）。

./CCA "M 1 3 3"
./CCA "N 1 1 14"

実行結果

"M 1 3 3"

"N 1 1 14"

感想

リファクタリング？　何それ、おいしいの？　な糞コードですが意外に遊べました。