Haskell で○トリス作った

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

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

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

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'

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))