Changeset 20943 for lang/haskell

Timestamp:

10/08/08 07:34:08 (2 months ago)

Author:

mokehehe

Message:

キー入力処理変更
Sキーでスクリーンショットを取れるように

Location:

lang/haskell/nario

Files:

• Actor/AnimBlock.hs (modified) (1 diff)
• Actor/BrokenBlock.hs (modified) (1 diff)
• Actor/CoinGet.hs (modified) (1 diff)
• Actor/Flower.hs (modified) (1 diff)
• Actor/Kinoko.hs (modified) (1 diff)
• Actor/Koura.hs (modified) (1 diff)
• Actor/Kuribo.hs (modified) (2 diffs)
• Actor/Nokonoko.hs (modified) (1 diff)
• Actor/ScoreAdd.hs (modified) (1 diff)
• AppUtil.hs (modified) (3 diffs)
• Main.hs (modified) (4 diffs)
• Player.hs (modified) (4 diffs)
• Util.hs (modified) (1 diff)

lang/haskell/nario/Actor/AnimBlock.hs

@@ -36 +36 @@
                                 else []
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres (chr2img $ chr self) (x self `div` one - scrx) (y self `div` one - 8)
-                return ()
 
         bDead self = vy self > 0 && y self >= startcy self * chrSize * one

lang/haskell/nario/Actor/BrokenBlock.hs

@@ -24 +24 @@
         update _ self = (self { x = x self + vx self, y = y self + vy self, vy = vy self + gravity }, [])
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres ImgBroken (x self `div` one - 4 - scrx) (y self `div` one - 4 - 8)
-                return ()
 
         bDead self = y self >= (screenHeight + chrSize * 2) * one

lang/haskell/nario/Actor/CoinGet.hs

@@ -32 +32 @@
                         self' = self { y = y self + vy self, vy = vy self + gravity, cnt = cnt self + 1 }
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres imgtype (sx self - scrx) (y self `div` one - 8)
-                return ()
                 where
                         imgtype = imgtbl !! (cnt self `div` 2 `mod` 4)

lang/haskell/nario/Actor/Flower.hs

@@ -27 +27 @@
         update fld self = (self, [])
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres ImgFlower ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - 15 - 8)
-                return ()
 
         getHitRect self = Just $ Rect (xx - 8) (yy - 16) (xx + 8) yy

lang/haskell/nario/Actor/Kinoko.hs

