content: -- 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)
  