dow-0.1.0: src/Render.hs
module Render
( getAspectRatio
, getRenderFunctions
, setViewport
) where
import Control.Monad
import Data.Array
import Data.Char
import Data.IORef
import Foreign.Marshal
import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL hiding (position)
import Actor as A
import Game
import GraphUtils
import Level
import Text
import Vector
hudHeight = 0.2
solid :: GLfloat
solid = 1
fullLevelSize = addBorder . levelSize
where addBorder (w,h) = (w+2,h+2)
getAspectRatio level = fromIntegral lh / fromIntegral lw + hudHeight
where (lw,lh) = fullLevelSize level
setViewport ref size@(Size w h) = do
lr <- readIORef ref
let r = (fromIntegral h/fromIntegral w)
r' = recip r
lr' = recip lr
s = 2*min (max 1 (min lr' r')) (max (r/lr) lr')
viewport $= (Position 0 0,size)
matrixMode $= Projection
loadIdentity
scale (s*min 1 r) (s*min 1 r') (1 :: GLfloat)
translate $ Vector3 (-0.5) (-0.5*lr) (0 :: GLfloat)
matrixMode $= Modelview 0
setAspectRatio ref val = do
writeIORef ref val
setViewport ref =<< get windowSize
getRenderFunctions aspectRatio charset = do
let displayText = uncurry displayString charset
rgbOverlay <- createTexture 24 24 True $ flip pokeArray $
concat [if b then [95,95,95,255] else c | y <- [0..23], x <- [0..23],
let c = case x `div` 4 `mod` 3 of
0 -> [255,191,191,255]
1 -> [191,255,191,255]
2 -> [191,191,255,255]
b = x `mod` 4 == 0 || x < 12 && y `mod` 12 == 0 || x >= 12 && y `mod` 12 == 6
]
return (renderGame aspectRatio displayText rgbOverlay
,renderMenu aspectRatio displayText rgbOverlay
)
renderMenu aspectRatio displayText rgbOverlay score items item = do
let charSize = 0.006
textCol = Color4 1 0 0 solid
activeCol = Color4 0.93 0.79 0 solid
menu = "DUNGEONS OF WOR":"":"":items++["","","HIGH SCORE "++show score]
setAspectRatio aspectRatio 1
clear [ColorBuffer]
loadIdentity
texture Texture2D $= Enabled
forM_ (zip menu [-3..]) $ \(text,i) -> do
color $ if i == item then activeCol else textCol
displayText (0.5-(fromIntegral (length text)*4*charSize))
(0.5+charSize*(7*fromIntegral (length items-1-2*i)))
charSize text
renderOverlay rgbOverlay
flush
swapBuffers
renderGame aspectRatio displayText rgbOverlay levelState levelCount scores lives = do
let curLevel = level levelState
(lw,lh) = fullLevelSize curLevel
height = fromIntegral lh / fromIntegral lw
magn = 1 / fromIntegral lw
setAspectRatio aspectRatio (getAspectRatio curLevel)
clear [ColorBuffer]
loadIdentity
renderHud displayText height scores lives (actors levelState) levelCount curLevel
preservingMatrix $ do
translate $ Vector3 0 hudHeight (0 :: GLfloat)
scale magn magn (1 :: GLfloat)
renderLevel curLevel
renderBullets (bullets levelState)
renderActors (actors levelState)
renderOverlay rgbOverlay
flush
swapBuffers
renderOverlay rgbOverlay = do
texture Texture2D $= Enabled
textureBinding Texture2D $= Just rgbOverlay
blendFunc $= (Zero,SrcColor)
color $ Color4 1 1 1 solid
let pscale = 100
renderPrimitive Quads $ do
texCoord2 0 0
vertex3 0 0 0
texCoord2 pscale 0
vertex3 1 0 0
texCoord2 pscale pscale
vertex3 1 1 0
texCoord2 0 pscale
vertex3 0 1 0
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderLevel level = do
let (lw,lh) = fullLevelSize level
height = fromIntegral lh / fromIntegral lw
entries = [((y,x),[]) | (_,y,x) <- entrances level]
texture Texture2D $= Disabled
color $ Color4 0.2 0.5 1 solid
forM_ (entries ++ assocs (legalMoves level)) $ \((y,x),ms) -> do
let xc = fromIntegral (x+1)
yc = fromIntegral (lh-y-2)
unless (North `elem` ms) $ drawRectangle xc (yc+0.95) 1 0.05
unless (South `elem` ms) $ drawRectangle xc yc 1 0.05
unless (East `elem` ms) $ drawRectangle (xc+0.95) yc 0.05 1
unless (West `elem` ms) $ drawRectangle xc yc 0.05 1
renderActors as = do
let players = filter ((`elem` [BlueWorrior,YellowWorrior]) . actorType) as
texture Texture2D $= Enabled
color $ Color4 1 1 1 solid
forM_ as $ \a -> do
let V x y = A.position a
x' = fromIntegral x / fromIntegral fieldSize
y' = fromIntegral y / fromIntegral fieldSize
dist = case actorType a of
Garwor -> 2*fieldSize
Thorwor -> fieldSize
_ -> maxBound
visible = any ((\(V px py) -> abs (x-px) < dist || abs (y-py) < dist) . A.position) players
when (visible && (not . null . animation) a) $
drawSprite (head (animation a)) (1.1+x') (1.1+y') 0.8 0.8 (facing a)
renderBullets bs = do
texture Texture2D $= Disabled
color $ Color4 1 0.3 0.1 solid
forM_ bs $ \(_,V x y) -> do
let x' = fromIntegral x / fromIntegral fieldSize
y' = fromIntegral y / fromIntegral fieldSize
drawRectangle (1.45+x') (1.45+y') 0.1 0.1
renderHud displayText height scores lives actors levelCount level = do
let r = Color4 1 0 0 solid
b = Color4 0.25 0.63 1 solid
y = Color4 0.93 0.79 0 solid
d = Color4 0 0 0 solid
charSize = 0.0028
radarTitle = if levelCount == 1 then "RADAR" else
case levelName level of
"pit" -> "THE PIT"
"arena" -> "THE ARENA"
_ -> "DUNGEON " ++ show levelCount
(levelW,levelH) = levelSize level
scoreB = hudHeight / 4
scoreW = 0.3
scoreH = scoreB*3
radarB = charSize
radarW = radarF*fromIntegral levelW
radarH = hudHeight-radarB*4-charSize*10
radarF = radarH/fromIntegral levelH
snum1 = show (scores !! 0)
snum2 = show (scores !! 1)
lnum1 = show (lives !! 0)
lnum2 = show (lives !! 1)
numPlayers = length lives
texture Texture2D $= Disabled
color b
drawRectangle 0 0 scoreW scoreH
drawRectangle (0.5-radarW/2-radarB) 0 (radarW+radarB*2) (radarH+radarB*2)
color y
drawRectangle (1-scoreW) 0 scoreW scoreH
color d
drawRectangle scoreB scoreB (scoreW-2*scoreB) (scoreH-2*scoreB)
drawRectangle (1-scoreW+scoreB) scoreB (scoreW-2*scoreB) (scoreH-2*scoreB)
drawRectangle (0.5-radarW/2) radarB radarW radarH
forM_ actors $ \actor -> do
let (fx,fy) = fieldPos (position actor)
rx = 0.5-radarW/2+radarF*fromIntegral fx
ry = radarB+radarF*fromIntegral fy
case actorType actor of
Burwor -> color b >> drawRectangle rx ry radarF radarF
Garwor -> color y >> drawRectangle rx ry radarF radarF
Thorwor -> color r >> drawRectangle rx ry radarF radarF
_ -> return ()
texture Texture2D $= Enabled
color y
displayText (1-scoreB-(fromIntegral (length snum1)*8*charSize)) (scoreB+scoreH/2-scoreB-5*charSize) charSize snum1
displayText (1-scoreW-3*radarB-(fromIntegral (length lnum1)*8*charSize)) (scoreB+scoreH/2-scoreB-5*charSize) charSize lnum1
when (numPlayers > 1) $ do
color b
displayText (scoreW-scoreB-(fromIntegral (length snum2)*8*charSize)) (scoreB+scoreH/2-scoreB-5*charSize) charSize snum2
displayText (scoreW+3*radarB) (scoreB+scoreH/2-scoreB-5*charSize) charSize lnum2
color r
displayText (0.5-(fromIntegral (length radarTitle)*4*charSize)) (radarH+radarB*3) charSize radarTitle
drawRectangle :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
drawRectangle x y sx sy = renderPrimitive Quads $ mapM_ vertex
[Vertex3 x y 0, Vertex3 (x+sx) y 0, Vertex3 (x+sx) (y+sy) 0, Vertex3 x (y+sy) 0]
drawSprite :: TextureObject -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> Direction -> IO ()
drawSprite tid x y sx sy dir = do
let (u1,v1,u2,v2,u3,v3,u4,v4) = case dir of
North -> (1,1,1,0,0,0,0,1)
East -> (1,1,0,1,0,0,1,0)
South -> (0,1,0,0,1,0,1,1)
West -> (0,1,1,1,1,0,0,0)
textureBinding Texture2D $= Just tid
renderPrimitive Quads $ do
texCoord2 u1 v1
vertex3 x y 0
texCoord2 u2 v2
vertex3 (x+sx) y 0
texCoord2 u3 v3
vertex3 (x+sx) (y+sy) 0
texCoord2 u4 v4
vertex3 x (y+sy) 0