IArrayとNcursesでGame of Life (Haskellで配列を利用する)

IArrayに一番向いてない配列全体の更新をやってみるとどうなるのかと思って、ライフ・ゲームをIArrayで書いてみた。当たり前だが予想通りとても遅い。immutableな配列ってやっぱりこういうもんだよな。実際のところ、IOArrayとか使ってもIO モナドの中で操作するのとコードの見た目がやたらとゴチャゴチャするのを除けば手間はほぼ変わらないので、この種のものを書くときにIArrayを使う理由は全然ないことがわかった。後で暇な時にRepaとかData.Vector.Mutableとか使って書き換えてみようと思っている。

追記：流石に手抜き過ぎると思ったので、もう少しマトモにしようと試しにNCursesを使ってみた
（一応、NCursesを使わないでもいい元々のヴァージョンも下の方にある）。フィールドの大きさはターミナル全画面なので適宜ターミナルのウィンドウサイズを変更のこと。コマンドライン引数はスリープ間隔（ミリ秒）。実行中にENTERキー押下で終了。

再追記：配列の中身を全面的に更新するのでご利益がないだろうと思っていたが、UArrayからDiffUArrayにしてみたら、それなりに改善された（もちろん本質的には遅いままだけど）。IArrayクラスが提供するインターフェースは共通なので、冒頭のtype宣言のところに数文字書き加えるだけだ。ということで、ますます素の(U)Arrayを使う理由がないなあ。

./LifeGame 500

こんな感じ。

LifeGame_IArray_NCurses.hs

module Main where

import Control.Monad (mapM_,forM_,sequence_,replicateM)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (killThread, myThreadId)
import System.Random (getStdRandom,random)
import System.Environment (getArgs)
import UI.NCurses
import Data.Array.Diff

type Field = DiffUArray (Int,Int) Bool 
type Counts = DiffUArray (Int,Int) Int
type Characters = DiffUArray (Int,Int) Char

initialize :: (Int,Int) -> IO Field
initialize (x,y) = do
  r <- replicateM (x*y) $ getStdRandom random
  return $ listArray ((0,0),(x-1,y-1)) r

aggregate :: Field -> Counts
aggregate f = foldl count (listArray ((0,0),(xmax,ymax)) []) (indices f)
  where
    (xmax,ymax) = snd $ bounds f
    count c (i,j) = c // [((i,j),n)]
      where 
        n = length $ filter (f!) 
            [(x,y)|x<-[i-1,i,i+1],y<-[j-1,j,j+1],0<=x,x<=xmax,0<=y,y<=ymax] 

update :: Field -> Field
update f = f // map life_or_death (indices f)
  where
    c = aggregate f
    life_or_death i = if f!i 
      then case c!i of {3 -> (i,True); 4 -> (i,True); _ -> (i,False);}
      else case c!i of {3 -> (i,True); _ -> (i,False);}

format :: Field -> Characters
format f = amap (\b -> if b then 'o' else ' ') f

drawScreen :: Characters -> Update ()
drawScreen c = do
  forM_ (indices c) $ \(x,y) -> do
    moveCursor (fromIntegral x) (fromIntegral y)
    drawString $ [c!(x,y)]


main :: IO ()
main = do
  [arg] <- getArgs -- 引数は画面の更新間隔(ミリ秒)
  let delaytime = read arg
  runCurses $ do
    (x,y) <- screenSize
    f <- liftIO $ initialize (fromIntegral (x-1), fromIntegral y)
    let series = map format $iterate update f
    setEcho False
    setCursorMode CursorInvisible
    w <- defaultWindow
    cid <- newColorID ColorGreen ColorBlack 1
    updateWindow w $ setColor cid
    forM_ series $ \c -> do 
      updateWindow w $ drawScreen c
      render
      listenTo w delaytime 
        (\ev -> ev == EventCharacter '\n') -- Enterキー押下で終了

listenTo :: Window -> Int -> (Event -> Bool) -> Curses ()
listenTo w n p = do
  ev <- getEvent w (Just $ fromIntegral n)
  case ev of
    Nothing -> return ()
    Just ev' -> if p ev' then liftIO (killThread =<< myThreadId) else return ()

LifeGame_IArray.hs

module Main where

import Control.Monad (mapM_,forM_,sequence_,replicateM)
import Control.Concurrent (threadDelay)
import System.Random (getStdRandom,random)
import System.Environment (getArgs)
import Data.List
import Data.List.Split
import Data.Array.Unboxed

type Field = UArray (Int,Int) Bool 
type Counts = UArray (Int,Int) Int

initialize :: (Int,Int) -> IO Field
initialize (x,y) = do
  r <- replicateM (x*y) $ getStdRandom random
  return $ listArray ((0,0),(x-1,y-1)) r

aggregate :: Field -> Counts
aggregate f = foldl count (listArray ((0,0),(xmax,ymax)) []) (indices f)
  where
    (xmax,ymax) = snd $ bounds f
    count c (i,j) = c // [((i,j),n)]
      where 
      	n = length $ filter (f!) 
            [(x,y)|x<-[i-1,i,i+1],y<-[j-1,j,j+1],0<=x,x<=xmax,0<=y,y<=ymax] 

update :: Field -> Field
update f = f // map life_or_death (indices f)
  where
  	c = aggregate f
  	life_or_death i = if f!i 
  	  then case c!i of {3 -> (i,True); 4 -> (i,True); _ -> (i,False);}
  	  else case c!i of {3 -> (i,True); _ -> (i,False);}

format :: Field -> [String]
format f = [take (ymax+3) $ repeat '#'] ++
            map mark clist ++
           [take (ymax+3) $ repeat '#']
  where
  	clist = chunksOf (ymax+1) $ elems f
  	(xmax,ymax) = snd $ bounds f
  	mark bs = "#" ++ map (\b -> if b then 'o' else ' ') bs ++ "#"


main = do
 [a1,a2,a3] <- getArgs -- a1:width, a2:height, a3:sleep (in mil. sec.) 
 f <- initialize (read a2, read a1)
 let series = iterate update f
     pField = mapM_ putStrLn . format
     pFields = sequence_ . intersperse (threadDelay $ (read a3)*10^3) . map pField
 pFields series