Changeset 20925

Timestamp:

10/07/08 20:42:00 (3 months ago)

Author:

mokehehe

Message:

ソース整理

Location:

lang/haskell/nario

Files:

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

lang/haskell/nario/Actor.hs

@@ -1 +1 @@
 {-# OPTIONS_GHC -fglasgow-exts #-}
+-- -*- mode: haskell; Encoding: UTF-8 -*-
+
+-- ゲーム内に登場するオブジェクト
 
 module Actor (
@@ -11 +14 @@
 import Multimedia.SDL (Surface)
 
+import AppUtil (ImageResource, Rect)
 import Event (Event)
-import AppUtil (ImageResource, Rect)
 import Field (Field)
 import Player (Player)
@@ -30 +33 @@
         onHit pl ac = (pl, Nothing, [])
 
--- ============================================================================
 
 ----

lang/haskell/nario/Actor/AnimBlock.hs

@@ -1 @@
--- -*- mode: haskell; Encoding: UTF-8 -*-
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- ブロックを叩いたときのバウンド演出
 
@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL hiding (Event)
+--import Multimedia.SDL hiding (Event)
 
 import Actor (Actor(..))
+import AppUtil (cellCrd, putimg)
 import Const
-import AppUtil
-import Images
-import Field
-import Event
+import Field (Cell, chr2img)
+import Event (Event(..))
 
 
@@ -33 +32 @@
                         y' = y self + vy'
                         self' = self { vy = vy', y = y' }
-                        ev' = if (bDead self')
+                        ev' = if bDead self'
                                 then [EvSetField (cellCrd $ x self) (startcy self) $ chr self]
                                 else []
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres $ chr2img $ chr self) Nothing sur (pt (x self `div` one - scrx) (y self `div` one - 8))
+                putimg sur imgres (chr2img $ chr self) (x self `div` one - scrx) (y self `div` one - 8)
                 return ()
 

lang/haskell/nario/Actor/BrokenBlock.hs

@@ -9 +9 @@
 
 import Actor (Actor(..))
-import AppUtil
 import Const
+import AppUtil (putimg)
 import Images
 
@@ -25 +25 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres ImgBroken) Nothing sur (pt (x self `div` one - 4 - scrx) (y self `div` one - 4 - 8))
+                putimg sur imgres ImgBroken (x self `div` one - 4 - scrx) (y self `div` one - 4 - 8)
                 return ()
 

lang/haskell/nario/Actor/CoinGet.hs

@@ -1 @@
--- -*- mode: haskell; Encoding: UTF-8 -*-
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- コインを取ったときの演出コイン
 
@@ -9 +9 @@
 
 import Actor (Actor(..))
-import AppUtil
+import AppUtil (putimg)
 import Const
 import Images
-import Event
+import Event (Event(..))
 
 
@@ -33 +33 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (sx self - scrx) (y self `div` one - 8))
+                putimg sur imgres imgtype (sx self - scrx) (y self `div` one - 8)
                 return ()
                 where

lang/haskell/nario/Actor/Flower.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL (blitSurface, pt)
+--import Multimedia.SDL (itSurface, pt)
 
 import Actor (Actor(..))
 import Const
 import Util (sgn)
-import AppUtil (getImageSurface, cellCrd, Rect(..))
+import AppUtil (cellCrd, Rect(..), putimg)
 import Images
-import Field
 import Player (PlayerType(..), getPlayerType, setPlayerType, addScore)
 import Event (Event(..))
@@ -29 +28 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres ImgFlower) Nothing sur (pt ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - 15 - 8))
+                putimg sur imgres ImgFlower ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - 15 - 8)
                 return ()
 

lang/haskell/nario/Actor/Kinoko.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL (blitSurface, pt)
+--import Multimedia.SDL (blitSurface, pt)
 
 import Actor (Actor(..))
 import Actor.Common (updateActorBase)
+import AppUtil (Rect(..), putimg)
 import Const
-import AppUtil (getImageSurface, Rect(..))
 import Images
 import Player (PlayerType(..), getPlayerType, setPlayerType, addScore)
@@ -33 +33 @@
 
         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 - ofsH - 8))
+                putimg sur imgres imgtype ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
                 return ()
                 where

lang/haskell/nario/Actor/Koura.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL (blitSurface, pt)
+--import Multimedia.SDL (blitSurface, pt)
 
 import Actor (Actor(..), ActorWrapper(..))
 import Actor.Common (updateActorBase, stamp)
+import AppUtil (Rect(..), putimg)
 import Const
-import AppUtil (getImageSurface, Rect(..))
 import Images
 import Player (getPlayerX, stampPlayer, setPlayerDamage, addScore)
@@ -44 +44 @@
 
         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 - ofsH - 8))
+                putimg sur imgres imgtype ((x self) `div` one - chrSize `div` 2 - scrx) ((y self) `div` one - ofsH - 8)
                 return ()
                 where

