tetris (empty) → 0.27177

raw patch · 10 files changed

+812/−0 lines, 10 filesdep +GLUTdep +basedep +randomsetup-changed

Dependencies added: GLUT, base, random

Files

• Board.hs +126/−0
• LICENSE +28/−0
• Main.hs +173/−0
• Pad.hs +76/−0
• Player.hs +303/−0
• README.en.txt +14/−0
• README.txt +23/−0
• Setup.hs +6/−0
• Util.hs +33/−0
• tetris.cabal +30/−0

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

@@ -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.

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

@@ -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'

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

@@ -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.

@@ -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‰ñ“]++

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

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

@@ -0,0 +1,30 @@+name:                tetris+version:             0.27177++license:             BSD3+license-file:        LICENSE+author:              mokehehe+maintainer:          <mokehehe@gmail.com>++stability:           Stable+category:            Game+synopsis:            A 2-D clone of Tetris+description:         A simple clone of Tetris using GLUT.+                     .+                     Subversion repo available at <http://svn.coderepos.org/share/lang/haskell/tetris>.+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