Changeset 20534

Timestamp:

10/03/08 01:04:54 (3 months ago)

Author:

mokehehe

Message:

Existence 型を使って書き換え

Location:

lang/haskell/nario

Files:

• Actor.hs (modified) (6 diffs)
• Images.hs (modified) (1 diff)
• Main.hs (modified) (6 diffs)
• tool/listup-imgs.hs (modified) (1 diff)

lang/haskell/nario/Actor.hs

@@ +1 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
 
 module Actor where
@@ -10 +11 @@
 import Event
 
-
-data AnimBlock = AnimBlock { startcy :: Int, x :: Int, y :: Int, vy :: Int }
-
-data Actor = ActNull | ActAnimBlock AnimBlock
+class Actor a where
+        update :: a -> (a, [Event])
+        render :: a -> ImageResource -> Int -> Surface -> IO ()
+        bDead :: a -> Bool
 
 -- ============================================================================
@@ -19 +20 @@
 --      死亡
 
-updateNull = (ActNull, [])
+data AnimNull = AnimNull
 
-renderNull imgres scrx sur = return ()
-
-bDieNull = True
+instance Actor AnimNull where
+        update self = (self, [])
+        render self imgres scrx sur = return ()
+        bDead self = True
 
 
@@ -30 +32 @@
 --      ブロックを叩いたときのバウンド演出
 
-updateAnimBlock self = result'
-        where
-                result'
-                        | not bEnd      = (ActAnimBlock $ self { vy = vy', y = y' }, [])
-                        | otherwise     = (ActNull, [EvSetField (cellCrd $ x self) (startcy self) '@'])
+data AnimBlock = AnimBlock { startcy :: Int, x :: Int, y :: Int, vy :: Int }
 
-                vy' = vy self + gravity
-                y' = y self + vy'
-                bEnd = y' >= startcy self * chrSize * one
+instance Actor AnimBlock where
+        update self = result'
+                where
+                        result'
+                                | not bEnd      = (self { vy = vy', y = y' }, [])
+                                | otherwise     = (self, [EvSetField (cellCrd $ x self) (startcy self) '@'])
+
+                        vy' = vy self + gravity
+                        y' = y self + vy'
+                        bEnd = y' >= startcy self * chrSize * one
+
+        render self imgres scrx sur = do
+                blitSurface (getImageSurface imgres ImgBlock2) Nothing sur (pt ((x self) `div` one - scrx) ((y self) `div` one - 8))
+                return ()
+
+        bDead self = False
 
 
-renderAnimBlock self imgres scrx sur = do
-        blitSurface (getImageSurface imgres ImgBlock2) Nothing sur (pt ((x self) `div` one - scrx) ((y self) `div` one - 8))
-        return ()
-
-bDieAnimBlock self = False
-
-newAnimBlock cx cy = ActAnimBlock $ AnimBlock { startcy = cy, x = cx * chrSize * one, y = cy * chrSize * one, vy = -3 * one }
-
+newAnimBlock cx cy = AnimBlock { startcy = cy, x = cx * chrSize * one, y = cy * chrSize * one, vy = -3 * one }
 
 
@@ -54 +58 @@
 -- ============================================================================
 
+{-
 updateActor :: Actor -> (Actor, [Event])
 updateActor ActNull                             = updateNull
@@ -65 +70 @@
 bDieActor ActNull                               = bDieNull
 bDieActor (ActAnimBlock a)              = bDieAnimBlock a
-
+-}

lang/haskell/nario/Images.hs

@@ -1 +1 @@
 module Images (ImageType(..), imageTypes, imageFn) where
