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