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

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

Files:
1 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