しつこいがまだライフゲームだ（RepaとSDLで）

いいかげんしつこいのはわかっているが、十数年前にC言語を初めて触って（Vine Linuxだった）、初めて言語仕様の勉強ではなくプログラミングらしきことをしてみた時に書いたものがncursesとSDLでのライフ・ゲームだったことを思い出したので、手抜きながらSDLでライフ・ゲームである（十数年進歩がない……）。せっかくなので世代ごとに色をつけ、フィールドの上下左右を繋いでトーラスに同相にしてみた。

スクリーンショットは最後にあるが、こんな情弱なガラクタを自分で試してみたい奇特な向きは、RepaはもちろんのことSDLバインディングをインストールする必要がある（Linuxならapt-getあたりでSDLをインストールした上でc2hsとか入れてから`cabal install sdl`でいいと思う）。

使い方は：

```
# 各セル 8x8、世代更新間隔200ミリ秒
./LifeGame 8 200
```

ENTERキー押下で終了。SPACEキー押下で編集モードと自動更新モードを切替。編集モードでは、nキーで次の世代に更新、iキーで再初期化（ランダム配置）、zキーで配置クリア、pキーでスクリーンショット。

そういえば、かなり昔（記憶が曖昧）、Windows向けのHaskellやCleanのディストリビューションに似たようなものが附属していた気がする……Cleanのは滑らかなのに同じプログラムのHaskell移植版はGCのせいか数秒おきにカクカクしていたような……だが、勘違いかもしれない。

