astrds-0.1: src/RenderUtil.hs
module RenderUtil where
import Control.Monad
import qualified Graphics.UI.SDL as SDL hiding (init)
import qualified Graphics.UI.SDL.TTF as SDL
import Graphics.Rendering.OpenGL as GL
import Data.Map as M
import Utilities
import States
import StaticInterface
import Static
import RenderInterface
import Pic
-- * Some text colours
textColour, userInputColour, messageColour :: SDL.Color
textColour = SDL.Color {SDL.colorRed = 255, SDL.colorGreen = 255, SDL.colorBlue = 255}
userInputColour = SDL.Color {SDL.colorRed = 200, SDL.colorGreen = 200, SDL.colorBlue = 255}
messageColour = SDL.Color {SDL.colorRed = 0, SDL.colorGreen = 0, SDL.colorBlue = 0}
clearScreen :: IO ()
clearScreen = GL.clear [GL.ColorBuffer]
showScreen :: IO ()
showScreen =
do
GL.flush
SDL.glSwapBuffers
---------------------------------------------------------------------------
-- * Render an SDLPic
---------------------------------------------------------------------------
renderImg :: SDLPic -> Pos -> IO ()
renderImg = renderImgAttr defaultRenderAttr
renderImgAnchor :: Anchor -> SDLPic -> Pos -> IO ()
renderImgAnchor anchor =
renderImgAttr (defaultRenderAttr { ra_anchor = anchor })
fadeOutImg :: SDLPic -> Pos -> Int -> Int -> IO ()
fadeOutImg pic pos t et =
renderImgAttr
(defaultRenderAttr { ra_fade = FadeOut fading_duration (et - t) })
pic pos
renderImgAttr :: RenderAttr -> SDLPic -> Pos -> IO ()
renderImgAttr attr pic =
renderSpriteAttr attr (sdlPicToSprite pic) ()
data RenderAttr = RenderAttr { ra_anchor :: Anchor
, ra_fade :: Fade
, ra_scale :: Double
} -- etc
-- | The anchor specifies the position of the point that's
-- passed. The result is the upper left and lower right
-- corner in OpenGL terms.
data Anchor = TopLeft
| Centre
| TopRight
| TopCentre
data Fade = NoFade
| FadeIn Int Int
| FadeOut Int Int
defaultRenderAttr = RenderAttr Centre NoFade 1.0
type ScaledDim = (Double, Double)
anchorTransform :: Anchor -> Pos -> ScaledDim -> (Pos, Pos)
anchorTransform TopCentre (x,y) (w,h) =
let w2 = w / 2
in ((x - w2, y), (x + w2, y + h))
anchorTransform Centre (x,y) (w,h) =
let w2 = w / 2
h2 = h / 2
in ((x - w2, y - h2), (x + w2, y + h2))
anchorTransform TopLeft (x,y) (w,h) =
((x,y), (x + w,y + h))
anchorTransform TopRight (x,y) (w,h) =
((x - w,y), (x, y + h))
renderSprite :: Ord a => SDLSprite a -> a -> Pos -> IO ()
renderSprite = renderSpriteAttr defaultRenderAttr
renderSpriteAttr :: Ord a => RenderAttr -> SDLSprite a -> a -> Pos -> IO ()
renderSpriteAttr (RenderAttr anchor fade scale) pic o pos
= do
let img = sdl_image (sdl_sprite pic)
let (w,h) = sdl_dim (sdl_sprite pic)
let (tw,th) = sdl_tiledim pic
let dim = (scale * fromIntegral tw, scale * fromIntegral th)
let op = sdl_offsets pic M.! o
-- here, we adapt the alpha channel ...
let alpha :: Float
alpha = case fade of
NoFade -> 1
FadeIn dur dt ->
1 - (fromIntegral dt / fromIntegral dur)
FadeOut dur dt ->
fromIntegral dt / fromIntegral dur
GL.color (GL.Color4 1 1 1 (alpha :: Float))
GL.texture GL.Texture2D $= GL.Enabled
GL.textureBinding GL.Texture2D $= Just img
GL.textureFunction $= GL.Modulate
GL.renderPrimitive GL.Quads $
do
let x0, x1, y0, y1, sx, sy, tx, ty :: Double
((x0,y0),(x1,y1)) = anchorTransform anchor pos dim
sx = nextPowerOfTwoFraction op w
sy = nextPowerOfTwoFraction 0 h
tx = nextPowerOfTwoFraction (op + tw) w
ty = nextPowerOfTwoFraction h h
GL.texCoord (GL.TexCoord2 (sx :: Double) sy)
GL.vertex (GL.Vertex2 x0 y0)
GL.texCoord (GL.TexCoord2 (tx :: Double) sy)
GL.vertex (GL.Vertex2 x1 y0)
GL.texCoord (GL.TexCoord2 (tx :: Double) ty)
GL.vertex (GL.Vertex2 x1 y1)
GL.texCoord (GL.TexCoord2 (sx :: Double) ty)
GL.vertex (GL.Vertex2 x0 y1)
return ()
-- TODO: parametrise
fading_duration :: Int
fading_duration = 30
fadeOutSprite :: Ord a => SDLSprite a -> a -> Pos -> Int -> Int -> IO ()
fadeOutSprite pic o pos t et
= renderSpriteAttr (defaultRenderAttr { ra_fade = FadeOut fading_duration (et - t) })
pic o pos
renderAnimation :: SDLAnimation -> Int -> Pos -> IO ()
renderAnimation (SDLAnimation sprite descr) t pos
= renderSprite sprite (descr t) pos
renderAnimationAttr :: RenderAttr -> SDLAnimation -> Int -> Pos -> IO ()
renderAnimationAttr ra (SDLAnimation sprite descr) t pos
= renderSpriteAttr ra sprite (descr t) pos
---------------------------------------------------------------------------
-- * Render text
---------------------------------------------------------------------------
renderTextFontAttr :: String -> SDL.Color -> Pos -> SDL.Font -> RenderAttr -> IO ()
renderTextFontAttr txt c pos fnt attr
= do
rtxt <- SDL.renderTextBlended fnt txt c
pic <- convertSurface (SDL.surfaceGetWidth rtxt, SDL.surfaceGetHeight rtxt) rtxt
renderImgAttr attr pic pos
GL.deleteObjectNames [ sdl_image pic ]
renderTextFontAnchor :: String -> SDL.Color -> Pos -> SDL.Font -> Anchor -> IO ()
renderTextFontAnchor txt c pos fnt anchor
= renderTextFontAttr txt c pos fnt (defaultRenderAttr { ra_anchor = anchor })
renderTextCFnt :: String -> SDL.Color -> Pos -> SDL.Font -> IO ()
renderTextCFnt txt c pos fnt = renderTextFontAnchor txt c pos fnt TopCentre
renderText :: String -> SDL.Color -> Pos -> Static -> IO ()
renderText txt c pos st
= let fnt = font (fonts st)
in renderTextFontAnchor txt c pos fnt TopLeft
renderTextC :: String -> SDL.Color -> Pos -> Static -> IO ()
renderTextC txt c pos st
= let fnt = font (fonts st)
in renderTextFontAnchor txt c pos fnt Centre
renderBigText :: String -> SDL.Color -> Pos -> Static -> IO ()
renderBigText txt c pos st
= let bigfnt = bigfont (fonts st)
in renderTextFontAnchor txt c pos bigfnt TopLeft
renderTexts :: [String] -> SDL.Color -> Pos -> Static -> IO ()
renderTexts txts c (x,y) st
= let fnt = font (fonts st)
in renderGLines (x,y) fnt txts
renderBigTextR :: String -> SDL.Color -> Pos -> Static -> IO ()
renderBigTextR txt c pos st
= let bigfnt = bigfont (fonts st)
in renderTextFontAnchor txt c pos bigfnt TopRight
renderBigTextC :: String -> SDL.Color -> Pos -> Static -> IO ()
renderBigTextC txt c pos st
= let bigfnt = bigfont (fonts st)
in renderTextFontAnchor txt c pos bigfnt Centre
fadeOutBigTextC :: String -> SDL.Color -> Pos -> Static -> Int -> Int -> IO ()
fadeOutBigTextC txt c pos st t et
= let bigfnt = bigfont (fonts st)
in renderTextFontAttr txt c pos bigfnt (defaultRenderAttr { ra_anchor = Centre, ra_fade = FadeOut fading_duration (et - t) })
---------------------------------------------------------------------------
-- * Render lines in SDL
---------------------------------------------------------------------------
renderGLinesAnchor :: Anchor -> Pos -> SDL.Font -> [String] -> IO ()
renderGLinesAnchor anchor pos fnt [] = return ()
renderGLinesAnchor anchor pos@(x,y) fnt (s:ss) =
do
renderTextFontAnchor s textColour pos fnt anchor
baselineskip <- SDL.fontLineSkip fnt
let npos = (x, y + fromIntegral baselineskip)
renderGLinesAnchor anchor npos fnt ss
renderGLines, renderGLinesR :: Pos -> SDL.Font -> [String] -> IO ()
renderGLines = renderGLinesAnchor TopLeft
renderGLinesR = renderGLinesAnchor TopRight