200行のHaskellでテトリス

私も流行りに乗ってn番煎じです。ただし、作るゲームはスネークゲームではなくテトリスです。
ゲームの作り方としては、こちらの多くを参考にしました。ありがとうございます。

今回作成したゲームは、仕様を明示していませんが、Wikipediaの記載と私の記憶を参考に作成したものです。
広く知られているテトリスと異なる部分があるかもしれませんが、ご了承ください。
基本的な動作は実装できていると思います。こうした方が良い等あれば、コメントいただけると嬉しいです。

ソースコードは以下に配置しています。 stack 導入済みであることを前提として、ReadMeに記載のとおりにインストールすれば動作すると思います。
https://github.com/chupaaaaaaan/tetris-with-haskell

※世には七行プログラミングなる世界もあるようで・・・おくがふかい。

以下では、特にテトリスに固有と思われる箇所について記載します。

テトリスのデータ型

初めて知りましたが、テトリスの色々な形のブロックは、正式には「テトリミノ」と言うそうです。
今回は、テトリミノを回転させることも考慮して、フィールドに回転の状態を表す _r を追加しています。

data Tetrimino = TO { _r :: Int, _x :: Int, _y :: Int }
               | TI { _r :: Int, _x :: Int, _y :: Int }
               | TS { _r :: Int, _x :: Int, _y :: Int }
               | TZ { _r :: Int, _x :: Int, _y :: Int }
               | TJ { _r :: Int, _x :: Int, _y :: Int }
               | TL { _r :: Int, _x :: Int, _y :: Int }
               | TT { _r :: Int, _x :: Int, _y :: Int }

ゲームの状態は以下の通り定義します。
スネークゲームとは異なり、1個のテトリミノだけでなく積み重なったブロックもゲーム状態に含める必要があります。
そのため、可変な配列（への参照）を盤面としてゲーム状態に含めます（今回は最低限の実装しかしていないので、スコアリングはゲーム状態に含めていません）。 Bool が True のとき、ブロックが存在する、とします。
配列の値に Color が含まれているのは、そのブロックがどのテトリミノに由来するかを明示しようとしたかったからですが、今回の実装には含んでいません。

data GameState = InGame | GameOver

type Field = IOArray (Int,Int) (Bool, Color)

data World = World
  { _state :: GameState
  , _field :: Field
  , _tetrimino :: Tetrimino
  }

テトリミノの動きについては、参考元記事と同様に以下のように定義します。
テトリミノの回転については、それぞれ1回対称(O)・2回対称(I/S/Z)・4回対称(J/L/T)なので、
_r フィールドの値を対称性の数で mod します。

data TetriminoAction = TALeft
                     | TARight
                     | TADown
                     | TARotR
                     | TARotL deriving Eq

moveTetrimino :: TetriminoAction -> Tetrimino -> Tetrimino
moveTetrimino TALeft  t = t { _x = _x t - 1 }
moveTetrimino TARight t = t { _x = _x t + 1 }
moveTetrimino TADown  t = t { _y = _y t - 1 }
moveTetrimino TARotR t = t { _r = (_r t-1)`mod`rotN t }
moveTetrimino TARotL t = t { _r = (_r t+1)`mod`rotN t }

rotN :: Tetrimino -> Int
rotN TO{} = 1
rotN TI{} = 2
rotN TS{} = 2
rotN TZ{} = 2
rotN TJ{} = 4
rotN TL{} = 4
rotN TT{} = 4

最後に、盤面を IO (Int, Int) (Bool, Color) で定義しているため、テトリミノを盤面に変更する処理が必要です。
盤面上でテトリミノが存在すべき位置を、配列のインデックス( (Int,Int) 型)のリストとして取得する処理を実装します。
ここでは実装の一部を掲載します。

