いいかげんしつこいのはわかっているが、十数年前に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のせいか数秒おきにカクカクしていたような……だが、勘違いかもしれない。
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
函数で画面を出力してみた: