diff --git a/Board.hs b/Board.hs new file mode 100644 --- /dev/null +++ b/Board.hs @@ -0,0 +1,126 @@ +module Board where + +import Util + +-------------------------------- +-- Cell + +data Cell = Empty | Gray | Red | Yellow | Purple | Green | Blue | Orange | Cyan + deriving Eq + +cellColor :: (Num t, Num t1, Num t2) => Cell -> (t, t1, t2) +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 + +blockPattern :: BlockType -> [[Int]] +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 :: BlockType -> Int -> [[Int]] +blockRotPattern blktype rot = rotate rot $ blockPattern blktype + +blockCell :: BlockType -> Cell +blockCell BlockI = Red +blockCell BlockO = Yellow +blockCell BlockS = Purple +blockCell BlockZ = Green +blockCell BlockJ = Blue +blockCell BlockL = Orange +blockCell BlockT = Cyan + +-- 乱数でブロックを選ぶ +randBlockType :: IO BlockType +randBlockType = fmap (blockTypes !!) (randN (length blockTypes)) + +blockTypes :: [BlockType] +blockTypes = [BlockI, BlockO, BlockS, BlockZ, BlockJ, BlockL, BlockT] + + +-------------------------------- +-- Board +type Board = [[Cell]] + +boardWidth,boardHeight :: Int +boardWidth = 10 + 2 +boardHeight = 20 + 4 + +emptyLine :: [Cell] +emptyLine = [Gray] ++ replicate (boardWidth - 2) Empty ++ [Gray] + +emptyBoard :: Board +emptyBoard = replicate (boardHeight-1) emptyLine ++ [bottom] + where + bottom = (replicate boardWidth Gray) + +inBoard :: Int -> Int -> Bool +inBoard x y = 0 <= x && x < boardWidth && 0 <= y && y < boardHeight + +boardRef :: [[Cell]] -> Int -> Int -> Cell +boardRef board x y = + if inBoard x y + then board !! y !! x + else Empty + +boardSet :: [[a]] -> Int -> Int -> a -> [[a]] +boardSet board x y c = + if inBoard x y + then replace board y (replace (board !! y) x c) + else board + +canMove :: Board -> BlockType -> Int -> Int -> Int -> Bool +canMove board blktype x y rot = not $ or $ concat $ idxmap2 isHit pat + where + pat = blockRotPattern blktype rot + isHit (_dx,_dy) 0 = False + isHit (dx,dy) 1 = inBoard (x+dx) (y+dy) && boardRef board (x+dx) (y+dy) /= Empty + +storeBlock :: Board -> BlockType -> Int -> Int -> Int -> Board +storeBlock board blktype x y rot = board' + where + pat = blockRotPattern blktype rot + patWithIdx = concat $ idxmap2 pair pat + board' = foldl store board $ map fst $ filter ((== (1::Int)) . snd) patWithIdx + + store bord (dx,dy) = boardSet bord (x+dx) (y+dy) (blockCell blktype) + +getFilledLines :: [[Cell]] -> [Int] +getFilledLines board = map fst $ filter (isFilled . snd) $ zip [0..] $ init board + where + isFilled = all (/= Empty) . init . tail + +eraseLines :: Board -> [Int] -> Board +eraseLines = foldl (\rs y -> replace rs y emptyLine) + +fallLines :: Board -> [Int] -> Board +fallLines = foldl (\rs y -> emptyLine : remove y rs) + + +landingY :: Board -> BlockType -> Int -> Int -> Int -> Int +landingY board blktype x y rot = loop y + where + loop z + | canMove board blktype x (z+1) rot = loop (z+1) + | otherwise = z + + +graynize :: [[Cell]] -> Int -> [[Cell]] +graynize board y = replace board y $ map (\x -> if x == Empty then Empty else Gray) $ board !! y diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,173 @@ +module Main where + +import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate) +import System.Exit +import Data.List (union, delete) +import Data.IORef +import Data.Bits ((.&.)) + +import Board +import Pad +import Player + + +screenWidth = 320 +screenHeight = 400 +-- タイマの間隔 +timerInterval :: Int +timerInterval = 1000 `div` frameRate + +-------------------------------- +-- エントリ + +data GameStat = Title | Game | GameOver + +main :: IO () +main = do + initialize "Tetris" [] + 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 + + --GLUTのメインループに入る + mainLoop + + +--キー入力の処理 +keyboardProc :: IORef Pad -> Key -> KeyState -> t -> t1 -> IO () +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 :: IORef GameStat -> IORef Player -> IORef Pad -> IO () +setTimerProc gameStatRef playerRef padRef = do + writeIORef gameStatRef Title + setNext $ titleProc + + where + setNext = addTimerCallback timerInterval + + -- タイトル + titleProc = do + modifyIORef padRef updatePad + pad <- readIORef padRef + + postRedisplay Nothing + + 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' + + postRedisplay Nothing + + 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 { board_of = graynize (board_of player) y' } + writeIORef playerRef player' + + postRedisplay Nothing + + if (y' < boardHeight-2) + then setNext $ gameoverProc2 (y'+1) + else setNext $ gameoverProc3 0 + gameoverProc3 count = do + modifyIORef padRef updatePad + pad <- readIORef padRef + + postRedisplay Nothing + + if (trig pad .&. padA) /= 0 + then do + writeIORef gameStatRef Game + newPlayer >>= writeIORef playerRef + setNext $ gameProc + else + if count < frameRate * 3 + then setNext $ gameoverProc3 (count + 1) + else do + writeIORef gameStatRef Title + setNext $ titleProc + + +-- 文字列表示 +putText :: Float -> Float -> String -> IO () +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 :: IORef GameStat -> IORef Player -> IO () +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" + _ -> return () + + putText 200 200 "MOVE: J L" + putText 200 220 "FALL: K" + putText 200 240 "ROT: Space, Z" + + --バッファの入れ替え + swapBuffers diff --git a/Pad.hs b/Pad.hs new file mode 100644 --- /dev/null +++ b/Pad.hs @@ -0,0 +1,76 @@ +module Pad where + +import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate) +import Data.Bits ((.|.), (.&.), complement) + +-------------------------------- +-- Pad +padU,padL,padR,padD,padA,padB,padAll :: Int +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 +newPad = Pad { + pressed = [], + btn = 0, + obtn = 0, + trig = 0, + rpt = 0, + rptc = 0 +} + +calcPadState :: [Key] -> Int +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 (SpecialKey KeyUp) = padU + btnValue (SpecialKey KeyLeft) = padL + btnValue (SpecialKey KeyRight) = padR + btnValue (SpecialKey KeyDown) = padD + + btnValue _ = 0 + +repeatCnt1, repeatCnt2, repeatBtn :: Int +repeatCnt1 = 7 -- リピート初回の時間 +repeatCnt2 = 1 -- リピート２回目以降の時間 +repeatBtn = padL .|. padR -- リピートで使うボタン + +updatePad :: Pad -> Pad +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' diff --git a/Player.hs b/Player.hs new file mode 100644 --- /dev/null +++ b/Player.hs @@ -0,0 +1,303 @@ +module Player where + +import Graphics.UI.GLUT hiding (Red, Green, Blue, rotate) +import Data.Bits ((.&.)) + +import Pad +import Board +import Util + +-------------------------------- +-- constant definition + +-- フレームレート +frameRate,cellWidth,cellHeight,defaultFallSpeed,blockFallCount,fixedTimer :: Int +frameRate = 40 + +-- セルの表示サイズ +cellWidth = 16 +cellHeight = 16 + +-- デフォルトの落下速度 +defaultFallSpeed = 1 + +-- 落ちるカウンタ +blockFallCount = 40 + +-- ブロックが着地してから固定されるまでの時間 +fixedTimer = frameRate `div` 2 + +-------------------------------- +-- 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 + +-- フィールド描画 +renderBoard board = mapM_ lineProc $ zip [0..] board + where + lineProc (iy, line) = mapM_ (cellProc iy) $ zip [0..] line + cellProc _ (_, Empty) = return () + cellProc iy (ix, cell) = renderCell (cellColor cell) ix iy + +-- ブロックを色つきで描画 +renderBlockTypeCol col blktype ix iy rote = do + sequence_ $ concat $ idxmap2 proc pat + where + pat = rotate rote $ blockPattern blktype + proc (dx,dy) 1 = renderCell col (ix+dx) (iy+dy) + proc (_dx,_dy) _ = return () + +renderBlockType blktype = renderBlockTypeCol (cellColor $ blockCell blktype) blktype + +-------------------------------- +-- Block + +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 = (boardWidth - length (head (blockPattern blktype))) `div` 2, + y = 0, + rot = 0, + fallSpeed = spd, + ycnt = 0, + fixedcnt = 0 +} + +-- ブロックをパッドで移動 +updateBlock :: Board -> Pad -> Block -> Block +updateBlock board pad block = + block { x = x', y = y', rot = rot' `mod` 4, ycnt = ycnt', fixedcnt = fixedcnt' } + where + x' + | canMove board 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 + 4) `mod` 4 + rotcw = if ((trgbtn .&. padA) /= 0) then 1 else 0 + rotccw = if ((trgbtn .&. padB) /= 0) then 1 else 0 + + canRot = canMove board blktype x' oldy (oldrot + drot) + rotPushUp = drot /= 0 && not canRot && canMove board blktype x' (oldy-1) (oldrot + drot) + + beFall = ((nowbtn .&. padD) /= 0) || (oldycnt + fallSpeed block >= blockFallCount) + canFall = canMove board 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 + +-- 操作中のブロック描画 +renderBlock block = + renderBlockType (blktype_of block) (x block) (y block) (rot block) + +-- ゴーストブロック描画 +renderGhostBlock board block = + renderBlockTypeCol col (blktype_of block) (x block) landY (rot block) + where + landY = landingY board (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 { + board_of :: Board, + block_of :: Block, + nxtblktype :: BlockType, + score :: Int, + + stat :: PlayerStat, + cnt :: Int, + + updater :: PlayerUpdater +} + +initialPlayer = + Player { + board_of = emptyBoard, + block_of = newBlock BlockI defaultFallSpeed, + nxtblktype = BlockI, + score = 0, + stat = PlDead, + cnt = 0, + updater = updatePlayerNormal + } + +newPlayer = do + blktype <- randBlockType + nxt <- randBlockType + return $ Player { + board_of = emptyBoard, + 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 { board_of = storedBoard } + else do + let upproc = updatePlayerErase filled + return $ player { board_of = eraseLines storedBoard filled, stat = PlEraseEffect, updater = upproc, cnt = 0 } + where + board = board_of player + block = block_of player + + block' = updateBlock board pad block + + storedBoard = storeBlock board (blktype_of block) (x block) (y block) (rot block) + filled = getFilledLines storedBoard + +-- そろったラインを消した後の時間待ち +updatePlayerErase filled _pad player = + if (not $ null filled) && (cnt player) < (frameRate `div` 2) + then return $ player { cnt = (cnt player) + 1 } + else return $ player { board_of = falledBoard, score = score', updater = updatePlayerErase2, cnt = 0 } + where + falledBoard = fallLines (board_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 board 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 storedBoard = storeBlock board nxtblk (x nxtBlock) (y nxtBlock) (rot nxtBlock) + return $ player { board_of = storedBoard, 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) + board = board_of player + + +-- 更新 +updatePlayer :: Pad -> Player -> IO Player +updatePlayer pad player = (updater player) pad player + +renderNextBlock :: Player -> IO () +renderNextBlock player = renderBlockType (nxtblktype player) (boardWidth + 2) 5 0 + +renderPlayer :: Player -> IO () +renderPlayer player = do + renderBoard (board_of player) + if (stat player) == PlNormal + then do + renderGhostBlock (board_of player) (block_of player) + renderBlock (block_of player) + else return () + if (stat player) /= PlDead + then renderNextBlock player + else return () + +isDead :: Player -> Bool +isDead player = (stat player) == PlDead diff --git a/README.en.txt b/README.en.txt new file mode 100644 --- /dev/null +++ b/README.en.txt @@ -0,0 +1,14 @@ + Tetris, written in Haskell & using GLUT + + ★ Commands + + 'q': quit, end Tetris. + + Left/right cursor keys: Move the current block left and right. + + Down cursor key: Move the block down the screen faster + than it is currently falling. + + Space bar: Rotate the block clockwise. + + 'z': Rotate the block counter-clockwise. diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -0,0 +1,23 @@ + +Tetris in Haskell & GLUT + + + +š‘€ì + + Q + ƒAƒvƒŠI—¹ + + ƒJ[ƒ\ƒ‹ƒL[¶‰E + ƒuƒƒbƒNˆÚ“® + + ƒJ[ƒ\ƒ‹ƒL[‰º + ƒuƒƒbƒN‚ð—Ž‚Æ‚· + + ƒXƒy[ƒXƒL[ + ƒuƒƒbƒNŽžŒv‰ñ“] + + Z + ƒuƒƒbƒN‹tŽžŒv‰ñ“] + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,33 @@ +module Util where + +import Data.List (transpose) +import System.Random + +-- | Square. +square :: Int -> Int +square x = x * x + +-- | Make pair. +pair :: a -> b -> (a, b) +pair a b = (a, b) + +-- | Replace i-th element of list to v. +replace :: [a] -> Int -> a -> [a] +replace ls i v = take i ls ++ [v] ++ drop (i + 1) ls + +-- | Remove i-th element of list. +remove :: Int -> [a] -> [a] +remove i = (\(xs, ys) -> xs ++ tail ys) . splitAt i + +-- | Rotate 2-D list clock-wise. +rotate :: Int -> [[a]] -> [[a]] +rotate 0 xss = xss +rotate (n + 1) xss = rotate n $ transpose $ reverse xss + +-- | Map 2-D list with index. +idxmap2 :: ((Int, Int) -> a -> b) -> [[a]] -> [[b]] +idxmap2 f = zipWith (\iy -> zipWith (\ix c -> f (ix,iy) c) [0..]) [0..] + +-- |Random integer number: 0..n-1 +randN :: Int -> IO Int +randN n = getStdRandom (randomR (0, n - 1)) diff --git a/tetris.cabal b/tetris.cabal new file mode 100644 --- /dev/null +++ b/tetris.cabal @@ -0,0 +1,30 @@ +name: tetris +version: 0.27177 + +license: BSD3 +license-file: LICENSE +author: mokehehe +maintainer: + +stability: Stable +category: Game +synopsis: A 2-D clone of Tetris +description: A simple clone of Tetris using GLUT. + . + Subversion repo available at . +homepage: http://d.hatena.ne.jp/mokehehe/20080921/tetris + +build-depends: base<4, GLUT, random + +build-type: Simple +tested-with: GHC==6.10.1 + +data-files: README.txt, README.en.txt + +executable: tetris +main-is: Main.hs +other-modules: Board Pad Player Util + + +ghc-options: -Wall +ghc-prof-options: -prof -auto-all