Changeset 20243 for lang/haskell

Timestamp:

09/30/08 07:05:13 (2 months ago)

Author:

mokehehe

Message:

ブロックを叩けるようにしてみた（仮）

Location:

lang/haskell/nario

Files:

• Actor.hs (added)
• Const.hs (modified) (3 diffs)
• Event.hs (added)
• Field.hs (modified) (6 diffs)
• Main.hs (modified) (6 diffs)
• Player.hs (modified) (6 diffs)
• Util.hs (modified) (2 diffs)

lang/haskell/nario/Const.hs

@@ -20 +20 @@
         | ImgCloud00 | ImgCloud01 | ImgCloud02 | ImgCloud10 | ImgCloud11 | ImgCloud12
         | ImgDk00 | ImgDk01 | ImgDk10 | ImgDk11
-        | ImgGrass00 | ImgGrass01 | ImgGrass02
+        | ImgGrass0 | ImgGrass1 | ImgGrass2
         | ImgPole0 | ImgPole1
         | ImgFont
@@ -59 +59 @@
 imageFn ImgDk10 = "dk10.bmp"
 imageFn ImgDk11 = "dk11.bmp"
-imageFn ImgGrass00 = "grass00.bmp"
-imageFn ImgGrass01 = "grass01.bmp"
-imageFn ImgGrass02 = "grass02.bmp"
+imageFn ImgGrass0 = "grass0.bmp"
+imageFn ImgGrass1 = "grass1.bmp"
+imageFn ImgGrass2 = "grass2.bmp"
 imageFn ImgPole0 = "pole0.bmp"
 imageFn ImgPole1 = "pole1.bmp"
@@ -74 +74 @@
         ImgCloud00, ImgCloud01, ImgCloud02, ImgCloud10, ImgCloud11, ImgCloud12,
         ImgDk00, ImgDk01, ImgDk10, ImgDk11,
-        ImgGrass00, ImgGrass01, ImgGrass02,
+        ImgGrass0, ImgGrass1, ImgGrass2,
         ImgPole0, ImgPole1,
         ImgFont,

lang/haskell/nario/Field.hs

@@ +1 @@
+
+-- フィールド
+{-
+        ' '             空白
+        '*'             見えない壁（壁を下から叩いたときに一時的に見えない壁に置き換える）
+-}
 
 module Field (
@@ -4 +10 @@
         loadField,
         fieldRef,
+        fieldSet,
         isBlock,
         renderField
@@ -41 +48 @@
 chr2img '5' = ImgCloud11
 chr2img '6' = ImgCloud12
-chr2img '7' = ImgGrass00
-chr2img '8' = ImgGrass01
-chr2img '9' = ImgGrass02
+chr2img '7' = ImgGrass0
+chr2img '8' = ImgGrass1
+chr2img '9' = ImgGrass2
 chr2img '[' = ImgDk00
 chr2img ']' = ImgDk01
@@ -52 +59 @@
 
 
+
 isBlock :: Cell -> Bool
-isBlock c = c `elem` "@OX?[]l|"
+isBlock c = c `elem` "@OX?[]l|*"
 
 inField :: Field -> Int -> Int -> Bool
@@ -63 +71 @@
         | otherwise                     = ' '
 
+fieldSet :: Field -> Int -> Int -> Cell -> Field
+fieldSet fld x y c
+        | inField fld x y       = replace fld y $ replace (fld !! y) x c
+        | otherwise                     = fld
+
 
 renderField sur imgres scrx fld =
@@ -68 +81 @@
         where
                 lineProc (y, ln) = map (cellProc y) $ zip [0..] $ window ln
-                cellProc _ (_, ' ') = return ()
-                cellProc y (x, c) = putchr x y c >> return ()
+                cellProc y (x, c)
+                        | c `elem` " *" = return ()
+                        | otherwise             = putchr x y c >> return ()
                 putchr x y c = blitSurface (getImageSurface imgres $ chr2img c) Nothing sur $ pt (x*chrSize - rx) (y*chrSize - 8)
 

lang/haskell/nario/Main.hs

@@ -3 +3 @@
 module Main where
 
-import Multimedia.SDL
+import Multimedia.SDL hiding (Event)
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Control.Concurrent (threadDelay)
@@ -14 +14 @@
 import Const
 import Font
+import Event
+import Actor
 
 wndTitle = "NARIO in Haskell"
@@ -71 +73 @@
 ----
 
+
 -- 状態
 data GameState = GameState {
         pl :: Player,
-        fld :: Field
+        fld :: Field,
+        actors :: [Actor]
         }
 
@@ -82 +86 @@
         return GameState {
                 pl = newPlayer,
-                fld = fldmap
+                fld = fldmap,
+                actors = []
                 }
         where
                 stage = 0
+
 
 -- キー入力を処理して描画コマンドを返す
@@ -99 +105 @@
                 loop bef gs (ks:kss) = scr' : loop ks gs' kss
                         where
-                                (scr', gs') = update kp gs
+                                (scr', gs') = updateProc kp gs
                                 kp = keyProc bef ks
 
 -- 更新
-update :: KeyProc -> GameState -> (ImageResource -> Scr, GameState)
-update kp gs = (render gs', gs')
+updateProc :: KeyProc -> GameState -> (ImageResource -> Scr, GameState)
+updateProc kp gs = (renderProc gs', gs')
         where
-                gs' = gs { pl = updatePlayer kp (fld gs) (pl gs) }
+                (pl', ev) = updatePlayer kp (fld gs) (pl gs)
+                actors_updates = map updateActor (actors gs)
+                actors' = map fst actors_updates
+                ev' = concatMap snd actors_updates
+
+                gstmp = gs { pl = pl', actors = actors' }
+                gs' = procEvent gstmp (ev ++ ev')
+
+-- イベントを処理
+procEvent :: GameState -> [Event] -> GameState
+procEvent gs ev = foldl f gs ev
+        where
+                f gs (EvHitBlock imgtype cx cy) = gs { fld = fld', actors = actors' }
+                        where
+                                fld' = fieldSet (fld gs) cx cy '*'
+                                actors' = (newAnimBlock cx cy) : actors gs
+                f gs (EvSetField cx cy c) = gs { fld = fld' }
+                        where
+                                fld' = fieldSet (fld gs) cx cy c
+
 
 -- 描画
-render :: GameState -> ImageResource -> Scr
-render gs imgres sur = do
+renderProc :: GameState -> ImageResource -> Scr
+renderProc gs imgres sur = do
         fillRect sur Nothing backColor
 
@@ -117 +142 @@
         renderField sur imgres scrx (fld gs)
         renderPlayer sur imgres scrx (pl gs)
+
+        mapM_ (\act -> renderActor act imgres scrx sur) (actors gs)
 
         renderInfo gs imgres sur

lang/haskell/nario/Player.hs

@@ -10 +10 @@
 ) where
 
-import Multimedia.SDL
+import Multimedia.SDL hiding (Event)
 
 import Util
@@ -16 +16 @@
 import Const
 import Field
+import Event
 
 
@@ -63 +64 @@
         [ImgNarioRStand, ImgNarioRWalk1, ImgNarioRWalk2, ImgNarioRWalk3, ImgNarioRJump, ImgNarioRSlip]
         ]
