テトリスっぽい何か - みずぴー日記

mzp2008-01-27

30分プログラム、その230。HaskellのFALでテトリスを作ろうとした。
Macだとうまいことイベントがとれなくて、操作ができなかったので途中で飽きらめた。一応、ブロックが落ちてきて積み上げるとこまではできている。

ソースコード

import Fal
import Shape
import Picture

-- データ型の定義
data Block = Block Int Int | None deriving (Show,Eq)
type Board = [[Block]]

mapi = flip zipWith [0..]
dmap f xs = mapi (\y -> mapi (\x -> f x y)) xs

getBlock :: Board -> Int -> Int -> Block
getBlock board x y = (board !! y) !! x

isFall :: Board -> [Block]->Bool
isFall board blocks = any check blocks 
    where check (Block x y) = if y < 1 then True 
                              else getBlock board x (y-1) /= None

addBlocks :: Board -> [Block] -> Board
addBlocks board blocks = foldl add board blocks
    where add board block@(Block x y) = dmap (\x' y' v -> if x==x' && y==y' then block else v) board

-- いくつかの定数
width = 10
height= 8
initBoard :: Board
initBoard = time width $ time height None
    where time n x = take n $ cycle [x]

-- BoardやBlockをRegionに変換する関数
-- Index to Point
point :: Int->Int->(Float,Float)
point x y = let x' = float x
                y' = float y
                cx = (float width) / 2
                cy = (float height) / 2
            in ((x'-cx)/5,(y'-cy)/5)
    where float  = fromInteger.toInteger


regBoard :: Board -> Region
regBoard board = foldl (\r xs-> (foldl (\r x->(regBlock x) `Union` r) Empty xs) `Union` r) Empty board

regBack :: Region
regBack = let (x,y) = point (width+1) (height+1) in
          Shape $ Rectangle (x*2) (y*2)

regBlock :: Block -> Region
regBlock (Block x y) = Translate (point x y) $ Shape $ Rectangle 0.2 0.2
regBlock None=Empty

regBlocks :: [Block] -> Region
regBlocks = (foldl1 Union).(map regBlock)

makeBlock x y = [Block x y,Block (x+1) y,Block x (y+1)]

-- Behaviorにliftして、ゲームにする
tetris v = let ybound = when $ lift2 isFall board blocks
               x = fst mouse
               y = 8+integral (-1) `switch` ybound ->> y
               blocks = lift2 makeBlock (floorB x) (floorB y)
               board = initBoard `stepAccum` (ybound `snapshot` blocks) 
                       =>> (\(_,b) -> flip addBlocks b)
               picBlock = paint red $ lift1 ((foldl1 Union).(map regBlock)) blocks
               picBoard = paint yellow $ lift1 regBoard board
               picBack  = paint blue $ lift0 regBack
           in picBlock `over` picBoard `over` picBack

floorB = lift1 floor

f = test $ tetris (-1)

参考

過去の30分プログラム