Changeset 20811 for lang/haskell

Timestamp:

10/05/08 22:27:31 (5 years ago)

Author:

mokehehe

Message:

プレーヤー操作性調整
ノコノコを倒して蹴れるように
スコア演出追加

Location:

lang/haskell/nario

Files:

• Actor.hs (modified) (1 diff)
• Actor.hs-boot (added)
• Actor/AnimBlock.hs (modified) (1 diff)
• Actor/BrokenBlock.hs (modified) (1 diff)
• Actor/CoinGet.hs (modified) (2 diffs)
• Actor/Common.hs (added)
• Actor/Flower.hs (modified) (4 diffs)
• Actor/Kinoko.hs (modified) (5 diffs)
• Actor/Koura.hs (added)
• Actor/Kuribo.hs (modified) (4 diffs)
• Actor/Nokonoko.hs (modified) (3 diffs)
• Actor/ScoreAdd.hs (modified) (3 diffs)
• Const.hs (modified) (1 diff)
• Event.hs (modified) (2 diffs)
• Images.hs (modified) (1 diff)
• Main.hs (modified) (8 diffs)
• Player.hs (modified) (10 diffs)
• README.txt (modified) (1 diff)
• data/stage0.map (modified) (1 diff)

lang/haskell/nario/Actor.hs

@@ -27 +27 @@
         getHitRect _ = Nothing
 
-        onHit :: Player -> a -> (Player, Maybe ActorWrapper)
-        onHit pl ac = (pl, Nothing)
+        onHit :: Player -> a -> (Player, Maybe ActorWrapper, [Event])
+        onHit pl ac = (pl, Nothing, [])
 
 -- ============================================================================

lang/haskell/nario/Actor/AnimBlock.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- ブロックを叩いたときのバウンド演出
 

lang/haskell/nario/Actor/BrokenBlock.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- ブロックを叩いたときのバウンド演出
 

lang/haskell/nario/Actor/CoinGet.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- コインを取ったときの演出コイン
 
@@ -26 +27 @@
 instance Actor CoinGet where
         update _ self
