Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 174 lines (130 sloc) 6.185 kb
622ff89 initial version of lesson32.
Korcan Hussein authored
1 {-
2 The MIT License
3 Copyright (c) 2010 Korcan Hussein
4
5 Permission is hereby granted, free of charge, to any person obtaining a copy
6 of this software and associated documentation files (the "Software"), to deal
7 in the Software without restriction, including without limitation the rights
8 to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 copies of the Software, and to permit persons to whom the Software is
10 furnished to do so, subject to the following conditions:
11
12 The above copyright notice and this permission notice shall be included in
13 all copies or substantial portions of the Software.
14
15 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21 THE SOFTWARE.
22 -}
23 {-# LANGUAGE FlexibleContexts #-}
24 module Main where
25
26 import Data.Word
27 import Control.Monad
28 import Control.Monad.State
29 import Control.Monad.Reader
30
31 import Graphics.UI.SDL
32 import Graphics.UI.SDL.Image
33
34 import Timer
35
36 screenWidth = 640
37 screenHeight = 480
38 screenBpp = 32
39
40 dotWidth = 20
41 dotHeight = 20
42 dotVel = 200
43
44 loadImage :: String -> Maybe (Word8, Word8, Word8) -> IO Surface
45 loadImage filename colorKey = load filename >>= displayFormat >>= setColorKey' colorKey
46
47 setColorKey' Nothing s = return s
48 setColorKey' (Just (r, g, b)) surface = mapRGB' surface r g b >>= setColorKey surface [SrcColorKey] >> return surface
49
50 applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool
51 applySurface x y src dst clip = blitSurface src clip dst offset
52 where offset = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 }
53
54 mapRGB' :: Surface -> Word8 -> Word8 -> Word8 -> IO Pixel
55 mapRGB' = mapRGB . surfaceGetPixelFormat
56
57 applySurface' :: MonadIO m => Int -> Int -> Surface -> Surface -> Maybe Rect -> m Bool
58 applySurface' x y src dst = liftIO . applySurface x y src dst
59
60 data Dot = Dot { pos :: (Float, Float), vel :: (Float, Float) }
61
62 defaultDot = Dot { pos=(0,0), vel=(0,0) }
63
64 handleInput :: Event -> Dot -> Dot
65 handleInput (KeyDown (Keysym SDLK_UP _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx, dy - dotVel) }
66 handleInput (KeyDown (Keysym SDLK_DOWN _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx, dy + dotVel) }
67 handleInput (KeyDown (Keysym SDLK_LEFT _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx - dotVel, dy) }
68 handleInput (KeyDown (Keysym SDLK_RIGHT _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx + dotVel, dy) }
69
70 handleInput (KeyUp (Keysym SDLK_UP _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx, dy + dotVel) }
71 handleInput (KeyUp (Keysym SDLK_DOWN _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx, dy - dotVel) }
72 handleInput (KeyUp (Keysym SDLK_LEFT _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx + dotVel, dy) }
73 handleInput (KeyUp (Keysym SDLK_RIGHT _ _)) dot@Dot { vel=(dx,dy) } = dot { vel=(dx - dotVel, dy) }
74
75 handleInput _ d = d
76
77 move :: Word32 -> Dot -> Dot
78 move deltaTicks dot@Dot { pos=(x,y), vel=(dx,dy) } = dot { pos=(x'', y'') }
79 where
80 x' = x + (dx * (fromIntegral deltaTicks / 1000.0))
81 y' = y + (dy * (fromIntegral deltaTicks / 1000.0))
82 x'' = if x' < 0 then 0 else if (x' + fromIntegral dotWidth) > fromIntegral screenWidth then fromIntegral $ screenWidth - dotWidth else x'
83 y'' = if y' < 0 then 0 else if (y' + fromIntegral dotHeight) > fromIntegral screenHeight then fromIntegral $ screenHeight - dotHeight else y'
84
85 showDot Dot { pos=(x,y) } = applySurface (truncate x) (truncate y)
86
87 data AppData = AppData {
88 dot :: Dot,
89 delta :: Timer
90 }
91
92 data AppConfig = AppConfig {
93 screen :: Surface,
94 dotSprite :: Surface
95 }
96
97 type AppState = StateT AppData IO
98 type AppEnv = ReaderT AppConfig AppState
99
100 getDelta :: MonadState AppData m => m Timer
101 getDelta = liftM delta get
102
103 putDelta :: MonadState AppData m => Timer -> m ()
104 putDelta t = modify $ \s -> s { delta = t }
105
106 modifyDeltaM :: MonadState AppData m => (Timer -> m Timer) -> m ()
107 modifyDeltaM act = getDelta >>= act >>= putDelta
108
109 getDot :: MonadState AppData m => m Dot
110 getDot = liftM dot get
111
112 putDot :: MonadState AppData m => Dot -> m ()
113 putDot t = modify $ \s -> s { dot = t }
114
115 modifyDotM :: MonadState AppData m => (Dot -> m Dot) -> m ()
116 modifyDotM act = getDot >>= act >>= putDot
117
118 modifyDot :: MonadState AppData m => (Dot -> Dot) -> m ()
119 modifyDot fn = fn `liftM` getDot >>= putDot
120
121 getScreen :: MonadReader AppConfig m => m Surface
122 getScreen = liftM screen ask
123
124 getDotSprite :: MonadReader AppConfig m => m Surface
125 getDotSprite = liftM dotSprite ask
126
127 initEnv :: IO (AppConfig, AppData)
128 initEnv = do
129 screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface]
130 setCaption "Move the Dot" []
131
132 dot <- loadImage "dot.bmp" Nothing--(Just (0x00, 0xff, 0xff))
133 delta <- start defaultTimer
134 return (AppConfig screen dot, AppData defaultDot delta)
135
136 loop :: AppEnv ()
137 loop = do
138
139 quit <- whileEvents $ modifyDot . handleInput
140
141 delta <- liftIO . getTimerTicks =<< getDelta
142 modifyDot $ move delta
143 modifyDeltaM $ liftIO . start
144
145 myDot <- getDot
146 dotSprite <- getDotSprite
147 screen <- getScreen
148 liftIO $ do
149 jrect <- Just `liftM` getClipRect screen
150 color <- mapRGB' screen 0xff 0xff 0xff
151
152 fillRect screen jrect color
153 showDot myDot dotSprite screen Nothing
154
155 Graphics.UI.SDL.flip screen
156
157 unless quit loop
158
159 whileEvents :: MonadIO m => (Event -> m ()) -> m Bool
160 whileEvents act = do
161 event <- liftIO pollEvent
162 case event of
163 Quit -> return True
164 NoEvent -> return False
165 _ -> do
166 act event
167 whileEvents act
168
169 runLoop :: AppConfig -> AppData -> IO ()
170 runLoop = evalStateT . runReaderT loop
171
172 main = withInit [InitEverything] $ do -- withInit calls quit for us.
173 (env, state) <- initEnv
174 runLoop env state
Something went wrong with that request. Please try again.