{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Display where
import Control.Arrow ((***))
import Control.Monad
import Data.Maybe (fromJust)
import FRP.Yampa.VectorSpace
import Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.Primitives as SDLP
import qualified Graphics.UI.SDL.TTF as TTF
import Graphics.UI.Extra.SDL as SDL
import Text.Printf
import Constants
import GameState
import Objects
import Resources
import Physics.TwoDimensions.Shapes
-- | 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,
-- so it's not a general, parameterised, scalable solution.
--
loadResources :: IO Resources
loadResources = do
-- Font initialization
_ <- TTF.init
-- Load the fonts we need
let gameFont = "data/lacuna.ttf"
font <- TTF.openFont gameFont 32 -- 32: fixed size?
-- Load the fonts we need
let gameFont = "data/lacuna.ttf"
font2 <- TTF.openFont gameFont 8 -- 32: fixed size?
-- Return all resources (just the font)
return $ Resources font font2
initializeDisplay :: IO ()
initializeDisplay =
-- Initialise SDL
SDL.init [InitEverything]
initGraphs :: Resources -> IO ()
initGraphs _res = do
screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]
SDL.setCaption gameName ""
-- 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 True
return ()
render :: Resources -> GameState -> IO()
render resources shownState = do
-- Obtain surface
screen <- getVideoSurface
-- Clear BG
fillRect screen Nothing (Pixel backgroundColor)
-- Paint objects
mapM_ (paintObject screen resources (gameTime (gameInfo shownState))) (gameObjects shownState)
when debugCollisions $
mapM_ (paintShape screen resources (gameTime (gameInfo shownState))) (gameObjects shownState)
-- Paint HUD
displayInfo screen resources (gameInfo shownState) (gameObjects shownState)
-- Paint messages/popups (eg. "Paused", "Level 0", etc.)
displayMessage screen resources (gameInfo shownState)
-- Double buffering
SDL.flip screen
-- * Painting functions
displayInfo :: Surface -> Resources -> GameInfo -> Objects -> IO()
displayInfo screen resources over objs = do
printAlignRight screen resources
("Time: " ++ printf "%.2f" (gameTime over)) (10,50)
let p = findPlayer objs
case p of
Just p' -> let e = playerEnergy p'
in printAlignRight screen resources ("Energy: " ++ show e) (10,100)
Nothing -> return ()
paintObject :: Surface -> Resources -> Double -> Object -> IO ()
paintObject screen resources time object =
case objectKind object of
(Side {}) -> return ()
(Ball ballSize) -> do
let (px,py) = (\(u,v) -> (u, gameHeight - v)) (objectPos object)
let (x,y) = (round *** round) (px,py)
(vx,vy) = objectVel object
(x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))
_ <- SDLP.filledCircle screen x y (round ballSize) (SDL.Pixel ballColor)
_ <- SDLP.line screen x y x' y' (SDL.Pixel velColor)
-- Print position
let font = miniFont resources
message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor
let w = SDL.surfaceGetWidth message
h = SDL.surfaceGetHeight message
(x'',y'') = (round *** round) (px,py)
rect = SDL.Rect (x''+30) (y''-30) w h
SDL.blitSurface message Nothing screen (Just rect)
return ()
(Block sz@(w', h')) -> void $ do
let (px,py) = (objectPos object)
(x,y) = (round *** round) (px,gameHeight - py -h')
(w,h) = (round *** round) sz
fillRect screen (Just (Rect x y w h)) (Pixel blockColor)
(Player state _ vulnerable energy) -> do
let blinkOn = vulnerable || (even (round (time * 10)))
when blinkOn $ do
let (px,py) = (\(u,v) -> (u, gameHeight - v - playerHeight)) (objectPos object)
let (x,y) = (round *** round) (px,py)
(vx,vy) = objectVel object
(x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))
(w,h) = (round playerWidth, round playerHeight)
playerColor = case (state, vulnerable) of
(PlayerRight, True) -> playerRightColor
(PlayerLeft , True) -> playerLeftColor
(PlayerStand, True) -> playerStandColor
(PlayerRight, False) -> playerBlinkRightColor
(PlayerLeft , False) -> playerBlinkLeftColor
(PlayerStand, False) -> playerBlinkStandColor
fillRect screen (Just (Rect x y w h)) (Pixel playerColor)
_ <- SDLP.line screen (fromIntegral x) (fromIntegral y) x' y' (SDL.Pixel velColor)
-- Print position
let font = miniFont resources
message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor
let w = SDL.surfaceGetWidth message
h = SDL.surfaceGetHeight message
(x'',y'') = (round *** round) (px,py)
rect = SDL.Rect (x''+30) (y''-30) w h
SDL.blitSurface message Nothing screen (Just rect)
return ()
Projectile -> do
let (x0,y0) = (\(x,y) -> (x - 5, height - y)) $ objectPos object
(dx, dy) = (10, snd (objectPos object))
(x0', y0', dx', dy') = (round x0, round y0, round dx, round dy)
fillRect screen (Just (Rect x0' y0' dx' dy')) (Pixel fireColor)
return ()
paintShape :: Surface -> Resources -> Double -> Object -> IO ()
paintShape screen resources time object =
paintShape' screen resources time (objShape object)
paintShape' screen resources time shape =
case shape of
Rectangle (px, py) (w,h) -> void $ do
let x1 = round px
x2 = round (px + w)
y1 = round (gameHeight - py - h)
y2 = round (gameHeight - py)
drawThickRectangle screen (Rect x1 y1 x2 y2) (Pixel collisionDebugColor) collisionDebugThickness
Circle (px, py) rd -> void $ do
let x = round px
y = round (gameHeight - py)
r = round rd
drawThickCircle screen x y r (Pixel collisionDebugColor) collisionDebugThickness
SemiPlane (px, py) s ->
let w = round width
h = round height
in case s of
LeftSide -> drawThickLine screen 0 0 0 h (Pixel collisionDebugColor) collisionDebugThickness
RightSide -> drawThickLine screen w 0 w h (Pixel collisionDebugColor) collisionDebugThickness
TopSide -> drawThickLine screen 0 0 w 0 (Pixel collisionDebugColor) collisionDebugThickness
BottomSide -> drawThickLine screen 0 h w h (Pixel collisionDebugColor) collisionDebugThickness
drawThickRectangle surface (Rect x1 y1 x2 y2) pixel 0 = return ()
drawThickRectangle surface rect@(Rect x1 y1 x2 y2) pixel n = do
let n' = n-1
SDLP.rectangle surface (Rect (x1-n') (y1-n') (x2+n') (y2+n')) pixel
drawThickRectangle surface rect pixel n'
drawThickCircle screen x y r pixel 0 = return ()
drawThickCircle screen x y r pixel n = do
let n' = n-1
SDLP.circle screen x y (r+n') pixel
drawThickCircle screen x y r pixel n'
drawThickLine screen x1 y1 x2 y2 pixel 0 = return ()
drawThickLine screen x1 y1 x2 y2 pixel n = do
let n' = n-1
SDLP.line screen (x1) (y1-n') (x2) (y2-n') pixel
SDLP.line screen (x1) (y1+n') (x2) (y2+n') pixel
SDLP.line screen (x1-n') (y1) (x2-n') (y2) pixel
SDLP.line screen (x1+n') (y1) (x2+n') (y2) pixel
drawThickLine screen x1 y1 x2 y2 pixel n'
-- * Painting functions
displayMessage :: Surface -> Resources -> GameInfo -> IO()
displayMessage screen resources info = case gameStatus info of
GameLoading ->
printAlignCenter screen resources ("Level " ++ show (gameLevel info))
_ -> return ()
-- * Render text with alignment
printAlignRight :: Surface -> Resources -> String -> (Int, Int) -> IO ()
printAlignRight screen resources msg (x,y) = void $ do
let font = resFont resources
message <- TTF.renderTextSolid font msg fontColor
renderAlignRight screen message (x,y)
-- * Render text with alignment
printAlignCenter :: Surface -> Resources -> String -> IO ()
printAlignCenter screen resources msg = void $ do
let font = resFont resources
message <- TTF.renderTextSolid font msg fontColor
renderAlignCenter screen message