```hs:LifeGame_Repa_SDL.hs
module Main where

import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.ST (runST)
import System.Random (getStdRandom,random)
import System.Environment (getArgs)
import System.Exit (exitSuccess)
import Data.IORef
import Data.Array.Repa as Repa
import Data.Array.Repa.Algorithms.Randomish (randomishIntArray)
import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.Primitives (vLine, hLine)

type Field = Array U DIM2 Int

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

zeroize :: (Int,Int) -> IO Field
zeroize (x,y) = do
  return $ fromListUnboxed (Z:.x:.y) $ take (x*y) $ repeat 0

toggle :: DIM2 -> Field -> Field
toggle (Z:.i:.j) f = runST $ do
  computeP $ traverse f id (\ _ sh -> replace f sh)
    where replace f pos@(Z:.p:.q) = if (p,q) == (i,j)
            then case f ! pos of {0->1; _->0;}
            else f ! pos


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

count :: Field -> DIM2 -> Int
count f (Z :.x :.y) = sum $ Prelude.map 
  (\(i,j) -> case (!) f (Z :.i :.j) of {0->0; _->1}) $
--  [torus (i,j)|i<-[x-1,x,x+1],j<-[y-1,y,y+1]]
  [(i,j)|i<-[x-1,x,x+1],j<-[y-1,y,y+1],0<=i,i<=(xmax-1),0<=j,j<=(ymax-1)]
    where (Z :.xmax :.ymax) = extent f
          torus (x,y) = ((mod x xmax),(mod y ymax))

step :: Field -> Field
step f = runST $ do
  computeP $ Repa.zipWith survival f (aggregate f)
    where survival x y = case x of
            0 -> case y of {3->1;_->0;}
            90 -> case y of {3->x; 4->x; _->0;}
            _ -> case y of {3->(x+1); 4->(x+1); _->0;}

drawField :: Surface -> Int -> Field -> IO ()
drawField sf n f = do
  let (Z :. xmax :. ymax) = extent f
  forM_ [(x,y)|x<-[0..(xmax-1)],y<-[0..(ymax-1)]] $ \(x,y) -> do
    let rect = Rect{rectX=x*n, rectY=y*n, rectW=(n-1), rectH=(n-1)}
        drawCellWith = fillRect sf (Just rect) . Pixel
    drawCellWith $ case f ! (Z:.x:.y) of 
      0 -> 0x00000000
      1 -> 0x00E60012
      2 -> 0x00F39800
      3 -> 0x00FFF100
      4 -> 0x00009944
      5 -> 0x000068B7
      6 -> 0x001D2088
      -- 7 -> 0x00A40896
      90 -> 0x00442288
      z -> fromIntegral $ (12-(div (fromIntegral z) 15))*0x00130112

drawGrid :: Surface -> Int -> IO ()
drawGrid sf n = do
  info    <- getVideoInfo
  let w = videoInfoWidth info
      h = videoInfoHeight info
  forM_ [y|y<-[0..(div h n)]] $ \y -> 
    hLine sf 0 (fromIntegral w) (fromIntegral (n*y-1)) (Pixel 0x00444444)
  forM_ [x|x<-[0..(div w n)]] $ \x ->
    vLine sf (fromIntegral (n*x-1)) 0 (fromIntegral h) (Pixel 0x00444444)       

eraseGrid :: Surface -> Int -> IO ()
eraseGrid sf n = do
  info    <- getVideoInfo
  let w = videoInfoWidth info
      h = videoInfoHeight info
  forM_ [y|y<-[0..(div h n)]] $ \y -> 
    hLine sf 0 (fromIntegral w) (fromIntegral (n*y-1)) (Pixel 0x000000FF)
  forM_ [x|x<-[0..(div w n)]] $ \x ->
    vLine sf (fromIntegral (n*x-1)) 0 (fromIntegral h) (Pixel 0x000000FF)
-- なぜFFにしないと黒くならないのか不明。バインディングのバグか。

main = do
  args <- getArgs
  let usage = "\n Usage: LifeGame [size of cells in px.] [interval in ms.]\n\
              \\n Hit RETURN to exit.\n\
              \ Hit SPACE to toggle Running mode/Editing mode.\n\
              \   When in Editing mode, hit\n\
              \      n -> proceed to next generation\n\
              \      i -> initialize (randomly)\n\
              \      z -> clear the field,\n\
              \      p -> screenshot the field to \"Life.bmp\"\n\
              \    or click the panel to toggle a cell.\n"
  if null args then do {putStrLn usage;exitSuccess;} else return ()
  let [size, delay] = Prelude.map read args
  
  
  SDL.init [SDL.InitEverything]
  info    <- getVideoInfo
  let w = videoInfoWidth info
      h = videoInfoHeight info
      
  n <- newIORef 0
  f <- newIORef =<< initialize (div w size,div h size)
  
  setVideoMode w h 32 [Fullscreen]
  setCaption "Game of Life" "Life Game"
  msf <- newIORef =<< getVideoSurface
  mainSF <- readIORef msf
  let mainLoop = do
        mainSF <- readIORef msf
        drawField mainSF size =<< readIORef f
        SDL.flip mainSF
        ev <- pollEvent
        checkEvent mainSF ev
        SDL.delay $ fromIntegral (1+delay)
        modifyIORef n succ
        modifyIORef f step
        mainLoop
        
      checkEvent sf Quit = exitSuccess
      checkEvent sf (KeyDown (Keysym SDLK_RETURN _ _)) = do {
         toggleFullscreen sf
        ;exitSuccess
        ;}
      checkEvent sf (KeyDown (Keysym SDLK_SPACE _ _)) = do
        drawGrid mainSF size
        SDL.flip mainSF
        enableKeyRepeat 200 delay
        manualModeLoop
        enableKeyRepeat 0 0
        return ()
          where manualModeLoop = do                                   
                  ev<-pollEvent
                  SDL.delay $ 1
                  case ev of
                    Quit -> exitSuccess
                    KeyDown (Keysym SDLK_RETURN _ _) -> do {
                       toggleFullscreen mainSF 
                      ;exitSuccess
                      ;}                       
                    KeyDown (Keysym SDLK_SPACE _ _) -> do {
                       eraseGrid mainSF size
                      ;drawField mainSF size =<< readIORef f                               
                      ;SDL.flip mainSF
                      ;return ()
                      ;}
                    KeyDown (Keysym SDLK_n _ _) -> do{
                       modifyIORef n succ
                      ;modifyIORef f step
                      ;drawField mainSF size =<< readIORef f                               
                      ;SDL.flip mainSF
                      ;manualModeLoop
                      ;}                                           
                    KeyDown (Keysym SDLK_i _ _) -> do{
                       writeIORef n 0
                      ;writeIORef f =<< initialize (div w size,div h size)
                      ;drawField mainSF size =<< readIORef f                               
                      ;SDL.flip mainSF
                      ;manualModeLoop
                      ;}
                    KeyDown (Keysym SDLK_z _ _) -> do{
                       writeIORef n 0
                      ;writeIORef f =<< zeroize (div w size,div h size)
                      ;drawField mainSF size =<< readIORef f                               
                      ;SDL.flip mainSF
                      ;manualModeLoop
                      ;}
                    KeyDown (Keysym SDLK_p _ _) -> do{
                       saveBMP mainSF "Life.bmp"                      
                      ;manualModeLoop
                      ;}  
                    MouseButtonDown x y _ -> do{
                       modifyIORef f $ toggle 
                         (Z:.(fromIntegral $ div x $ fromIntegral size):.
                             (fromIntegral $ div y $ fromIntegral size))
                      ;writeIORef n 0
                      ;drawField mainSF size =<< readIORef f
                      ;SDL.flip mainSF
                      ;manualModeLoop
                      ;}
                    _ -> manualModeLoop
        
      checkEvent _ _  = return ()
  
  mainLoop 
  exitSuccess
```

SDLの`saveBMP`函数で画面を出力してみた：

![Life.png](https://qiita-image-store.s3.amazonaws.com/0/33744/db329f6e-9cec-a4a4-6cf9-fa9fe77bf3bd.png)