Changeset 20397 for lang/haskell

Timestamp:

10/01/08 22:17:57 (7 weeks ago)

Author:

mokehehe

Message:

画像定義ファイルを自動に作成するように

Location:

lang/haskell/nario

Files:

• Actor.hs (modified) (1 diff)
• AppUtil.hs (added)
• Const.hs (modified) (2 diffs)
• Event.hs (modified) (1 diff)
• Field.hs (modified) (1 diff)
• Images.hs (added)
• Main.hs (modified) (2 diffs)
• Makefile (modified) (1 diff)
• Player.hs (modified) (1 diff)
• Util.hs (modified) (2 diffs)
• tool (added)
• tool/FileUtils.hs (added)
• tool/listup-imgs.hs (added)

lang/haskell/nario/Actor.hs

@@ -5 +5 @@
 
 import Const
+import Images
 import Util
+import AppUtil
 import Event
 

lang/haskell/nario/Const.hs

@@ -12 +12 @@
 gravity2 = one `div` 4
 
+{-
 -- 画像
 data ImageType =
@@ -79 +80 @@
         ImgTitle
         ]
+-}

lang/haskell/nario/Event.hs

@@ -3 +3 @@
 
 import Const
+import Images
 import Field
 

lang/haskell/nario/Field.hs

@@ -19 +19 @@
 
 import Const
+import Images
 import Util
+import AppUtil
 
 type Cell = Char

lang/haskell/nario/Main.hs

@@ -12 +12 @@
 import Field
 import Util
+import AppUtil
 import Const
+import Images
 import Font
 import Event
@@ -96 +98 @@
 process :: [[SDLKey]] -> IO [Scr]
 process kss = do
-        imgres <- loadImageResource images
+        imgres <- loadImageResource imageTypes
         st <- initialState
         let scrs = map (\scr -> scr imgres) $ loop [] st kss

lang/haskell/nario/Makefile

@@ -20 +20 @@
 doc:
         haddock -h -o man -l C:\\ghc\\haddock-2.0.0.0 -B c:\\ghc\\ghc-6.8.2 *.hs
+
+
+imgs:
+        runghc -itool tool/listup-imgs.hs data/img > Images.hs

lang/haskell/nario/Player.hs

@@ -13 +13 @@
 
 import Util
+import AppUtil
 import SDLUtil
 import Const
+import Images
 import Field
 import Event

lang/haskell/nario/Util.hs

@@ -1 +1 @@
 module Util where
-
-import System.Time (getClockTime, diffClockTimes, noTimeDiff, tdMin, tdSec, tdPicosec)
-import Control.Concurrent (threadDelay)
-import Data.Maybe (fromJust)
-import Multimedia.SDL
-
-import Const
 
 
@@ -34 +27 @@
         | x < -d        = x + d
         | otherwise     = 0
-
-
-
--- キーボード処理
-
-data PadBtn =
-        PadU | PadD | PadL | PadR | PadA | PadB
-        deriving (Eq, Show, Enum)
-
-data KeyState =
-        Pushed | Pushing | Released | Releasing
-        deriving (Eq, Show)
-
-isPressed Pushed  = True
-isPressed Pushing = True
-isPressed _       = False
-
-type KeyProc = PadBtn -> KeyState
-
-keyProc bef cur gk
-        | not bp && not cp = Releasing
-        | not bp && cp     = Pushed
-        | bp     && not cp = Released
-        | bp     && cp     = Pushing
-        where
-                bp = any (flip elem bef) phykeys
-                cp = any (flip elem cur) phykeys
-                phykeys = mapPhyKey gk
-
-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]
-
-
-
--- 画像リソース
-type ImageResource = [(ImageType, Surface)]
-
-
--- 画像リソース読み込み
-loadImageResource :: [ImageType] -> IO ImageResource
-loadImageResource = mapM load
-        where
-                load imgtype = do
-                        sur <- loadBMP $ ("data/img/" ++) $ imageFn imgtype
-                        setNuki sur
-                        converted <- displayFormat sur
-                        freeSurface sur
-                        return (imgtype, converted)
-
-                setNuki sur = do
-                        let fmt = surfacePixelFormat sur
-                        if not $ null $ pfPalette fmt
-                                then setColorKey sur [SRCCOLORKEY] 0 >> return ()       -- パレット０番目をぬき色に
-                                else return ()
-
-releaseImageResource :: ImageResource -> IO ()
-releaseImageResource = mapM_ (\(t, sur) -> freeSurface sur)
-
-getImageSurface :: ImageResource -> ImageType -> Surface
-getImageSurface imgres t = fromJust $ lookup t imgres
-
-
--- 固定座標系からセル座標系に
-cellCrd :: Int -> Int
-cellCrd x = x `div` (chrSize * one)