root/lang/haskell/nario/Util.hs @ 20086

Revision 20086, 2.9 kB (checked in by mokehehe, 6 years ago)

横移動、ジャンプの当たり判定

Line 
1module Util where
2
3import System.Time (getClockTime, diffClockTimes, noTimeDiff, tdMin, tdSec, tdPicosec)
4import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)
5import Control.Concurrent (threadDelay)
6import Data.Maybe (fromJust)
7import Multimedia.SDL
8
9import Const
10
11
12-- ユーティリティ関数
13
14-- 符号を返す
15sgn x
16        | x > 0         = 1
17        | x < 0         = -1
18        | otherwise     = 0
19
20-- x に d を加算した結果が x0~x1 の範囲内を超えないようにする
21-- もとから範囲外だったときはそれ以上遠ざからないように
22rangeadd x d x0 x1
23        | d > 0 && x < x1       = min (x + d) x1
24        | d < 0 && x > x0       = max (x + d) x0
25        | otherwise     = x
26
27
28-- 値を0に近づける
29friction x d
30        | x > d         = x - d
31        | x < -d        = x + d
32        | otherwise     = 0
33
34
35
36-- キーボード処理
37
38data PadBtn =
39        PadU | PadD | PadL | PadR | PadA | PadB
40        deriving (Eq, Show, Enum)
41
42data KeyState =
43        Pushed | Pushing | Released | Releasing
44        deriving (Eq, Show)
45
46isPressed Pushed  = True
47isPressed Pushing = True
48isPressed _       = False
49
50type KeyProc = PadBtn -> KeyState
51
52keyProc bef cur gk
53        | not bp && not cp = Releasing
54        | not bp && cp     = Pushed
55        | bp     && not cp = Released
56        | bp     && cp     = Pushing
57        where
58                bp = any (flip elem bef) phykeys
59                cp = any (flip elem cur) phykeys
60                phykeys = mapPhyKey gk
61
62mapPhyKey PadU = [SDLK_UP, SDLK_i]
63mapPhyKey PadD = [SDLK_DOWN, SDLK_k]
64mapPhyKey PadL = [SDLK_LEFT, SDLK_j]
65mapPhyKey PadR = [SDLK_RIGHT, SDLK_l]
66mapPhyKey PadA = [SDLK_SPACE, SDLK_z]
67mapPhyKey PadB = [SDLK_LSHIFT, SDLK_RSHIFT]
68
69-- 時間調節
70
71elapseTime :: Integer -> IO (IO (Int,Bool))
72elapseTime fps = do
73  let frametime = picosec `div` fps
74  tm <- getClockTime
75  st <- newIORef ((0,0,noTimeDiff), (1,tm))
76  return $ do
77    ((bef,cur,fdt), (cnt,bt)) <- readIORef st
78    ct       <- getClockTime
79    let dt   = diffClockTimes ct bt
80        ndt  = diffClockTimes ct tm
81        adj  = frametime*cnt - toPsec dt
82        nc   = if cnt==fps then (1,ct) else (cnt+1,bt)
83        (nbef,ncur) = if tdSec fdt /= tdSec ndt then (cur,0) else (bef,cur)
84    if adj < 0 then do
85        writeIORef st ((nbef,ncur,ndt), nc)
86        return (bef, False)
87      else do
88        writeIORef st ((nbef,ncur+1,ndt), nc)
89        threadDelay $ fromInteger $ min 16666 $ adj `div` 1000000
90        return (bef, True)
91  where
92    toPsec dt = toInteger (tdMin dt * 60 + tdSec dt) * picosec + tdPicosec dt
93    picosec = 1000000000000
94
95
96
97-- 画像リソース
98type ImageResource = [(ImageType, Surface)]
99
100
101-- 画像リソース読み込み
102loadImageResource :: IO ImageResource
103loadImageResource = mapM load images
104        where
105                load imgtype = do
106                        sur <- loadBMP $ ("data/img/" ++) $ imageFn imgtype
107--                      colorKey <- mapRGB (surfacePixelFormat sur) $ Color r g b a
108                        let colorKey = 0xff00ff
109                        setColorKey sur [SRCCOLORKEY] colorKey
110                        return (imgtype, sur)
111                r = 255
112                g = 0
113                b = 255
114                a = 255
115
116
117getImageSurface :: ImageResource -> ImageType -> Surface
118getImageSurface imgres t = fromJust $ lookup t imgres
Note: See TracBrowser for help on using the browser.