Haskell で○トリス作った

2008-09-21
  • 全部で672行(長い…)
  • フォント表示は のストロークフォント表示
  • Haskell は純粋関数型言語で値の代入ができない、ので更新処理は前回の状態を受け取って次の状態を返す関数を作って、そいつを IORef で保持する、という感じ
  • ゴーストの表示とか落下速度の変化とかブロックが消えるときの間とか左右移動のリピートとかゲームオーバー時の演出とか多少細かいところを入れてあります(結構こういう細かいところがメンドイと思うので)
  • カーソルキーがわからなかったので操作は jkl に割り当ててあります
  • q で終了

作って思ったこと:

  • Haskellの利点:
    • ポインタとかメモリ管理とか悩まなくていい。速度は今のところ考えてもない
    • コンパイル時の方チェックが厳しいので、実行時のエラーの心配をしなくてすむ
    • モナドとか考えなくても全然いける
  • 欠点:
    • 作り散らかせない。コーディングに入る前にしっかり考えないと作り始められない
    • 修正を加えようとするとちょっとした間違いから大量のエラーメッセージが出てわけがわからなくなる場合がある
    • 数値の扱いが厄介。整数とかFloatとか。さらに GLUT に GLfloat とか GLsizei とかいろいろあってわけがわからない。ヘタに関数の型宣言すると数値の型が合わなくなってエラーが出まくる
    • プログラム全体で参照する変数やリソースの受け渡しがメンドイ
    • 時間で変化していくような内容のオブジェクトの記述がメンドイ
    • 代数的データ型のフィールドラベルが、グローバルに染み出してしまう。例えば x という名前をつけてしまうと x という関数ができてしまって他には使えなくなってしまうのが厄介。大きいプログラムを作るときに障害になりそう。

利点はあるけど規模が小さいこともあるしあまり大きなメリットは感じなかった。もっと Haskell に慣れて、もっといい組み方がわかれば変わってくるかもしれない。 ○トリスだとフィールドとかブロックとか、自分がゲームの全ての情報を知っていて他のオブジェクトとの相互作用がないのでまだ簡単。なので次は HSDL を使って こういうのを作ってみたいと思う。

以下ソース:

tetris.hs

module Main where

import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate)
import System
import Data.List (union, delete)
import Data.IORef
import Data.Bits ((.&.))

import Field
import Pad
import Player

screenWidth = 320
screenHeight = 400

-- タイマの間隔
timerInterval = 1000 `div` frameRate

--------------------------------
-- エントリ

data GameStat = Title | Game | GameOver

main = do
gameStatRef <- newIORef Title
playerRef <- newIORef initialPlayer
padRef <- newIORef newPad

--GLUTの初期化
initialDisplayMode $= [RGBAMode, DoubleBuffered]
initialWindowSize $= Size screenWidth screenHeight

--ウィンドウを作る
createWindow "Tetris in Haskell & GLUT"

--表示に使うコールバック関数の指定
displayCallback $= display gameStatRef playerRef

--キーボードやマウスのコールバック
keyboardMouseCallback $= Just (keyboardProc padRef)

--タイマを作る
setTimerProc gameStatRef playerRef padRef (display gameStatRef playerRef)

--GLUTのメインループに入る
mainLoop


--キー入力の処理
keyboardProc _ (Char 'q') _ _ _ = exitWith ExitSuccess
keyboardProc padRef key Down _ _ = modifyIORef padRef (\pad -> pad { pressed = union [key] (pressed pad) })
keyboardProc padRef key Up _ _ = modifyIORef padRef (\pad -> pad { pressed = delete key (pressed pad) })
keyboardProc _ _ _ _ _ = return ()


-- タイマ割り込み設定
setTimerProc gameStatRef playerRef padRef act = do
writeIORef gameStatRef Title
setNext $ titleProc

where
setNext = addTimerCallback timerInterval

-- タイトル
titleProc = do
modifyIORef padRef updatePad
pad <- readIORef padRef

act

if (((trig pad) .&. padA) /= 0)
then do
writeIORef gameStatRef Game
newPlayer >>= writeIORef playerRef
setNext $ gameProc
else
setNext $ titleProc

-- ゲーム中
gameProc = do
modifyIORef padRef updatePad
pad <- readIORef padRef

player' <- readIORef playerRef >>= updatePlayer pad
writeIORef playerRef player'

act