convertTetriminoToPoints :: Tetrimino -> [(Int,Int)]
convertTetriminoToPoints TO{..} = [(_x,_y),(_x-1,_y),(_x,_y-1),(_x-1,_y-1)]
convertTetriminoToPoints TI{..}
  | _r == 0 = [(_x,_y),(_x-1,_y),(_x-2,_y),(_x+1,_y)]
  | _r == 1 = [(_x,_y),(_x,_y-1),(_x,_y-2),(_x,_y+1)]

行消去の実装

テトリス固有の事情として、盤面上で横一列がブロックで埋められたときにその行を消去する処理が必要です。
これは、以下のような関数として実装します。

eraseRows :: Field -> IO Field
eraseRows f = go 0 0
  where go y h
          | y + h >= cHeight = pure f
          | otherwise = do
              forM_ [0..cWidth-1] $ \x -> readArray f (x,y+h) >>= writeArray f (x,y)
              mino <- and <$> forM [0..cWidth-1] (\x -> fst <$> readArray f (x,y))
              if mino then go y (h+1) else go (y+1) h

ポイントは、一番下の段から再帰的に処理していくことです。今回は盤面にリストを使用していないので、ブロックで埋められた行を消去する、という処理ができず、単に上の段を下の段にコピーするだけになります。

ゲーム進行

ゲームは、以下のステップで進行します。
1. テトリミノを次にすすめる（1ブロック分下げる）。
2. 盤面の外に出ていないか判定。出ていない場合は3へ。出ている場合はテトリミノをもとの位置に戻して4へ。
3. 他ブロックと重なっていないか判定。重なっていない場合は今の状態を新しい状態として1へ。重なっている場合はテトリミノをもとの位置に戻して4へ。
4. テトリミノを盤面に追加する。
5. 埋められた行があれば消去する。
6. 中央2列の最上段にブロックが存在すればゲーム状態を GameOver にする。そうでないなら、テトリミノを生成して新しい状態として1へ。

stepWorld :: Float -> World -> IO World
stepWorld _ w@World{..} = case _state of
  InGame -> do
    let nextTetrimino = moveTetrimino TADown _tetrimino
    wall <- checkOutOfField nextTetrimino
    if wall then nextWorldWithNewField
      else do coll <- checkCollided _field nextTetrimino
              if coll then nextWorldWithNewField
                else pure w { _tetrimino = nextTetrimino }
  GameOver -> pure w

  where nextWorldWithNewField = do
          forM_ (convertTetriminoToPoints _tetrimino) $ \p -> writeArray _field p (True, greyN 0.5)
          newField <- eraseRows _field
          r1 <- fst <$> readArray newField (cWidth `div` 2 - 1, cHeight - 1)
          r2 <- fst <$> readArray newField (cWidth `div` 2    , cHeight - 1)
          if r1 || r2
            then pure w { _field = newField, _state = GameOver }
            else do newTetrimino <- withSystemRandom . asGenIO $ \gen -> randomInitTetrimino gen
                    pure w { _field = newField, _tetrimino = newTetrimino }

テトリミノの次の位置が範囲外参照とならないよう、盤面外にあるかどうかの判定を先にしておきます。

こんな感じで遊べます

それぞれ左/下/右キーでテトリミノを移動できます。xキーで右回転、zキーで左回転です。

下手なプレイでお恥ずかしい・・・（動画編集の都合で、ゲームオーバーから動画開始しています）。

終わりに

初めてのゲーム作成でしたが、実質おおよそ3日ほどで実装でき、結構サクサク行ったなー、という印象です。

状態変化は完全にglossにまかせてしまっていますが、自前で実装できるようにもなりたいですね。
（ Stateや ST になんとなく苦手意識を持っていて、避けて通っていました）。

スコアを表示するなど、ゲーム性を向上させるような機能も、折を見て実装したいと思います。
またglossの制約か、キーを押しっぱなしにすることができませんでした（今は下に落とすために下キーを連打しないといけない）。これも解決したい。

以上です。