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

Continue refactoring shaders

Browse Source
This commit is contained in:
jgk
2021-03-10 21:22:52 +01:00
parent 4a455cc7c9
commit a2fa713bde
10 changed files with 29 additions and 375 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture/Data.hs
+4 -51
View File
@@ -2,6 +2,7 @@
--{-# LANGUAGE Strict #-}
module Picture.Data
where
import Shader.Data
import Data.Monoid
import qualified Data.Foldable as F
import qualified Data.Sequence as Se
@@ -24,63 +25,14 @@ import Data.Traversable
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderText [(Point3,Point4,Point3)]
-- | RenderCirc (Point3,Point4,Float)
| RenderArc (Point3,Point4,Point4)
| RenderLine [(Point3,Point4)]
| RenderEllipse [(Point3,Point4)]
data VAO = VAO
{ _vao :: VertexArrayObject
, _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
}
data FullShader = FullShader
{ _shaderProgram :: Program
, _shaderUniforms :: [UniformLocation]
, _shaderVAO :: VAO
, _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
, _shaderDrawPrimitive :: PrimitiveMode
, _shaderTexture :: Maybe ShaderTexture
}
data ShaderTexture = ShaderTexture
{ _textureObject :: TextureObject }
makeLenses ''VAO
makeLenses ''FullShader
drawShaders :: [FullShader] -> [Int] -> IO ()
drawShaders fss is =
zipWithM_ f fss is
where f fs i = do
currentProgram $= Just (_shaderProgram fs)
bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs))
case _shaderTexture fs of
Just (ShaderTexture {_textureObject = to})
-> textureBinding Texture2D $= Just to
_ -> return ()
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
bindShaderBuffers fss is =
zipWithM_ f fss is
where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
fSize = sizeOf (0 :: Float)
bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
{-# INLINE bindArrayBuffers #-}
bindArrayBuffers numVs ps = do
forM_ ps $ \(bo,ptr,i) -> do
bindBuffer ArrayBuffer $= Just bo
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
pokeShaders :: [FullShader RenderType] -> F.FoldM IO RenderType [Int]
pokeShaders fss = traverse pokeShader fss
pokeShader :: FullShader -> F.FoldM IO RenderType Int
pokeShader :: FullShader RenderType -> F.FoldM IO RenderType Int
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
where vao = _shaderVAO fs
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
@@ -104,6 +56,7 @@ pokeArrayOff ptr i xs =
zipWithM_ (pokeElemOff ptr) [i..] xs
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
src/Picture/Preload.hs
+11 -85
View File
@@ -5,10 +5,10 @@ module Picture.Preload
import Picture.Data
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL
import Codec.Picture
import qualified Data.Vector.Storable as V
import Control.Lens
@@ -16,15 +16,15 @@ import Control.Monad
import Foreign
import Shaders
import Shader
data RenderData = RenderData
{ --_charMap :: Image PixelRGBA8
_textures :: [TextureObject]
, _lightmapCircleShader :: (Program, [UniformLocation])
, _backShader :: (Program, [UniformLocation])
, _wallShadowShader :: (Program, [UniformLocation])
, _listShaders :: [FullShader]
, _lightmapCircleShader :: (Program, [UniformLocation])
, _listShaders :: [FullShader RenderType]
, _backVAO :: VAO
, _wallVAO :: VAO
, _fadeCircVAO :: VAO
@@ -35,46 +35,6 @@ data RenderData = RenderData
makeLenses ''RenderData
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (RenderType -> [[[Float]]]) -> IO FullShader
makeShader s shaderlist alocs pm renStrat = do
(prog,unis) <- makeSourcedShader s shaderlist
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Nothing
}
makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)]
-> PrimitiveMode -> (RenderType -> [[[Float]]])
-> String
-> IO FullShader
makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(prog,unis) <- makeSourcedShader s shaderlist
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
let texData = V.toList $ imageData tex
wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
withArray texData $ \ptr -> do
texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0
(PixelData RGBA UnsignedByte ptr)
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
}
pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeTriStrat _ = []
@@ -91,39 +51,6 @@ pokeLineStrat _ = []
pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeEllStrat _ = []
floatSize = sizeOf (0.5 :: GLfloat)
setupVAO :: [(GLuint,Int)] -> IO VAO
setupVAO ps = do
theVAO <- genObjectName
bindVertexArrayObject $= Just theVAO
vbos <- forM ps setupArrayBuffer
ptrs <- forM (zip vbos $ map snd ps) setupVBOPointers
return $ VAO theVAO ptrs
numDrawableElements :: Int
numDrawableElements = 50000
setupVBOPointers :: (BufferObject,Int) -> IO (BufferObject,Ptr Float,Int)
setupVBOPointers (vbo,vsize) = do
thePtr <- mallocArray (vsize * numDrawableElements)
return (vbo,thePtr,vsize)
setupArrayBuffer :: (GLuint,Int) -> IO BufferObject
setupArrayBuffer (aloc,i) = do
vbo <- genObjectName
bindBuffer ArrayBuffer $= Just vbo
vertexAttribPointer (AttribLocation aloc) $=
( ToFloat
, VertexArrayDescriptor (fromIntegral i)
Float
(fromIntegral $ floatSize * i)
(bufferOffset 0)
)
vertexAttribArray (AttribLocation aloc) $= Enabled
return vbo
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
@@ -134,19 +61,20 @@ frag = FragmentShader
preloadRender :: IO RenderData
preloadRender = do
-- compile shader programs
lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos"
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeArcStrat
eslist <- makeShader "ellipse" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
cslist <- makeTextureShader "character" [vert,geom,frag]
[(0,3),(1,4),(2,3)] Points pokeCharStrat
"data/texture/charMap.png"
aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,3)] Points pokeArcStrat
eslist <- makeShader "ellipseInterpolate" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
--the following vbo is set up to contain one fixed vertex
dummyvbo <- genObjectName
@@ -168,13 +96,11 @@ preloadRender = do
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
--textureBinding Texture2D $= Just chartex
-- input a list of (attribute location, attrib length) pairs
-- these will have buffers and pointers created
backgroundvao <- setupVAO [(0,4),(1,2)]
wallvao <- setupVAO [(0,4),(1,4)]
fadecircvao <- setupVAO [(0,4)]
fadevao <- setupVAO [(0,4)]
return $ RenderData
{ -- _charMap = convertRGBA8 cmap
@@ -185,7 +111,7 @@ preloadRender = do
, _wallShadowShader = wss
, _backVAO = backgroundvao
, _wallVAO = wallvao
, _fadeCircVAO = fadecircvao
, _fadeCircVAO = fadevao
, _dummyVBO = dummyvbo
, _dummyPtr = dummyptr
, _wssLightPos = wssLightPosUniLoc
src/Picture/Render.hs
+4 -8
View File
@@ -2,6 +2,9 @@
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
where
import Shader
import Control.Lens
import Control.Monad
@@ -284,13 +287,6 @@ pokeLineVert pa pb n (p,c)
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
@@ -342,7 +338,7 @@ threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
(a:b:c:_) -> (a,b,c)
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader] -> IO ()
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [FullShader RenderType] -> IO ()
setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do
let scalMat = Linear.Matrix.transpose $
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))