Changeset 20420 for lang/haskell

Show
Ignore:
Timestamp:
10/02/08 01:25:33 (2 months ago)
Author:
mokehehe
Message:

タイトル画面とゲーム中を作成
プレーヤーが画面外に落ちたりタイムアップならゲームオーバー

Location:
lang/haskell/nario
Files:
1 removed
3 modified

Legend:

Unmodified
Added
Removed

  • lang/haskell/nario/Main.hs

    r20397 r20420  
    2020 
    2121wndTitle = "NARIO in Haskell" 
    22 wndWidth = 256 
    23 wndHeight = 224 
     22screenWidth = 256 
     23screenHeight = 224 
    2424wndBpp = 32 
    2525 
    … …  
    3737        sdlInit [VIDEO] 
    3838        setCaption wndTitle wndTitle 
    39         sur <- setVideoMode wndWidth wndHeight wndBpp [HWSURFACE, DOUBLEBUF, ANYFORMAT] 
     39        sur <- setVideoMode screenWidth screenHeight wndBpp [HWSURFACE, DOUBLEBUF, ANYFORMAT] 
    4040        do 
    4141                strm <- delayedStream (1000000 `div` frameRate) fetch 
    … …  
    7777 
    7878-- 状態 
    79 data GameState = GameState { 
    80         pl :: Player, 
    81         fld :: Field, 
    82         actors :: [Actor] 
     79data GameGame = 
     80        GameGame { 
     81                pl :: Player, 
     82                fld :: Field, 
     83                actors :: [Actor], 
     84                time :: Int 
    8385        } 
    84  
    85 -- 開始状態 
    86 initialState = do 
    87         fldmap <- loadField stage 
    88         return GameState { 
    89                 pl = newPlayer, 
    90                 fld = fldmap, 
    91                 actors = [] 
    92                 } 
    93         where 
    94                 stage = 0 
    9586 
    9687 
    … …  
    9990process kss = do 
    10091        imgres <- loadImageResource imageTypes 
    101         st <- initialState 
    102         let scrs = map (\scr -> scr imgres) $ loop [] st kss 
     92        fldmap <- loadField 0 
     93 
     94        let tmpscrs = doTitle fldmap kss 
     95 
     96        let scrs = map (\scr sur -> scr imgres sur >> flipSurface sur >> return ()) $ tmpscrs 
    10397        return $ scrs ++ [(\sur -> do {releaseImageResource imgres})] 
    104         where 
    105                 loop :: [SDLKey] -> GameState -> [[SDLKey]] -> [(ImageResource -> Scr)] 
    106                 loop _ _ [] = [] 
    107                 loop bef gs (ks:kss) = scr' : loop ks gs' kss 
    108                         where 
    109                                 (scr', gs') = updateProc kp gs 
    110                                 kp = keyProc bef ks 
    111  
    112 -- 更新 
    113 updateProc :: KeyProc -> GameState -> (ImageResource -> Scr, GameState) 
    114 updateProc kp gs = (renderProc gs', gs') 
    115         where 
    116                 (pl', ev) = updatePlayer kp (fld gs) (pl gs) 
    117                 actors_updates = map updateActor (actors gs) 
    118                 actors' = map fst actors_updates 
    119                 ev' = concatMap snd actors_updates 
    120  
    121                 gstmp = gs { pl = pl', actors = actors' } 
    122                 gs' = procEvent gstmp (ev ++ ev') 
     98 
     99 
     100-- タイトル 
     101doTitle :: Field -> [[SDLKey]] -> [ImageResource -> Scr] 
     102doTitle fldmap kss = loop kss 
     103        where 
     104                loop :: [[SDLKey]] -> [ImageResource -> Scr] 
     105                loop (ks:kss) = res : left ks kss 
     106 
     107                res imgres sur = do 
     108                        fillRect sur Nothing backColor 
     109                        renderTitle imgres sur 
     110 
     111                left ks kss 
     112                        | SDLK_SPACE `elem` ks  = doGame fldmap kss 
     113                        | otherwise                             = loop kss 
     114 
     115-- ゲーム 
     116doGame :: Field -> [[SDLKey]] -> [ImageResource -> Scr] 
     117doGame fldmap kss = loop (head kss) initialState kss 
     118        where 
     119                loop :: [SDLKey] -> GameGame -> [[SDLKey]] -> [ImageResource -> Scr] 
     120                loop bef gs (ks:kss) = scr' : left ks kss 
     121                        where 
     122                                (scr', gs') = updateProc (keyProc bef ks) gs 
     123                                isPlayerDead = getPlayerYPos (pl gs') >= screenHeight + chrSize * 2 
     124                                timeOver = time gs' <= 0 
     125 
     126                                left ks kss 
     127                                        | isPlayerDead || timeOver      = doGameOver fldmap kss 
     128                                        | otherwise                                     = loop ks gs' kss 
     129 
     130                -- 更新 
     131                updateProc :: KeyProc -> GameGame -> (ImageResource -> Scr, GameGame) 
     132                updateProc kp gs = (renderProc gs', gs') 
     133                        where 
     134                                time' = max 0 (time gs - one `div` 25) 
     135                                (pl', ev) = updatePlayer kp (fld gs) (pl gs) 
     136                                actors_updates = map updateActor (actors gs) 
     137                                actors' = map fst actors_updates 
     138                                ev' = concatMap snd actors_updates 
     139 
     140                                gstmp = gs { pl = pl', actors = actors', time = time' } 
     141                                gs' = procEvent gstmp (ev ++ ev') 
     142 
     143                initialState = GameGame { pl = newPlayer, fld = fldmap, actors = [], time = 400 * one } 
     144 
     145doGameOver fldmap kss = doTitle fldmap kss 
     146 
    123147 
    124148-- イベントを処理 
    125 procEvent :: GameState -> [Event] -> GameState 
     149procEvent :: GameGame -> [Event] -> GameGame 
    126150procEvent gs ev = foldl f gs ev 
    127151        where 
    … …  
    136160 
    137161-- 描画 
    138 renderProc :: GameState -> ImageResource -> Scr 
     162renderProc :: GameGame -> ImageResource -> Scr 
    139163renderProc gs imgres sur = do 
    140164        fillRect sur Nothing backColor 
    … …  
    148172 
    149173        renderInfo gs imgres sur 
    150  
    151         flipSurface sur 
    152174        return () 
    153175 
     176tailN n = reverse . take n . reverse 
     177 
     178deciWide w c n = tailN w $ replicate w c ++ show n 
     179 
    154180-- 情報描画 
    155 renderInfo :: GameState -> ImageResource -> Scr 
     181renderInfo :: GameGame -> ImageResource -> Scr 
    156182renderInfo gs imgres sur = do 
    157183        puts 3 1 "MARIO" 
    158         puts 3 2 "000000" 
    159         puts 11 2 "?*00" 
     184        puts 3 2 $ deciWide 6 '0' $ getPlayerScore (pl gs) 
     185        puts 11 2 ("?*" ++ deciWide 2 '0' (getPlayerMedal (pl gs))) 
    160186        puts 18 1 "WORLD" 
    161187        puts 19 2 "1-1" 
    162188        puts 25 1 "TIME" 
    163         puts 26 2 "255" 
     189        puts 26 2 $ deciWide 3 ' ' ((time gs + one-1) `div` one) 
    164190        where 
    165191                puts = fontPut sur fontsur 
    … …  
    167193 
    168194-- タイトル画面 
    169 renderTitle gs imgres sur = do 
     195renderTitle imgres sur = do 
    170196        blitSurface (getImageSurface imgres ImgTitle) Nothing sur (pt (5*8) (3*8)) 
    171197        puts 13 14 "@1985 NINTENDO" 
    172198        puts 9 17 "> 1 PLAYER GAME" 
    173         puts 9 19 "  2 PLAYER GAME" 
     199--      puts 9 19 "  2 PLAYER GAME" 
    174200        puts 12 22 "TOP- 000000" 
    175201        where 

  • lang/haskell/nario/Player.hs

    r20397 r20420  
    77        updatePlayer, 
    88        renderPlayer, 
    9         getScrollPos 
     9        getScrollPos, 
     10        getPlayerYPos, 
     11        getPlayerMedal, 
     12        getPlayerScore 
    1013) where 
    1114 
    … …  
    1417import Util 
    1518import AppUtil 
    16 import SDLUtil 
    1719import Const 
    1820import Images 
    … …  
    3739        stand :: Bool, 
    3840 
     41        medal :: Int, 
     42        score :: Int, 
     43 
    3944        lr :: Int, 
    4045        pat :: Int, 
    … …  
    4954        scrx = 0, 
    5055        stand = False, 
     56 
     57        medal = 0, 
     58        score = 0, 
    5159 
    5260        lr = 1, 
    … …  
    160168checkCeil fld player 
    161169        | stand player || vy player >= 0 || not isCeil  = (player, []) 
    162         | otherwise = (player { vy = 0 }, [EvHitBlock ImgBlock2 cx cy]) 
     170        | otherwise = (player { vy = 0, score = (score player) + 10 }, [EvHitBlock ImgBlock2 cx cy]) 
    163171        where 
    164172                ytmp = y player - one * chrSize 
    … …  
    188196getScrollPos player = (scrx player) `div` one 
    189197 
     198-- Ｙ座標取得 
     199getPlayerYPos :: Player -> Int 
     200getPlayerYPos = (`div` one) . y 
     201 
     202-- メダル枚数取得 
     203getPlayerMedal :: Player -> Int 
     204getPlayerMedal = medal 
     205 
     206-- スコア取得 
     207getPlayerScore :: Player -> Int 
     208getPlayerScore = score 
     209 
    190210-- 描画 
    191211renderPlayer sur imgres scrx player = do 

  • lang/haskell/nario/tool/listup-imgs.hs

    r20397 r20420  
     1-- 画像ファイルを列挙して、ソースを生成 
    12 
    23import System (getArgs) 
    … …  
    78import Data.List (intercalate) 
    89 
    9 -- �摜�t�@�C���̗�listupImgFiles path = fileEntries path >>= return . filter bmpFile 
     10-- 画像ファイルの列挙 
     11listupImgFiles path = fileEntries path >>= return . filter bmpFile 
    1012        where 
    1113                bmpFile = isJust . regex "\\.bmp$" 
    1214 
    13 regex :: String -> String -> Maybe [String] 
    14 regex rex str = matchRegex (mkRegex rex) str 
    15  
     15-- 全置換 
    1616gsub rexstr f str = loop str 
    1717        where 
    … …  
    2222                rex = mkRegex rexstr 
    2323 
     24-- 拡張子を除いたファイル名 
    2425basefn fn = 
    2526        case regex "^(.*)\\..*$" $ basename fn of 
    … …  
    2728                Nothing         -> fn 
    2829 
    29 -- �擪�������camelize (x:xs) = toUpper x : xs 
     30-- 先頭を大文字に 
     31camelize (x:xs) = toUpper x : xs 
    3032 
    31  
     33-- エントリ 
    3234main = do 
    3335        args <- getArgs