lang/haskell/nario/Actor/Kuribo.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL (blitSurface, pt)
+--import Multimedia.SDL (blitSurface, pt)
 
 import Actor (Actor(..), ActorWrapper(..))
 import Actor.Common (updateActorBase, stamp)
+import AppUtil (Rect(..), putimg)
 import Const
-import AppUtil (getImageSurface, Rect(..))
 import Images
 import Player (setPlayerDamage, stampPlayer, addScore)
@@ -33 +33 @@
 
         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 - ofsH - 8))
+                putimg sur imgres imgtype (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - ofsH - 8)
                 return ()
                 where
@@ -67 +67 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres ImgKuriDead) Nothing sur (pt (sx self - scrx) (sy self - 7 - 8))
+                putimg sur imgres ImgKuriDead (sx self - scrx) (sy self - 7 - 8)
                 return ()
 

lang/haskell/nario/Actor/Nokonoko.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL (blitSurface, pt)
+--import Multimedia.SDL (blitSurface, pt)
 
 import Actor (Actor(..), ActorWrapper(..))
 import Actor.Common (updateActorBase, stamp)
 import Actor.Koura
+import AppUtil (Rect(..), putimg)
 import Const
-import AppUtil (getImageSurface, Rect(..))
 import Images
 import Player (setPlayerDamage, stampPlayer, addScore)
@@ -34 +34 @@
 
         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 - ofsH - 8))
+                putimg sur imgres imgtype (x self `div` one - chrSize `div` 2 - scrx) (y self `div` one - ofsH - 8)
                 return ()
                 where

lang/haskell/nario/Actor/ScoreAdd.hs

@@ -6 +6 @@
 ) where
 
-import Multimedia.SDL hiding (Event)
+--import Multimedia.SDL hiding (Event)
 
 import Actor (Actor(..))
-import AppUtil
+import AppUtil (putimg)
 import Const
 import Images
@@ -27 +27 @@
 
         render self imgres scrx sur = do
-                blitSurface (getImageSurface imgres imgtype) Nothing sur (pt (sx self - scrx) (sy self))
+                putimg sur imgres imgtype (sx self - scrx) (sy self)
                 return ()
                 where

lang/haskell/nario/AppUtil.hs

@@ -1 +1 @@
 module AppUtil where
 
-import Multimedia.SDL (Surface, SDLKey(..), loadBMP, freeSurface, surfacePixelFormat, displayFormat, pfPalette, setColorKey, SurfaceFlag(..))
+import Multimedia.SDL (Surface, SDLKey(..), loadBMP, freeSurface, surfacePixelFormat, displayFormat, pfPalette, setColorKey, SurfaceFlag(..), blitSurface, pt)
 import Data.Maybe (fromJust)
 
@@ -69 +69 @@
 getImageSurface imgres = fromJust . flip lookup imgres
 
+putimg :: Surface -> ImageResource -> ImageType -> Int -> Int -> IO ()
+putimg sur imgres imgtype x y = do
+        blitSurface (getImageSurface imgres imgtype) Nothing sur (pt x y)
+        return ()
+
 
 -- 固定座標系からセル座標系に

lang/haskell/nario/Field.hs

@@ -94 +94 @@
                         | 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)
+                putchr x y c = putimg sur imgres (chr2img c) (x*chrSize - rx) (y*chrSize - 8)
 
                 -- 表示される部分だけ取り出す

lang/haskell/nario/Font.hs

@@ +1 @@
+-- -*- mode: haskell; Encoding: UTF-8 -*-
 -- Bitmap font
 module Font (
+        Font(..),
         fontPut,
         fontPutc
 ) where
 
-import Multimedia.SDL
-import Control.Monad
-import Data.Char
+import Multimedia.SDL (blitSurface, pt, Rect(..), Surface)
+import Control.Monad (zipWithM_)
+import Data.Char (ord)
 
-fontWidth = 8
-fontHeight = 8
-fontXN = 16
+data Font = Font {
+        fontSurface :: Surface,
+        fontWidth :: Int,
+        fontHeight :: Int,
+        fontXN :: Int
+        }
+
 
 -- 文字列表示
-fontPut sur imgsur x y str = zipWithM_ (\i c -> fontPutc sur imgsur i y c) [x..] str
+fontPut font sur x y str = zipWithM_ (\i c -> fontPutc font sur i y c) [x..] str
 
 -- １文字表示
-fontPutc sur imgsur x y c = do
-        blitSurface imgsur (Just rc) sur pos
+fontPutc font sur x y c = do
+        blitSurface (fontSurface font) (Just rc) sur pos
         where
-                pos = pt (x * fontWidth) (y * fontHeight)
+                pos = pt (x * (fontWidth font)) (y * (fontHeight font))
                 ic = ord c - ord ' '