-
-
-cellCrd :: Int -> Int
-cellCrd x = x `div` (chrSize * one)
 
 
@@ -125 +122 @@
                         | otherwise                                             = player
                         where
-                                cx = cellCrd (x player + dx * chrSize `div` 2 * one)
+                                cx = cellCrd (x player + ofsx dx)
                                 cy = cellCrd (y player - chrSize `div` 2 * one)
+                                ofsx (-1) = -6 * one
+                                ofsx   1  =  5 * one
 
 
@@ -153 +152 @@
                 isGround y = isBlock $ fieldRef fld (cellCrd $ x player) (cellCrd y)
 
-
 -- 上をチェック
-checkCeil :: Field -> Player -> Player
+checkCeil :: Field -> Player -> (Player, [Event])
 checkCeil fld player
-        | stand player || vy player >= 0 || not isCeil  = player
-        | otherwise = player { vy = 0 }
+        | stand player || vy player >= 0 || not isCeil  = (player, [])
+        | otherwise = (player { vy = 0 }, [EvHitBlock ImgBlock2 cx cy])
         where
                 ytmp = y player - one * chrSize
 
-                isCeil = isBlock $ fieldRef fld (cellCrd $ x player) (cellCrd ytmp)
+                cx = cellCrd $ x player
+                cy = cellCrd ytmp
+                isCeil = isBlock $ fieldRef fld cx cy
                 yground y = (cellCrd y) * (chrSize * one)
 
@@ -174 +174 @@
 
 -- 更新処理
-updatePlayer :: KeyProc -> Field -> Player -> Player
+updatePlayer :: KeyProc -> Field -> Player -> (Player, [Event])
 updatePlayer kp fld player =
         moveY $ checkX fld $ moveX kp player
         where
-                moveY = doJump kp . checkFloor fld . checkCeil fld . fall kp
+                moveY = checkCeil fld . doJump kp . checkFloor fld . fall kp
 
 -- スクロール位置取得

lang/haskell/nario/Util.hs

@@ -10 +10 @@
 
 -- ユーティリティ関数
+
+-- |Replace i-th element of list to v.
+replace :: [a] -> Int -> a -> [a]
+replace ls i v = take i ls ++ [v] ++ drop  (i + 1) ls
 
 -- 符号を返す
@@ -94 +98 @@
 getImageSurface :: ImageResource -> ImageType -> Surface
 getImageSurface imgres t = fromJust $ lookup t imgres
+
+
+-- 固定座標系からセル座標系に
+cellCrd :: Int -> Int
+cellCrd x = x `div` (chrSize * one)