@@ -32 +32 @@
                         (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
-        render self imgres scrx sur = do
-                putimg sur imgres imgtype ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
-                return ()
-                where
-                        imgtype = ImgKinoko
+        render self imgres scrx sur =
+                putimg sur imgres ImgKinoko ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
 
         bDead self = y self >= (screenHeight + chrSize * 3) * one || x self <= -chrSize * one

lang/haskell/nario/Actor/Koura.hs

@@ -44 +44 @@
 
         render self imgres scrx sur = do
-                putimg sur imgres imgtype ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
-                return ()
-                where
-                        imgtype = ImgKoura
+                putimg sur imgres ImgKoura ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
 
         bDead self = y self >= (screenHeight + chrSize * 3) * one || x self <= -chrSize * one

lang/haskell/nario/Actor/Kuribo.hs

@@ -32 +32 @@
                         (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres imgtype (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - ofsH - 8)
-                return ()
                 where
                         imgtype = [ImgKuri0, ImgKuri1] !! (cnt self `mod` 16 `div` 8)
@@ -66 +65 @@
         update fld self = (self { ccnt = ccnt self + 1 }, [])
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres ImgKuriDead (sx self - scrx) (sy self - 7 - 8)
-                return ()
 
         bDead self = ccnt self >= frameRate `div` 2

lang/haskell/nario/Actor/Nokonoko.hs

@@ -33 +33 @@
                         (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres imgtype (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - ofsH - 8)
-                return ()
                 where
                         imgtype = imgtbl !! (cnt self `mod` 16 `div` 8)

lang/haskell/nario/Actor/ScoreAdd.hs

@@ -26 +26 @@
         update _ self = (self { sy = sy self + vy, cnt = cnt self + 1 }, [])
 
-        render self imgres scrx sur = do
+        render self imgres scrx sur =
                 putimg sur imgres imgtype (sx self - scrx) (sy self)
-                return ()
                 where
                         imgtype = case pnt self of

lang/haskell/nario/AppUtil.hs

@@ -1 @@
-module AppUtil where
+module AppUtil (
+        KeyState(..),
+        isPressing,
+        KeyProc,
+        keyProc,
+
+        PadBtn(..),
+        padPressing,
+        padPressed,
+
+        ImageResource,
+        loadImageResource,
+        releaseImageResource,
+        getImageSurface,
+        putimg,
+
+        cellCrd,
+        Rect(..),
+        ishit
+) where
 
 import Multimedia.SDL (Surface, SDLKey(..), loadBMP, freeSurface, surfacePixelFormat, displayFormat, pfPalette, setColorKey, SurfaceFlag(..), blitSurface, pt)
@@ -9 +28 @@
 -- キーボード処理
 
-data PadBtn =
-        PadU | PadD | PadL | PadR | PadA | PadB
-        deriving (Eq, Show, Enum)
-
 data KeyState =
         Pushed | Pushing | Released | Releasing
-        deriving (Eq, Show)
+        deriving (Eq)
 
-isPressed Pushed  = True
-isPressed Pushing = True
-isPressed _       = False
+isPressing Pushed  = True
+isPressing Pushing = True
+isPressing _       = False
 
-type KeyProc = PadBtn -> KeyState
+type KeyProc = SDLKey -> KeyState
 
-keyProc bef cur gk
+keyProc :: [SDLKey] -> [SDLKey] -> KeyProc
+keyProc bef cur k
         | not bp && not cp = Releasing
         | not bp && cp     = Pushed
@@ -29 +45 @@
         | bp     && cp     = Pushing
         where
-                bp = any (flip elem bef) phykeys
-                cp = any (flip elem cur) phykeys
-                phykeys = mapPhyKey gk
+                bp = k `elem` bef
+                cp = k `elem` cur
 
-mapPhyKey PadU = [SDLK_UP, SDLK_i]
-mapPhyKey PadD = [SDLK_DOWN, SDLK_k]
-mapPhyKey PadL = [SDLK_LEFT, SDLK_j]
-mapPhyKey PadR = [SDLK_RIGHT, SDLK_l]
-mapPhyKey PadA = [SDLK_SPACE, SDLK_z]
-mapPhyKey PadB = [SDLK_LSHIFT, SDLK_RSHIFT]
+
+-- パッド
+
+data PadBtn =
+        PadU | PadD | PadL | PadR | PadA | PadB
+        deriving (Eq)
+
+padPressing kp btn = any (isPressing . kp) $ mapSDLKey btn
+padPressed kp btn = any ((== Pushed) . kp) $ mapSDLKey btn
+
+mapSDLKey PadU = [SDLK_UP, SDLK_i]
+mapSDLKey PadD = [SDLK_DOWN, SDLK_k]
+mapSDLKey PadL = [SDLK_LEFT, SDLK_j]
+mapSDLKey PadR = [SDLK_RIGHT, SDLK_l]
+mapSDLKey PadA = [SDLK_SPACE, SDLK_z]
+mapSDLKey PadB = [SDLK_LSHIFT, SDLK_RSHIFT]
 
 

lang/haskell/nario/Main.hs

@@ -86 +86 @@
 
 
--- キー入力を処理して描画コマンドを返す
+-- キー入力全体を処理して描画コマンド列を返す
 process :: [[SDLKey]] -> IO [Scr]
 process kss = do
@@ -93 +93 @@
 
         let tmpscrs = doTitle fldmap kss
-
-        let scrs = map (\scr sur -> scr imgres sur >> flipSurface sur >> return ()) $ tmpscrs
-        return $ scrs ++ [(\sur -> do {releaseImageResource imgres})]
-
+        let scrs = zipWith (common imgres) tmpscrs kss
+        return $ scrs ++ [final imgres]
+
+        where
+                -- 共通動作
+                common imgres scr ks sur = do
+                        scr imgres sur
+                        if SDLK_s `elem` ks
+                                then saveBMP sur "ss.bmp" >> return ()
+                                else return ()
+                        flipSurface sur
+                        return ()
+                -- 後始末
+                final imgres sur = releaseImageResource imgres
 
 -- タイトル
@@ -172 +182 @@
                 -- 更新
                 updateProc :: KeyProc -> GameGame -> (ImageResource -> Scr, GameGame)
-                updateProc kp gs = (renderProc gs', gs')
+                updateProc kp gs = (scr', gs')
                         where
                                 time' = max 0 (time gs - 1)
@@ -186 +196 @@
                                 gstmp = gs { pl = pl'', fld = fld', actors = actors'', time = time' }
                                 gs' = procEvent gstmp (plev ++ ev' ++ screv' ++ ev'')
+                                scr' = renderProc gs'
 
                 initialState = GameGame { pl = newPlayer, fld = fldmap, actors = [], time = 400 * timeBase }

lang/haskell/nario/Player.hs

@@ -26 +26 @@
 
 import Util
-import AppUtil (KeyProc, isPressed, PadBtn(..), cellCrd, KeyState(..), getImageSurface, Rect(..), putimg)
+import AppUtil (KeyProc, padPressed, padPressing, PadBtn(..), cellCrd, KeyState(..), getImageSurface, Rect(..), putimg)
 import Const
 import Images
@@ -132 +132 @@
                 x' = max xmin $ (x self) + vx'
 
-                padd = if isPressed (kp PadD) then True else False
-                padl = if isPressed (kp PadL) then 1 else 0
-                padr = if isPressed (kp PadR) then 1 else 0
+                padd = if padPressing kp PadD then True else False
+                padl = if padPressing kp PadL then 1 else 0
+                padr = if padPressing kp PadR then 1 else 0
                 maxspd
                         | not $ stand self      = walkVx `div` 2
-                        | isPressed (kp PadB)   = runVx
+                        | padPressing kp PadB   = runVx
                         | otherwise                             = walkVx
                 nowacc
-                        | isPressed (kp PadB)   = acc2
+                        | padPressing kp PadB   = acc2
                         | otherwise                             = acc
                 xmin = (scrx self + chrSize `div` 2) * one
@@ -237 +237 @@
 doJump :: KeyProc -> Player -> Player
 doJump kp self
-        | stand self && kp PadA == Pushed       = self { vy = vy', stand = False, pat = patJump }
+        | stand self && padPressed kp PadA      = self { vy = vy', stand = False, pat = patJump }
         | otherwise                                                     = self
         where
@@ -257 +257 @@
         moveY $ scroll self $ checkX fld $ moveX kp self
         where
-                moveY = checkCeil fld . doJump kp . checkFloor fld . fall (isPressed $ kp PadA)
+                moveY = checkCeil fld . doJump kp . checkFloor fld . fall (padPressing kp PadA)
 
 -- 死亡時

lang/haskell/nario/Util.hs

@@ -8 +8 @@
 
 -- けつの n 個取り出し
-lastN n xs = loop n [] xs
+lastN n xs = supply n [] xs
         where
-                loop _ acc [] = acc
-                loop 0 acc (x:xs) = loop 0 (tail acc ++ [x]) xs
-                loop n acc (x:xs) = loop (n-1) (acc ++ [x]) xs
+                supply _ acc [] = acc
+                supply 0 acc xs = queue acc xs
+                supply n acc (x:xs) = supply (n-1) (acc ++ [x]) xs
+                queue acc [] = acc
+                queue acc (x:xs) = queue (tail acc ++ [x]) xs
 
 -- 数値の符号を返す