API tools faq
paste
Guest User

Untitled

a guest
Jun 20th, 2018
99
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 9.11 KB | None | 0 0
raw download clone embed print report
  1. -- breakout prototype in haskell using SDL
  2.  
  3.  
  4. module Main where
  5.  
  6. import Debug.Trace
  7. import Graphics.UI.SDL as SDL
  8. import Graphics.UI.SDL.Image as Image
  9. import Graphics.UI.SDL.Framerate as Framerate
  10. import Graphics.UI.SDL.Mixer as Mixer
  11. import Foreign
  12. import Data.Typeable
  13. import Data.Char
  14. import Data.IORef
  15. import Control.Monad
  16. import System.Environment
  17. import System.Exit
  18. import System.Random
  19.  
  20. -- screenwidth = 640
  21. -- screenheight = 480
  22. screenwidth = 400
  23. screenheight = 400
  24. screendepth = 16
  25. screenmode = [SWSurface,Resizable]
  26. framerate = 60 -- (hz)
  27. batfriction = 0.2
  28. defbataccel = 2
  29.  
  30. data Game = Game {
  31. running :: Bool,
  32. fpsmgr :: FPSManager,
  33. screenw :: Int,
  34. screenh :: Int,
  35. leftDown :: Bool,
  36. rightDown :: Bool,
  37. bat :: Bat,
  38. ball :: Ball
  39. }
  40. data Bat = Bat {
  41. batx :: Int,
  42. baty :: Int,
  43. batvx :: Int,
  44. batvy :: Int,
  45. batmaxspeed :: Int,
  46. bataccel :: Int,
  47. batw :: Int,
  48. bath :: Int
  49. }
  50. data Ball = Ball {
  51. ballx :: Int,
  52. bally :: Int,
  53. ballvx :: Int,
  54. ballvy :: Int,
  55. ballmaxspeed :: Int,
  56. ballw :: Int,
  57. ballh :: Int
  58. }
  59.  
  60. main :: IO ()
  61. main = initialize >>= mainloop
  62.  
  63. initialize :: IO Game
  64. initialize =
  65. do
  66. SDL.init [InitVideo,InitAudio]
  67. setVideoMode screenwidth screenheight screendepth screenmode
  68. setCaption "Breakout" ""
  69. enableUnicode True
  70. fpsmgr <- Framerate.new
  71. Framerate.init fpsmgr
  72. Framerate.set fpsmgr framerate
  73. return $ newGame fpsmgr
  74.  
  75. newGame :: FPSManager -> Game
  76. newGame fpsmgr = Game True fpsmgr screenwidth screenheight False False newBat newBall
  77. newBat = Bat (div screenwidth 2) (screenheight-h-40) 0 0 10 defbataccel w h where w = 60; h = 10
  78. newBall = Ball 0 0 4 4 0 8 8
  79.  
  80. mainloop :: Game -> IO ()
  81. mainloop game =
  82. do
  83. event <- pollEvent
  84. game' <- handleevent game event
  85. let game = step game'
  86. Framerate.delay $ fpsmgr game
  87. display game
  88. when (running game) $ do mainloop game
  89.  
  90. handleevent :: Game -> Event -> IO Game
  91. handleevent game (Quit) = return game{running=False}
  92. handleevent game (KeyDown (Keysym SDLK_q _ _)) = return game{running=False}
  93. handleevent game (KeyDown (Keysym SDLK_LEFT _ _)) = return game{leftDown=True}
  94. handleevent game (KeyUp (Keysym SDLK_LEFT _ _)) = return game{leftDown=False}
  95. handleevent game (KeyDown (Keysym SDLK_RIGHT _ _)) = return game{rightDown=True}
  96. handleevent game (KeyUp (Keysym SDLK_RIGHT _ _)) = return game{rightDown=False}
  97. handleevent game (VideoResize w h) =
  98. do
  99. setVideoMode w h screendepth screenmode
  100. return game{screenw=w,screenh=h}
  101. handleevent game _ = return game
  102.  
  103. step :: Game -> Game
  104. step game@(Game _ _ screenw screenh leftDown rightDown
  105. bat@(Bat batx baty batvx batvy batmaxspeed bataccel batw bath)
  106. ball@(Ball ballx bally ballvx ballvy ballmaxspeed ballw ballh)) =
  107. game{bat=bat', ball=ball'}
  108. where
  109. batvx' = if leftDown then (max (batvx-bataccel) (-batmaxspeed)) else batvx
  110. batvx'' = if rightDown then (min (batvx'+bataccel) (batmaxspeed)) else batvx'
  111. batvx''' = if (and [not leftDown, not rightDown]) then truncate(fromIntegral batvx'' * (1.0-batfriction)) else batvx''
  112. (batx',batvx'''') = incrementWithStop batx batvx''' 0 (screenw-batw)
  113. (baty',batvy') = (screenh-bath-40, 0)
  114. bat' = bat{batx=batx',baty=baty',batvx=batvx''',batvy=batvy'}
  115. (ballx',ballvx') = incrementWithBounce ballx ballvx 0 (screenw-ballw)
  116. (bally',ballvy') = if (and [ballx >= batx-ballw,
  117. ballx <= (batx+batw),
  118. bally >= (baty-ballh),
  119. bally <= baty,
  120. ballvy > 0])
  121. then incrementWithBounce bally ballvy 0 (baty-ballh)
  122. else incrementWithBounce bally ballvy 0 (screenh-ballh)
  123. ball' = if (bally+ballvy) >= (screenh-ballh)
  124. then newBall
  125. else ball{ballx=ballx',bally=bally',ballvx=ballvx',ballvy=ballvy'}
  126.  
  127. incrementWithBounce :: Int -> Int -> Int -> Int -> (Int, Int)
  128. incrementWithBounce val inc lo hi =
  129. let v = val + inc in
  130. if v < lo then (lo+(lo-v), -inc)
  131. else if v > hi then (hi-(v-hi), -inc)
  132. else (v,inc)
  133.  
  134. incrementWithStop val inc lo hi =
  135. let v = val + inc in
  136. if v < lo then (lo, -inc)
  137. else if v > hi then (hi, -inc)
  138. else (v,inc)
  139.  
  140. display :: Game -> IO ()
  141. display (Game _ _ _ _ _ _
  142. (Bat batx baty _ _ _ _ batw bath)
  143. (Ball ballx bally _ _ _ ballw ballh)) =
  144. do
  145. screen <- getVideoSurface
  146. let format = surfaceGetPixelFormat screen
  147. red <- mapRGB format 0xFF 0 0
  148. green <- mapRGB format 0 0xFF 0
  149. black <- mapRGB format 0 0 0
  150. white <- mapRGB format 0xFF 0xFF 0xFF
  151. fillRect screen Nothing black
  152. fillRect screen (Just (Rect batx baty batw bath)) red
  153. fillRect screen (Just (Rect ballx bally ballw ballh)) white
  154. SDL.flip screen
  155.  
  156.  
  157.  
  158. Wed Oct 27 04:26 2010 Time and Allocation Profiling Report (Final)
  159.  
  160. breakoutp +RTS -p -RTS
  161.  
  162. total time = 2.30 secs (115 ticks @ 20 ms)
  163. total alloc = 512,268 bytes (excludes profiling overheads)
  164.  
  165. COST CENTRE MODULE %time %alloc
  166.  
  167. display Main 93.0 34.8
  168. step Main 4.3 52.0
  169. mainloop Main 1.7 7.0
  170. incrementWithStop Main 0.0 1.6
  171. incrementWithBounce Main 0.0 3.2
  172.  
  173.  
  174. individual inherited
  175. COST CENTRE MODULE no. entries %time %alloc %time %alloc
  176.  
  177. MAIN MAIN 1 0 0.0 0.0 100.0 100.0
  178. CAF MainWrapper 322 1 0.0 0.0 0.0 0.0
  179. CAF Main 321 22 0.0 0.0 99.1 99.9
  180. batfriction Main 344 1 0.0 0.0 0.0 0.0
  181. newBall Main 341 1 0.0 0.0 0.0 0.0
  182. newBat Main 340 1 0.0 0.0 0.0 0.0
  183. framerate Main 334 1 0.0 0.0 0.0 0.0
  184. screenmode Main 333 1 0.0 0.0 0.0 0.0
  185. screendepth Main 332 1 0.0 0.0 0.0 0.0
  186. screenheight Main 331 1 0.0 0.0 0.0 0.0
  187. screenwidth Main 330 1 0.0 0.0 0.0 0.0
  188. initialize Main 329 1 0.0 0.2 0.0 0.2
  189. newGame Main 335 1 0.0 0.0 0.0 0.0
  190. main Main 328 1 0.0 0.0 99.1 99.7
  191. mainloop Main 336 223 1.7 7.0 99.1 99.7
  192. running Main 349 0 0.0 0.5 0.0 0.5
  193. display Main 342 223 93.0 34.8 93.0 34.8
  194. step Main 339 223 4.3 52.0 4.3 56.7
  195. incrementWithBounce Main 348 446 0.0 3.2 0.0 3.2
  196. incrementWithStop Main 343 223 0.0 1.6 0.0 1.6
  197. fpsmgr Main 338 0 0.0 0.5 0.0 0.5
  198. handleevent Main 337 223 0.0 0.1 0.0 0.1
  199. CAF Graphics.UI.SDL.General 211 1 0.0 0.0 0.0 0.0
  200. CAF Graphics.UI.SDL.Events 207 1 0.9 0.0 0.9 0.0
  201. CAF Graphics.UI.SDL.Video 199 2 0.0 0.0 0.0 0.0
  202. main Main 345 0 0.0 0.0 0.0 0.0
  203. mainloop Main 346 0 0.0 0.0 0.0 0.0
  204. display Main 347 0 0.0 0.0 0.0 0.0
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!