if (not $ isDead player')
then setNext $ gameProc
else do
writeIORef gameStatRef GameOver
setNext $ gameoverProc

-- ゲームオーバー
gameoverProc = gameoverProc2 0
gameoverProc2 y = do
modifyIORef padRef updatePad

player <- readIORef playerRef
let player' = player { field_of = graynize (field_of player) y }
writeIORef playerRef player'

act

if (y < fieldHeight-2)
then setNext $ gameoverProc2 (y+1)
else setNext $ gameoverProc3 0
gameoverProc3 cnt = do
modifyIORef padRef updatePad
pad <- readIORef padRef

act
if (((trig pad) .&. padA) /= 0)
then do
writeIORef gameStatRef Game
newPlayer >>= writeIORef playerRef
setNext $ gameProc
else
if cnt < frameRate * 3
then setNext $ gameoverProc3 (cnt + 1)
else do
writeIORef gameStatRef Title
setNext $ titleProc


-- 文字列表示
putText x y str =
preservingMatrix $ do
translate (Vector3 (scrx x) (scry y) 0 ::Vector3 Float)
scale 0.0007 0.0005 (1.0 :: Double)
renderString Roman str


-- 表示
display gameStatRef playerRef = do
gameStat <- readIORef gameStatRef
player <- readIORef playerRef

--背景を黒にする
clear [ColorBuffer]

--単位行列を読み込む
loadIdentity

--表示
renderPlayer player

color3i 255 255 255
putText 200 20 $ "SCORE:" ++ show (score player)

case gameStat of
Title -> do
putText 70 50 "TETRIS"
putText 50 300 "PRESS SPACE"
GameOver -> do
putText 200 350 "GAME OVER"
otherwise -> return ()

putText 200 200 "MOVE: J L"
putText 200 220 "FALL: K"
putText 200 240 "ROT: Space, Z"

--バッファの入れ替え
swapBuffers

player.hs

module Player where

import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate)
import Data.Bits ((.&.))

import Pad
import Field
import Util

--------------------------------
-- constant definition

-- フレームレート
frameRate = 40

-- セルの表示サイズ
cellWidth = 16
cellHeight = 16

-- デフォルトの落下速度
defaultFallSpeed = 1

--------------------------------
-- render util

scrx x = 2 * x / 320.0 - 1.0
scry y = 1.0 - 2 * y / 400.0

vertex2f :: Float -> Float -> IO ()
vertex2f x y = vertex (Vertex3 (scrx x) (scry y) (0 :: GLfloat))

color3i r g b = color (Color3 (r/255) (g/255) (b/255 :: GLfloat))

scaleColor s (r,g,b) = (s*r, s*g, s*b)

fill x y w h (r,g,b) = do
color3i r g b
renderPrimitive TriangleStrip $ do
vertex2f ix1 iy1
vertex2f ix2 iy1
vertex2f ix1 iy2
vertex2f ix2 iy2
where
ix1 = fromInteger $ toInteger $ x
iy1 = fromInteger $ toInteger $ y
ix2 = fromInteger $ toInteger $ x + w
iy2 = fromInteger $ toInteger $ y + h

renderCell col@(r,g,b) ix iy = do
fill x y (cellWidth-1) (cellHeight-1) col

color3i (r + 0.5*(255-r)) (g + 0.5*(255-g)) (b + 0.5*(255-b))
renderPrimitive LineStrip $ do
vertex2f (fromInteger $ toInteger $ x+cellWidth-1) (fromInteger $ toInteger $ y)
vertex2f (fromInteger $ toInteger $ x) (fromInteger $ toInteger $ y)
vertex2f (fromInteger $ toInteger $ x) (fromInteger $ toInteger $ y+cellHeight-1)

color3i (0.5*r) (0.5*g) (0.5*b)
renderPrimitive LineStrip $ do
vertex2f (fromInteger $ toInteger $ x) (fromInteger $ toInteger $ y+cellHeight-1)
vertex2f (fromInteger $ toInteger $ x+cellWidth-1) (fromInteger $ toInteger $ y+cellHeight-1)
vertex2f (fromInteger $ toInteger $ x+cellWidth-1) (fromInteger $ toInteger $ y)

where
x = ix * cellWidth
y = iy * cellHeight

renderField field = mapM_ lineProc $ zip [0..] field
where
lineProc (iy, line) = mapM_ (cellProc iy) $ zip [0..] line
cellProc iy (ix, Empty) = return ()
cellProc iy (ix, cell) = renderCell (cellColor cell) ix iy

--------------------------------
-- Block

blockFallCount = 40

data Block = Block {
blktype_of :: BlockType,
x :: Int,
y :: Int,
rot :: Int,
fallSpeed :: Int,
ycnt :: Int,
fixedcnt :: Int
}

