209 lines
7.1 KiB
Haskell
209 lines
7.1 KiB
Haskell
--{-# LANGUAGE Strict #-}
|
|
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
|
|
module Picture.Render
|
|
( module Picture.Render
|
|
, picToLTree
|
|
)
|
|
where
|
|
|
|
import Shader
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
|
|
import qualified Control.Applicative as Ap
|
|
|
|
import Linear.Matrix
|
|
import Linear.V4
|
|
|
|
import qualified Control.Foldl as F
|
|
|
|
import Data.Bifunctor
|
|
|
|
import Picture.Data
|
|
import Picture.Tree
|
|
import Geometry
|
|
|
|
import Picture.Preload
|
|
|
|
import Foreign hiding (rotate)
|
|
|
|
import Codec.Picture
|
|
|
|
import Graphics.GL.Core43
|
|
|
|
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import Data.Foldable
|
|
import Data.List
|
|
import Data.Maybe (fromJust)
|
|
|
|
--import qualified Data.Vector.Storable as V
|
|
import qualified Data.IntMap as IM
|
|
--import qualified Data.DList as DL
|
|
|
|
--import Control.DeepSeq
|
|
|
|
import qualified SDL as SDL
|
|
|
|
pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
|
|
{-# INLINE pokeTwoOff #-}
|
|
pokeTwoOff ptr n (x,y) = do
|
|
pokeElemOff ptr (2*n+0) x
|
|
pokeElemOff ptr (2*n+1) y
|
|
pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
|
|
{-# INLINE pokeThreeOff #-}
|
|
pokeThreeOff ptr n (x,y,z) = do
|
|
pokeElemOff ptr (3*n+0) x
|
|
pokeElemOff ptr (3*n+1) y
|
|
pokeElemOff ptr (3*n+2) z
|
|
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
|
|
{-# INLINE pokeFourOff #-}
|
|
pokeFourOff ptr n (x,y,z,w) = do
|
|
pokeElemOff ptr (4*n+0) x
|
|
pokeElemOff ptr (4*n+1) y
|
|
pokeElemOff ptr (4*n+2) z
|
|
pokeElemOff ptr (4*n+3) w
|
|
|
|
renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
|
|
[(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
|
|
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
|
|
wallPokeStart <- SDL.ticks
|
|
|
|
-- setting the depth function to less, instead of lequal,
|
|
-- seems to stop a lot of unecessary drawing
|
|
-- of wall shadows when creating the light map
|
|
depthFunc $= Just Less
|
|
|
|
-- calculate world transformation matrix
|
|
let scalMat = Linear.Matrix.transpose $
|
|
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))
|
|
(V4 0 (2*zoom/winy) 0 0)
|
|
(V4 0 0 1 0)
|
|
(V4 0 0 0 1)
|
|
let rotMat = Linear.Matrix.transpose $
|
|
V4 (V4 (cos rot) (sin (-rot)) 0 0)
|
|
(V4 (sin rot) (cos rot) 0 0)
|
|
(V4 0 0 1 0)
|
|
(V4 0 0 0 1)
|
|
let tranMat = Linear.Matrix.transpose $
|
|
V4 (V4 1 0 0 0)
|
|
(V4 0 1 0 0)
|
|
(V4 0 0 1 0)
|
|
(V4 (-tranx) (-trany) 0 1)
|
|
let wmat = scalMat !*! rotMat !*! tranMat
|
|
vToL (V4 a b c d) = [a,b,c,d]
|
|
wmata <- (newMatrix RowMajor $ concatMap vToL $ vToL wmat) :: IO (GLmatrix GLfloat)
|
|
|
|
-- set common uniforms
|
|
setShaderUniforms rot zoom (tranx,trany) (winx,winy)
|
|
( (extractProgAndUnis $ _lightSourceShader pdata)
|
|
: (extractProgAndUnis $ _wlShadShader pdata)
|
|
: (map extractProgAndUnis $ _listShaders pdata)
|
|
)
|
|
|
|
forM_ [--lightmapCircleShader pdata
|
|
_backShader pdata
|
|
,_wallShadowShader pdata
|
|
] $ \shad -> do
|
|
currentProgram $= Just (fst shad)
|
|
uniform (snd shad !! 0) $= Vector2 winx winy
|
|
uniform (snd shad !! 1) $= zoom
|
|
uniform (snd shad !! 2) $= rot
|
|
uniform (snd shad !! 3) $= Vector2 tranx trany
|
|
uniform (snd shad !! 4) $= wmata
|
|
|
|
-- draw lightmap
|
|
|
|
nWalls <- F.foldM (pokeShader (_wlShadShader pdata)) wallPoints
|
|
bindShaderBuffers [_wlShadShader pdata] [nWalls]
|
|
|
|
forM_ lightPoints $ \(x,y,r,lum) -> do
|
|
cullFace $= Just Front
|
|
clear [DepthBuffer]
|
|
|
|
-- currentProgram does get called twice: here and inside drawShader below
|
|
currentProgram $= Just (_shaderProgram $ _wlShadShader pdata)
|
|
uniform (head $ fromJust $ _shaderCustomUnis $ _wlShadShader pdata)
|
|
$= Vector2 (x) (y)
|
|
blendFunc $= (Zero,One)
|
|
drawShader (_wlShadShader pdata) nWalls
|
|
|
|
cullFace $= Nothing
|
|
|
|
let lightPtr = (\(_,ptr,_) -> ptr) $ head
|
|
$ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
|
|
pokeFourOff lightPtr 0 (x,y,r,lum)
|
|
bindShaderBuffers [_lightSourceShader pdata] [1]
|
|
|
|
blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
|
|
drawShader (_lightSourceShader pdata) 1
|
|
|
|
startWallTicks <- SDL.ticks
|
|
wallPokeEnd <- SDL.ticks
|
|
ticksS <- SDL.ticks
|
|
ticksAfterL <- SDL.ticks
|
|
-- draw picture
|
|
-- set drawing for on top
|
|
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
|
clear [DepthBuffer]
|
|
-- draw background
|
|
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
|
|
depthFunc $= Just Less
|
|
|
|
currentProgram $= Just (fst $ _backShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
|
|
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
|
|
backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
|
|
pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
|
|
pokeTwoOff backPtr2 0 (winx,winy)
|
|
textureBinding Texture2D $= Just (_textures pdata !! 1)
|
|
drawArrays Points (fromIntegral 0) (fromIntegral 1)
|
|
|
|
depthFunc $= Just Lequal
|
|
|
|
-- draw layer 0
|
|
ticks2 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
|
|
--((picToAlt 0 pic) :: [RenderType])
|
|
-- reset blend so that light map doesn't apply
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
ticks3 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
|
|
-- set drawing for on top
|
|
aticks <- SDL.ticks
|
|
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
|
ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
|
|
bticks <- SDL.ticks
|
|
|
|
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
|
|
|
|
endWallTicks <- SDL.ticks
|
|
--return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
|
|
ticksE <- SDL.ticks
|
|
--return (ticksAfterL, ticksE - ticksS)
|
|
--return (ticksAfterL, ticks2 + ticks3 + ticks4)
|
|
return (ticksAfterL, wallPokeEnd - wallPokeStart)
|
|
|
|
bufferOffset :: Integral a => a -> Ptr b
|
|
bufferOffset = plusPtr nullPtr . fromIntegral
|
|
|
|
renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
|
-> f RenderType -> IO Word32
|
|
renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
|
pokeStartTicks <- SDL.ticks
|
|
|
|
let slist = _listShaders pdata
|
|
|
|
-- poke data, returns list of number of vertices for each shader
|
|
is <- F.foldM (pokeShaders slist) tree
|
|
|
|
-- the idea of doing as binding of buffers at once, rather than interweaving with draw
|
|
-- calls, is to prevent opengl from waiting for a draw call to finish
|
|
-- before it performs another state change
|
|
bindShaderBuffers slist is
|
|
|
|
drawShaders slist is
|
|
|
|
pokeEndTicks <- SDL.ticks
|
|
return $ pokeEndTicks - pokeStartTicks
|