Haskell で○トリス作った
- 全部で672行（長い…）
- フォント表示は 502 Bad Gateway のストロークフォント表示
- Haskell は純粋関数型言語で値の代入ができない、ので更新処理は前回の状態を受け取って次の状態を返す関数を作って、そいつを IORef で保持する、という感じ
- ゴーストの表示とか落下速度の変化とかブロックが消えるときの間とか左右移動のリピートとかゲームオーバー時の演出とか多少細かいところを入れてあります（結構こういう細かいところがメンドイと思うので）
- カーソルキーがわからなかったので操作は jkl に割り当ててあります
- q で終了
作って思ったこと：
- Haskellの利点：
- 欠点：
- 作り散らかせない。コーディングに入る前にしっかり考えないと作り始められない
- 修正を加えようとするとちょっとした間違いから大量のエラーメッセージが出てわけがわからなくなる場合がある
- 数値の扱いが厄介。整数とかFloatとか。さらに GLUT に GLfloat とか GLsizei とかいろいろあってわけがわからない。ヘタに関数の型宣言すると数値の型が合わなくなってエラーが出まくる
- プログラム全体で参照する変数やリソースの受け渡しがメンドイ
- 時間で変化していくような内容のオブジェクトの記述がメンドイ
- 代数的データ型のフィールドラベルが、グローバルに染み出してしまう。例えば x という名前をつけてしまうと x という関数ができてしまって他には使えなくなってしまうのが厄介。大きいプログラムを作るときに障害になりそう。
利点はあるけど規模が小さいこともあるしあまり大きなメリットは感じなかった。もっと Haskell に慣れて、もっといい組み方がわかれば変わってくるかもしれない。
○トリスだとフィールドとかブロックとか、自分がゲームの全ての情報を知っていて他のオブジェクトとの相互作用がないのでまだ簡単。なので次は HSDL を使って こういうのを作ってみたいと思う。
以下ソース、CodeReposにも置きました ( http://svn.coderepos.org/share/lang/haskell/tetris )：
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 -- リピート２回目以降の時間 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 -- |２乗 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 -- |２次元リストを時計回りに９０度回転させる rotate 0 xss = xss rotate (n+1) xss = rotate n $ transpose $ reverse xss -- |２次元リストにインデクスを振って関数を呼び出す 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))