tetris-0.27177: Main.hs

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