tetris-0.27177: Player.hs

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