100行のHaskellでスネークゲームを作った

Haskell

Posted at 2019-10-04

200行のVue.jsでスネークゲームを作ったという面白い記事を見つけて自分のスネークゲーム魂に火がついたので書いてみました。別に短い行数で書けたぞとか言う話ではなく、純粋に僕はスネークゲームを昔からよく作っていたのですが¹²

シンプルに
分かりやすく

を目指して作ったことがないことに気づいたので作ってみることにしました。プログラム自体は2時間ぐらいで完成しました。

今回使うHackageはglossとmwc-randomのみです。

{-# LANGUAGE RecordWildCards #-}

import Data.Function (fix)
import Graphics.Gloss.Interface.IO.Game
import System.Random.MWC

まずはプログラムの核となる部分の実装です。

wWidth, wHeight :: Num a => a
wWidth  = 640
wHeight = 480

window :: Display
window = InWindow "Snake Game" (wWidth, wHeight) (100, 100)

main :: IO ()
main = do
    world <- generateNewWorld
    playIO window white 10 world drawWorld eventHandler stepWorld

wWidth, wHeightはウィンドウの幅と高さを表す変数です。このたぐいの変数はIntとして使ったりFloatとして使ったりまちまちでいちいち型変換するのが面倒なのでNum a => aと多相的に宣言しています。

generateNewWorld, drawWorld, eventHandler, stepWorldは未定義なのでこれから定義していきます。処理、描画の中心となる関数はglossのplayIOです。glossの使い方は手前味噌ですが以下の記事が参考になると思います。

glossではじめるグラフィック描画 :: Haskell入門の次に読む記事 - Qiita

まずはゲームに関係する概念を定義していきましょう。

cSize, cWidth, cHeight :: Num a => a
cSize   = 20
cWidth  = fromIntegral $ wWidth  `div` cSize
cHeight = fromIntegral $ wHeight `div` cSize

type Position = (Int, Int)

randomPosition :: GenIO -> IO Position
randomPosition gen = (,) <$> uniformR (0, cWidth - 1) gen <*> uniformR (0, cHeight - 1) gen

cSize, cWidth, cHeightはそれぞれセルのサイズと横の数と縦の数です。スネークゲームの蛇はマス目上を動くのでどのセルの上にいるのかをPositionnという二組のIntで判別します。randomPositionはターゲットと蛇の初期位置をランダムに決めるための関数です。

data SnakeAction = SAStop | SAUp | SADown | SALeft | SARight deriving Eq

moveSnake :: SnakeAction -> Position -> Position
moveSnake SAStop  (x, y) = (x, y)
moveSnake SAUp    (x, y) = (x, y + 1)
moveSnake SADown  (x, y) = (x, y - 1)
moveSnake SALeft  (x, y) = (x - 1, y)
moveSnake SARight (x, y) = (x + 1, y)

SnakeActionは蛇の行動を表す型です。停止・上・下・左・右の5つの行動があり、moveSnakeを使ってPositionを更新することが出来ます。glossの座標系は数学のグラフと同じように右に行けばx座標が増え上に行けばy座標が増えるようになっています。

data GameState = InGame | GameOver

data World = World
    { _state  :: GameState
    , _target :: Position
    , _snake  :: [Position]
    , _action :: SnakeAction
    , _score  :: Int
    }

generateNewWorld :: IO World
generateNewWorld = do
    (target, snakeH) <- withSystemRandom . asGenIO $ \gen -> do
        fix $ \loop -> do
            target <- randomPosition gen
            snakeH <- randomPosition gen
            if target == snakeH then loop else pure (target, snakeH)
    pure $ World InGame target [snakeH] SAStop 0

GameStateはゲームの進行状態を表す型で、今回は進行中とゲームオーバーの2種類だけを用意しています。Worldはゲームの全ての状態が入っている型です。generateNewWorldは新しいゲーム状態を生成する関数で、ターゲットと蛇がかぶらないように初期値を与えるように工夫しています。fixでループを書くのはやはり便利ですね（参考: fixで簡単にループを書く - Qiita）。

drawWorld :: World -> IO Picture
drawWorld World{..} = case _state of
    InGame -> pure $ pictures
        [ drawCell red _target
        , drawCell (greyN 0.3) (head _snake)
        , pictures $ map (drawCell (greyN 0.6)) (tail _snake)
        , translate (-wWidth/2+10) (-wHeight/2+10)  . scale 0.2 0.2 $ text ("SCORE: " ++ show _score)
        ]
        where
            cell = translate (-wWidth/2) (-wHeight/2) $ polygon [(0, 0), (0, cSize), (cSize, cSize), (cSize, 0)]
            drawCell c (x, y) = translate (fromIntegral x * cSize) (fromIntegral y * cSize) $ color c cell
    GameOver -> pure $ pictures
        [ translate (-270) 20     . scale 0.7 0.7 $ text "GAME OVER"
        , translate (-100) (-50)  . scale 0.3 0.3 $ text ("SCORE: " ++ show _score)
        , translate (-200) (-120) . scale 0.3 0.3 $ text "Press Enter to Retry"
        ]

drawWorldはWorldを元にゲームを描画する関数です。特に難しいことはしていないと思います。

eventHandler :: Event -> World -> IO World
eventHandler e w@World{..} = case _state of
    InGame -> case e of
        EventKey (SpecialKey KeyUp)    Down _ _ -> pure $ if _action == SADown  then w else w { _action = SAUp }
        EventKey (SpecialKey KeyDown)  Down _ _ -> pure $ if _action == SAUp    then w else w { _action = SADown }
        EventKey (SpecialKey KeyLeft)  Down _ _ -> pure $ if _action == SARight then w else w { _action = SALeft }
        EventKey (SpecialKey KeyRight) Down _ _ -> pure $ if _action == SALeft  then w else w { _action = SARight }
        _ -> pure w
    GameOver -> case e of
        EventKey (SpecialKey KeyEnter) Down _ _ -> generateNewWorld
        _ -> pure w

eventHandlerはマウスやキーボードのイベントを受け取ってWorldを変化させる関数です。今回は矢印キーとエンターキーしか使いません。工夫してるのは蛇の進行方向と真逆の方向のキーが押されても反応しないようになっているところです。そうしないとすぐ自己交差してゲームオーバーになってしまいますからね。

stepWorld :: Float -> World -> IO World
stepWorld _ w@World{..} = case _state of
    InGame -> do
        let (x, y) = moveSnake _action $ head _snake
            isSelfIntersection = _action /= SAStop && (x, y) `elem` _snake
            snake = (x, y) : _snake
        if isSelfIntersection || x < 0 || x >= cWidth || y < 0 || y >= cHeight
            then pure $ w { _state = GameOver }
            else if (x, y) == _target
                then do
                    target <- withSystemRandom . asGenIO $ \gen -> do
                        fix $ \loop -> do
                            target <- randomPosition gen
                            if target `elem` snake then loop else pure target
                    pure $ w { _target = target, _snake = snake, _score = _score + 1}
                else pure $ w { _snake = init snake}
    GameOver -> pure w

stepWorldはゲームを次の状態に進める関数です。InGameの場合の処理がほとんどで

蛇を先にすすめる
自己交差があるか判定する
枠の外に出ていないか判定する
2,3が当てはまればゲームの進行状態をGameOverにする
ターゲットにあたったか判定する
もし当たっていればターゲットを新しく配置しスコアを加算する
そうでなければ蛇のしっぽを一つ切り離す（1で先頭にくっつけてるので実質長さは変わらない）

というような処理になっています。

プログラムとしては以上で、実行すればスネークゲームが遊べると思います。

完全なコードを見たい人はここをクリック

{-# LANGUAGE RecordWildCards #-}

import Data.Function (fix)
import Graphics.Gloss.Interface.IO.Game
import System.Random.MWC

wWidth, wHeight :: Num a => a
wWidth  = 640
wHeight = 480

window :: Display
window = InWindow "Snake Game" (wWidth, wHeight) (100, 100)

main :: IO ()
main = do
    world <- generateNewWorld
    playIO window white 10 world drawWorld eventHandler stepWorld

cSize, cWidth, cHeight :: Num a => a
cSize   = 20
cWidth  = fromIntegral $ wWidth  `div` cSize
cHeight = fromIntegral $ wHeight `div` cSize

type Position = (Int, Int)

randomPosition :: GenIO -> IO Position
randomPosition gen = (,) <$> uniformR (0, cWidth - 1) gen <*> uniformR (0, cHeight - 1) gen

data GameState = InGame | GameOver

data SnakeAction = SAStop | SAUp | SADown | SALeft | SARight deriving Eq

moveSnake :: SnakeAction -> Position -> Position
moveSnake SAStop  (x, y) = (x, y)
moveSnake SAUp    (x, y) = (x, y + 1)
moveSnake SADown  (x, y) = (x, y - 1)
moveSnake SALeft  (x, y) = (x - 1, y)
moveSnake SARight (x, y) = (x + 1, y)

data World = World
    { _state  :: GameState
    , _target :: Position
    , _snake  :: [Position]
    , _action :: SnakeAction
    , _score  :: Int
    }

generateNewWorld :: IO World
generateNewWorld = do
    (target, snakeH) <- withSystemRandom . asGenIO $ \gen -> do
        fix $ \loop -> do
            target <- randomPosition gen
            snakeH <- randomPosition gen
            if target == snakeH then loop else pure (target, snakeH)
    pure $ World InGame target [snakeH] SAStop 0

drawWorld :: World -> IO Picture
drawWorld World{..} = case _state of
    InGame -> pure $ pictures
        [ drawCell red _target
        , drawCell (greyN 0.3) (head _snake)
        , pictures $ map (drawCell (greyN 0.6)) (tail _snake)
        , translate (-wWidth/2+10) (-wHeight/2+10)  . scale 0.2 0.2 $ text ("SCORE: " ++ show _score)
        ]
        where
            cell = translate (-wWidth/2) (-wHeight/2) $ polygon [(0, 0), (0, cSize), (cSize, cSize), (cSize, 0)]
            drawCell c (x, y) = translate (fromIntegral x * cSize) (fromIntegral y * cSize) $ color c cell
    GameOver -> pure $ pictures
        [ translate (-270) 20     . scale 0.7 0.7 $ text "GAME OVER"
        , translate (-100) (-50)  . scale 0.3 0.3 $ text ("SCORE: " ++ show _score)
        , translate (-200) (-120) . scale 0.3 0.3 $ text "Press Enter to Retry"
        ]

eventHandler :: Event -> World -> IO World
eventHandler e w@World{..} = case _state of
    InGame -> case e of
        EventKey (SpecialKey KeyUp)    Down _ _ -> pure $ if _action == SADown  then w else w { _action = SAUp }
        EventKey (SpecialKey KeyDown)  Down _ _ -> pure $ if _action == SAUp    then w else w { _action = SADown }
        EventKey (SpecialKey KeyLeft)  Down _ _ -> pure $ if _action == SARight then w else w { _action = SALeft }
        EventKey (SpecialKey KeyRight) Down _ _ -> pure $ if _action == SALeft  then w else w { _action = SARight }
        _ -> pure w
    GameOver -> case e of
        EventKey (SpecialKey KeyEnter) Down _ _ -> generateNewWorld
        _ -> pure w

stepWorld :: Float -> World -> IO World
stepWorld _ w@World{..} = case _state of
    InGame -> do
        let (x, y) = moveSnake _action $ head _snake
            isSelfIntersection = _action /= SAStop && (x, y) `elem` _snake
            snake = (x, y) : _snake
        if isSelfIntersection || x < 0 || x >= cWidth || y < 0 || y >= cHeight
            then pure $ w { _state = GameOver }
            else if (x, y) == _target
                then do
                    target <- withSystemRandom . asGenIO $ \gen -> do
                        fix $ \loop -> do
                            target <- randomPosition gen
                            if target `elem` snake then loop else pure target
                    pure $ w { _target = target, _snake = snake, _score = _score + 1}
                else pure $ w { _snake = init snake}
    GameOver -> pure w

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up