140 lines
4.5 KiB
Haskell
140 lines
4.5 KiB
Haskell
module Shader
|
|
( pokeShaders
|
|
, pokeArrayOff
|
|
, pokeShader'
|
|
, bindArrayBuffers'
|
|
, bindShaderBuffers
|
|
, drawShader
|
|
, drawShaders
|
|
, setShaderUniforms
|
|
, resetShaderUniforms
|
|
, extractProgAndUnis
|
|
, freeShaderPointers
|
|
, setPerpMatUniform
|
|
, module Shader.Data
|
|
)
|
|
where
|
|
import Geometry
|
|
import Shader.Data
|
|
import Shader.Parameters
|
|
import MatrixHelper
|
|
import Picture.Data
|
|
|
|
import Foreign
|
|
import Control.Monad
|
|
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 -> (Program,UniformLocation)
|
|
extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)
|
|
|
|
pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
|
|
pokeShaders = traverse pokeShader'
|
|
--pokeShaders = traverse pokeShader
|
|
|
|
pokeShader' :: FullShader -> F.FoldM IO RenderType Int
|
|
pokeShader' fs = F.FoldM (pokeRender' fls ptr stride) (return 0) return
|
|
where
|
|
theVBO = _vaoVBO $ _shaderVAO fs
|
|
ptr = _vboPointer theVBO
|
|
stride = sum $ _vboAttribSizes theVBO
|
|
fls = _shaderPokeStrategy fs
|
|
|
|
pokeRender'
|
|
:: (RenderType -> [[[Float]]])
|
|
-> Ptr Float
|
|
-> Int -- ^ stride
|
|
-> Int
|
|
-> RenderType
|
|
-> IO Int
|
|
pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt)
|
|
|
|
pokeList' :: Ptr Float -> Int -> Int -> [[[Float]]] -> IO Int
|
|
pokeList' ptr stride = foldM (pokePtrs' ptr stride)
|
|
|
|
pokePtrs' :: Ptr Float -> Int -> Int -> [[Float]] -> IO Int
|
|
pokePtrs' ptr stride n fss = do
|
|
pokeArrayOff ptr (stride * n) (concat fss)
|
|
return $ n + 1
|
|
|
|
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
|
|
pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
|
|
|
|
bindArrayBuffers' :: Int -> VBO -> IO ()
|
|
bindArrayBuffers' numVs theVBO = do
|
|
bindBuffer ArrayBuffer $= Just (_vbo theVBO)
|
|
bufferData ArrayBuffer $=
|
|
(fromIntegral $ floatSize * numVs * (sum $ _vboAttribSizes theVBO), _vboPointer theVBO, DynamicDraw)
|
|
|
|
|
|
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
|
|
bindShaderBuffers = zipWithM_ f
|
|
where
|
|
f fs i = bindArrayBuffers' i $ _vaoVBO $ _shaderVAO fs
|
|
|
|
drawShaders :: [FullShader] -> [Int] -> IO ()
|
|
drawShaders = zipWithM_ drawShader
|
|
|
|
drawShader :: FullShader -> 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)
|
|
|
|
|
|
|
|
resetShaderUniforms :: [(Program, UniformLocation)] -> IO ()
|
|
{-# INLINE resetShaderUniforms #-}
|
|
resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)
|
|
|
|
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) $= wmata
|
|
|
|
setPerpMatUniform
|
|
:: Float -- ^ rotation
|
|
-> Float -- ^ zoom
|
|
-> Point2 -- ^ translation
|
|
-> Point2 -- ^ window size
|
|
-> Point2 -- ^ viewfrom point
|
|
-> FullShader
|
|
-> IO ()
|
|
setPerpMatUniform rot czoom trans wins vFrom shad = do
|
|
pmat <- (newMatrix RowMajor $ perspectiveMatrix rot czoom trans wins vFrom) :: IO (GLmatrix GLfloat)
|
|
currentProgram $= Just (_shaderProgram shad)
|
|
uniform (_shaderMatrixUniform shad) $= pmat
|
|
return ()
|
|
|
|
freeShaderPointers :: FullShader -> IO ()
|
|
freeShaderPointers fs = free $ _vboPointer $ _vaoVBO $ _shaderVAO fs
|