257 lines
9.3 KiB
Haskell
257 lines
9.3 KiB
Haskell
module Shader
|
|
( makeShader
|
|
, addTexture
|
|
, addUniforms
|
|
, pokeShaders
|
|
, pokeShader
|
|
, bindArrayBuffers
|
|
, bindShaderBuffers
|
|
, makeSourcedShader
|
|
, setupVAO
|
|
, floatSize
|
|
, numDrawableElements
|
|
, drawShader
|
|
, drawShaders
|
|
, setShaderUniforms
|
|
, resetShaderUniforms
|
|
, extractProgAndUnis
|
|
, freeShaderPointers
|
|
, module Shader.Data
|
|
)
|
|
where
|
|
import Geometry
|
|
import Shader.Data
|
|
|
|
import Foreign
|
|
import Codec.Picture
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.Vector.Storable as V
|
|
import Control.Monad (unless, forM, zipWithM_, forM_, foldM)
|
|
import Control.Lens
|
|
import qualified Control.Foldl as F
|
|
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
|
|
--import Text.RawString.QQ
|
|
import Linear.Matrix
|
|
import Linear.V4
|
|
|
|
extractProgAndUnis :: FullShader a -> (Program,[UniformLocation])
|
|
extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s)
|
|
|
|
pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
|
|
pokeShaders = traverse pokeShader
|
|
|
|
pokeShader :: FullShader a -> F.FoldM IO a Int
|
|
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
|
|
where
|
|
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ _shaderVAO fs
|
|
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 = foldM (pokePtrs ptrs)
|
|
|
|
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 = zipWithM_ (pokeElemOff ptr) [i..]
|
|
|
|
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 = zipWithM_ f
|
|
where
|
|
f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
|
|
|
|
drawShaders :: [FullShader a] -> [Int] -> IO ()
|
|
drawShaders = zipWithM_ drawShader
|
|
|
|
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 = txo}
|
|
-> textureBinding Texture2D $= Just txo
|
|
_ -> return ()
|
|
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
|
|
|
|
-- I am not sure if this assumes that the shader is constructed directly before
|
|
-- the texture is added...
|
|
addTexture :: String -> FullShader a -> IO (FullShader a)
|
|
addTexture texturePath shad = do
|
|
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)
|
|
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
|
|
|
|
{- |
|
|
Compiles a full shader found within the shader directory.
|
|
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
|
|
-}
|
|
makeShader
|
|
:: String -- ^ First part of the name of the shader
|
|
-> [ShaderType] -- ^ Filetype extensions
|
|
-> [(GLuint,Int)] -- ^ The shaders input vertices (location, size)
|
|
-> PrimitiveMode
|
|
-> (a -> [[[Float]]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound
|
|
-> IO (FullShader a)
|
|
makeShader s shaderlist alocs pm renStrat = do
|
|
(prog,unis) <- makeSourcedShader s shaderlist
|
|
vaob <- setupVAO alocs
|
|
return $ FullShader { _shaderProgram = prog
|
|
, _shaderUniforms = unis
|
|
, _shaderVAO = vaob
|
|
, _shaderPokeStrategy = renStrat
|
|
, _shaderDrawPrimitive = pm
|
|
, _shaderTexture = Nothing
|
|
, _shaderCustomUnis = Nothing
|
|
}
|
|
floatSize :: Int
|
|
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::Int))
|
|
)
|
|
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)
|
|
|
|
addUniforms :: [String] -> FullShader a -> IO (FullShader a)
|
|
addUniforms uniStrings shad = do
|
|
uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
|
|
return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
|
|
|
|
|
|
shaderTypeExt :: ShaderType -> String
|
|
shaderTypeExt VertexShader = ".vert"
|
|
shaderTypeExt GeometryShader = ".geom"
|
|
shaderTypeExt FragmentShader = ".frag"
|
|
shaderTypeExt _ = undefined
|
|
|
|
makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program
|
|
makeShaderProgram str sources = do
|
|
theShaderProgram <- createProgram
|
|
shaders <- mapM (compileAndCheckShader str) sources
|
|
mapM_ (attachShader theShaderProgram) shaders
|
|
|
|
linkProgram theShaderProgram
|
|
linkingSuccess <- linkStatus theShaderProgram
|
|
unless linkingSuccess $ do
|
|
infoLog <- get (programInfoLog theShaderProgram)
|
|
putStrLn $ str ++ ": Program Linking" ++ infoLog
|
|
|
|
return theShaderProgram
|
|
|
|
compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader
|
|
compileAndCheckShader str (theShaderType,sourceCode) = do
|
|
theShader <- createShader theShaderType
|
|
shaderSourceBS theShader $= sourceCode
|
|
compileShader theShader
|
|
success <- compileStatus theShader
|
|
unless success $ do
|
|
infoLog <- get (shaderInfoLog theShader)
|
|
putStrLn $ str ++ ": Shader compile: " ++ show theShaderType ++ " : " ++ show infoLog
|
|
return theShader
|
|
|
|
resetShaderUniforms :: [(Program, [UniformLocation])] -> IO ()
|
|
resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)
|
|
{-# INLINE resetShaderUniforms #-}
|
|
|
|
setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [(Program,[UniformLocation])] -> IO ()
|
|
{-# INLINE setShaderUniforms #-}
|
|
setShaderUniforms rot czoom (tranx,trany) (winx,winy) fss = do
|
|
let scalMat = Linear.Matrix.transpose $
|
|
V4 (V4 (2*czoom/winx) 0 0 (0::GLfloat))
|
|
(V4 0 (2*czoom/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) $= czoom
|
|
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
|