Refactor level/room generation modules
This commit is contained in:
+279
@@ -0,0 +1,279 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Shader
|
||||
( makeShader
|
||||
, makeTextureShader
|
||||
, makeShaderCustomUnis
|
||||
, pokeShaders
|
||||
, pokeShader
|
||||
, bindArrayBuffers
|
||||
, bindShaderBuffers
|
||||
, makeSourcedShader
|
||||
, setupVAO
|
||||
, floatSize
|
||||
, numDrawableElements
|
||||
, drawShader
|
||||
, drawShaders
|
||||
, setShaderUniforms
|
||||
, resetShaderUniforms
|
||||
, extractProgAndUnis
|
||||
, freeShaderPointers
|
||||
, module Shader.Data
|
||||
)
|
||||
where
|
||||
import Shader.Data
|
||||
|
||||
import Foreign
|
||||
import Codec.Picture
|
||||
|
||||
import qualified Data.Vector.Storable as V
|
||||
|
||||
import Control.Monad (when, forM, zipWithM_, forM_, foldM)
|
||||
|
||||
import qualified Control.Foldl as F
|
||||
|
||||
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
|
||||
--import Text.RawString.QQ
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
import Linear.Matrix
|
||||
import Linear.V4
|
||||
|
||||
import Geometry
|
||||
|
||||
extractProgAndUnis :: FullShader a -> (Program,[UniformLocation])
|
||||
extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s)
|
||||
|
||||
pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
|
||||
pokeShaders fss = traverse pokeShader fss
|
||||
|
||||
pokeShader :: FullShader a -> F.FoldM IO a Int
|
||||
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
|
||||
where vao = _shaderVAO fs
|
||||
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
|
||||
fls = _shaderPokeStrategy fs
|
||||
|
||||
pokeRender :: (a -> [[[Float]]])
|
||||
-> [(Ptr Float,Int)] -> Int -> a -> IO Int
|
||||
pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
|
||||
|
||||
pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
|
||||
pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss
|
||||
|
||||
pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
|
||||
pokePtrs ptrIs n fss = do
|
||||
zipWithM_ f ptrIs fss
|
||||
return $ n + 1
|
||||
where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
|
||||
|
||||
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
|
||||
pokeArrayOff ptr i xs =
|
||||
zipWithM_ (pokeElemOff ptr) [i..] xs
|
||||
|
||||
|
||||
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 $ floatSize * numVs * i, ptr, StreamDraw)
|
||||
|
||||
bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
|
||||
bindShaderBuffers fss is =
|
||||
zipWithM_ f fss is
|
||||
where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
|
||||
|
||||
drawShaders :: [FullShader a] -> [Int] -> IO ()
|
||||
drawShaders fss is =
|
||||
zipWithM_ drawShader fss is
|
||||
|
||||
drawShader :: FullShader a -> Int -> IO ()
|
||||
{-# INLINE drawShader #-}
|
||||
drawShader 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)
|
||||
|
||||
makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)]
|
||||
-> PrimitiveMode -> (a -> [[[Float]]])
|
||||
-> String
|
||||
-> IO (FullShader a)
|
||||
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}
|
||||
, _shaderCustomUnis = Nothing
|
||||
}
|
||||
|
||||
makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]])
|
||||
-> [String] -> IO (FullShader a)
|
||||
makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
|
||||
(prog,unis,unis') <- makeSourcedShaderCustomUnis s shaderlist uniStrings
|
||||
vao <- setupVAO alocs
|
||||
return $ FullShader { _shaderProgram = prog
|
||||
, _shaderUniforms = unis
|
||||
, _shaderVAO = vao
|
||||
, _shaderPokeStrategy = renStrat
|
||||
, _shaderDrawPrimitive = pm
|
||||
, _shaderTexture = Nothing
|
||||
, _shaderCustomUnis = Just unis'
|
||||
}
|
||||
|
||||
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
|
||||
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
|
||||
, _shaderCustomUnis = Nothing
|
||||
}
|
||||
|
||||
floatSize = sizeOf (0.5 :: GLfloat)
|
||||
{-# INLINE floatSize #-}
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
|
||||
numDrawableElements :: Int
|
||||
{-# INLINE numDrawableElements #-}
|
||||
numDrawableElements = 50000
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
-- 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","worldMat"]
|
||||
$ \uniString -> uniformLocation prog uniString
|
||||
return (prog,uniformLocations)
|
||||
|
||||
makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String]
|
||||
-> IO (Program, [UniformLocation], [UniformLocation])
|
||||
makeSourcedShaderCustomUnis s shadTypes uniStrings = do
|
||||
(prog,unis0) <- makeSourcedShader s shadTypes
|
||||
unis <- mapM (uniformLocation prog) uniStrings
|
||||
return (prog,unis0,unis)
|
||||
|
||||
shaderTypeExt :: ShaderType -> String
|
||||
shaderTypeExt VertexShader = ".vert"
|
||||
shaderTypeExt GeometryShader = ".geom"
|
||||
shaderTypeExt FragmentShader = ".frag"
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)
|
||||
{-# INLINE resetShaderUniforms #-}
|
||||
|
||||
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [(Program,[UniformLocation])] -> IO ()
|
||||
{-# INLINE setShaderUniforms #-}
|
||||
setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do
|
||||
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_ fss $ \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
|
||||
|
||||
freeShaderPointers :: FullShader a -> IO ()
|
||||
freeShaderPointers fs = do
|
||||
forM_ (_vaoBufferTargets $ _shaderVAO fs) $ \(_,ptr,_) ->
|
||||
free ptr
|
||||
Reference in New Issue
Block a user