ライフゲーム

以前Haskellで書いたLifeゲーム

-- life.hs
-- $ ghc -package HGL life.hs -o life

-- ライフゲーム
-- 描画のオーバヘッドがかなり大きい。
-- 描画をしなければかなり速く動作するが、描画をすると重たい。
-- HGLの使い方で何か高速化できるのか？？


import Graphics.HGL
import System.Random

-------------------------------------------------------------------
-- 型定義、環境定義
-------------------------------------------------------------------

-- 状態の定義
data State = On | Off
             deriving (Eq, Show)

-- セルの色の定義
colorOn = RGB 230 240 230
colorOff = RGB 10 10 30

-- スクリーン情報


-- 96セル
width :: Int
width = 673
height :: Int
height = 673
numWidth :: Int
numWidth = 96
numHeight :: Int
numHeight = 96



-- 32セル
{-
width :: Int
width = 513
height :: Int
height = 513
numWidth :: Int
numWidth = 32
numHeight :: Int
numHeight = 32
-}

{-
-- 8セル
width :: Int
width = 161
height :: Int
height = 161
numWidth :: Int
numWidth = 8
numHeight :: Int
numHeight = 8
-}

cellWidth :: Int
cellWidth = div width numWidth

cellHeight :: Int
cellHeight = div height numHeight



-------------------------------------------------------------------
-- メイン
-------------------------------------------------------------------
main = runGraphics $
--       do w <- openWindowEx "LIFE" Nothing (width, height) DoubleBuffered (Just 100)
       do w <- openWindowEx "LIFE" Nothing (width, height) Unbuffered (Just 100)
          drawBoard w
          eventLoop w initMatrix 0


-------------------------------------------------------------------
-- 碁盤の目を描画（初期化）
-------------------------------------------------------------------
drawBoard :: Window -> IO ()
drawBoard w =
  do drawHorizontal w
     drawVertical w
     putStrLn "drawBoard"

drawHorizontal :: Window -> IO ()
drawHorizontal w
  = do drawHline w 0

drawHline :: Window -> Int -> IO ()
drawHline w pos =
  do let p1 = (0, pos)
     let p2 = (width, pos)
     if pos < height
       then do drawInWindow w $ line p1 p2
               drawHline w (pos + cellHeight)
       else return ()

drawVertical :: Window -> IO ()
drawVertical h
  = do drawVline h 0

drawVline :: Window -> Int -> IO ()
drawVline w pos =
  do let p1 = (pos, 0)
     let p2 = (pos, height)
     if pos < width
       then do drawInWindow w $ line p1 p2
               drawVline w (pos + cellWidth)
       else return ()


-------------------------------------------------------------------
-- セルの描画
-------------------------------------------------------------------

-- マトリックスの描画

-- 時々画面を更新する。
-- 描画が遅いので間引いて描画するための関数
interval :: Int
interval = 100

drawSomeTimes :: Window -> Matrix -> Int -> IO ()
drawSomeTimes w m count
  | mod count interval == 0 = drawUpdate w m
  | otherwise               = return ()


drawUpdate :: Window -> Matrix -> IO ()
--drawUpdate w m = drawInWindow w $ overGraphics $ concat $ drawMatrix w m
drawUpdate w m = directDraw w $ overGraphics $ concat $ drawMatrix w m

drawMatrix :: Window -> [[State]] -> [[Graphic]]
drawMatrix w m = sub w 0 m
                 where sub :: Window -> Int -> [[State]] -> [[Graphic]]
                       sub w x [] = []
                       sub w x (y:ys) = drawRow w x y : sub w (x+1) ys

drawRow :: Window -> Int -> [State] -> [Graphic]
drawRow w x xs = sub w x 0 xs
                 where sub :: Window -> Int -> Int -> [State] -> [Graphic]
                       sub w x y [] = []
                       sub w x y (z:zs) = drawCell w x y z : sub w x (y+1) zs

drawCell :: Window -> Int -> Int -> State -> Graphic
drawCell w x y s =
  do let p1 = (cellWidth * x + 1, cellHeight * y + 1)
     let p2 = ((fst p1) + cellWidth - 1, (snd p1) + cellHeight - 1)
     let region = rectangleRegion p1 p2
     if s == On
       then withRGB colorOn $ regionToGraphic region
       else withRGB colorOff $ regionToGraphic region
 

-------------------------------------------------------------------
-- イベントループ
-------------------------------------------------------------------

-- ESCでアプリ終了
eventLoop :: Window -> Matrix -> Int -> IO ()
eventLoop w m count =
  do e <- maybeGetWindowEvent w
     case e of
       Just(Char {char=c}) ->
         if c == '\ESC'
           then closeWindow w
           else if c == 't'
             then do t <- getTime
                     putStrLn (show t)
                     eventLoop w m count
             else eventLoop w m count
       Nothing ->
         do putStrLn ((show count) ++ "\t" ++ (show (countOnCell m)))
            drawUpdate w m
            -- drawSomeTimes w m count
            let newM = nextMatrix m
            getWindowTick w
            eventLoop w newM (count+1)
       _ ->
         do eventLoop w m count



