justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work towards doing transformations using uniforms

Browse Source
This commit is contained in:
jgk
2021-02-25 03:41:19 +01:00
parent 1969aa4f4a
commit 32bfab2e02
14 changed files with 310 additions and 205 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+5 -8
View File
@@ -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)
shader/arc.vert
+6
View File
@@ -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);
shader/background.geom
+3 -1
View File
@@ -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;
shader/background.vert
+7 -1
View File
@@ -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);
shader/basic.vert
+6
View File
@@ -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);
shader/basicTexture.vert
+5
View File
@@ -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;
shader/circle.vert
+6
View File
@@ -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);
shader/fadeCircle.vert
+6
View File
@@ -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);
shader/wallShadow.vert
+5
View File
@@ -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;
src/Dodge/Rendering.hs
+129 -68
View File
@@ -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
src/Picture/Data.hs
+2
View File
@@ -54,6 +54,8 @@ data Picture
| SetDepth Float Picture
| Color RGBA Picture
| Pictures [Picture]
| OverPos (Point3 -> Point3) (Float -> Float) Picture
blank :: Picture
{-# INLINE blank #-}
src/Picture/Preload.hs
+15 -33
View File
@@ -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]
src/Picture/Render.hs
+71 -93
View File
@@ -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)
src/Shaders.hs
+44 -1
View File
@@ -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