From 32bfab2e0273aa68c3787af381ed4601b30cdc93 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 25 Feb 2021 03:41:19 +0100 Subject: [PATCH] Work towards doing transformations using uniforms --- app/Main.hs | 13 +-- shader/arc.vert | 6 ++ shader/background.geom | 4 +- shader/background.vert | 8 +- shader/basic.vert | 6 ++ shader/basicTexture.vert | 5 + shader/circle.vert | 6 ++ shader/fadeCircle.vert | 6 ++ shader/wallShadow.vert | 5 + src/Dodge/Rendering.hs | 197 +++++++++++++++++++++++++-------------- src/Picture/Data.hs | 2 + src/Picture/Preload.hs | 48 +++------- src/Picture/Render.hs | 164 ++++++++++++++------------------ src/Shaders.hs | 45 ++++++++- 14 files changed, 310 insertions(+), 205 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c140a4dba..b16caa22a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -60,17 +60,14 @@ main = do (_windowX w,_windowY w) (wallsForGloom' w) (lightsForGloom' w) - (draw blank w) + (worldPictures w) + blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w) + (_windowX w,_windowY w) + (picToList 1 $ fixedCoordPictures w) playSoundQueue (_soundData preData) (_soundQueue w) newSoundData <- playAndUpdate (_sounds w) (_soundData preData) return $ preData {_soundData = newSoundData} - --renderPicture' preData (_windowX w,_windowY w) (Circle 5) --- renderPicture' preData --- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)] --- ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)] --- ,color red $ scale 0.0005 0.0005 $ text "asdf" --- ] --- ) ) (flip $ menuEvents $ flip handleEvent) (\w -> Just $ update w) diff --git a/shader/arc.vert b/shader/arc.vert index 6da2ce3e0..e436d45c0 100644 --- a/shader/arc.vert +++ b/shader/arc.vert @@ -4,6 +4,12 @@ layout (location = 1) in vec4 color; layout (location = 2) in vec4 saEaRadWdth; out vec4 vColor; out vec4 vparams; + +uniform vec2 winSize; +uniform float zoom; +uniform vec2 translation; +uniform float rotation; + void main() { gl_Position = vec4(position,1); diff --git a/shader/background.geom b/shader/background.geom index b475c375d..7a7529817 100644 --- a/shader/background.geom +++ b/shader/background.geom @@ -5,6 +5,8 @@ in vec4 vParams []; in vec2 vWinSize []; out vec2 gTexPos; +uniform vec2 translation; + vec2 rotBy( float rot, vec2 v) { return vec2 ( v.x * cos(rot) - v.y * sin(rot) @@ -15,7 +17,7 @@ vec2 rotBy( float rot, vec2 v) void main() { - vec2 cPos = vec2(vParams[0].x / 250 , vParams[0].y /250 ); + vec2 cPos = vec2(translation.x / 250 , translation.y /250 ); float zoom = vParams[0].w; float rot = 0 - vParams[0].z; diff --git a/shader/background.vert b/shader/background.vert index cd37b6199..791c26dcf 100644 --- a/shader/background.vert +++ b/shader/background.vert @@ -1,8 +1,14 @@ #version 430 core layout (location = 0) in vec4 params; -layout (location = 1) in vec2 winSize; +layout (location = 1) in vec2 winSizea; out vec4 vParams; out vec2 vWinSize; + +uniform vec2 winSize; +uniform float zoom; +uniform vec2 translation; +uniform float rotation; + void main() { gl_Position = vec4(0,0,0,0); diff --git a/shader/basic.vert b/shader/basic.vert index a9cb79602..c1a82c0a8 100644 --- a/shader/basic.vert +++ b/shader/basic.vert @@ -2,6 +2,12 @@ layout (location = 0) in vec3 position; layout (location = 1) in vec4 color; out vec4 vColor; + +uniform vec2 winSize; +uniform float zoom; +uniform float rotation; +uniform vec2 translation; + void main() { gl_Position = vec4(position,1); diff --git a/shader/basicTexture.vert b/shader/basicTexture.vert index 11474be8c..cc19a07cd 100644 --- a/shader/basicTexture.vert +++ b/shader/basicTexture.vert @@ -3,6 +3,11 @@ layout (location = 0) in vec3 aPos; layout (location = 1) in vec4 aColor; layout (location = 2) in vec2 aTexCoord; +uniform vec2 winSize; +uniform float zoom; +uniform vec2 translation; +uniform float rotation; + out vec4 vColor; out vec2 vTexCoord; diff --git a/shader/circle.vert b/shader/circle.vert index f1a9bab1c..32bf3612f 100644 --- a/shader/circle.vert +++ b/shader/circle.vert @@ -4,6 +4,12 @@ layout (location = 1) in vec4 color; layout (location = 2) in float rad; out vec4 vColor; out float vRad; + +uniform vec2 winSize; +uniform float zoom; +uniform vec2 translation; +uniform float rotation; + void main() { gl_Position = vec4(position,1); diff --git a/shader/fadeCircle.vert b/shader/fadeCircle.vert index 0dc6a0423..8dc4ad405 100644 --- a/shader/fadeCircle.vert +++ b/shader/fadeCircle.vert @@ -1,6 +1,12 @@ #version 430 core layout (location = 0) in vec4 position; out vec2 vParams; + +uniform vec2 winSize; +uniform float zoom; +uniform vec2 translation; +uniform float rotation; + void main() { gl_Position = vec4(position.xy,0,1); diff --git a/shader/wallShadow.vert b/shader/wallShadow.vert index 731d182aa..a1eeb778f 100644 --- a/shader/wallShadow.vert +++ b/shader/wallShadow.vert @@ -4,6 +4,11 @@ layout (location = 1) in vec4 backPoss; out vec4 vBackPoss; +uniform vec2 winSize; +uniform float zoom; +uniform float rotation; +uniform vec2 translation; + void main() { gl_Position = poss; diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index d267adb0d..d87f6034e 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -22,65 +22,42 @@ import qualified Data.Map as M import qualified Data.Set as S -- }}} --- -drawTest :: World -> Picture -drawTest w = screenT $ color red $ circle 200 - where (x,y) = (_windowX w,_windowY w) - screenT = scale (1/x) (1/y) - - -draw' :: Picture -> World -> ([((Float,Float),(Float,Float))] - ,[((Float,Float),Float,Float)] - ,Picture,Picture) -draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w) - -draw :: Picture -> World -> Picture -draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w - where f = scale (2/_windowX w) (2/_windowY w) - -draw'' :: Picture -> World -> (Picture , Picture) -draw'' b w-- | (Char 'm') `S.member` _keys w - -- = let a = (-500,30) - -- b = (200,0) - -- in pictures [ color white $ polygon screenBox - -- , color blue $ circleSolid 40 - -- , line [a,b] - -- , uncurry translate (ssaTriPoint a (0,0) b 40) - -- $ color red $ circleSolid 5 - -- ] - = case _mapDisplay w of - (True, z) -> (blank - ,pictures [color white $ circleSolid 3 - ,scale z z $ rotate (0 - (_cameraRot w)) - $ uncurry translate ((0,0) -.- _cameraCenter w) - $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w] - ) - _ -> ( blank - --,pictures $ map fst pics - ,collectDrawings w - ) --- ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w)) - where yourPos = _crPos $ you w - backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ] - where (x',y') = yourPos - (x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5))) - x1 = (x''-1) - x2 = (x''+1) - y1 = (y''-1) - y2 = (y''+1) - screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) ) - . uncurry translate ((0,0) -.- _cameraPos w) - zoom = _cameraZoom w - pathsTest = map drawPair $ _pathGraph' w - drawPair (x,y) = color cyan $ pictures [line [x,y] - -- , uncurry translate x $ scale 0.05 0.05 $ text $ show x +fixedCoordPictures :: World -> Picture +fixedCoordPictures w = pictures + [ scaler $ onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels] + , scaler $ hudDrawings w + , scaler $ onLayer MenuLayer menuScreen + ] + where scaler = scale (2 / _windowX w) (2 / _windowY w) + itLabels = pictures $ map (drawItemName w) (IM.elems (_floorItems w)) + ppLabels = pictures $ map (drawPPText w) (IM.elems (_pressPlates w)) + btLabels = pictures $ map (drawButText w) (IM.elems (_buttons w)) + menuScreen :: Picture + menuScreen = case _menuState w of + InGame -> blank + LevelMenu x -> + pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w + tst (-100) 100 0.4 ("LEVEL "++show x) + ,controlsList + ] + PauseMenu -> pictures + [--color (withAlpha 0.5 black) $ polygon $ screenBox w + tst (-100) 100 0.4 "PAUSED" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + , controlsList ] - drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i + GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "GAME OVER" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ,controlsList + ] + where tst x y sc t = translate x y $ scale sc sc $ color white $ text t -collectDrawings :: World -> Picture -collectDrawings w = pictures - [screenShift $ - pictures $ concat +worldPictures :: World -> Picture +worldPictures w + = pictures $ map screenShift $ concat [ decPicts , ppPicts , itFloorPicts @@ -94,15 +71,99 @@ collectDrawings w = pictures , wallShadows , smokeShadows ] - , onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels] - , hudDrawings w - , onLayer MenuLayer menuScreen + where + screenShift = scale zoomx zoomy . rotate (0 - (_cameraRot w) ) + . uncurry translate ((0,0) -.- _cameraPos w) + zoomx = 2 * _cameraZoom w / _windowX w + zoomy = 2 * _cameraZoom w / _windowY w + scaler = scale (2 / _windowX w) (2 / _windowY w) + decPicts = IM.elems $ _decorations w + ptPicts = map _ptPict (IM.elems (_particles w)) + ptPicts' = map _ptPict' $ _particles' w + afterPtPicts' = map _ptPict' $ _afterParticles' w + buttonPicts = map btDraw (IM.elems (_buttons w)) + ppPicts = map ppDraw (IM.elems (_pressPlates w)) + crPicts = map crDraw $ IM.elems $ _creatures w + clPicts = map clDraw $ IM.elems $ _clouds w + wallShadows = map (drawWallShadow w) $ wallShadowsToDraw w + smokeShadows = map (drawSmokeShadow w) $ _smoke w + wlPicts = map drawWall (wallsToDraw w) + itFloorPicts = map (drawItem) (IM.elems (_floorItems w)) + yourPos = _crPos $ you w + yourRot = _crDir $ you w + yourRad = _crRad $ you w + -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w))) + -- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w))) + itLabels = pictures $ map (drawItemName w) (IM.elems (_floorItems w)) + ppLabels = pictures $ map (drawPPText w) (IM.elems (_pressPlates w)) + btLabels = pictures $ map (drawButText w) (IM.elems (_buttons w)) + menuScreen :: Picture + menuScreen = case _menuState w of + InGame -> blank + LevelMenu x -> + pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w + tst (-100) 100 0.4 ("LEVEL "++show x) + ,controlsList + ] + PauseMenu -> pictures + [--color (withAlpha 0.5 black) $ polygon $ screenBox w + tst (-100) 100 0.4 "PAUSED" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + , controlsList + ] + GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w + ,tst (-100) 100 0.4 "GAME OVER" + ,tst (-100) 50 0.2 "n - new level" + ,tst (-100) 0 0.2 "r - restart" + ,controlsList + ] + where tst x y sc t = translate x y $ scale sc sc $ color white $ text t + +draw :: World -> Picture +draw w + = case _mapDisplay w of + (True, z) -> scaler $ pictures [color white $ circleSolid 3 + ,scale z z $ rotate (0 - (_cameraRot w)) + $ uncurry translate ((0,0) -.- _cameraCenter w) + $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w] + _ -> collectDrawings w + where yourPos = _crPos $ you w + f = scale (2/_windowX w) (2/_windowY w) + pathsTest = map drawPair $ _pathGraph' w + drawPair (x,y) = color cyan $ pictures [line [x,y] + -- , uncurry translate x $ scale 0.05 0.05 $ text $ show x + ] + drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i + scaler = scale (2 / _windowX w) (2 / _windowY w) + +collectDrawings :: World -> Picture +collectDrawings w = pictures $ (map screenShift $ + concat + [ decPicts + , ppPicts + , itFloorPicts + , crPicts + , clPicts + , buttonPicts + , ptPicts + , ptPicts' + , afterPtPicts' + , wlPicts + , wallShadows + , smokeShadows + ]) ++ + [ scaler $ onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels] + , scaler $ hudDrawings w + , scaler $ onLayer MenuLayer menuScreen ] -- <> [onLayer GloomLayer $ theLighting w] where - screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) ) + screenShift = scale zoomx zoomy . rotate (0 - (_cameraRot w) ) . uncurry translate ((0,0) -.- _cameraPos w) - zoom = _cameraZoom w + zoomx = 2 * _cameraZoom w / _windowX w + zoomy = 2 * _cameraZoom w / _windowY w + scaler = scale (2 / _windowX w) (2 / _windowY w) decPicts = IM.elems $ _decorations w ptPicts = map _ptPict (IM.elems (_particles w)) ptPicts' = map _ptPict' $ _particles' w @@ -444,12 +505,12 @@ ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10 dShadCol :: Color -> Picture -> Picture dShadCol c p = pictures $ - map (flip (uncurry translate) p) [(0.2,-0.2) - ,(0.4,-0.4) - ,(0.6,-0.6) - ,(0.8,-0.8) - ,( 1,- 1) - ,(1.2,-1.2) + map (flip (uncurry translate) p) [--(0.2,-0.2) + --,(0.4,-0.4) + --,(0.6,-0.6) + --,(0.8,-0.8) + --,( 1,- 1) + (1.2,-1.2) ] ++ [color c p] dropShadow :: Picture -> Picture diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 72dd5f5cc..64fd6e87d 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -54,6 +54,8 @@ data Picture | SetDepth Float Picture | Color RGBA Picture | Pictures [Picture] + | OverPos (Point3 -> Point3) (Float -> Float) Picture + blank :: Picture {-# INLINE blank #-} diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index 04ba792a0..28c10c760 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -19,13 +19,13 @@ import Shaders data RenderData = RenderData { --_charMap :: Image PixelRGBA8 _textures :: [TextureObject] - , _basicShader :: Program - , _textShader :: Program - , _circShader :: Program - , _arcShader :: Program - , _fadeCircleShader :: Program - , _backShader :: Program - , _wallShadowShader :: Program + , _basicShader :: (Program, [UniformLocation]) + , _textShader :: (Program, [UniformLocation]) + , _circShader :: (Program, [UniformLocation]) + , _arcShader :: (Program, [UniformLocation]) + , _fadeCircleShader :: (Program, [UniformLocation]) + , _backShader :: (Program, [UniformLocation]) + , _wallShadowShader :: (Program, [UniformLocation]) , _triVAO :: VAO , _lineVAO :: VAO , _textVAO :: VAO @@ -37,12 +37,6 @@ data RenderData = RenderData , _posVBO :: BufferObject , _colVBO :: BufferObject , _texVBO :: BufferObject - , _uniWinSize :: UniformLocation - , _csZoomUni :: UniformLocation - , _asWinUni :: UniformLocation - , _asZoomUni :: UniformLocation - , _fcsWinUni :: UniformLocation - , _fcsZoomUni :: UniformLocation , _wssLightPos :: UniformLocation , _dummyVBO :: BufferObject , _dummyPtr :: Ptr Float @@ -103,21 +97,15 @@ bufferOffset = plusPtr nullPtr . fromIntegral preloadRender :: IO RenderData preloadRender = do -- compile shader programs - bs <- makeBasicShader - ts <- makeTextureShader - cs <- makeCircleShader - as <- makeArcShader - fcs <- makeFadeShader - bgs <- makeBackgroundShader - wss <- makeWallShadowShader + bs <- makeSourcedShader "basic" [VertexShader,FragmentShader] + ts <- makeSourcedShader "character" [VertexShader,GeometryShader,FragmentShader] + cs <- makeSourcedShader "circle" [VertexShader,GeometryShader,FragmentShader] + as <- makeSourcedShader "arc" [VertexShader,GeometryShader,FragmentShader] + fcs <- makeSourcedShader "fadeCircle" [VertexShader,GeometryShader,FragmentShader] + bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader] + wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader] - winSizeUni <- GL.uniformLocation cs "winSize" - zoomUni <- GL.uniformLocation cs "zoom" - asWinSizeUniLoc <- GL.uniformLocation as "winSize" - asZoomUniLoc <- GL.uniformLocation as "zoom" - wssLightPosUniLoc <- GL.uniformLocation wss "lightPos" - fcsWinSizeUniLoc <- GL.uniformLocation fcs "winSize" - fcsZoomUniLoc <- GL.uniformLocation fcs "zoom" + wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos" -- get uniform locations --setup vbos @@ -195,13 +183,7 @@ preloadRender = do , _texVBO = texVBO , _dummyVBO = dummyvbo , _dummyPtr = dummyptr - , _uniWinSize = winSizeUni - , _csZoomUni = zoomUni - , _asWinUni = asWinSizeUniLoc - , _asZoomUni = asZoomUniLoc , _wssLightPos = wssLightPosUniLoc - , _fcsWinUni = fcsWinSizeUniLoc - , _fcsZoomUni = fcsZoomUniLoc } vaoPointers :: VAO -> [Ptr Float] diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index acd5999ca..e139f06a6 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -93,6 +93,36 @@ charToTuple :: Char -> (Point3,Point4,Point2) charToTuple c = ((0,0,0),white,(offset,100)) where offset = fromIntegral (fromEnum c) - 32 +picToList :: Int -> Picture -> [RenderType] +--{-# INLINE picToList #-} +picToList x (Polygon i ps) + | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black] + | otherwise = [] +picToList x (PolygonCol i vs) + | i /= x = [] + | otherwise = + let (ps,cs) = unzip vs + in [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs] +picToList x (Circle i r) + | i == x = [RenderCirc $ ((0,0,0),black,r)] + | otherwise = [] +picToList x (ThickArc i startA endA rad wdth) + | i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))] + | otherwise = [] +picToList x (Line i ps) + | i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white] + | otherwise = [] +picToList x (Text i s) + | i == x = [RenderText $ stringToList s] + | otherwise = [] +picToList j Blank = [] +picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic +picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic +picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic +picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic +picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic +picToList j (Pictures pics) = concatMap (picToList j) pics + --picToFTree :: Picture -> IM.IntMap (FTree RenderType) --{-# INLINE picToFTree #-} --picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black @@ -113,7 +143,7 @@ charToTuple c = ((0,0,0),white,(offset,100)) --picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics picToFTree :: Int -> Picture -> FTree RenderType -{-# INLINE picToFTree #-} +--{-# INLINE picToFTree #-} picToFTree x (Polygon i ps) | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black | otherwise = FLeaf RenderBlank @@ -135,13 +165,18 @@ picToFTree x (Text i s) | i == x = FLeaf $ RenderText $ stringToList s | otherwise = FLeaf RenderBlank picToFTree j Blank = FLeaf RenderBlank -picToFTree j (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree j pic -picToFTree j (Translate x y pic) = FBranch (translateRen x y) $ picToFTree j pic -picToFTree j (Rotate a pic) = FBranch (rotateRen a) $ picToFTree j pic -picToFTree j (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree j pic -picToFTree j (Color c pic) = FBranch (colorRen c) $ picToFTree j pic +picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic +picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic +picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic +picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic +picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic picToFTree j (Pictures pics) = FBranches $ map (picToFTree 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 t = FBranch f t + doubleLine :: [Point2] -> [Point2] doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs) doubleLine _ = [] @@ -276,6 +311,21 @@ renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do depthFunc $= Just Lequal +-- set common uniforms + forM_ [_basicShader pdata + ,_textShader pdata + ,_circShader pdata + ,_arcShader pdata + ,_fadeCircleShader 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 + -- draw lightmap bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata @@ -289,97 +339,32 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p forM_ lightPoints $ \(x,y,r,lum) -> do cullFace $= Just Front clear [DepthBuffer] - currentProgram $= Just (_wallShadowShader pdata) + currentProgram $= Just (fst $ _wallShadowShader pdata) bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata bindVertexArrayObject $= Just (_vao $ _wallVAO pdata) uniform (_wssLightPos pdata) $= Vector2 (x) (y) blendFunc $= (Zero,One) drawArrays Points (fromIntegral 0) (fromIntegral $ length wallPoints) cullFace $= Nothing - currentProgram $= Just (_fadeCircleShader pdata) + currentProgram $= Just (fst $ _fadeCircleShader 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 - uniform (_fcsWinUni pdata) $= Vector2 winx winy - uniform (_fcsZoomUni pdata) $= zoom - -- to refactor: put these uniforms in a ubo blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha)) drawArrays Points (fromIntegral 0) (fromIntegral 1) - -- draw picture -- set drawing for on top blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) clear [DepthBuffer] - -- draw layer 0 - renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic) - + renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToList 0 pic) -- reset blend so that light map doesn't apply blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - - renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic + renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToList 1 pic -- set drawing for on top blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) - - renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic --- ----- poke necessary data --- (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) ----- <- 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) --- ) $ (picToFTree 0 pic) --- --- depthFunc $= Just Less --- --- currentProgram $= Just (_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) --- bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata --- textureBinding Texture2D $= Just (_textures pdata !! 1) --- drawArrays Points (fromIntegral 0) (fromIntegral 1) --- ----- draw triangles --- currentProgram $= Just (_basicShader pdata) --- bindVertexArrayObject $= Just (_vao $ _triVAO pdata) --- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata --- drawArrays Triangles 0 (fromIntegral $ nTriVs) ----- draw circles --- currentProgram $= Just (_circShader pdata) --- uniform (_uniWinSize pdata) $= Vector2 winx winy --- uniform (_csZoomUni pdata) $= zoom --- bindVertexArrayObject $= Just (_vao $ _circVAO pdata) --- bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata --- drawArrays Points 0 (fromIntegral $ numCircVs) ----- draw arcs --- currentProgram $= Just (_arcShader pdata) --- uniform (_asWinUni pdata) $= Vector2 winx winy --- uniform (_asZoomUni pdata) $= zoom --- bindVertexArrayObject $= Just (_vao $ _arcVAO pdata) --- bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata --- drawArrays Points 0 (fromIntegral $ nArcVs) --- ----- reset blend so that light map doesn't apply --- blendFunc $= (SrcAlpha,OneMinusSrcAlpha) --- ----- draw lines --- currentProgram $= Just (_basicShader pdata) --- bindVertexArrayObject $= Just (_vao $ _lineVAO pdata) --- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata --- drawArrays Lines 0 (fromIntegral $ nLineVs) ----- draw text --- currentProgram $= Just (_textShader pdata) --- bindVertexArrayObject $= Just (_vao $ _textVAO pdata) --- bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata --- textureBinding Texture2D $= Just (_textures pdata !! 0) --- drawArrays Points 0 (fromIntegral $ nTextVs) + renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToList 2 pic bufferOffset :: Integral a => a -> Ptr b @@ -388,8 +373,9 @@ bufferOffset = plusPtr nullPtr . fromIntegral -- the following code draws a picture tree -- it does not set nor change the blend function or depth buffer -renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) - -> FTree RenderType -> IO () +-- nor does it set uniforms +renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) + -> f RenderType -> IO () renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do -- poke necessary data @@ -404,7 +390,7 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do depthFunc $= Just Less - currentProgram $= Just (_backShader pdata) + 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 @@ -415,37 +401,29 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do drawArrays Points (fromIntegral 0) (fromIntegral 1) depthFunc $= Just Lequal - -- draw triangles - currentProgram $= Just (_basicShader pdata) + currentProgram $= Just (fst $ _basicShader pdata) bindVertexArrayObject $= Just (_vao $ _triVAO pdata) bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata drawArrays Triangles 0 (fromIntegral $ nTriVs) -- draw circles - currentProgram $= Just (_circShader pdata) - uniform (_uniWinSize pdata) $= Vector2 winx winy - uniform (_csZoomUni pdata) $= zoom + currentProgram $= Just (fst $ _circShader pdata) bindVertexArrayObject $= Just (_vao $ _circVAO pdata) bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata drawArrays Points 0 (fromIntegral $ numCircVs) -- draw arcs - currentProgram $= Just (_arcShader pdata) - uniform (_asWinUni pdata) $= Vector2 winx winy - uniform (_asZoomUni pdata) $= zoom +-- assumes that the uniforms are set + currentProgram $= Just (fst $ _arcShader pdata) bindVertexArrayObject $= Just (_vao $ _arcVAO pdata) bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata drawArrays Points 0 (fromIntegral $ nArcVs) - --- reset blend so that light map doesn't apply --- blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - -- draw lines - currentProgram $= Just (_basicShader pdata) + currentProgram $= Just (fst $ _basicShader pdata) bindVertexArrayObject $= Just (_vao $ _lineVAO pdata) bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata drawArrays Lines 0 (fromIntegral $ nLineVs) -- draw text - currentProgram $= Just (_textShader pdata) + currentProgram $= Just (fst $ _textShader pdata) bindVertexArrayObject $= Just (_vao $ _textVAO pdata) bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata textureBinding Texture2D $= Just (_textures pdata !! 0) diff --git a/src/Shaders.hs b/src/Shaders.hs index d08a06069..e8a423469 100644 --- a/src/Shaders.hs +++ b/src/Shaders.hs @@ -7,13 +7,30 @@ module Shaders ,makeArcShader ,makeBackgroundShader ,makeWallShadowShader + ,makeSourcedShader ) where import Graphics.Rendering.OpenGL -import Control.Monad (when) +import Control.Monad (when, forM) import Text.RawString.QQ import qualified Data.ByteString as BS +-- compile shader and get its uniform locations +-- supposes the shader code is in the shader folder, with the string names +-- followed by .vert/.geom/.frag +makeSourcedShader :: String -> [ShaderType] -> IO (Program, [UniformLocation]) +makeSourcedShader s sts = do + sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st) + prog <- makeShaderProgram' s $ zip sts sources + uniformLocations <- forM ["winSize","zoom","rotation","translation"] + $ \uniString -> uniformLocation prog uniString + return (prog,uniformLocations) + +shaderTypeExt :: ShaderType -> String +shaderTypeExt VertexShader = ".vert" +shaderTypeExt GeometryShader = ".geom" +shaderTypeExt FragmentShader = ".frag" + makeBasicShader :: IO Program makeBasicShader = do vsSource <- BS.readFile "shader/basic.vert" @@ -88,6 +105,21 @@ makeTextureShader = do ,(FragmentShader, fsSource ) ] +makeShaderProgram' :: String -> [(ShaderType,BS.ByteString)] -> IO Program +makeShaderProgram' str sources = do + shaderProgram <- createProgram + shaders <- mapM (compileAndCheckShader' str) sources + mapM_ (attachShader shaderProgram) shaders + + linkProgram shaderProgram + linkingSuccess <- linkStatus shaderProgram + when (not linkingSuccess) $ do + infoLog <- get (programInfoLog shaderProgram) + putStrLn $ str ++ ": Program Linking" ++ infoLog + + return shaderProgram + + makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program makeShaderProgram sources = do shaderProgram <- createProgram @@ -112,3 +144,14 @@ compileAndCheckShader (shaderType,sourceCode) = do infoLog <- get (shaderInfoLog theShader) putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog return theShader + +compileAndCheckShader' :: String -> (ShaderType,BS.ByteString) -> IO Shader +compileAndCheckShader' str (shaderType,sourceCode) = do + theShader <- createShader shaderType + shaderSourceBS theShader $= sourceCode + compileShader theShader + success <- compileStatus theShader + when (not success) $ do + infoLog <- get (shaderInfoLog theShader) + putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog + return theShader