------------------------------------------------------------------
-- セル状態の更新
-------------------------------------------------------------------

type Matrix = [[State]]

-- マトリックスの状態を更新する。
nextMatrix :: Matrix -> Matrix
nextMatrix m = sub m 0 m
               where sub :: Matrix -> Int -> [[State]] -> [[State]]
                     sub m x [] = []
                     sub m x (y:ys) = nextRow m x y : sub m (x+1) ys

nextRow :: Matrix -> Int -> [State] -> [State]
nextRow m x xs = sub m x 0 xs
                 where sub :: Matrix -> Int -> Int -> [State] -> [State]
                       sub m x y [] = []
                       sub m x y (z:zs) = nextCell m x y : sub m x (y+1) zs


-- 指定されたセルの次状態を計算する。
-- ルール
-- 自身がOnの場合、周辺のOnの個数が２、３の場合は次もOn
-- 自身がOffの場合、周辺のOnの個数が３の場合は次はOn
-- それら以外はOffとなる。
nextCell :: Matrix -> Int -> Int -> State
nextCell m x y =
  if (getState m x y) == On
    then if ((sum == 2) || (sum == 3))
           then On
           else Off
    else if (sum == 3)
           then On
           else Off

  where   sum = length [ x | x <- neighborsList, x == On]
          neighborsList =
            (getState m (x-1) (y-1)) :
            (getState m  x    (y-1)) :
            (getState m (x+1) (y-1)) :
            (getState m (x-1)  y   ) :
            (getState m (x+1)  y   ) :
            (getState m (x-1) (y+1)) :
            (getState m  x    (y+1)) :
            (getState m (x+1) (y+1)) : []

-- 指定された座標の状態値を得る。
-- マトリックスの境界条件はトーラス型とする。
-- 即ち、右端は左端と繋がっており、上端は下端と繋がっている。
getState :: Matrix -> Int -> Int -> State
getState m x y
  | x < 0          = getState m (x+numWidth) y
  | x >= numWidth  = getState m (x-numWidth) y
  | y < 0          = getState m x (y+numHeight)
  | y >= numHeight = getState m x (y-numHeight)
  | otherwise      = (m !! x) !! y


-- マトリックス中の有効セルの個数を調べる。
countOnCell :: Matrix -> Int
countOnCell m = length [x | x <- (concat m), x == On]

-- <<alternative>>
--countOnCell m = foldl (+) 0 (map countOnRow m)
--countOnRow xs = length [x | x <- xs, x == On]


-------------------------------------------------------------------
-- 初期パターンの設定
-------------------------------------------------------------------

-- マトリックスにパターンを挿入する。
insertPattern :: Matrix -> Pattern -> Matrix
insertPattern m p = foldl insertDot m p

insertDot :: Matrix -> (Int,Int) -> Matrix
insertDot m p = insertRow 0 m p

insertRow :: Int -> [[State]] -> (Int,Int) -> [[State]]
insertRow i (x:xs) p
  | (fst p) == i = (insertCell 0 x p) : xs
  | otherwise    = x : insertRow (i+1) xs p

insertCell :: Int -> [State] -> (Int,Int) -> [State]
insertCell i [] p = []
insertCell i (x:xs) p
  | (snd p) == i = On : xs
  | otherwise    = x : insertCell (i+1) xs p



-- 初期マトリックス
initMatrix = insertPattern nullMatrix patterns


-- 全てのセルがOffのマトリックス
nullMatrix :: Matrix
nullMatrix = [nullRow| n <- [1 .. numWidth]]
nullRow = [Off| n <- [1 .. numWidth]]


-- パターン

type Pattern = [(Int,Int)]

--patterns = concat [spaceShip]
--patterns = concat [spaceShip, glider]
patterns = randomPatterns 2


-- グライダー
glider :: Pattern
glider = [(5,5),
          (4,6),
          (4,7),
          (5,7),
          (6,7)]

-- 宇宙船
spaceShip :: Pattern
spaceShip = [
    ( 15 ,15 ),
    ( 18 ,15 ),
    ( 14 ,16 ),
    ( 14 ,17 ),
    ( 18 ,17 ),
    ( 14 ,18 ),
    ( 15 ,18 ),
    ( 16 ,18 ),
    ( 17 ,18 )]


--
-- 乱数で初期配置を行う。
-- 引数の数値は全体のセル数に対してどの程度Onのセルを埋めるかを指定する。
-- この数値で割り算をするため、数値が大きい方が、初期配置のセル数は少なくなる。
randomPatterns :: Int -> Pattern
randomPatterns p = zip hRandomList vRandomList
  where n = (div (numWidth * numHeight) p)
        hRandomList = take n $ randomRs (0, numWidth-1) $ mkStdGen 17485
        vRandomList = take n $ randomRs (0, numHeight-1) $ mkStdGen 32254