Changeset 19989 for lang/haskell

Show
Ignore:
Timestamp:
09/27/08 00:27:32 (2 months ago)
Author:
mokehehe
Message:

ソース分割
プレーヤー、フィールドマップを追加

Location:
lang/haskell/nario
Files:
2 added
1 modified

Legend:

Unmodified
Added
Removed

  • lang/haskell/nario/main.hs

    r19868 r19989  
    44module Main where 
    55 
    6 import Data.List 
    7 import Data.IORef 
    8 import System.Time 
    9 import System.Random 
    10 import Control.Concurrent 
    11 import Control.Monad 
    126import Multimedia.SDL 
    13  
     7import Control.Monad (when) 
     8import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef) 
    149import Data.Maybe (fromJust) 
     10 
     11import SDLUtil 
     12import Util 
    1513 
    1614----------------------------------- 
    … …  
    2321 
    2422 
    25 data ImageType = ImgNario00 | ImgNario01 | ImgNario02 | ImgNario03 | ImgNario04 
     23-- �摜 
     24data ImageType = 
     25                ImgNario00 | ImgNario01 | ImgNario02 | ImgNario03 | ImgNario04 
     26        |       ImgNario10 | ImgNario11 | ImgNario12 | ImgNario13 | ImgNario14 
     27        |       ImgBlock1 | ImgBlock2 | ImgBlock3 | ImgBlock4 | ImgBlock5 
    2628        deriving Eq 
    2729 
    … …  
    3133imageFn ImgNario03 = "nario03.bmp" 
    3234imageFn ImgNario04 = "nario04.bmp" 
    33  
    34 images = [ImgNario00, ImgNario01, ImgNario02, ImgNario03, ImgNario04] 
    35  
    36  
    37  
    38 -- �L�[�{�[�h���� 
    39  
    40 data GameKey = 
    41         GKUp | GKDown | GKLeft | GKRight | GKRotate 
    42         deriving (Eq,Show,Enum) 
    43  
    44 data KeyState = 
    45         Pushed | Pushing | Released | Releasing 
    46         deriving (Eq,Show) 
    47  
    48 isPressed Pushed  = True 
    49 isPressed Pushing = True 
    50 isPressed _       = False 
    51  
    52 type KeyProc = GameKey -> KeyState 
    53  
    54 keyProc bef cur gk 
    55         | not bp && not cp = Releasing 
    56         | not bp && cp     = Pushed 
    57         | bp     && not cp = Released 
    58         | bp     && cp     = Pushing 
    59         where 
    60                 bp = (mapPhyKey gk) `elem` bef 
    61                 cp = (mapPhyKey gk) `elem` cur 
    62  
    63 mapPhyKey GKUp     = SDLK_UP 
    64 mapPhyKey GKDown   = SDLK_DOWN 
    65 mapPhyKey GKLeft   = SDLK_LEFT 
    66 mapPhyKey GKRight  = SDLK_RIGHT 
    67 mapPhyKey GKRotate = SDLK_z 
    68  
    69 -- ���Ԓ��� 
    70  
    71 elapseTime :: Integer -> IO (IO (Int,Bool)) 
    72 elapseTime fps = do 
    73   let frametime = picosec `div` fps 
    74   tm <- getClockTime 
    75   st <- newIORef ((0,0,noTimeDiff), (1,tm)) 
    76   return $ do 
    77     ((bef,cur,fdt), (cnt,bt)) <- readIORef st 
    78     ct       <- getClockTime 
    79     let dt   = diffClockTimes ct bt 
    80         ndt  = diffClockTimes ct tm 
    81         adj  = frametime*cnt - toPsec dt 
    82         nc   = if cnt==fps then (1,ct) else (cnt+1,bt) 
    83         (nbef,ncur) = if tdSec fdt /= tdSec ndt then (cur,0) else (bef,cur) 
    84     if adj < 0 then do 
    85         writeIORef st ((nbef,ncur,ndt), nc) 
    86         return (bef, False) 
    87       else do 
    88         writeIORef st ((nbef,ncur+1,ndt), nc) 
    89         threadDelay $ fromInteger $ min 16666 $ adj `div` 1000000 
    90         return (bef, True) 
    91   where 
    92     toPsec dt = toInteger (tdMin dt * 60 + tdSec dt) * picosec + tdPicosec dt 
    93     picosec = 1000000000000 
     35imageFn ImgNario10 = "nario10.bmp" 
     36imageFn ImgNario11 = "nario11.bmp" 
     37imageFn ImgNario12 = "nario12.bmp" 
     38imageFn ImgNario13 = "nario13.bmp" 
     39imageFn ImgNario14 = "nario14.bmp" 
     40imageFn ImgBlock1 = "block1.bmp" 
     41imageFn ImgBlock2 = "block2.bmp" 
     42imageFn ImgBlock3 = "block3.bmp" 
     43imageFn ImgBlock4 = "block4.bmp" 
     44imageFn ImgBlock5 = "block5.bmp" 
     45 
     46images = [ 
     47        ImgNario00, ImgNario01, ImgNario02, ImgNario03, ImgNario04, 
     48        ImgNario10, ImgNario11, ImgNario12, ImgNario13, ImgNario14, 
     49        ImgBlock1, ImgBlock2, ImgBlock3, ImgBlock4, ImgBlock5 
     50        ] 
     51 
     52 
     53 
     54type ImageResource = [(ImageType, Surface)] 
     55 
     56 
     57 
     58 
     59fieldMap = [ 
     60        "                ", 
     61        "                ", 
     62        "                ", 
     63        "                ", 
     64        "                ", 
     65        "                ", 
     66        "        O?O     ", 
     67        "                ", 
     68        "                ", 
     69        "       O?O?O    ", 
     70        "                ", 
     71        "                ", 
     72        "                ", 
     73        "@@@@@@@@@@@@@@@@", 
     74        "@@@@@@@@@@@@@@@@" 
     75        ] 
     76 
     77chr2img '@' = ImgBlock1 
     78chr2img 'O' = ImgBlock2 
     79chr2img '?' = ImgBlock4 
     80 
     81renderMap sur imgres = sequence_ $ concatMap lineProc $ zip [0..] fieldMap 
     82        where 
     83                lineProc (y, ln) = map (cellProc y) $ zip [0..] ln 
     84                cellProc y (x, c) = do 
     85                        if c == ' ' 
     86                                then return () 
     87                                else do 
     88                                        blitSurface (getImageSurface imgres $ chr2img c) Nothing sur $ pt (x*16) (y*16) 
     89                                        return () 
     90 
     91 
     92 
     93 
     94data Player = Player { 
     95        x :: Int, 
     96        y :: Int, 
     97        lr :: Int 
     98        } 
     99 
     100one = 256 
     101 
     102newPlayer = Player { 
     103        x = 1 * 16 * one, 
     104        y = 12 * 16 * one, 
     105        lr = 1 
     106        } 
     107 
     108updatePlayer :: Player -> KeyProc -> Player 
     109updatePlayer player kp = 
     110        player { x = x', y = y', lr = lr' } 
     111        where 
     112                x' 
     113                        | isPressed (kp GKLeft)         = (x player) - 1 * one 
     114                        | isPressed (kp GKRight)        = (x player) + 1 * one 
     115                        | otherwise                                     = x player 
     116                y' 
     117                        | isPressed (kp GKUp)           = (y player) - 1 * one 
     118                        | isPressed (kp GKDown)         = (y player) + 1 * one 
     119                        | otherwise                                     = y player 
     120                lr' 
     121                        | isPressed (kp GKLeft)         = 0 
     122                        | isPressed (kp GKRight)        = 1 
     123                        | otherwise                                     = lr player 
     124 
     125renderPlayer sur player imgres = 
     126        blitSurface (getImageSurface imgres chr) Nothing sur pos 
     127        where 
     128                pos = pt ((x player) `div` one) ((y player) `div` one) 
     129                chr = if (lr player) == 0 
     130                                then ImgNario00 
     131                                else ImgNario10 
     132 
     133 
     134-- �摜���\�[�X�ǂݍ��� 
     135loadImageResource :: IO ImageResource 
     136loadImageResource = mapM load images 
     137        where 
     138                load imgtype = do 
     139                        sur <- loadBMP $ ("img/" ++) $ imageFn imgtype 
     140--                      colorKey <- mapRGB (surfacePixelFormat sur) $ Color r g b a 
     141                        setColorKey sur [SRCCOLORKEY] 0 
     142                        return (imgtype, sur) 
     143                r = 0 
     144                g = 0 
     145                b = 0 
     146                a = 255 
     147 
     148 
     149getImageSurface :: ImageResource -> ImageType -> Surface 
     150getImageSurface imgres t = fromJust $ lookup t imgres 
    94151 
    95152-- ���C�����[�v 
    … …  
    97154main :: IO () 
    98155main = sdlStart [VIDEO] wndTitle wndSize $ \sur -> do 
    99         is  <- initState 
    100         gs  <- newIORef is 
    101         res2 <- loadResource2 
     156        gs <- newIORef initState 
     157        imgres <- loadImageResource 
    102158 
    103159        et <- elapseTime 60 
    104         loop et gs onProcess (onDraw sur res2) [] 
     160        loop et gs onProcess (onDraw sur imgres) [] 
    105161 
    106162loop et gs op od bef = do 
    … …  
    136192data GameState = 
    137193        GameState { 
    138                 dmy :: Int 
     194                pl :: Player 
    139195        } 
    140196 
    141197-- �J�n�� 
    142 initState :: IO GameState 
    143 initState = do 
    144         return GameState 
    145                 { dmy = 0 
     198initState :: GameState 
     199initState = 
     200        GameState { 
     201                pl = newPlayer 
    146202                } 
    147203 
    148  
    149  
    150 type Resource = (Surface,Surface,Surface,Surface, AudioData) 
    151  
    152 -- ���\�[�X�ǂݍ��� 
    153 loadResource2 :: IO [(ImageType, Surface)] 
    154 loadResource2 = mapM f images 
    155         where 
    156                 f t = do 
    157                         sur <- loadBMP $ ("img/" ++) $ imageFn t 
    158                         return (t, sur) 
    159204 
    160205-- ���t���[���̏��� 
    161206onProcess :: KeyProc -> GameState -> GameState 
    162207onProcess kp gs 
    163         | otherwise             = gs { dmy = dmy gs + 1 } 
     208        | otherwise             = gs { pl = updatePlayer (pl gs) kp} 
    164209 
    165210 
    … …  
    185230 
    186231 
     232backColor = 0x2891ff 
     233 
     234 
    187235-- �`�揈�� 
    188 onDraw :: Surface -> [(ImageType, Surface)] -> GameState -> IO () 
    189 onDraw sur res gs = do 
    190         fillRect sur Nothing 0x000000 
    191         let c = lookup ImgNario00 res 
    192         blitSurface (fromJust c) Nothing sur $ pt  70 20 
     236onDraw :: Surface -> ImageResource -> GameState -> IO () 
     237onDraw sur imgres gs = do 
     238        fillRect sur Nothing backColor 
     239 
     240        renderMap sur imgres 
     241        renderPlayer sur (pl gs) imgres 
    193242 
    194243        flipSurface sur 
    195244        return () 
     245