565 lines
22 KiB
Haskell
565 lines
22 KiB
Haskell
--{-# LANGUAGE Strict #-}
|
|
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
|
|
module Picture.Render
|
|
where
|
|
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 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 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
|
|
|
|
white = (1,1,1,1)
|
|
black = (0,0,0,1)
|
|
|
|
polyToTris :: [s] -> [s]
|
|
{-# INLINE polyToTris #-}
|
|
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
|
|
polyToTris _ = []
|
|
|
|
tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
|
|
{-# INLINE tripFirst #-}
|
|
tripFirst f (x,y,z) = (f x,y,z)
|
|
|
|
tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
|
|
{-# INLINE tripSecond #-}
|
|
tripSecond f (x,y,z) = (x,f y,z)
|
|
|
|
scaleT :: (Float,Float) -> (Point3,Point4,Point3) -> (Point3,Point4,Point3)
|
|
{-# INLINE scaleT #-}
|
|
scaleT (x,y) (a,b,(o,s,t)) = (a,b,(o,s*x,t*y))
|
|
|
|
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
|
{-# INLINE overPos #-}
|
|
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
|
|
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
|
|
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
|
|
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
|
|
overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
|
|
overPos f (RenderArc (a,b,c)) = RenderArc (f a,b,c)
|
|
|
|
overRot :: Float -> RenderType -> RenderType
|
|
{-# INLINE overRot #-}
|
|
overRot ang (RenderArc (a,b,(r,s,t,v))) = RenderArc (a,b,(r+ang,s+ang,t,v))
|
|
overRot _ ren = ren
|
|
|
|
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
|
{-# INLINE overCol #-}
|
|
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
|
|
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
|
|
overCol f (RenderEllipse vs) = RenderEllipse $ map (second $ f) vs
|
|
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
|
|
overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
|
|
overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
|
|
|
|
overSca :: (Point2 -> Point2) -> RenderType -> RenderType
|
|
{-# INLINE overSca #-}
|
|
overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs
|
|
overSca f p = p
|
|
|
|
scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
|
|
{-# INLINE scaleRen #-}
|
|
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT (x,y)) vs
|
|
scaleRen x y rt = overPos (scale3 x y) rt
|
|
{-# INLINE translateRen #-}
|
|
translateRen x y = overPos $ translate3 x y
|
|
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
|
|
{-# INLINE rotateRen #-}
|
|
rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
|
|
--where f b = normalizeAngle $ a + b
|
|
where f b = a + b
|
|
rotateRen a pic = overPos (rotate3 a) pic
|
|
{-# INLINE setDepthRen #-}
|
|
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
|
|
{-# INLINE colorRen #-}
|
|
colorRen :: RGBA -> RenderType -> RenderType
|
|
colorRen c = overCol $ const c
|
|
|
|
stringToList :: String -> [(Point3,Point4,Point3)]
|
|
{-# INLINE stringToList #-}
|
|
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
|
|
[0,0.9*dimText..]
|
|
$ map charToTuple s
|
|
--where dimText = 100
|
|
dimText :: Float
|
|
dimText = 100
|
|
|
|
charToTuple :: Char -> (Point3,Point4,Point3)
|
|
{-# INLINE charToTuple #-}
|
|
charToTuple c = ((0,0,0),white,(offset,dimText,2*dimText))
|
|
where offset = fromIntegral (fromEnum c) - 32
|
|
|
|
picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
|
|
{-# INLINE picToAlt #-}
|
|
picToAlt x (Polygon i ps)
|
|
| i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
| otherwise = Ap.empty
|
|
picToAlt x (PolygonCol i vs)
|
|
| i /= x = Ap.empty
|
|
| otherwise =
|
|
let (ps,cs) = unzip vs
|
|
in Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
|
picToAlt x (Circle i r)
|
|
| i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
|
|
| otherwise = Ap.empty
|
|
picToAlt x (Ellipse i (ax,ay) (bx,by) r)
|
|
| i == x = Ap.pure $ RenderEllipse [((ax,ay+r,0),black)
|
|
,((ax,ay-r,0),black)
|
|
,((bx,by-r,0),black)
|
|
]
|
|
| otherwise = Ap.empty
|
|
picToAlt x (ThickArc i startA endA rad wdth)
|
|
| i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
|
| otherwise = Ap.empty
|
|
picToAlt x (Line i ps)
|
|
| i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
|
| otherwise = Ap.empty
|
|
picToAlt x (Text i s)
|
|
| i == x = Ap.pure $ RenderText $ stringToList s
|
|
| otherwise = Ap.empty
|
|
picToAlt j Blank = Ap.empty
|
|
picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
|
|
|
|
collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
|
|
collapseBranch f (FBranch g t) = FBranch (f . g) t
|
|
collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
|
|
collapseBranch f (FLeaf x) = FLeaf (f x)
|
|
|
|
picToLTree :: Maybe Int -> Picture -> LTree RenderType
|
|
{-# INLINE picToLTree #-}
|
|
picToLTree mx (Polygon i ps)
|
|
| Just i == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
| Nothing == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
|
| otherwise = LBranches []
|
|
picToLTree mx (PolygonCol i vs)
|
|
| Just i == mx || Nothing == mx =
|
|
let (ps,cs) = unzip vs
|
|
in LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
|
| otherwise = LBranches []
|
|
picToLTree mx (Circle i r)
|
|
| Just i == mx || Nothing == mx = LLeaf $ RenderEllipse
|
|
[((-r, r,0), black)
|
|
,((-r,-r,0), black)
|
|
,(( r,-r,0), black)
|
|
]
|
|
| otherwise = LBranches []
|
|
picToLTree mx (Ellipse i (ax,ay) (bx,by) r)
|
|
| Just i == mx || Nothing == mx = LLeaf $ RenderEllipse [((ax,ay+r,0),black)
|
|
,((ax,ay-r,0),black)
|
|
,((bx,by-r,0),black)
|
|
]
|
|
| otherwise = LBranches []
|
|
picToLTree mx (ThickArc i startA endA rad wdth)
|
|
| Just i == mx || Nothing == mx = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
|
| otherwise = LBranches []
|
|
picToLTree mx (Line i ps)
|
|
| Just i == mx || Nothing == mx = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
|
| otherwise = LBranches []
|
|
picToLTree mx (LineCol i vs)
|
|
| Just i == mx || Nothing == mx =
|
|
let (ps,cs) = unzip vs
|
|
in LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
|
|
| otherwise = LBranches []
|
|
picToLTree mx (Text i s)
|
|
| Just i == mx || Nothing == mx = LLeaf $ RenderText $ stringToList s
|
|
| otherwise = LBranches []
|
|
picToLTree j Blank = LBranches []
|
|
picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
|
|
picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic))
|
|
= picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic
|
|
picToLTree j (OverPic f f' r f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' r f'') ps)
|
|
picToLTree j (OverPic f f' r f'' pic) = fmap (overPos f . overSca f' . overRot r . overCol f'') $ picToLTree j pic
|
|
picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
|
|
| otherwise = LBranches []
|
|
picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
|
|
|
|
doubleLine :: [a] -> [a]
|
|
{-# INLINE doubleLine #-}
|
|
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
|
doubleLine _ = []
|
|
|
|
theFold :: TwoPtrs
|
|
-> ThreePtrs
|
|
-> ThreePtrs
|
|
-> TwoPtrs
|
|
-> ThreePtrs
|
|
-> TwoPtrs
|
|
-> F.FoldM IO RenderType (Int,Int,Int,Int,Int,Int)
|
|
theFold pas pbs pcs pds pes pfs
|
|
= (,,,,,) <$> pokeTwoPtrsWith pokePoly pas
|
|
<*> pokeThreePtrsWith pokeText pbs
|
|
<*> pokeThreePtrsWith pokeCirc pcs
|
|
<*> pokeTwoPtrsWith pokeLine pds
|
|
<*> pokeThreePtrsWith pokeArc pes
|
|
<*> pokeTwoPtrsWith pokeEllipse pfs
|
|
|
|
type ThreePtrs = (Ptr Float,Ptr Float,Ptr Float)
|
|
type TwoPtrs = (Ptr Float,Ptr Float)
|
|
|
|
pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
|
|
-> ThreePtrs -> F.FoldM IO RenderType Int
|
|
{-# INLINE pokeThreePtrsWith #-}
|
|
pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
|
|
pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
|
|
-> TwoPtrs -> F.FoldM IO RenderType Int
|
|
{-# INLINE pokeTwoPtrsWith #-}
|
|
pokeTwoPtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
|
|
|
|
pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokeArc #-}
|
|
pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
pokeFourOff pc n s
|
|
return $ n + 1
|
|
pokeArc _ n _ = return n
|
|
|
|
pokeEllipse:: TwoPtrs -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokeEllipse #-}
|
|
pokeEllipse ptrs n (RenderEllipse vs) = foldM (pokeEllipseVert ptrs) n vs
|
|
pokeEllipse _ n _ = return n
|
|
|
|
pokeEllipseVert :: TwoPtrs -> Int -> (Point3,Point4) -> IO Int
|
|
{-# INLINE pokeEllipseVert #-}
|
|
pokeEllipseVert (pa,pb) n (p,c)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
return $ n + 1
|
|
|
|
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
|
|
|
|
|
|
pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokeLine #-}
|
|
pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
|
|
pokeLine _ n _ = return n
|
|
|
|
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
|
{-# INLINE pokeLineVert #-}
|
|
pokeLineVert pa pb n (p,c)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
return (n+1)
|
|
|
|
pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokeCirc #-}
|
|
pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
pokeElemOff pc n s
|
|
return (n+1)
|
|
pokeCirc _ n _ = return n
|
|
|
|
pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokeText #-}
|
|
pokeText (pa,pb,pc) n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
|
|
pokeText _ n _ = return n
|
|
|
|
pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point3) -> IO Int
|
|
{-# INLINE pokeTextVert #-}
|
|
pokeTextVert pa pb pc n (p,c,t)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
pokeThreeOff pc n t
|
|
return (n+1)
|
|
|
|
pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
|
|
{-# INLINE pokePoly #-}
|
|
pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
|
|
pokePoly _ n _ = return n
|
|
|
|
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
|
{-# INLINE pokeVert #-}
|
|
pokeVert pa pb n (p,c)
|
|
| n > 20000 * 2 = return n
|
|
| otherwise = do
|
|
pokeThreeOff pa n p
|
|
pokeFourOff pb n c
|
|
return (n+1)
|
|
|
|
translate3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE translate3 #-}
|
|
translate3 a b (x,y,z) = (x+a,y+b,z)
|
|
scale3 :: Float -> Float -> Point3 -> Point3
|
|
{-# INLINE scale3 #-}
|
|
scale3 a b (x,y,z) = (x*a,y*b,z)
|
|
rotate3 :: Float -> Point3 -> Point3
|
|
{-# INLINE rotate3 #-}
|
|
rotate3 a (x,y,z) = (x',y',z)
|
|
where (x',y') = rotateV a (x,y)
|
|
|
|
fSize = sizeOf (0 :: Float)
|
|
|
|
bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
|
|
bindArrayBuffers numVs ps = do
|
|
forM_ ps $ \(bo,ptr,i) -> do
|
|
bindBuffer ArrayBuffer $= Just bo
|
|
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
|
|
|
|
twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
|
|
{-# INLINE twoPtrsVAO #-}
|
|
twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
|
|
(a:b:_) -> (a,b)
|
|
threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
|
|
{-# INLINE threePtrsVAO #-}
|
|
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
|
|
(a:b:c:_) -> (a,b,c)
|
|
|
|
|
|
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
|
|
forM_ [_basicShader pdata
|
|
,_textShader pdata
|
|
,_circShader pdata
|
|
,_arcShader pdata
|
|
,_ellipseShader pdata
|
|
,_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
|
|
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
|
|
let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
|
|
wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
|
|
foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
|
|
pokeFourOff wallPtr n (x,y,z,w)
|
|
-- pokeElemOff (_dummyPtr pdata) n (fromIntegral n)
|
|
pokeFourOff wallPtr2 n (a,b,c,d)
|
|
return $ n+1
|
|
nWalls <- foldM foldWalls 0 wallPoints
|
|
bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
|
|
|
|
forM_ lightPoints $ \(x,y,r,lum) -> do
|
|
cullFace $= Just Front
|
|
clear [DepthBuffer]
|
|
currentProgram $= Just (fst $ _wallShadowShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
|
|
uniform (_wssLightPos pdata) $= Vector2 (x) (y)
|
|
blendFunc $= (Zero,One)
|
|
-- drawElements Points (fromIntegral nWalls) UnsignedByte (_dummyPtr pdata)
|
|
-- withArray [0..(nWalls-1)::Int] $ \ptr ->
|
|
---- --drawElements Points (fromIntegral nWalls) UnsignedByte ptr
|
|
-- glDrawElements GL_POINTS (fromIntegral $ length wallPoints) GL_UNSIGNED_BYTE ptr
|
|
drawArrays Points (fromIntegral 0) (fromIntegral $ nWalls)
|
|
cullFace $= Nothing
|
|
currentProgram $= Just (fst $ _lightmapCircleShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata)
|
|
let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata
|
|
pokeFourOff fadeCircPtr 0 (x,y,r,lum)
|
|
bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata
|
|
blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
|
|
drawArrays Points (fromIntegral 0) (fromIntegral 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 layer 0
|
|
ticks2 <- renderTree 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 <- renderTree 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 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
|
|
bticks <- SDL.ticks
|
|
-- reset uniforms (hacky for now)
|
|
idmat <- (newMatrix RowMajor [1,0,0,0
|
|
,0,1,0,0
|
|
,0,0,1,0
|
|
,0,0,0,1
|
|
]
|
|
) :: IO (GLmatrix GLfloat)
|
|
forM_ [_basicShader pdata
|
|
,_textShader pdata
|
|
,_circShader pdata
|
|
,_arcShader pdata
|
|
,_ellipseShader pdata
|
|
] $ \shad -> do
|
|
currentProgram $= Just (fst shad)
|
|
uniform (snd shad !! 0) $= Vector2 (2::Float) 2
|
|
uniform (snd shad !! 1) $= (1::Float)
|
|
uniform (snd shad !! 2) $= (0::Float)
|
|
uniform (snd shad !! 3) $= Vector2 (0::Float) 0
|
|
uniform (snd shad !! 4) $= idmat
|
|
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
|
|
|
|
|
|
-- the following code draws a picture tree
|
|
-- it does not set nor change the blend function or depth buffer
|
|
-- nor does it set uniforms
|
|
renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
|
-> f RenderType -> IO Word32
|
|
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
|
|
|
pokeStartTicks <- SDL.ticks
|
|
-- poke necessary data
|
|
(nTriVs,nTextVs,nCircVs,nLineVs,nArcVs,nEllVs)
|
|
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
|
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
|
|
(threePtrsVAO $ _textVAO pdata)
|
|
(threePtrsVAO $ _circVAO pdata)
|
|
(twoPtrsVAO $ _lineVAO pdata)
|
|
(threePtrsVAO $ _arcVAO pdata)
|
|
(twoPtrsVAO $ _ellipseVAO pdata)
|
|
) $ tree
|
|
|
|
pokeEndTicks <-SDL.ticks
|
|
-- bind buffers
|
|
-- the idea of doing as much of this 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
|
|
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
|
|
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
|
|
bindArrayBuffers nCircVs $ _vaoBufferTargets $ _circVAO pdata
|
|
bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
|
|
bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
|
|
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
|
|
bindArrayBuffers nEllVs $ _vaoBufferTargets $ _ellipseVAO 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 triangles
|
|
currentProgram $= Just (fst $ _basicShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
|
|
drawArrays Triangles 0 (fromIntegral $ nTriVs)
|
|
-- draw circles
|
|
currentProgram $= Just (fst $ _circShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
|
|
drawArrays Points 0 (fromIntegral $ nCircVs)
|
|
-- draw ellipses
|
|
currentProgram $= Just (fst $ _ellipseShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _ellipseVAO pdata)
|
|
drawArrays Triangles 0 (fromIntegral $ nEllVs)
|
|
-- draw arcs
|
|
currentProgram $= Just (fst $ _arcShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
|
|
drawArrays Points 0 (fromIntegral $ nArcVs)
|
|
-- draw lines
|
|
currentProgram $= Just (fst $ _basicShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
|
|
drawArrays Lines 0 (fromIntegral $ nLineVs)
|
|
-- draw text
|
|
currentProgram $= Just (fst $ _textShader pdata)
|
|
bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
|
|
textureBinding Texture2D $= Just (_textures pdata !! 0)
|
|
drawArrays Points 0 (fromIntegral $ nTextVs)
|
|
return (pokeEndTicks - pokeStartTicks)
|