Raindrops, with new assets

Author: ivanperez-keera

examples/raindrops/Raindrops.hs

@@ -0,0 +1,276 @@
+-- A demo game put together in less than 2 hours to show how easy
+-- game programming is in Haskell.
+--
+-- If you want to use the wiimote, compile the game with the flag
+-- -rtsopts
+-- and run it with
+-- +RTS -V0
+-- import Control.Concurrent
+import Control.Monad
+import Graphics.UI.SDL       as SDL
+import Graphics.UI.SDL.Image as SDL
+import Graphics.UI.SDL.TTF   as TTF
+import System.CWiid
+import System.Random
+
+-- * Game State
+data GameState = GameState
+ { raindrops    :: [(Float, Float)]
+ , paddle       :: (Float, Float)
+ , lives        :: Int
+ , points       :: Int
+ , lastRaindrop :: Float
+ , lastFrame    :: Float -- Time of last frame
+ , randomGen    :: StdGen
+ }
+ deriving Show
+
+level :: GameState -> Int
+level gameState = points gameState `div` dropsPerLevel
+
+updatePaddlePos :: GameState -> Float -> GameState
+updatePaddlePos gameState newX =
+  gameState { paddle = (min newX (width - paddleW), height - paddleMargin) }
+
+initialGameState :: StdGen -> GameState
+initialGameState gen =
+  GameState [(width / 2, dropMargin)] (0, height - paddleMargin) maxLives 0 0 0 gen
+
+-- * Runtime environment (resources, devices)
+data Env = Env
+ { bgImg     :: Surface
+ , dropImg   :: Surface
+ , paddleImg :: Surface
+ , font      :: TTF.Font
+ , cwiid     :: Maybe CWiidWiimote
+ }
+
+main :: IO ()
+main = do
+  -- Initialise SDL
+  SDL.init [InitEverything]
+  ttfOk <- TTF.init
+
+  when ttfOk $ do
+    font   <- TTF.tryOpenFont "data/font.ttf" 32
+    bg     <- load "data/background.png"
+
+    -- Load with a mask
+    drop   <- load "data/cherry.png"
+    t <- mapRGB (surfaceGetPixelFormat drop) 0 255 0 
+    setColorKey drop [SrcColorKey, RLEAccel] t
+
+    -- Load with a mask
+    paddle <- load "data/player.png"
+    t <- mapRGB (surfaceGetPixelFormat paddle) 0 255 0 
+    setColorKey paddle [SrcColorKey, RLEAccel] t
+
+    -- Create window, no mouse
+    SDL.setVideoMode (round width) (round height) 32 [SWSurface]
+    SDL.setCaption "Raindrops" ""
+    SDL.showCursor False
+
+    -- Create Random number generator
+    gen <- getStdGen
+
+    -- Initialise input devices
+    wiimote <- initializeWiimote
+
+    case font of
+      Nothing  -> return ()
+      Just ttf -> let env = Env bg drop paddle ttf wiimote
+                      gs  = initialGameState gen
+                  in run env gs
+
+-- Game loop
+run :: Env -> GameState -> IO ()
+run env gameState = do
+  -- IO: Sense (input)
+  gameStateP <- calculatePaddlePos env gameState
+
+  -- IO: Sense (time)
+  newTime <- fmap fromIntegral SDL.getTicks
+  let dt = newTime - lastFrame gameStateP
+  let gameStateT = gameStateP { lastFrame = newTime }
+
+  -- Physics (movement)
+  let gameStateP = moveForward dt gameStateT
+
+  -- Physics (collisions)
+  let gameStateC = raindropsBottom (raindropsPaddle gameStateP)
+
+  -- Logic (new raindrops)
+  let dtLastRaindrop = newTime - lastRaindrop gameStateC
+      gameStateN =
+        if dtLastRaindrop > dropDelay
+          then let (newX, gen') = randomR (0, round (width - dropW) :: Int)
+                                          (randomGen gameStateC)
+                   oldDrops = raindrops gameStateC
+               in gameStateC { raindrops    = (fromIntegral newX, dropMargin) : oldDrops
+                             , lastRaindrop = newTime
+                             , randomGen    = gen'
+                             }
+          else gameStateC
+
+  -- Logic (game over)
+  let gameStateO = if lives gameStateN < 0
+                     then initialGameState (randomGen gameStateN)
+                     else gameStateN
+
+  -- IO: Paint
+  render env gameStateO
+
+  -- Loop
+  run env gameStateO
+
+-- * Physics
+moveForward :: Float -> GameState -> GameState
+moveForward dt gs = gs { raindrops = movedRaindrops }
+  where movedRaindrops     = map moveRaindrop (raindrops gs)
+        moveRaindrop (x,y) = (x, y + 0.1 * dt * fromIntegral (level gs + 1))
+
+-- * Collisions
+
+-- ** Collisions with paddle
+raindropsPaddle :: GameState -> GameState
+raindropsPaddle gs = gs { raindrops = remainingRaindrops
+                        , points    = points gs + pts
+                        } 
+ where remainingRaindrops       = filter (not.collidesWithPaddle) (raindrops gs)
+       pts                      = length (raindrops gs) - length remainingRaindrops
+       collidesWithPaddle (x,y) = (within x paddleXMin paddleXMax
+                                  || within paddleXMin x (x + dropW))
+                                  && (within y paddleYMin paddleYMax
+                                     || within paddleYMin y (y + dropH))
+         where paddleXMin = fst (paddle gs)
+               paddleXMax = fst (paddle gs) + paddleW
+               paddleYMin = snd (paddle gs)
+               paddleYMax = snd (paddle gs) + paddleH
+               within x xMin xMax = x >= xMin && x <= xMax
+
+-- ** Collisions with bottom
+raindropsBottom :: GameState -> GameState
+raindropsBottom gs = gs { raindrops = remainingRaindrops
+                        , lives     = decreasedLives
+                        }
+ where remainingRaindrops = filter (\(_,y) -> y < height) (raindrops gs)
+       decreasedLives     = lives gs - diffDrops
+       diffDrops          = length (raindrops gs) - length remainingRaindrops
+
+-- * Input sensing
+calculatePaddlePos :: Env -> GameState -> IO GameState
+calculatePaddlePos env gs = case cwiid env of
+ Nothing -> calculatePaddlePosSDL env gs
+ Just wm -> do (x,y) <- senseWiimote wm
+               return (updatePaddlePos gs x)
+
+-- ** SDL Sensing
+calculatePaddlePosSDL :: Env -> GameState -> IO GameState
+calculatePaddlePosSDL env gs = do
+  e <- pollEvent
+  case e of
+    NoEvent             -> return gs
+    MouseMotion x y _ _ -> calculatePaddlePosSDL env (updatePaddlePos gs (fromIntegral x))
+    _                   -> calculatePaddlePosSDL env gs
+
+-- * Output drawing
+render :: Env -> GameState -> IO ()
+render env gameState = do
+
+  screen <- getVideoSurface
+
+  -- Clear screen
+  SDL.blitSurface (bgImg env) Nothing
+                  screen (Just (SDL.Rect 0 0 (round width) (round height)))
+
+  -- Paint each raindrop
+  let paintADropAt (x,y) = do
+        SDL.blitSurface (dropImg env) Nothing
+                        screen (Just (SDL.Rect (round x) (round y) (round dropW) (round dropH)))
+
+  mapM_ paintADropAt (raindrops gameState)
+
+  -- Paint the paddle
+  let (x,y) = paddle gameState
+  SDL.blitSurface (paddleImg env) Nothing
+                  screen (Just (SDL.Rect (round x) (round y) (round paddleW) (round paddleH)))
+
+  -- Paint points, lives
+  let ttf = font env
+  message <- TTF.renderTextSolid
+               ttf
+               ("Level " ++ show (level gameState)
+                ++ " / Lives " ++ show (lives gameState))
+               (SDL.Color 128 128 128)
+  let w1 = SDL.surfaceGetWidth  message
+      h1 = SDL.surfaceGetHeight message
+  SDL.blitSurface message Nothing
+                  screen (Just (SDL.Rect 10 10 w1 h1))
+
+  -- Present
+  SDL.flip screen
+
+-- * Game constants
+paddleW, paddleH :: Float
+paddleW = 126
+paddleH = 31
+
+paddleMargin :: Float
+paddleMargin = 60
+
+width, height :: Float
+width         = 800
+height        = 480
+
+dropW, dropH :: Float
+dropW        = 70
+dropH        = 70
+
+dropMargin :: Float
+dropMargin = 10
+
+dropsPerLevel :: Int
+dropsPerLevel = 20
+
+dropDelay :: Float
+dropDelay = 500
+
+maxLives :: Int
+maxLives = 10
+
+-- * Wiimote sensing
+
+-- | Initializes the wiimote, optionally returning the sensing function. It
+-- returns Nothing if the Wiimote cannot be detected. Users should have a BT
+-- device and press 1+2 to connect to it. A message is shown on stdout.
+initializeWiimote :: IO (Maybe CWiidWiimote)
+initializeWiimote = do
+  putStrLn "Initializing WiiMote. Please press 1+2 to connect."
+  wm <- cwiidOpen
+  case wm of
+    Nothing  -> return ()
+    Just wm' -> void $ cwiidSetRptMode wm' 15 -- Enable button reception, acc and IR
+  return wm
+
+senseWiimote :: CWiidWiimote -> IO (Float, Float)
+senseWiimote wmdev = do
+  irs   <- cwiidGetIR wmdev
+
+  -- Obtain positions of leds 1 and 2 (with a normal wii bar, those
+  -- will be the ones we use).
+  let led1   = irs!!0
+      led2   = irs!!1
+
+  -- Calculate mid point between sensor bar leds
+  let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2
+      posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2
+
+  -- Calculate proportional coordinates
+  let propX = fromIntegral (1024 - posX) / 1024.0
+      propY = fromIntegral (max 0 (posY - 384)) / 384.0
+
+  -- Calculate game area coordinates
+  let finX  = width  * propX
+      finY  = height * propY
+
+  return (finX, finY)