newBlock :: BlockType -> Int -> Block
newBlock blktype spd = Block {
blktype_of = blktype,
x = (fieldWidth - length (head (blockPattern blktype))) `div` 2,
y = 0,
rot = 0,
fallSpeed = spd,
ycnt = 0,
fixedcnt = 0
}

-- 固定されるまでの時間
fixedTimer = frameRate `div` 2

updateBlock :: Field -> Pad -> Block -> Block
updateBlock field pad block =
block { x = x', y = y', rot = rot' `mod` 4, ycnt = ycnt', fixedcnt = fixedcnt' }
where
x'
| canMove field blktype (oldx + dx) oldy oldrot = oldx + dx
| otherwise = oldx
rot'
| canRot = oldrot + drot
| rotPushUp = oldrot + drot
| otherwise = oldrot
ytmp
| rotPushUp = oldy - 1
| otherwise = oldy
y'
| beFall && canFall = ytmp + 1
| otherwise = ytmp
ycnt'
| beFall && canFall = (oldycnt + fallSpeed block) `mod` blockFallCount
| beFall && (not canFall) = blockFallCount
| otherwise = oldycnt + fallSpeed block
fixedcnt' =
if isLand
then (fixedcnt block) + 1
else 0

trgbtn = trig pad
rptbtn = rpt pad
nowbtn = btn pad

dx = -left + right
left = if ((rptbtn .&. padL) /= 0) then 1 else 0
right = if ((rptbtn .&. padR) /= 0) then 1 else 0

drot = (rotcw - rotccw) `mod` 4
rotcw = if ((trgbtn .&. padA) /= 0) then 1 else 0
rotccw = if ((trgbtn .&. padB) /= 0) then 1 else 0

canRot = canMove field blktype x' oldy (oldrot + drot)
rotPushUp = drot /= 0 && not canRot && canMove field blktype x' (oldy-1) (oldrot + drot)

beFall = ((nowbtn .&. padD) /= 0) || (oldycnt + fallSpeed block >= blockFallCount)
canFall = canMove field blktype x' (oldy + 1) rot'
isLand = beFall && (not canFall)

blktype = blktype_of block
oldx = x block
oldy = y block
oldrot = rot block
oldycnt = ycnt block

isBlockFixed block = (fixedcnt block) > fixedTimer

renderBlockTypeCol col blktype ix iy rot = do
sequence_ $ concat $ idxmap2 proc pat
where
pat = rotate rot $ blockPattern blktype
proc (dx,dy) 1 = renderCell col (ix+dx) (iy+dy)
proc (dx,dy) _ = return ()

renderBlockType blktype = renderBlockTypeCol (cellColor $ blockCell blktype) blktype

renderBlock block =
renderBlockType (blktype_of block) (x block) (y block) (rot block)

renderGhostBlock field block =
renderBlockTypeCol col (blktype_of block) (x block) landY (rot block)
where
landY = landingY field (blktype_of block) (x block) (y block) (rot block)
col = scaleColor 0.25 (cellColor $ blockCell $ blktype_of block)

--------------------------------
-- Player

data PlayerStat = PlNormal | PlEraseEffect | PlDead
deriving (Eq)

type PlayerUpdater = Pad -> Player -> IO Player

data Player = Player {
field_of :: Field,
block_of :: Block,
nxtblktype :: BlockType,
score :: Int,

stat :: PlayerStat,
cnt :: Int,

updater :: PlayerUpdater
}

initialPlayer =
Player {
field_of = emptyField,
block_of = newBlock BlockI defaultFallSpeed,
nxtblktype = BlockI,
score = 0,
stat = PlDead,
cnt = 0,
updater = updatePlayerNormal
}

newPlayer = do
blktype <- randBlockType
nxt <- randBlockType
return $ Player {
field_of = emptyField,
block_of = newBlock blktype defaultFallSpeed,
nxtblktype = nxt,
score = 0,
stat = PlNormal,
cnt = 0,
updater = updatePlayerNormal
}

-- 通常時
updatePlayerNormal pad player
-- 通常
| not (isBlockFixed block) = return $ player { block_of = block' }
-- 接地したとき:フィールドに格納して次のブロックを出す
| otherwise = do
if null filled
then setupNextBlock $ player { field_of = storedField }
else do
let upproc = updatePlayerErase filled
return $ player { field_of = eraseLines storedField filled, stat = PlEraseEffect, updater = upproc, cnt = 0 }
where
field = field_of player
block = block_of player

block' = updateBlock field pad block

storedField = storeBlock field (blktype_of block) (x block) (y block) (rot block)
filled = getFilledLines storedField

-- そろったラインを消した後の時間待ち
updatePlayerErase filled pad player =
if (not $ null filled) && (cnt player) < (frameRate `div` 2)
then return $ player { cnt = (cnt player) + 1 }
else return $ player { field_of = falledField, score = score', updater = updatePlayerErase2, cnt = 0 }
where
falledField = fallLines (field_of player) filled
score' = (score player) + 10 * square (length filled)

-- そろったラインを消して下に詰めた後の時間待ち
updatePlayerErase2 pad player =
if (cnt player) < (frameRate `div` 2)
then return $ player { cnt = (cnt player) + 1 }
else setupNextBlock player

-- 死亡
updatePlayerDead pad player = return player

-- 次のブロックを出す
setupNextBlock player = do
if canMove field nxtblk (x nxtBlock) (y nxtBlock) (rot nxtBlock)
then do -- 登場できる
nxt' <- randBlockType -- 次の次のブロックを乱数で選ぶ
return $ player { block_of = nxtBlock, nxtblktype = nxt', stat = PlNormal, updater = updatePlayerNormal }
else do -- 詰まってる:死亡
let storedField = storeBlock field nxtblk (x nxtBlock) (y nxtBlock) (rot nxtBlock)
return $ player { field_of = storedField, stat = PlDead, updater = updatePlayerDead }
where
nxtblk = nxtblktype player -- 次のブロックの種類
nxtBlock = newBlock nxtblk nxtFallSpd
nxtFallSpd = if curFallSpd < blockFallCount then curFallSpd + 1 else defaultFallSpeed
curFallSpd = fallSpeed (block_of player)
field = field_of player


-- 更新
updatePlayer :: Pad -> Player -> IO Player
updatePlayer pad player = (updater player) pad player


renderNextBlock :: Player -> IO ()
renderNextBlock player = renderBlockType (nxtblktype player) (fieldWidth + 2) 5 0

renderPlayer player = do
renderField (field_of player)
if (stat player) == PlNormal
then do
renderGhostBlock (field_of player) (block_of player)
renderBlock (block_of player)
else return ()
if (stat player) /= PlDead
then renderNextBlock player
else return ()


isDead player = (stat player) == PlDead

field.hs

module Field where

import Util

--------------------------------
-- Cell

data Cell = Empty | Gray | Red | Yellow | Purple | Green | Blue | Orange | Cyan
deriving Eq

cellColor cell =
case cell of
Gray -> (128, 128, 128)
Red -> (255, 0, 0)
Yellow -> (255, 255, 0)
Purple -> (255, 0, 255)
Green -> ( 0, 255, 0)
Blue -> ( 0, 0, 255)
Orange -> (255, 128, 0)
Cyan -> ( 0, 255, 255)


--------------------------------
-- BlockType

data BlockType = BlockI | BlockO | BlockS | BlockZ | BlockJ | BlockL | BlockT

blockTypes = [BlockI, BlockO, BlockS, BlockZ, BlockJ, BlockL, BlockT]

blockPattern BlockI = [[0, 0, 0, 0, 0], [0, 0, 0, 0, 0], [0, 1, 1, 1, 1], [0, 0, 0, 0, 0], [0, 0, 0, 0, 0]]
blockPattern BlockO = [[1, 1], [1, 1]]
blockPattern BlockS = [[0, 1, 1], [1, 1, 0]]
blockPattern BlockZ = [[1, 1, 0], [0, 1, 1]]
blockPattern BlockJ = [[0, 0, 0], [1, 1, 1], [1, 0, 0]]
blockPattern BlockL = [[0, 0, 0], [1, 1, 1], [0, 0, 1]]
blockPattern BlockT = [[0, 0, 0], [1, 1, 1], [0, 1, 0]]

blockRotPattern blktype rot = rotate rot $ blockPattern blktype

blockCell BlockI = Red
blockCell BlockO = Yellow
blockCell BlockS = Purple
blockCell BlockZ = Green
blockCell BlockJ = Blue
blockCell BlockL = Orange
blockCell BlockT = Cyan

randBlockType = randN (length blockTypes) >>= return . (blockTypes !!)


--------------------------------
-- Field
type Field = [[Cell]]

fieldWidth = 10 + 2
fieldHeight = 20 + 4

emptyLine = [Gray] ++ (replicate (fieldWidth - 2) Empty) ++ [Gray]

emptyField :: Field
emptyField = replicate (fieldHeight-1) emptyLine ++ [bottom]
where
bottom = (replicate fieldWidth Gray)

inField x y = 0 <= x && x < fieldWidth && 0 <= y && y < fieldHeight

fieldRef field x y =
if inField x y
then field !! y !! x
else Empty

fieldSet field x y c =
if inField x y
then replace field y (replace (field !! y) x c)
else field

canMove :: Field -> BlockType -> Int -> Int -> Int -> Bool
canMove field blktype x y rot = not $ or $ concat $ idxmap2 isHit pat
where
pat = blockRotPattern blktype rot
isHit (dx,dy) 0 = False
isHit (dx,dy) 1 = inField (x+dx) (y+dy) && fieldRef field (x+dx) (y+dy) /= Empty

storeBlock :: Field -> BlockType -> Int -> Int -> Int -> Field
storeBlock field blktype x y rot = field'
where
pat = blockRotPattern blktype rot
patWithIdx = concat $ idxmap2 pair pat
field' = foldl store field $ map fst $ filter ((== 1) . snd) patWithIdx

store field (dx,dy) = fieldSet field (x+dx) (y+dy) (blockCell blktype)

getFilledLines field = map fst $ filter (isFilled . snd) $ zip [0..] $ init field
where
isFilled = all (/= Empty) . init . tail

eraseLines :: Field -> [Int] -> Field
eraseLines field = foldl (\rs y -> replace rs y emptyLine) field

fallLines :: Field -> [Int] -> Field
fallLines field = foldl (\rs y -> emptyLine : remove y rs) field


landingY field blktype x y rot = loop y
where
loop y
| canMove field blktype x (y+1) rot = loop (y+1)
| otherwise = y


graynize field y = replace field y $ map (\x -> if x == Empty then Empty else Gray) $ field !! y

pad.hs

module Pad where

import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate)
import Data.Bits ((.|.), (.&.), complement)

--------------------------------
-- Pad

padU = 1
padL = 2
padR = 4
padD = 8
padA = 16
padB = 32

padAll = padU .|. padL .|. padR .|. padD .|. padA .|. padB

data Pad = Pad {
pressed :: [Key], -- 現在押されてるキー
btn :: Int, -- 押されてるボタン
obtn :: Int, -- 前回押されてたボタン
trig :: Int, -- 押された瞬間のボタン
rpt :: Int, -- 押され続けてるボタン
rptc :: Int -- リピート用カウンタ
}

newPad = Pad {
pressed = [],
btn = 0,
obtn = 0,
trig = 0,
rpt = 0,
rptc = 0
}

calcPadState keys = foldl (\r x -> r .|. (btnValue x)) 0 keys
where
btnValue :: Key -> Int
btnValue (Char 'i') = padU
btnValue (Char 'j') = padL
btnValue (Char 'k') = padD
btnValue (Char 'l') = padR
btnValue (Char ' ') = padA
btnValue (Char 'z') = padB
btnValue _ = 0

repeatCnt1 = 7 -- リピート初回の時間
repeatCnt2 = 1 -- リピート2回目以降の時間
repeatBtn = padL .|. padR -- リピートで使うボタン

updatePad pad =
pad { btn = btn', obtn = obtn', trig = trg', rpt = rpt', rptc = rptc' }
where
btn' = calcPadState (pressed pad)
obtn' = btn pad
trg' = btn' .&. (complement obtn')
tmprptc
| (btn' .&. repeatBtn) /= (obtn' .&. repeatBtn) = 0
| otherwise = (rptc pad) + 1
bRepeat = tmprptc >= repeatCnt1
rptc'
| bRepeat = repeatCnt1 - repeatCnt2
| otherwise = tmprptc
rpt'
| bRepeat = btn'
| otherwise = trg'

util.hs

module Util where

import Data.List (transpose)
import System.Random

-- |2乗
square x = x * x

-- |ペアを作る
pair a b = (a, b)

-- |リストの i 番目を v に入れ替える
replace :: [a] -> Int -> a -> [a]
replace ls i v = take i ls ++ [v] ++ drop (i + 1) ls

-- |リストの i 番目を取り除く
remove :: Int -> [a] -> [a]
remove i = (\(xs, ys) -> xs ++ tail ys) . splitAt i

-- |2次元リストを時計回りに90度回転させる
rotate 0 xss = xss
rotate (n+1) xss = rotate n $ transpose $ reverse xss

-- |2次元リストにインデクスを振って関数を呼び出す
idxmap2 f xss = zipWith (\iy -> zipWith (\ix c -> f (ix,iy) c) [0..]) [0..] xss


-- |整数の乱数 0~n-1
randN :: Int -> IO Int
randN n = getStdRandom (randomR (0, n-1))