![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
Changeset 20003 for lang/haskell
- Timestamp:
- 09/27/08 09:31:17 (2 months ago)
- Location:
- lang/haskell/tetris
- Files:
-
- 4 modified
Legend:
- Unmodified
- Added
- Removed
-
lang/haskell/tetris/Board.hs
r20002 r20003 44 44 blockCell BlockT = Cyan 45 45 46 -- �����Ńu���b�N���randBlockType = randN (length blockTypes) >>= return . (blockTypes !!) 46 -- 乱数でブロックを選ぶ 47 randBlockType = randN (length blockTypes) >>= return . (blockTypes !!) 47 48 48 49 blockTypes = [BlockI, BlockO, BlockS, BlockZ, BlockJ, BlockL, BlockT] -
lang/haskell/tetris/Main.hs
r20002 r20003 15 15 screenHeight = 400 16 16 17 -- �^�C�}�̊Ԋu17 -- タイマの間隔 18 18 timerInterval = 1000 `div` frameRate 19 19 20 20 -------------------------------- 21 -- �G���g��21 -- エントリ 22 22 23 23 data GameStat = Title | Game | GameOver … … 28 28 padRef <- newIORef newPad 29 29 30 --GLUT�̏���initialDisplayMode $= [RGBAMode, DoubleBuffered] 30 --GLUTの初期化 31 initialDisplayMode $= [RGBAMode, DoubleBuffered] 31 32 initialWindowSize $= Size screenWidth screenHeight 32 33 33 --�E�B���h�E���createWindow "Tetris in Haskell & GLUT" 34 --ウィンドウを作る 35 createWindow "Tetris in Haskell & GLUT" 34 36 35 --�\���Ɏg���R�[���o�b�N���̎w��displayCallback $= display gameStatRef playerRef 37 --表示に使うコールバック関数の指定 38 displayCallback $= display gameStatRef playerRef 36 39 37 -- �L�[�{�[�h���E�X�̃R�[���o�b�N40 --キーボードやマウスのコールバック 38 41 keyboardMouseCallback $= Just (keyboardProc padRef) 39 42 40 --�^�C�}���setTimerProc gameStatRef playerRef padRef 43 --タイマを作る 44 setTimerProc gameStatRef playerRef padRef 41 45 42 --GLUT�̃��C�����[�v�ɓ�ainLoop 46 --GLUTのメインループに入る 47 mainLoop 43 48 44 49 45 -- �L�[�����50 --キー入力の処理 46 51 keyboardProc _ (Char 'q') _ _ _ = exitWith ExitSuccess 47 52 keyboardProc padRef key Down _ _ = modifyIORef padRef (\pad -> pad { pressed = union [key] (pressed pad) }) … … 50 55 51 56 52 -- �^�C�}���荞�ݐݒ�etTimerProc gameStatRef playerRef padRef = do 57 -- タイマ割り込み設定 58 setTimerProc gameStatRef playerRef padRef = do 53 59 writeIORef gameStatRef Title 54 60 setNext $ titleProc … … 57 63 setNext = addTimerCallback timerInterval 58 64 59 -- �^�C�g��65 -- タイトル 60 66 titleProc = do 61 67 modifyIORef padRef updatePad … … 72 78 setNext $ titleProc 73 79 74 -- �Q�[����80 -- ゲーム中 75 81 gameProc = do 76 82 modifyIORef padRef updatePad … … 88 94 setNext $ gameoverProc 89 95 90 -- �Q�[���I�[�o�[96 -- ゲームオーバー 91 97 gameoverProc = gameoverProc2 0 92 98 gameoverProc2 y = do … … 121 127 122 128 123 -- �������129 -- 文字列表示 124 130 putText x y str = 125 131 preservingMatrix $ do … … 129 135 130 136 131 -- �\��137 -- 表示 132 138 display gameStatRef playerRef = do 133 139 gameStat <- readIORef gameStatRef 134 140 player <- readIORef playerRef 135 141 136 --�w�i��ɂ���clear [ColorBuffer] 142 --背景を黒にする 143 clear [ColorBuffer] 137 144 138 --�P�ʍs��ǂݍ��� loadIdentity 145 --単位行列を読み込む 146 loadIdentity 139 147 140 -- �\��148 --表示 141 149 renderPlayer player 142 150 … … 156 164 putText 200 240 "ROT: Space, Z" 157 165 158 -- �o�b�t�@�̓��166 --バッファの入れ替え 159 167 swapBuffers -
lang/haskell/tetris/Pad.hs
r20002 r20003 17 17 18 18 data Pad = Pad { 19 pressed :: [Key], -- ���݉��������[20 btn :: Int, -- ���������^��21 obtn :: Int, -- �O�������{�^��22 trig :: Int, -- �����ꂽ�u�Ԃ̃{�^��23 rpt :: Int, -- �����ꑱ���Ă��^��24 rptc :: Int -- ���s�[�g�p�J�E���^19 pressed :: [Key], -- 現在押されてるキー 20 btn :: Int, -- 押されてるボタン 21 obtn :: Int, -- 前回押されてたボタン 22 trig :: Int, -- 押された瞬間のボタン 23 rpt :: Int, -- 押され続けてるボタン 24 rptc :: Int -- リピート用カウンタ 25 25 } 26 26 … … 51 51 btnValue _ = 0 52 52 53 repeatCnt1 = 7 -- ���s�[�g�������repeatCnt2 = 1 -- ���s�[�g�Q��ȍ~�̎���repeatBtn = padL .|. padR -- ���s�[�g�Ŏg���{�^�� 53 repeatCnt1 = 7 -- リピート初回の時間 54 repeatCnt2 = 1 -- リピート２回目以降の時間 55 repeatBtn = padL .|. padR -- リピートで使うボタン 54 56 55 57 updatePad pad = -
lang/haskell/tetris/Player.hs
r20002 r20003 11 11 -- constant definition 12 12 13 -- �t���[�����[�g13 -- フレームレート 14 14 frameRate = 40 15 15 16 -- �Z���̕\���T�C�Y16 -- セルの表示サイズ 17 17 cellWidth = 16 18 18 cellHeight = 16 19 19 20 -- �f�t�H���g�̗������x20 -- デフォルトの落下速度 21 21 defaultFallSpeed = 1 22 22 23 -- �������E���^23 -- 落ちるカウンタ 24 24 blockFallCount = 40 25 25 26 -- �u���b�N�����n���Ă����肳���܂ł̎���fixedTimer = frameRate `div` 2 26 -- ブロックが着地してから固定されるまでの時間 27 fixedTimer = frameRate `div` 2 27 28 28 29 -------------------------------- … … 39 40 scaleColor s (r,g,b) = (s*r, s*g, s*b) 40 41 41 -- ���̈����Ԃ�42 -- 矩形領域塗りつぶし 42 43 fill x y w h (r,g,b) = do 43 44 color3i r g b … … 53 54 iy2 = fromInteger $ toInteger $ y + h 54 55 55 -- �Z������i���Â���56 -- セルを描く（明暗あり） 56 57 renderCell col@(r,g,b) ix iy = do 57 58 fill x y (cellWidth-1) (cellHeight-1) col … … 73 74 y = iy * cellHeight 74 75 75 -- �t�B�[���h�`��enderBoard board = mapM_ lineProc $ zip [0..] board 76 -- フィールド描画 77 renderBoard board = mapM_ lineProc $ zip [0..] board 76 78 where 77 79 lineProc (iy, line) = mapM_ (cellProc iy) $ zip [0..] line … … 79 81 cellProc iy (ix, cell) = renderCell (cellColor cell) ix iy 80 82 81 -- �u���b�N����ŕ`��enderBlockTypeCol col blktype ix iy rot = do 83 -- ブロックを色つきで描画 84 renderBlockTypeCol col blktype ix iy rot = do 82 85 sequence_ $ concat $ idxmap2 proc pat 83 86 where … … 112 115 } 113 116 114 -- �u���b�N��b�h�ňړ�117 -- ブロックをパッドで移動 115 118 updateBlock :: Board -> Pad -> Block -> Block 116 119 updateBlock board pad block = … … 164 167 oldycnt = ycnt block 165 168 166 -- �u���b�N���n�ʂɂ��ČŒ肳�ꂽ���H169 -- ブロックが地面について固定されたか？ 167 170 isBlockFixed block = (fixedcnt block) > fixedTimer 168 171 169 -- ���쒆�̃u���b�N�`��enderBlock block = 172 -- 操作中のブロック描画 173 renderBlock block = 170 174 renderBlockType (blktype_of block) (x block) (y block) (rot block) 171 175 172 -- �S�[�X�g�u���b�N�`��enderGhostBlock board block = 176 -- ゴーストブロック描画 177 renderGhostBlock board block = 173 178 renderBlockTypeCol col (blktype_of block) (x block) landY (rot block) 174 179 where … … 220 225 } 221 226 222 -- �ʏ펞227 -- 通常時 223 228 updatePlayerNormal pad player 224 -- �ʏ�| not (isBlockFixed block) = return $ player { block_of = block' } 225 -- �ڒn�����Ƃ��F�t�B�[���h�Ɋi�[���Ď��̃u���b�N��� 229 -- 通常 230 | not (isBlockFixed block) = return $ player { block_of = block' } 231 -- 接地したとき：フィールドに格納して次のブロックを出す 226 232 | otherwise = do 227 233 if null filled … … 239 245 filled = getFilledLines storedBoard 240 246 241 -- ���������C������������ԑ҂�247 -- そろったラインを消した後の時間待ち 242 248 updatePlayerErase filled pad player = 243 249 if (not $ null filled) && (cnt player) < (frameRate `div` 2) … … 248 254 score' = (score player) + 10 * square (length filled) 249 255 250 -- ���������C������ĉ��ɋl�߂������ԑ҂�256 -- そろったラインを消して下に詰めた後の時間待ち 251 257 updatePlayerErase2 pad player = 252 258 if (cnt player) < (frameRate `div` 2) … … 254 260 else setupNextBlock player 255 261 256 -- ���S262 -- 死亡 257 263 updatePlayerDead pad player = return player 258 264 259 -- ���̃u���b�N���265 -- 次のブロックを出す 260 266 setupNextBlock player = do 261 267 if canMove board nxtblk (x nxtBlock) (y nxtBlock) (rot nxtBlock) 262 then do -- �o������ nxt' <- randBlockType -- ���̎��̃u���b�N�𗐐��őI�� return $ player { block_of = nxtBlock, nxtblktype = nxt', stat = PlNormal, updater = updatePlayerNormal } 263 else do -- �l�܂�Ă����S 268 then do -- 登場できる 269 nxt' <- randBlockType -- 次の次のブロックを乱数で選ぶ 270 return $ player { block_of = nxtBlock, nxtblktype = nxt', stat = PlNormal, updater = updatePlayerNormal } 271 else do -- 詰まってる：死亡 264 272 let storedBoard = storeBlock board nxtblk (x nxtBlock) (y nxtBlock) (rot nxtBlock) 265 273 return $ player { board_of = storedBoard, stat = PlDead, updater = updatePlayerDead } 266 274 where 267 nxtblk = nxtblktype player -- ���̃u���b�N�̎�275 nxtblk = nxtblktype player -- 次のブロックの種類 268 276 nxtBlock = newBlock nxtblk nxtFallSpd 269 277 nxtFallSpd = if curFallSpd < blockFallCount then curFallSpd + 1 else defaultFallSpeed … … 272 280 273 281 274 -- �X�V282 -- 更新 275 283 updatePlayer :: Pad -> Player -> IO Player 276 284 updatePlayer pad player = (updater player) pad player