-                u = (ic `mod` fontXN) * fontWidth
-                v = (ic `div` fontXN) * fontHeight
-                rc = Rect u v fontWidth fontHeight
+                u = (ic `mod` xn) * w
+                v = (ic `div` xn) * h
+                rc = Rect u v w h
+
+                xn = fontXN font
+                w = fontWidth font
+                h = fontHeight font

lang/haskell/nario/Main.hs

@@ -240 +240 @@
         return ()
 
-tailN n = reverse . take n . reverse
-
-deciWide w c n = tailN w $ replicate w c ++ show n
-
 -- 情報描画
 renderInfo :: GameGame -> ImageResource -> Scr
 renderInfo gs imgres sur = do
-        puts 3 1 "NARIO"
-        puts 3 2 $ deciWide 6 '0' $ getPlayerScore (pl gs)
-        puts 11 2 ("?*" ++ deciWide 2 '0' (getPlayerCoin (pl gs)))
+        puts  3 1 "NARIO"
+        puts  3 2 $ deciWide 6 '0' $ getPlayerScore (pl gs)
+        puts 11 2 ("?*" ++ deciWide 2 '0' (getPlayerCoin $ pl gs))
         puts 18 1 "WORLD"
         puts 19 2 "1-1"
         puts 25 1 "TIME"
-        puts 26 2 $ deciWide 3 '0' ((time gs + timeBase-1) `div` timeBase)
-
-        where
-                puts = fontPut sur fontsur
-                fontsur = getImageSurface imgres ImgFont
+        puts 26 2 $ deciWide 3 '0' $ (time gs + timeBase-1) `div` timeBase
+        where
+                puts = fontPut font sur
+                font = Font (getImageSurface imgres ImgFont) 8 8 16
 
 -- タイトル画面
 renderTitle imgres sur = do
-        blitSurface (getImageSurface imgres ImgTitle) Nothing sur (pt (5*8) (3*8))
+        putimg sur imgres ImgTitle (5*8) (3*8)
 --      puts 13 14 "@1985 NINTENDO"
-        puts 9 17 "> 1 PLAYER GAME"
---      puts 9 19 "  2 PLAYER GAME"
+        puts  9 17 "> 1 PLAYER GAME"
+--      puts  9 19 "  2 PLAYER GAME"
         puts 12 22 "TOP- 000000"
         where
-                puts = fontPut sur fontsur
-                fontsur = getImageSurface imgres ImgFont
+                puts = fontPut font sur
+                font = Font (getImageSurface imgres ImgFont) 8 8 16

lang/haskell/nario/Player.hs

@@ -26 +26 @@
 
 import Util
-import AppUtil (KeyProc, isPressed, PadBtn(..), cellCrd, KeyState(..), getImageSurface, Rect(..))
+import AppUtil (KeyProc, isPressed, PadBtn(..), cellCrd, KeyState(..), getImageSurface, Rect(..), putimg)
 import Const
 import Images
@@ -120 +120 @@
 moveX :: KeyProc -> Player -> Player
 moveX kp self =
-        if (stand self)
+        if stand self
                 then self' { lr = lr', pat = pat', anm = anm' }
                 else self'
@@ -324 +324 @@
 renderPlayer sur imgres scrx self = do
         if undeadCount self == 0 || (undeadCount self .&. 1) /= 0
-                then blitSurface (getImageSurface imgres imgtype) Nothing sur pos >> return ()
+                then putimg sur imgres imgtype sx posy
                 else return ()
         where
-                pos = case pltype self of
-                        SmallNario      -> pt sx $ sy - chrSize + 1
-                        otherwise       -> pt sx $ sy - chrSize * 2 + 1
+                posy = case pltype self of
+                        SmallNario      -> sy - chrSize + 1
+                        otherwise       -> sy - chrSize * 2 + 1
                 imgtype
                         | plstate self == Dead  = ImgNarioDead

lang/haskell/nario/README.txt

@@ -4 +4 @@
 
 を Haskell/HSDL で作る
-
-HSDL
-http://fxp.hp.infoseek.co.jp/haskell/HSDL/
 
 
@@ -15 +12 @@
 
         スペースキー, z
-                Aボタン
+                ジャンプ（Aボタン）
 
         シフトキー
-                Bボタン
+                ダッシュ（Bボタン）
 
         エスケープキー
@@ -47 +44 @@
 
 　○実行
-        できた実行ファイルを入力、または
+        できた実行ファイルを起動する、または
         make run
 

lang/haskell/nario/Util.hs

@@ -7 +7 @@
 replace ls i v = take i ls ++ [v] ++ drop  (i + 1) ls
 
--- 符号を返す
+-- けつの n 個取り出し
+lastN n xs = loop 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
+
+-- 数値の符号を返す
 sgn x
         | x > 0         = 1
         | x < 0         = -1
         | otherwise     = 0
+
+-- １０進数 n 桁文字列を返す
+deciWide n c = lastN n . (replicate n c ++) . show
 
 -- x に d を加算した結果が x0～x1 の範囲内を超えないようにする