-import Maybe
+import Maybe (fromJust)
 data ImageType = ImgBlock1 | ImgBlock2 | ImgBlock3 | ImgBlock4 | ImgBlock5 | ImgCloud00 | ImgCloud01 | ImgCloud02 | ImgCloud10 | ImgCloud11 | ImgCloud12 | ImgDk00 | ImgDk01 | ImgDk10 | ImgDk11 | ImgFlag | ImgFont | ImgGrass0 | ImgGrass1 | ImgGrass2 | ImgMt02 | ImgMt11 | ImgMt12 | ImgMt13 | ImgMt22 | ImgNarioDie | ImgNarioLJump | ImgNarioLSlip | ImgNarioLStand | ImgNarioLWalk1 | ImgNarioLWalk2 | ImgNarioLWalk3 | ImgNarioRJump | ImgNarioRSlip | ImgNarioRStand | ImgNarioRWalk1 | ImgNarioRWalk2 | ImgNarioRWalk3 | ImgPole0 | ImgPole1 | ImgTitle       deriving (Eq)
 imageTypes = [ImgBlock1, ImgBlock2, ImgBlock3, ImgBlock4, ImgBlock5, ImgCloud00, ImgCloud01, ImgCloud02, ImgCloud10, ImgCloud11, ImgCloud12, ImgDk00, ImgDk01, ImgDk10, ImgDk11, ImgFlag, ImgFont, ImgGrass0, ImgGrass1, ImgGrass2, ImgMt02, ImgMt11, ImgMt12, ImgMt13, ImgMt22, ImgNarioDie, ImgNarioLJump, ImgNarioLSlip, ImgNarioLStand, ImgNarioLWalk1, ImgNarioLWalk2, ImgNarioLWalk3, ImgNarioRJump, ImgNarioRSlip, ImgNarioRStand, ImgNarioRWalk1, ImgNarioRWalk2, ImgNarioRWalk3, ImgPole0, ImgPole1, ImgTitle]

lang/haskell/nario/Main.hs

@@ +1 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
 -- Nario
 
@@ -74 +76 @@
 
 ----
+data ObjWrapper = forall a. Actor a => ObjWrapper a     -- 存在型aの動く範囲を型クラスDuckに制限
+
+updateActors :: [ObjWrapper] -> [(ObjWrapper, [Event])]
+updateActors = map (\(ObjWrapper x) -> let (x', ev') = update x in (ObjWrapper x', ev'))
+
+renderActors :: ImageResource -> Int -> Surface -> [ObjWrapper] -> IO ()
+renderActors imgres ofsx sur = mapM_ (\(ObjWrapper x) -> render x imgres ofsx sur)
 
 
@@ -81 +90 @@
                 pl :: Player,
                 fld :: Field,
-                actors :: [Actor],
+                actors :: [ObjWrapper],
                 time :: Int
         }
@@ -134 +143 @@
                                 time' = max 0 (time gs - one `div` 25)
                                 (pl', ev) = updatePlayer kp (fld gs) (pl gs)
-                                actors_updates = map updateActor (actors gs)
+                                actors_updates = updateActors (actors gs)
                                 actors' = map fst actors_updates
                                 ev' = concatMap snd actors_updates
@@ -153 +162 @@
                         where
                                 fld' = fieldSet (fld gs) cx cy '*'
-                                actors' = (newAnimBlock cx cy) : actors gs
+                                actors' = (ObjWrapper $ newAnimBlock cx cy) : actors gs
                 f gs (EvSetField cx cy c) = gs { fld = fld' }
                         where
@@ -170 +179 @@
         renderPlayer sur imgres scrx (pl gs)
 
-        mapM_ (\act -> renderActor act imgres scrx sur) (actors gs)
+        renderActors imgres scrx sur (actors gs)
         return ()
 

lang/haskell/nario/tool/listup-imgs.hs

@@ -43 +43 @@
 
         putStrLn "module Images (ImageType(..), imageTypes, imageFn) where"
-        putStrLn "import Maybe"
+        putStrLn "import Maybe (fromJust)"
 
         putStrLn $ "data ImageType = " ++ intercalate " | " symbols ++ "\tderiving (Eq)"