haskanoid-0.1.6: src/Display.hs
-- |
-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.
-- License : See LICENSE file.
-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>
--
-- Audio and video renderer.
module Display where
-- External imports
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IfElse
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.IORef
import Data.Maybe
import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.Image as Image
import qualified Graphics.UI.SDL.TTF as TTF
-- Internal imports
import Audio
import Constants
import GameState
import Levels
import Objects
import Paths_haskanoid
import Resources hiding (audio)
-- * Initialization
initializeDisplay :: IO ()
initializeDisplay = do
-- Initialise SDL
SDL.init [InitEverything]
initAudio
initGraphs :: IO ()
initGraphs = do
-- Create window
screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]
SDL.setCaption "Test" ""
-- Important if we want the keyboard to work right (I don't know
-- how to make it work otherwise)
SDL.enableUnicode True
-- Hide mouse
SDL.showCursor False
-- * Rendering and Sound
-- | Loads new resources, renders the game state using SDL, and adjusts music.
render :: ResourceMgr -> GameState -> IO()
render resourceManager shownState = do
resources <- loadNewResources resourceManager shownState
audio resources shownState
display resources shownState
-- ** Audio
audio :: Resources -> GameState -> IO()
audio resources shownState = do
-- Start bg music if necessary
playing <- musicPlaying
unless playing $ awhen (bgMusic resources) playMusic
-- Play object hits
mapM_ (audioObject resources) $ gameObjects shownState
audioObject :: Resources -> Object -> IO ()
audioObject resources object = when (objectHit object) $
case objectKind object of
(Block _ _) -> playFile (blockHitSnd resources) 3000
_ -> return ()
-- ** Painting
display :: Resources -> GameState -> IO()
display resources shownState = do
-- Obtain surface
screen <- getVideoSurface
-- Paint screen green
let format = surfaceGetPixelFormat screen
-- Paint background
awhen (bgImage resources) $ \bg' -> void $ do
let bg = imgSurface bg'
let rectBg = SDL.Rect 0 0 (round width) (round height)
SDL.blitSurface bg Nothing screen $ Just rectBg
hud <- createRGBSurface [SWSurface]
(round width) (round gameTop)
32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
paintGeneral hud resources (gameInfo shownState)
let rectHud = SDL.Rect 0 0 (round width) (round gameTop)
SDL.blitSurface hud Nothing screen $ Just rectHud
-- The following line is BIG_ENDIAN specific
-- The 32 is important because we are using Word32 for the masks
-- FIXME: Should I use HWSurface and possibly other flags (alpha?)?
surface <- createRGBSurface [SWSurface]
(round gameWidth) (round gameHeight)
32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
paintGeneralMsg surface resources (gameStatus (gameInfo shownState))
mapM_ (paintObject resources surface) $ gameObjects shownState
let rect = SDL.Rect (round gameLeft) (round gameTop)
(round gameWidth) (round gameHeight)
SDL.blitSurface surface Nothing screen $ Just rect
-- Double buffering
SDL.flip screen
paintGeneral :: Surface -> Resources -> GameInfo -> IO ()
paintGeneral screen resources over = void $ do
-- Paint screen green
let format = surfaceGetPixelFormat screen
bgColor <- mapRGB format 0x11 0x22 0x33
fillRect screen Nothing bgColor
paintGeneralHUD screen resources over
paintGeneralMsg :: Surface -> Resources -> GameStatus -> IO ()
paintGeneralMsg screen resources GamePlaying = return ()
paintGeneralMsg screen resources GamePaused =
paintGeneralMsg' screen resources "Paused"
paintGeneralMsg screen resources (GameLoading n) =
paintGeneralMsg' screen resources ("Level " ++ show n)
paintGeneralMsg screen resources GameOver =
paintGeneralMsg' screen resources "GAME OVER!!!"
paintGeneralMsg screen resources GameFinished =
paintGeneralMsg' screen resources "You won!!! Well done :)"
paintGeneralMsg' :: Surface -> Resources -> String -> IO ()
paintGeneralMsg' screen resources msg = void $ do
let font = resFont resources
message <- TTF.renderTextSolid (unFont font) msg (SDL.Color 128 128 128)
let x = (SDL.surfaceGetWidth screen - w) `div` 2
y = (SDL.surfaceGetHeight screen - h) `div` 2
w = SDL.surfaceGetWidth message
h = SDL.surfaceGetHeight message
SDL.blitSurface message Nothing screen $ Just (SDL.Rect x y w h)
paintGeneralHUD :: Surface -> Resources -> GameInfo -> IO ()
paintGeneralHUD screen resources over = void $ do
let font = unFont $ resFont resources
message1 <- TTF.renderTextSolid font
("Level: " ++ show (gameLevel over))
(SDL.Color 128 128 128)
let w1 = SDL.surfaceGetWidth message1
h1 = SDL.surfaceGetHeight message1
SDL.blitSurface message1 Nothing screen $ Just (SDL.Rect 10 10 w1 h1)
message2 <- TTF.renderTextSolid font
("Points: " ++ show (gamePoints over))
(SDL.Color 128 128 128)
let w2 = SDL.surfaceGetWidth message2
h2 = SDL.surfaceGetHeight message2
SDL.blitSurface message2 Nothing screen $
Just (SDL.Rect 10 (10 + h2 + 5) w2 h2)
message3 <- TTF.renderTextSolid font
("Lives: " ++ show (gameLives over))
(SDL.Color 128 128 128)
let rightMargin = SDL.surfaceGetWidth screen
w2 = SDL.surfaceGetWidth message3
h2 = SDL.surfaceGetHeight message3
SDL.blitSurface message3 Nothing screen $
Just (SDL.Rect (rightMargin - 10 - w2) 10 w2 h2)
-- | Paints a game object on a surface.
paintObject :: Resources -> Surface -> Object -> IO ()
paintObject resources screen object =
case objectKind object of
(Paddle (w, h)) -> void $ do let bI = imgSurface $ paddleImg resources
t <- mapRGB
(surfaceGetPixelFormat bI) 0 255 0
setColorKey bI [SrcColorKey, RLEAccel] t
SDL.blitSurface bI Nothing screen $
Just (SDL.Rect x y (round w) (round h))
(Block e (w, h)) -> void $ do let bI = imgSurface $ blockImage e
SDL.blitSurface bI Nothing screen $
Just (SDL.Rect x y (round w) (round h))
(Ball r) -> void $ do let x' = x - round r
y' = y - round r
sz = round (2 * r)
-- b <- convertSurface
-- (imgSurface $ ballImg resources)
-- (format)
-- []
let bI = imgSurface $ ballImg resources
t <- mapRGB
(surfaceGetPixelFormat bI) 0 255 0
setColorKey bI [SrcColorKey, RLEAccel] t
SDL.blitSurface bI Nothing screen $
Just (SDL.Rect x' y' sz sz)
_ -> return ()
where
format = surfaceGetPixelFormat screen
p = objectPos object
x = round (fst p)
y = round (snd p)
blockImage 3 = block1Img resources
blockImage 2 = block2Img resources
blockImage n = block3Img resources
-- * Resource management
newtype ResourceMgr = ResourceMgr { unResMgr :: IORef ResourceManager }
data ResourceManager = ResourceManager
{ lastKnownStatus :: GameStatus
, resources :: Resources
}
-- | Includes all the assets needed at the current time in the game.
data Resources = Resources
{ resFont :: Font
, blockHitSnd :: Audio
, bgImage :: Maybe Image
, ballImg :: Image
, block1Img :: Image
, block2Img :: Image
, block3Img :: Image
, paddleImg :: Image
, bgMusic :: Maybe Music
}
data Image = Image { imgName :: String, imgSurface :: Surface }
data Font = Font { fontName :: String, unFont :: TTF.Font }
-- | Ad-hoc resource loading
--
-- This function is ad-hoc in two senses: first, because it has the paths to
-- the files hard-coded inside. And second, because it loads the specific
-- resources that are needed, not a general
loadResources :: IO (Maybe ResourceMgr)
loadResources = runMaybeT $ do
-- Font initialization
ttfOk <- lift TTF.init
gameFont <- liftIO $ getDataFileName "data/lacuna.ttf"
-- Load the fonts we need
font <- liftIO $ TTF.tryOpenFont gameFont 32 -- What does the 32 do?
let myFont = fmap (Font gameFont) font
blockHit <-
liftIO $ loadAudio =<< getDataFileName "data/196106_aiwha_ding-cc-by.wav"
-- bgM <- liftIO $ loadMusic "Ckotty_-_Game_Loop_11.ogg"
-- bgM <- liftIO $ loadMusic "data/level0.mp3"
-- let levelBg = "data/level0.png"
-- img <- lift $ fmap (Image levelBg) $ load levelBg
ballImg <- liftIO $ getDataFileName "data/ball2.png"
ball <- lift $ Image ballImg <$> load ballImg
b1Img <- liftIO $ getDataFileName "data/block1.png"
b1 <- lift $ Image b1Img <$> load b1Img
b2Img <- liftIO $ getDataFileName "data/block2.png"
b2 <- lift $ Image b2Img <$> load b2Img
b3Img <- liftIO $ getDataFileName "data/block3.png"
b3 <- lift $ Image b3Img <$> load b3Img
paddleImg <- liftIO $ getDataFileName "data/paddleBlu.png"
paddle <- lift $ Image paddleImg <$> load paddleImg
-- Start playing music
-- when (isJust bgM) $ lift (playMusic (fromJust bgM))
-- Return Nothing or embed in Resources
res <- case (myFont, blockHit) of
(Just f, Just b) -> return $
Resources f b Nothing
ball b1 b2
b3 paddle Nothing
_ -> do liftIO $
putStrLn
"Some resources could not be loaded"
mzero
liftIO $ ResourceMgr <$>
newIORef (ResourceManager GameStarted res)
loadNewResources :: ResourceMgr -> GameState -> IO Resources
loadNewResources mgr state = do
manager <- readIORef (unResMgr mgr)
let oldState = lastKnownStatus manager
newState = gameStatus (gameInfo state)
oldResources = resources manager
newResources <- case newState of
(GameLoading _) | newState /= oldState
-> updateAllResources oldResources newState
_ -> return oldResources
let manager' = ResourceManager { lastKnownStatus = newState
, resources = newResources
}
writeIORef (unResMgr mgr) manager'
return newResources
updateAllResources :: Resources -> GameStatus -> IO Resources
updateAllResources res (GameLoading n) = do
-- Load new music
let newMusicFP' = _resourceFP $ levelMusic $ levels !! n
newMusicFP <- getDataFileName newMusicFP'
let oldMusic = bgMusic res
oldMusicFP = maybe "" musicName oldMusic
newMusic <- if oldMusicFP == newMusicFP
then return oldMusic
else do -- Loading can fail, in which case we continue with the
-- old music
bgM <- loadMusic newMusicFP
if isNothing bgM
then do putStrLn $
"Could not load resource " ++ newMusicFP
return oldMusic
else do stopMusic
return bgM
-- Load new background
let newBgFP' = _resourceFP $ levelBg $ levels !! n
newBgFP <- getDataFileName newBgFP'
let oldBg = bgImage res
oldBgFP = maybe "" imgName oldBg
newBg <- if oldBgFP == newBgFP
then return oldBg
else do img' <- load newBgFP
return $ Just (Image newBgFP img')
return (res { bgImage = newBg, bgMusic = newMusic })