-                | bDead self'   = (self', [EvScoreAddEfe (sx self) (y self `div` one) Img1000])
+                | bDead self'   = (self', [EvScoreAddEfe (sx self) (y self `div` one) pointGetCoin])
                 | otherwise             = (self', [])
                 where

lang/haskell/nario/Actor/Flower.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- フラワー
 
@@ -13 +14 @@
 import Images
 import Field
-import Player (PlayerType(..), getPlayerType, setPlayerType)
-
-maxVy = one * 6
+import Player (PlayerType(..), getPlayerType, setPlayerType, addScore)
+import Event (Event(..))
 
 
@@ -37 +37 @@
                         yy = y self `div` one
 
-        onHit pl self = (setPlayerType nt pl, Nothing)
+        onHit pl self = (addScore pointFlower $ setPlayerType nt pl, Nothing, ev)
                 where
                         nt = case typ of
@@ -44 +44 @@
                                 otherwise       -> typ
                         typ = getPlayerType pl
+                        ev = [EvScoreAddEfe (x self `div` one) (y self `div` one - chrSize * 2) pointFlower]
 
 

lang/haskell/nario/Actor/Kinoko.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- きのこ
 
@@ -8 +9 @@
 
 import Actor (Actor(..))
+import Actor.Common (updateActorBase)
 import Const
-import Util (sgn)
 import AppUtil (getImageSurface, cellCrd, Rect(..))
 import Images
 import Field
 import Player (PlayerType(..), getPlayerType, setPlayerType, addScore)
+import Event (Event(..))
 
-maxVy = one * 6
-
-pointKinoko = 1000
+ofsH = 15
 
 
@@ -28 +28 @@
 
 instance Actor Kinoko where
-        update fld self
-                | isGround      = (self { x = x', vx = vx', y = (cellCrd y') * one * chrSize, vy = 0 }, [])
-                | otherwise     = (self { x = x', vx = vx', y = y', vy = vy' }, [])
+        update fld self = (self', [])
                 where
-                        x' = x self + vx self
-                        sideWall = isBlock $ fieldRef fld (cellCrd $ x' + sgn (vx self) * 6 * one) (cellCrd $ y self - chrSize * one `div` 2)
-                        vx'
-                                | sideWall      = -(vx self)
-                                | otherwise     = vx self
-
-                        vy' = min maxVy $ vy self + gravity
-                        y' = y self + vy'
-                        isGround = isBlock $ fieldRef fld (cellCrd $ x') (cellCrd y')
+                        self' = self { x = x', y = y', vx = vx', vy = vy' }
+                        (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - 15 - 8))
+                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8))
                 return ()
                 where
                         imgtype = ImgKinoko
 
-        bDead self = y self `div` one >= screenHeight + chrSize * 3
+        bDead self = y self >= (screenHeight + chrSize * 3) * one || x self <= -chrSize * one
 
         getHitRect self = Just $ Rect (xx - 8) (yy - 16) (xx + 8) yy
@@ -55 +46 @@
                         yy = y self `div` one
 
-        onHit pl self = (addScore pointKinoko $ setPlayerType nt pl, Nothing)
+        onHit pl self = (addScore pointKinoko $ setPlayerType nt pl, Nothing, ev)
                 where
                         nt = case typ of
@@ -61 +52 @@
                                 otherwise       -> typ
                         typ = getPlayerType pl
-
+                        ev = [EvScoreAddEfe (x self `div` one) (y self `div` one - chrSize * 2) pointKinoko]
 
 newKinoko :: Int -> Int -> Kinoko

lang/haskell/nario/Actor/Kuribo.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- クリボー
 
@@ -8 +9 @@
 
 import Actor (Actor(..), ActorWrapper(..))
+import Actor.Common (updateActorBase, stamp)
 import Const
-import AppUtil
+import AppUtil (getImageSurface, cellCrd, Rect(..))
 import Images
-import Player (setPlayerDamage, getPlayerVY, stampPlayer)
+import Player (setPlayerDamage, stampPlayer, addScore)
+import Event (Event(..))
 
+ofsH = 15
 
 data Kuribo = Kuribo {
@@ -23 +27 @@
 
 instance Actor Kuribo where
-        update fld self = (self { x = x self + vx self, cnt = cnt self + 1 }, [])
+        update fld self = (self', [])
+                where
+                        self' = self { x = x', y = y', vx = vx', vy = vy', cnt = cnt self + 1 }
+                        (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - 15 - 8))
+                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (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)
+
+        bDead self = y self >= (screenHeight + chrSize * 3) * one || x self <= -chrSize * one
 
         getHitRect self = Just $ Rect (xx - 8) (yy - 16) (xx + 8) yy
@@ -37 +46 @@
 
         onHit pl self
-                | stamp         = (stampPlayer pl, Just $ ActorWrapper $ newStampedKuribo (x self `div` one - chrSize `div` 2) (y self `div` one))
-                | otherwise     = (setPlayerDamage pl, Just $ ActorWrapper self)
+                | stamp pl (x self, y self)     = (addScore pointKuribo $ stampPlayer pl, Just $ ActorWrapper $ newStampedKuribo (x self `div` one - chrSize `div` 2) (y self `div` one), ev)
+                | otherwise     = (setPlayerDamage pl, Just $ ActorWrapper self, [])
                 where
-                        stamp = getPlayerVY pl > 0
+                        ev = [EvScoreAddEfe (x self `div` one) (y self `div` one - chrSize * 2) pointKuribo]
 
 newKuribo :: Int -> Int -> Kuribo

lang/haskell/nario/Actor/Nokonoko.hs

@@ -1 @@
--- クリボー
+-- -*- mode: haskell; Encoding: UTF-8 -*-
+-- ノコノコ
 
 module Actor.Nokonoko (
@@ -5 +6 @@
 ) where
 
-import Multimedia.SDL hiding (Event)
+import Multimedia.SDL (blitSurface, pt)
 
-import Actor (Actor(..))
+import Actor (Actor(..), ActorWrapper(..))
+import Actor.Common (updateActorBase, stamp)
+import Actor.Koura
 import Const
-import AppUtil
+import AppUtil (getImageSurface, cellCrd, Rect(..))
 import Images
+import Player (setPlayerDamage, stampPlayer, addScore)
+import Event (Event(..))
 
+ofsH = 23
 
 data Nokonoko = Nokonoko {
@@ -22 +28 @@
 
 instance Actor Nokonoko where
-        update fld self = (self { x = x self + vx self, cnt = cnt self + 1 }, [])
+        update fld self = (self', [])
+                where
+                        self' = self { x = x', y = y', vx = vx', vy = vy', cnt = cnt self + 1 }
+                        (x', y', vx', vy') = updateActorBase fld (x self, y self, vx self, vy self)
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt ((x self) `div` one - scrx) ((y self) `div` one - 8))
+                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - ofsH - 8))
                 return ()
                 where
                         imgtype = [ImgNoko0, ImgNoko1] !! (cnt self `mod` 16 `div` 8)
 
+        bDead self = y self >= (screenHeight + chrSize * 3) * one || x self <= -chrSize * one
+
+        getHitRect self = Just $ Rect (xx - 8) (yy - 16) (xx + 8) yy
+                where
+                        xx = x self `div` one
+                        yy = y self `div` one
+
+        onHit pl self
+                | stamp pl (x self, y self)     = (addScore pointNokonoko $ stampPlayer pl, Just $ ActorWrapper $ newKoura (x self) (y self), ev)
+                | otherwise     = (setPlayerDamage pl, Just $ ActorWrapper self, [])
+                where
+                        ev = [EvScoreAddEfe (x self `div` one) (y self `div` one - chrSize * 2) pointNokonoko]
+
 newNokonoko :: Int -> Int -> Nokonoko
 newNokonoko cx cy =

lang/haskell/nario/Actor/ScoreAdd.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- スコアが増えるときの増分表示
 
@@ -15 +16 @@
 
 data ScoreAdd = ScoreAdd {
-        imgtype :: ImageType,
+        pnt :: Int,
         sx :: Int,
         sy :: Int,
@@ -26 +27 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres $ imgtype self) Nothing sur (pt (sx self - scrx) (sy self))
+                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (sx self - scrx) (sy self))
                 return ()
+                where
+                        imgtype = case pnt self of
+                                100             -> Img100
+                                200             -> Img200
+                                400             -> Img400
+                                500             -> Img500
+                                1000    -> Img1000
 
         bDead self = cnt self >= frameRate `div` 2
 
-newScoreAdd :: Int -> Int -> ImageType -> ScoreAdd
-newScoreAdd sx' sy' imgtype' =
-        ScoreAdd { imgtype = imgtype', sx = sx', sy = sy', cnt = 0 }
+newScoreAdd :: Int -> Int -> Int -> ScoreAdd
+newScoreAdd sx' sy' pnt' =
+        ScoreAdd { pnt = pnt', sx = sx', sy = sy', cnt = 0 }

lang/haskell/nario/Const.hs

@@ -17 +17 @@
 
 -- 重力
-gravity = one `div` 2
+gravity = one * 2 `div` 5
+
+
+-- ポイント
+pointKuribo = 100       :: Int
+pointNokonoko = 100     :: Int
+pointKinoko = 1000      :: Int
+pointFlower = 1000      :: Int
+pointBreakBlock = 50    :: Int
+pointGetCoin = 200      :: Int
+pointKoura = 400        :: Int

lang/haskell/nario/Event.hs

@@ -1 +1 @@
 module Event where
 
-import Const
-import Images
-import Field
+import Images (ImageType)
+import Field (Cell)
+import {-# SOURCE #-} Actor (Actor(..), ActorWrapper(..))
 
 data Event =
@@ -12 +12 @@
         |       EvSetField Int Int Cell
 
-                -- 敵登場
-        |       EvAppearEnemy Int Int Cell
+                -- アクター追加
+        |       EvAddActor ActorWrapper
 
                 -- スコア加算エフェクト
-        |       EvScoreAddEfe Int Int ImageType
+        |       EvScoreAddEfe Int Int Int

lang/haskell/nario/Images.hs

@@ -1 +1 @@
 module Images (ImageType(..), imageTypes, imageFn) where
 import Maybe (fromJust)
-data ImageType = Img100 | Img1000 | Img200 | Img500 | ImgBlock1 | ImgBlock2 | ImgBlock3 | ImgBlock4 | ImgBlock5 | ImgBroken | ImgCloud00 | ImgCloud01 | ImgCloud02 | ImgCloud10 | ImgCloud11 | ImgCloud12 | ImgCoin0 | ImgCoin1 | ImgCoin2 | ImgCoin3 | ImgDk00 | ImgDk01 | ImgDk10 | ImgDk11 | ImgFlag | ImgFlower | ImgFNarioLJump | ImgFNarioLShot | ImgFNarioLSit | ImgFNarioLSlip | ImgFNarioLStand | ImgFNarioLWalk1 | ImgFNarioLWalk2 | ImgFNarioLWalk3 | ImgFNarioRJump | ImgFNarioRShot | ImgFNarioRSit | ImgFNarioRSlip | ImgFNarioRStand | ImgFNarioRWalk1 | ImgFNarioRWalk2 | ImgFNarioRWalk3 | ImgFont | ImgGrass0 | ImgGrass1 | ImgGrass2 | ImgKinoko | ImgKuri0 | ImgKuri1 | ImgKuriDead | ImgMt02 | ImgMt11 | ImgMt12 | ImgMt13 | ImgMt22 | ImgNarioDead | ImgNarioLJump | ImgNarioLSlip | ImgNarioLStand | ImgNarioLWalk1 | ImgNarioLWalk2 | ImgNarioLWalk3 | ImgNarioRJump | ImgNarioRSlip | ImgNarioRStand | ImgNarioRWalk1 | ImgNarioRWalk2 | ImgNarioRWalk3 | ImgNoko0 | ImgNoko1 | ImgPole0 | ImgPole1 | ImgSNarioLJump | ImgSNarioLSit | ImgSNarioLSlip | ImgSNarioLStand | ImgSNarioLWalk1 | ImgSNarioLWalk2 | ImgSNarioLWalk3 | ImgSNarioRJump | ImgSNarioRSit | ImgSNarioRSlip | ImgSNarioRStand | ImgSNarioRWalk1 | ImgSNarioRWalk2 | ImgSNarioRWalk3 | ImgTitle     deriving (Eq)
-imageTypes = [Img100, Img1000, Img200, Img500, ImgBlock1, ImgBlock2, ImgBlock3, ImgBlock4, ImgBlock5, ImgBroken, ImgCloud00, ImgCloud01, ImgCloud02, ImgCloud10, ImgCloud11, ImgCloud12, ImgCoin0, ImgCoin1, ImgCoin2, ImgCoin3, ImgDk00, ImgDk01, ImgDk10, ImgDk11, ImgFlag, ImgFlower, ImgFNarioLJump, ImgFNarioLShot, ImgFNarioLSit, ImgFNarioLSlip, ImgFNarioLStand, ImgFNarioLWalk1, ImgFNarioLWalk2, ImgFNarioLWalk3, ImgFNarioRJump, ImgFNarioRShot, ImgFNarioRSit, ImgFNarioRSlip, ImgFNarioRStand, ImgFNarioRWalk1, ImgFNarioRWalk2, ImgFNarioRWalk3, ImgFont, ImgGrass0, ImgGrass1, ImgGrass2, ImgKinoko, ImgKuri0, ImgKuri1, ImgKuriDead, ImgMt02, ImgMt11, ImgMt12, ImgMt13, ImgMt22, ImgNarioDead, ImgNarioLJump, ImgNarioLSlip, ImgNarioLStand, ImgNarioLWalk1, ImgNarioLWalk2, ImgNarioLWalk3, ImgNarioRJump, ImgNarioRSlip, ImgNarioRStand, ImgNarioRWalk1, ImgNarioRWalk2, ImgNarioRWalk3, ImgNoko0, ImgNoko1, ImgPole0, ImgPole1, ImgSNarioLJump, ImgSNarioLSit, ImgSNarioLSlip, ImgSNarioLStand, ImgSNarioLWalk1, ImgSNarioLWalk2, ImgSNarioLWalk3, ImgSNarioRJump, ImgSNarioRSit, ImgSNarioRSlip, ImgSNarioRStand, ImgSNarioRWalk1, ImgSNarioRWalk2, ImgSNarioRWalk3, ImgTitle]
-imageFilenames = ["100.bmp", "1000.bmp", "200.bmp", "500.bmp", "block1.bmp", "block2.bmp", "block3.bmp", "block4.bmp", "block5.bmp", "broken.bmp", "cloud00.bmp", "cloud01.bmp", "cloud02.bmp", "cloud10.bmp", "cloud11.bmp", "cloud12.bmp", "coin0.bmp", "coin1.bmp", "coin2.bmp", "coin3.bmp", "dk00.bmp", "dk01.bmp", "dk10.bmp", "dk11.bmp", "flag.bmp", "flower.bmp", "fNarioLJump.bmp", "fNarioLShot.bmp", "fNarioLSit.bmp", "fNarioLSlip.bmp", "fNarioLStand.bmp", "fNarioLWalk1.bmp", "fNarioLWalk2.bmp", "fNarioLWalk3.bmp", "fNarioRJump.bmp", "fNarioRShot.bmp", "fNarioRSit.bmp", "fNarioRSlip.bmp", "fNarioRStand.bmp", "fNarioRWalk1.bmp", "fNarioRWalk2.bmp", "fNarioRWalk3.bmp", "font.bmp", "grass0.bmp", "grass1.bmp", "grass2.bmp", "kinoko.bmp", "kuri0.bmp", "kuri1.bmp", "kuriDead.bmp", "mt02.bmp", "mt11.bmp", "mt12.bmp", "mt13.bmp", "mt22.bmp", "narioDead.bmp", "narioLJump.bmp", "narioLSlip.bmp", "narioLStand.bmp", "narioLWalk1.bmp", "narioLWalk2.bmp", "narioLWalk3.bmp", "narioRJump.bmp", "narioRSlip.bmp", "narioRStand.bmp", "narioRWalk1.bmp", "narioRWalk2.bmp", "narioRWalk3.bmp", "noko0.bmp", "noko1.bmp", "pole0.bmp", "pole1.bmp", "sNarioLJump.bmp", "sNarioLSit.bmp", "sNarioLSlip.bmp", "sNarioLStand.bmp", "sNarioLWalk1.bmp", "sNarioLWalk2.bmp", "sNarioLWalk3.bmp", "sNarioRJump.bmp", "sNarioRSit.bmp", "sNarioRSlip.bmp", "sNarioRStand.bmp", "sNarioRWalk1.bmp", "sNarioRWalk2.bmp", "sNarioRWalk3.bmp", "title.bmp"]
+data ImageType = Img100 | Img1000 | Img200 | Img400 | Img500 | ImgBlock1 | ImgBlock2 | ImgBlock3 | ImgBlock4 | ImgBlock5 | ImgBroken | ImgCloud00 | ImgCloud01 | ImgCloud02 | ImgCloud10 | ImgCloud11 | ImgCloud12 | ImgCoin0 | ImgCoin1 | ImgCoin2 | ImgCoin3 | ImgDk00 | ImgDk01 | ImgDk10 | ImgDk11 | ImgFlag | ImgFlower | ImgFNarioLJump | ImgFNarioLShot | ImgFNarioLSit | ImgFNarioLSlip | ImgFNarioLStand | ImgFNarioLWalk1 | ImgFNarioLWalk2 | ImgFNarioLWalk3 | ImgFNarioRJump | ImgFNarioRShot | ImgFNarioRSit | ImgFNarioRSlip | ImgFNarioRStand | ImgFNarioRWalk1 | ImgFNarioRWalk2 | ImgFNarioRWalk3 | ImgFont | ImgGrass0 | ImgGrass1 | ImgGrass2 | ImgKinoko | ImgKoura | ImgKoura2 | ImgKuri0 | ImgKuri1 | ImgKuriDead | ImgMt02 | ImgMt11 | ImgMt12 | ImgMt13 | ImgMt22 | ImgNarioDead | ImgNarioLJump | ImgNarioLSlip | ImgNarioLStand | ImgNarioLWalk1 | ImgNarioLWalk2 | ImgNarioLWalk3 | ImgNarioRJump | ImgNarioRSlip | ImgNarioRStand | ImgNarioRWalk1 | ImgNarioRWalk2 | ImgNarioRWalk3 | ImgNoko0 | ImgNoko1 | ImgPole0 | ImgPole1 | ImgSNarioLJump | ImgSNarioLSit | ImgSNarioLSlip | ImgSNarioLStand | ImgSNarioLWalk1 | ImgSNarioLWalk2 | ImgSNarioLWalk3 | ImgSNarioRJump | ImgSNarioRSit | ImgSNarioRSlip | ImgSNarioRStand | ImgSNarioRWalk1 | ImgSNarioRWalk2 | ImgSNarioRWalk3 | ImgTitle     deriving (Eq)
+imageTypes = [Img100, Img1000, Img200, Img400, Img500, ImgBlock1, ImgBlock2, ImgBlock3, ImgBlock4, ImgBlock5, ImgBroken, ImgCloud00, ImgCloud01, ImgCloud02, ImgCloud10, ImgCloud11, ImgCloud12, ImgCoin0, ImgCoin1, ImgCoin2, ImgCoin3, ImgDk00, ImgDk01, ImgDk10, ImgDk11, ImgFlag, ImgFlower, ImgFNarioLJump, ImgFNarioLShot, ImgFNarioLSit, ImgFNarioLSlip, ImgFNarioLStand, ImgFNarioLWalk1, ImgFNarioLWalk2, ImgFNarioLWalk3, ImgFNarioRJump, ImgFNarioRShot, ImgFNarioRSit, ImgFNarioRSlip, ImgFNarioRStand, ImgFNarioRWalk1, ImgFNarioRWalk2, ImgFNarioRWalk3, ImgFont, ImgGrass0, ImgGrass1, ImgGrass2, ImgKinoko, ImgKoura, ImgKoura2, ImgKuri0, ImgKuri1, ImgKuriDead, ImgMt02, ImgMt11, ImgMt12, ImgMt13, ImgMt22, ImgNarioDead, ImgNarioLJump, ImgNarioLSlip, ImgNarioLStand, ImgNarioLWalk1, ImgNarioLWalk2, ImgNarioLWalk3, ImgNarioRJump, ImgNarioRSlip, ImgNarioRStand, ImgNarioRWalk1, ImgNarioRWalk2, ImgNarioRWalk3, ImgNoko0, ImgNoko1, ImgPole0, ImgPole1, ImgSNarioLJump, ImgSNarioLSit, ImgSNarioLSlip, ImgSNarioLStand, ImgSNarioLWalk1, ImgSNarioLWalk2, ImgSNarioLWalk3, ImgSNarioRJump, ImgSNarioRSit, ImgSNarioRSlip, ImgSNarioRStand, ImgSNarioRWalk1, ImgSNarioRWalk2, ImgSNarioRWalk3, ImgTitle]
+imageFilenames = ["100.bmp", "1000.bmp", "200.bmp", "400.bmp", "500.bmp", "block1.bmp", "block2.bmp", "block3.bmp", "block4.bmp", "block5.bmp", "broken.bmp", "cloud00.bmp", "cloud01.bmp", "cloud02.bmp", "cloud10.bmp", "cloud11.bmp", "cloud12.bmp", "coin0.bmp", "coin1.bmp", "coin2.bmp", "coin3.bmp", "dk00.bmp", "dk01.bmp", "dk10.bmp", "dk11.bmp", "flag.bmp", "flower.bmp", "fNarioLJump.bmp", "fNarioLShot.bmp", "fNarioLSit.bmp", "fNarioLSlip.bmp", "fNarioLStand.bmp", "fNarioLWalk1.bmp", "fNarioLWalk2.bmp", "fNarioLWalk3.bmp", "fNarioRJump.bmp", "fNarioRShot.bmp", "fNarioRSit.bmp", "fNarioRSlip.bmp", "fNarioRStand.bmp", "fNarioRWalk1.bmp", "fNarioRWalk2.bmp", "fNarioRWalk3.bmp", "font.bmp", "grass0.bmp", "grass1.bmp", "grass2.bmp", "kinoko.bmp", "koura.bmp", "koura2.bmp", "kuri0.bmp", "kuri1.bmp", "kuriDead.bmp", "mt02.bmp", "mt11.bmp", "mt12.bmp", "mt13.bmp", "mt22.bmp", "narioDead.bmp", "narioLJump.bmp", "narioLSlip.bmp", "narioLStand.bmp", "narioLWalk1.bmp", "narioLWalk2.bmp", "narioLWalk3.bmp", "narioRJump.bmp", "narioRSlip.bmp", "narioRStand.bmp", "narioRWalk1.bmp", "narioRWalk2.bmp", "narioRWalk3.bmp", "noko0.bmp", "noko1.bmp", "pole0.bmp", "pole1.bmp", "sNarioLJump.bmp", "sNarioLSit.bmp", "sNarioLSlip.bmp", "sNarioLStand.bmp", "sNarioLWalk1.bmp", "sNarioLWalk2.bmp", "sNarioLWalk3.bmp", "sNarioRJump.bmp", "sNarioRSit.bmp", "sNarioRSlip.bmp", "sNarioRStand.bmp", "sNarioRWalk1.bmp", "sNarioRWalk2.bmp", "sNarioRWalk3.bmp", "title.bmp"]
 imageFn = fromJust . flip lookup (zip imageTypes imageFilenames)

lang/haskell/nario/Main.hs

@@ -34 +34 @@
 
 
-pointBreakBlock = 50
-pointGetCoin = 200
-
-
 -- エントリ
 main :: IO ()
@@ -130 +126 @@
                 cols = map (!! cx) fld
                 event cy c
-                        | c `elem` "kn" = Just $ EvAppearEnemy cx cy c
+                        | c `elem` "kn" = Just $ EvAddActor $ genActor c
                         | otherwise             = Nothing
+                        where
+                                genActor c = case c of
+                                        'k'     -> ActorWrapper $ newKuribo cx cy
+                                        'n'     -> ActorWrapper $ newNokonoko cx cy
+
 
 
 -- 当たり判定
-hitcheck :: Player -> [ActorWrapper] -> (Player, [ActorWrapper])
-hitcheck player actors = foldl proc (player, []) actors
-        where
-                proc (pl, ac) (ActorWrapper a) = case getHitRect a of
+hitcheck :: Player -> [ActorWrapper] -> (Player, [ActorWrapper], [Event])
+hitcheck player actors = foldl proc (player, [], []) actors
+        where
+                proc (pl, ac, ev) (ActorWrapper a) = case getHitRect a of
                         Nothing -> nothingHappened
                         Just rc ->
                                 if not $ ishit plrc rc
                                         then nothingHappened
-                                        else (pl', ac')
-                        where
-                                nothingHappened = (pl, ac ++ [ActorWrapper a])
+                                        else (pl', ac', ev')
+                        where
+                                nothingHappened = (pl, ac ++ [ActorWrapper a], ev)
                                 plrc = getPlayerHitRect player
-                                (pl', a') = onHit pl a
+                                (pl', a', evtmp) = onHit pl a
                                 ac' = case a' of
                                         Just a''        -> ac ++ [a'']
                                         Nothing         -> ac
-
+                                ev' = ev ++ evtmp
+
+
+timeBase = 22
 
 -- ゲーム
@@ -161 +165 @@
                         where
                                 (scr', gs') = updateProc (keyProc bef ks) gs
-                                isPlayerDead = getPlayerYPos (pl gs') >= screenHeight + chrSize * 2
+                                isPlayerDead = getPlayerY (pl gs') >= (screenHeight + chrSize * 2) * one
                                 timeOver = time gs' <= 0
 
@@ -172 +176 @@
                 updateProc kp gs = (renderProc gs', gs')
                         where
-                                time' = max 0 (time gs - one `div` 25)
+                                time' = max 0 (time gs - 1)
                                 (fld', screv') = scrollEvent (fld gs) $ getScrollPos (pl gs) `div` chrSize + 18
 
@@ -180 +184 @@
                                 ev' = concatMap snd actors_updates
 
-                                (pl'', actors'') = hitcheck pl' actors'
+                                (pl'', actors'', ev'') = hitcheck pl' actors'
 
                                 gstmp = gs { pl = pl'', fld = fld', actors = actors'', time = time' }
-                                gs' = procEvent gstmp (plev ++ ev' ++ screv')
-
-                initialState = GameGame { pl = newPlayer, fld = fldmap, actors = [], time = 400 * one }
+                                gs' = procEvent gstmp (plev ++ ev' ++ screv' ++ ev'')
+
+                initialState = GameGame { pl = newPlayer, fld = fldmap, actors = [], time = 400 * timeBase }
 
 -- ゲームオーバー
@@ -221 +225 @@
 
                 proc gs (EvSetField cx cy c) = gs { fld = fieldSet (fld gs) cx cy c }
-                proc gs (EvAppearEnemy cx cy c) = gs { actors = actors gs ++ [ene] }
-                        where
-                                ene = case c of
-                                        'k'     -> ActorWrapper $ newKuribo cx cy
-                                        'n'     -> ActorWrapper $ newNokonoko cx cy
-                proc gs (EvScoreAddEfe sx sy imgtype) = gs { actors = actors gs ++ [ActorWrapper $ newScoreAdd sx sy imgtype] }
+                proc gs (EvAddActor act) = gs { actors = actors gs ++ [act] }
+                proc gs (EvScoreAddEfe sx sy pnt) = gs { actors = actors gs ++ [ActorWrapper $ newScoreAdd sx sy pnt] }
 
 -- 描画
@@ -255 +255 @@
         puts 19 2 "1-1"
         puts 25 1 "TIME"
-        puts 26 2 $ deciWide 3 ' ' ((time gs + one-1) `div` one)
+        puts 26 2 $ deciWide 3 '0' ((time gs + timeBase-1) `div` timeBase)
 
         where
@@ -264 +264 @@
 renderTitle imgres sur = do
         blitSurface (getImageSurface imgres ImgTitle) Nothing sur (pt (5*8) (3*8))
-        puts 13 14 "@1985 NINTENDO"
+--      puts 13 14 "@1985 NINTENDO"
         puts 9 17 "> 1 PLAYER GAME"
 --      puts 9 19 "  2 PLAYER GAME"

lang/haskell/nario/Player.hs

@@ -10 +10 @@
         addScore,
         getScrollPos,
-        getPlayerYPos,
+        getPlayerX,
+        getPlayerY,
         getPlayerVY,
         getPlayerHitRect,
@@ -32 +33 @@
 
 
-walkVx = one * 3 `div` 2
-runVx = one * 3
-maxVy = one * 6
-acc = one `div` 6
-jumpVy = -13 * gravity
-scrollMinX = 5 * chrSize
+walkVx = one * 4 `div` 2
+runVx = one * 11 `div` 4
+maxVy = one * 5
+acc = one `div` 32
+acc2 = one `div` 14
+jumpVy = -12 * gravity
+jumpVy2 = -13 * gravity
+scrollMinX = 5 * chrSize + 6
 scrollMaxX = 8 * chrSize
-gravity2 = one `div` 4          -- Aを長押ししたときの重力
+gravity2 = one `div` 6          -- Aを長押ししたときの重力
 stampVy = -8 * gravity
 undeadFrame = frameRate * 2
@@ -121 +124 @@
                 else self'
         where
-                ax = if padd then 0 else (-padl + padr) * acc
+                axtmp = if padd then 0 else (-padl + padr) * nowacc
+                ax = if sgn (axtmp * vx self) < 0 then axtmp * 2 else axtmp
                 vx'
                         | ax /= 0                       = rangeadd (vx self) ax (-maxspd) maxspd
@@ -127 +131 @@
                         | otherwise                     = vx self
                 x' = max xmin $ (x self) + vx'
-                scrx'
-                        | vx' > 0 && (x' - (scrx self)) `div` one > scrollPos   = (scrx self) + vx'
-                        | otherwise                                                                                             = (scrx self)
-
-                scrollPos = (max vx' 0) * (scrollMaxX - scrollMinX) `div` runVx + scrollMinX
 
                 padd = if isPressed (kp PadD) then True else False
@@ -138 +137 @@
                 maxspd
                         | not $ stand self      = walkVx `div` 2
-                        | isPressed (kp PadB)   = walkVx * 2
+                        | isPressed (kp PadB)   = runVx
                         | otherwise                             = walkVx
-                xmin = (scrx self) + chrSize `div` 2 * one
-
-                self' = self { x = x', vx = vx', scrx = scrx' }
+                nowacc
+                        | isPressed (kp PadB)   = acc2
+                        | otherwise                             = acc
+                xmin = (scrx self + chrSize `div` 2) * one
+
+                self' = self { x = x', vx = vx' }
 
                 lr' =
@@ -160 +162 @@
                 anmCnt = walkVx * 3
 
-
 -- 横移動チェック
 checkX :: Field -> Player -> Player
@@ -177 +178 @@
                                 ofsx   1  =  5 * one
 
+-- スクロール
+scroll :: Player -> Player -> Player
+scroll opl self = self { scrx = scrx' }
+        where
+                odx = x opl `div` one - scrx opl
+                dx = (max 0 $ vx self) * (scrollMaxX - scrollMinX) `div` runVx + scrollMinX
+                scrx'
+                        | d > 0         = scrx self + d
+                        | otherwise     = scrx self
+                d = x self `div` one - scrx self - (max odx dx)
+
 
 -- 重力による落下
@@ -222 +234 @@
                 y' = ((cy + 1) * chrSize + yofs) * one
 
-
 -- ジャンプする？
 doJump :: KeyProc -> Player -> Player
 doJump kp self
-        | stand self && kp PadA == Pushed       = self { vy = jumpVy, stand = False, pat = patJump }
+        | stand self && kp PadA == Pushed       = self { vy = vy', stand = False, pat = patJump }
         | otherwise                                                     = self
-
+        where
+                vy' = (jumpVy2 - jumpVy) * (abs $ vx self) `div` runVx + jumpVy
 
 -- 更新処理
@@ -243 +255 @@
 updateNormal :: KeyProc -> Field -> Player -> (Player, [Event])
 updateNormal kp fld self =
-        moveY $ checkX fld $ moveX kp self
+        moveY $ scroll self $ checkX fld $ moveX kp self
         where
                 moveY = checkCeil fld . doJump kp . checkFloor fld . fall (isPressed $ kp PadA)
@@ -253 +265 @@
 -- スクロール位置取得
 getScrollPos :: Player -> Int
-getScrollPos self = (scrx self) `div` one
+getScrollPos = scrx
+
+-- Ｘ座標取得
+getPlayerX :: Player -> Int
+getPlayerX = x
 
 -- Ｙ座標取得
-getPlayerYPos :: Player -> Int
-getPlayerYPos = (`div` one) . y
+getPlayerY :: Player -> Int
+getPlayerY = y
 
 -- Ｙ速度取得

lang/haskell/nario/README.txt

@@ -67 +67 @@
         存在型
         http://d.hatena.ne.jp/syd_syd/20080805#p2
+
+        Haskellの循環import問題 - ABAの日誌
+        http://d.hatena.ne.jp/ABA/20060627#p1

lang/haskell/nario/data/stage0.map

@@ -11 +11 @@
   _                                   []      l|  _      l|                                      k_k                                    XX  XX    _   XXX  XX                          XXXXXXX    _   !         
  /,\             _          []        l|      l| /,\     l|      _                               /,\             _                     XXX  XXX  /,\ XXXX  XXX   _ []              [] XXXXXXXX   /,\  !   OO OO 
-/,.,\      78889/,\ k  789  l|        l|k7889 l|/,.,\k k l|78889/,\    789                      /,.,\     n78889/,\k k 789  k k  k k  XXXX  XXXX/,.,XXXXX  XXXX9/,\l|  789    k k  l|XXXXXXXXX  /,.,\ X   OO OO9
+/,.,\      78889/,\ k  789  l|        l|k7889 l|/,.,\k k l|78889/,\    789                      /,.,\     n78889/,\k k 789  k k  k    XXXX  XXXX/,.,XXXXX  XXXX9/,\l|  789    k k  l|XXXXXXXXX  /,.,\ X   OO OO9
 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  @@@@@@@@@@@@@@@   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  @@@@@@@@@@@@@@@   @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@  @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@