Changeset 20156

Show
Ignore:
Timestamp:
09/28/08 19:48:28 (5 years ago)
Author:
mokehehe
Message:

遅延ストリームを使って IORef を排除

Location:
lang/haskell/nario
Files:
3 modified

Legend:

Unmodified
Added
Removed

  • lang/haskell/nario/Main.hs

    r20045 r20156  
    1  
    21-- Nario 
    32 
    … …  
    54 
    65import Multimedia.SDL 
    7 import Control.Monad (when) 
    8 import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef) 
     6import System.IO.Unsafe (unsafeInterleaveIO) 
     7import Control.Concurrent (threadDelay) 
    98 
    10 import SDLUtil 
    11 import Util 
     9--import Control.Exception 
     10 
    1211import Player 
    1312import Field 
    14 import Const 
     13import Util 
    1514 
    16 ----------------------------------- 
    17 -- システム周り  
    18 ----------------------------------- 
    19  
    20 -- 種種の定義 
    21  
    22 wndTitle = "Nario in Haskell" 
    23 wndSize  = sz 256 240 
     15wndTitle = "delayed-stream test" 
     16wndWidth = 256 
     17wndHeight = 240 
     18wndBpp = 32 
    2419 
    2520frameRate = 60 
    2621 
    2722-- 背景色 
    28 backColor = 0x2891ff            -- 青 
     23backColor = 0x2891ff 
    2924 
     25-- 描画コマンド 
     26type Scr = Surface -> IO () 
    3027 
     28-- エントリ 
     29main :: IO () 
     30main = do 
     31        sdlInit [VIDEO] 
     32        setCaption wndTitle wndTitle 
     33        sur <- setVideoMode wndWidth wndHeight wndBpp [HWSURFACE, DOUBLEBUF, ANYFORMAT] 
     34        do 
     35                strm <- delayedStream (1000000 `div` frameRate) fetch 
     36                scrs <- process $ map snd $ takeWhile notQuit strm 
     37                mapM_ (\scr -> scr sur) scrs 
     38        sdlQuit 
    3139 
     40        where 
     41                -- 環境のフェッチ 
     42                fetch = do 
     43                        quit <- checkSDLEvent 
     44                        ks <- getKeyState 
     45                        return (quit, ks) 
     46                notQuit = not . fst 
    3247 
    33 -- メインループ 
     48-- 遅延ストリーム 
     49-- microsec 秒ごとに func を実行したアクションの結果をリストとして返す 
     50delayedStream :: Int -> IO a -> IO [a] 
     51delayedStream microsec func = unsafeInterleaveIO $ do 
     52        threadDelay microsec 
     53        x <- func 
     54        xs <- delayedStream microsec func 
     55        return $ x:xs 
    3456 
    35 main :: IO () 
    36 main = sdlStart [VIDEO] wndTitle wndSize $ \sur -> do 
    37         gs <- newIORef =<< initState 
    38         imgres <- loadImageResource 
    39  
    40         et <- elapseTime frameRate 
    41         loop et gs onProcess (onDraw sur imgres) [] 
    42  
    43 loop et gs op od bef = do 
    44         quit <- checkEvent 
    45         when (not quit) $ do 
    46                 ks <- getKeyState 
    47                 modifyIORef gs $ op $ keyProc bef ks 
    48                 st <- readIORef gs 
    49                 (fps, draw) <- et 
    50                 when draw $ od st 
    51                 loop et gs op od ks 
    52  
    53 checkEvent = do 
     57-- SDL のイベントを処理 
     58-- 終了イベントがきたら True を返す 
     59checkSDLEvent = do 
    5460        ev <- pollEvent 
    5561        case ev of 
    … …  
    5763                Just (KeyboardEvent { kbPress = True, kbKeysym = Keysym { ksSym = ks, ksMod = km } }) 
    5864                        | ks == SDLK_ESCAPE -> return True 
    59                         | ks == SDLK_F4 && (KMOD_LALT `elem` km || 
    60                                                                 KMOD_RALT `elem` km) -> return True 
     65                        | ks == SDLK_F4 && (KMOD_LALT `elem` km || KMOD_RALT `elem` km) -> return True 
    6166                Nothing -> return False 
    62                 _               -> checkEvent 
     67                _               -> checkSDLEvent 
    6368 
    64 sdlStart fs title (Size w h) p = do 
    65         True <- sdlInit fs 
    66         setCaption title title 
    67         sur <- setVideoMode w h 32 [HWSURFACE, DOUBLEBUF, ANYFORMAT] 
    68         p sur 
    69         sdlQuit 
     69---- 
    7070 
    71  
    72 -- ゲームの状態 
    73 data GameState = 
    74         GameState { 
    75                 pl :: Player, 
    76                 fld :: Field 
     71-- 状態 
     72data GameState = GameState { 
     73        pl :: Player, 
     74        fld :: Field 
    7775        } 
    7876 
    7977-- 開始状態 
    80 initState = do 
     78initialState = do 
    8179        fldmap <- loadField stage 
    8280        return GameState { 
    … …  
    8785                stage = 0 
    8886 
     87-- キー入力を処理して描画コマンドを返す 
     88process :: [[SDLKey]] -> IO [Scr] 
     89process kss = do 
     90        imgres <- loadImageResource 
     91        st <- initialState 
     92        return $ map (\scr -> scr imgres) $ loop [] st kss 
     93        where 
     94                loop :: [SDLKey] -> GameState -> [[SDLKey]] -> [(ImageResource -> Scr)] 
     95                loop _ _ [] = [] 
     96                loop bef gs (ks:kss) = scr' : loop ks gs' kss 
     97                        where 
     98                                (scr', gs') = update kp gs 
     99                                kp = keyProc bef ks 
    89100 
    90 -- 毎フレームの処理 
    91 onProcess :: KeyProc -> GameState -> GameState 
    92 onProcess kp gs 
    93         | otherwise             = gs { pl = updatePlayer kp (fld gs) (pl gs) } 
     101-- 更新 
     102update :: KeyProc -> GameState -> (ImageResource -> Scr, GameState) 
     103update kp gs = (render gs', gs') 
     104        where 
     105                gs' = gs { pl = updatePlayer kp (fld gs) (pl gs) } 
    94106 
    95  
    96 -- 描画処理 
    97 onDraw :: Surface -> ImageResource -> GameState -> IO () 
    98 onDraw sur imgres gs = do 
     107-- 描画 
     108render :: GameState -> ImageResource -> Scr 
     109render gs imgres sur = do 
    99110        fillRect sur Nothing backColor 
    100111 
    … …  
    106117        flipSurface sur 
    107118        return () 
    108  

  • lang/haskell/nario/Player.hs

    r20086 r20156  
    168168        moveY $ checkX fld $ moveX kp player 
    169169        where 
    170                 moveY 
    171                         | stand player  = doJump kp . checkFloor fld . fall 
    172                         | otherwise             = checkCeil fld . checkFloor fld . fall 
     170                moveY = doJump kp . checkFloor fld . checkCeil fld . fall 
    173171 
    174172-- スクロール位置取得 

  • lang/haskell/nario/Util.hs

    r20086 r20156  
    22 
    33import System.Time (getClockTime, diffClockTimes, noTimeDiff, tdMin, tdSec, tdPicosec) 
    4 import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef) 
    54import Control.Concurrent (threadDelay) 
    65import Data.Maybe (fromJust) 
    … …  
    6766mapPhyKey PadB = [SDLK_LSHIFT, SDLK_RSHIFT] 
    6867 
    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 
    94  
    9568 
    9669