module LambdaCube.GL.Backend where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Maybe
import Data.Bits
import Data.IORef
import Data.IntMap (IntMap)
import Data.Maybe (isNothing,fromJust)
import Data.Map (Map)
import Data.Set (Set)
import Data.Vector (Vector,(!),(//))
import qualified Data.Foldable as F
import qualified Data.IntMap as IM
import qualified Data.Map as Map
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import Graphics.GL.Core33
import Foreign
import Foreign.C.String
import LambdaCube.PipelineSchema
import LambdaCube.Linear
import LambdaCube.IR hiding (streamType)
import qualified LambdaCube.IR as IR
import LambdaCube.GL.Type
import LambdaCube.GL.Util
import LambdaCube.GL.Data
import LambdaCube.GL.Input
setupRasterContext :: RasterContext -> IO ()
setupRasterContext = cvt
where
cff :: FrontFace -> GLenum
cff CCW = GL_CCW
cff CW = GL_CW
setProvokingVertex :: ProvokingVertex -> IO ()
setProvokingVertex pv = glProvokingVertex $ case pv of
FirstVertex -> GL_FIRST_VERTEX_CONVENTION
LastVertex -> GL_LAST_VERTEX_CONVENTION
setPointSize :: PointSize -> IO ()
setPointSize ps = case ps of
ProgramPointSize -> glEnable GL_PROGRAM_POINT_SIZE
PointSize s -> do
glDisable GL_PROGRAM_POINT_SIZE
glPointSize $ realToFrac s
cvt :: RasterContext -> IO ()
cvt (PointCtx ps fts sc) = do
setPointSize ps
glPointParameterf GL_POINT_FADE_THRESHOLD_SIZE (realToFrac fts)
glPointParameterf GL_POINT_SPRITE_COORD_ORIGIN $ realToFrac $ case sc of
LowerLeft -> GL_LOWER_LEFT
UpperLeft -> GL_UPPER_LEFT
cvt (LineCtx lw pv) = do
glLineWidth (realToFrac lw)
setProvokingVertex pv
cvt (TriangleCtx cm pm po pv) = do
case cm of
CullNone -> glDisable GL_CULL_FACE
CullFront f -> do
glEnable GL_CULL_FACE
glCullFace GL_FRONT
glFrontFace $ cff f
CullBack f -> do
glEnable GL_CULL_FACE
glCullFace GL_BACK
glFrontFace $ cff f
case pm of
PolygonPoint ps -> do
setPointSize ps
glPolygonMode GL_FRONT_AND_BACK GL_POINT
PolygonLine lw -> do
glLineWidth (realToFrac lw)
glPolygonMode GL_FRONT_AND_BACK GL_LINE
PolygonFill -> glPolygonMode GL_FRONT_AND_BACK GL_FILL
glDisable GL_POLYGON_OFFSET_POINT
glDisable GL_POLYGON_OFFSET_LINE
glDisable GL_POLYGON_OFFSET_FILL
case po of
NoOffset -> return ()
Offset f u -> do
glPolygonOffset (realToFrac f) (realToFrac u)
glEnable $ case pm of
PolygonPoint _ -> GL_POLYGON_OFFSET_POINT
PolygonLine _ -> GL_POLYGON_OFFSET_LINE
PolygonFill -> GL_POLYGON_OFFSET_FILL
setProvokingVertex pv
setupAccumulationContext :: AccumulationContext -> IO ()
setupAccumulationContext (AccumulationContext n ops) = cvt ops
where
cvt :: [FragmentOperation] -> IO ()
cvt (StencilOp a b c : DepthOp f m : xs) = do
cvtC 0 xs
cvt (StencilOp a b c : xs) = do
cvtC 0 xs
cvt (DepthOp df dm : xs) = do
glDisable GL_STENCIL_TEST
case df == Always && dm == False of
True -> glDisable GL_DEPTH_TEST
False -> do
glEnable GL_DEPTH_TEST
glDepthFunc $! comparisonFunctionToGLType df
glDepthMask (cvtBool dm)
cvtC 0 xs
cvt xs = do
glDisable GL_DEPTH_TEST
glDisable GL_STENCIL_TEST
cvtC 0 xs
cvtC :: Int -> [FragmentOperation] -> IO ()
cvtC i (ColorOp b m : xs) = do
case b of
NoBlending -> do
glDisable GL_BLEND
glDisable GL_COLOR_LOGIC_OP
BlendLogicOp op -> do
glDisable GL_BLEND
glEnable GL_COLOR_LOGIC_OP
glLogicOp $ logicOperationToGLType op
Blend cEq aEq scF dcF saF daF (V4 r g b a) -> do
glDisable GL_COLOR_LOGIC_OP
glEnable GL_BLEND
glBlendEquationSeparate (blendEquationToGLType cEq) (blendEquationToGLType aEq)
glBlendFuncSeparate (blendingFactorToGLType scF) (blendingFactorToGLType dcF)
(blendingFactorToGLType saF) (blendingFactorToGLType daF)
glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
let cvt True = 1
cvt False = 0
(mr,mg,mb,ma) = case m of
VBool r -> (cvt r, 1, 1, 1)
VV2B (V2 r g) -> (cvt r, cvt g, 1, 1)
VV3B (V3 r g b) -> (cvt r, cvt g, cvt b, 1)
VV4B (V4 r g b a) -> (cvt r, cvt g, cvt b, cvt a)
_ -> (1,1,1,1)
glColorMask mr mg mb ma
cvtC (i + 1) xs
cvtC _ [] = return ()
cvtBool :: Bool -> GLboolean
cvtBool True = 1
cvtBool False = 0
clearRenderTarget :: [ClearImage] -> IO ()
clearRenderTarget values = do
let setClearValue (m,i) value = case value of
ClearImage Depth (VFloat v) -> do
glDepthMask 1
glClearDepth $ realToFrac v
return (m .|. GL_DEPTH_BUFFER_BIT, i)
ClearImage Stencil (VWord v) -> do
glClearStencil $ fromIntegral v
return (m .|. GL_STENCIL_BUFFER_BIT, i)
ClearImage Color c -> do
let (r,g,b,a) = case c of
VFloat r -> (realToFrac r, 0, 0, 1)
VV2F (V2 r g) -> (realToFrac r, realToFrac g, 0, 1)
VV3F (V3 r g b) -> (realToFrac r, realToFrac g, realToFrac b, 1)
VV4F (V4 r g b a) -> (realToFrac r, realToFrac g, realToFrac b, realToFrac a)
_ -> (0,0,0,1)
glColorMask 1 1 1 1
glClearColor r g b a
return (m .|. GL_COLOR_BUFFER_BIT, i+1)
_ -> error "internal error (clearRenderTarget)"
(mask,_) <- foldM setClearValue (0,0) values
glClear $ fromIntegral mask
printGLStatus = checkGL >>= print
printFBOStatus = checkFBO >>= print
compileProgram :: Program -> IO GLProgram
compileProgram p = do
po <- glCreateProgram
let createAndAttach src t = do
o <- glCreateShader t
compileShader o [src]
glAttachShader po o
return o
objs <- sequence $ createAndAttach (vertexShader p) GL_VERTEX_SHADER : createAndAttach (fragmentShader p) GL_FRAGMENT_SHADER : case geometryShader p of
Nothing -> []
Just s -> [createAndAttach s GL_GEOMETRY_SHADER]
forM_ (zip (V.toList $ programOutput p) [0..]) $ \(Parameter n t,i) -> withCString n $ \pn -> do
glBindFragDataLocation po i $ castPtr pn
glLinkProgram po
log <- printProgramLog po
status <- glGetProgramiv1 GL_LINK_STATUS po
when (status /= fromIntegral GL_TRUE) $ fail $ unlines ["link program failed:",log]
(uniforms,uniformsType) <- queryUniforms po
(attributes,attributesType) <- queryStreams po
let lcUniforms = (programUniforms p) `Map.union` (programInTextures p)
lcStreams = fmap ty (programStreams p)
check a m = and $ map go $ Map.toList m
where go (k,b) = case Map.lookup k a of
Nothing -> False
Just x -> x == b
unless (check lcUniforms uniformsType) $ fail $ unlines
[ "shader program uniform input mismatch!"
, "expected: " ++ show lcUniforms
, "actual: " ++ show uniformsType
]
unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams)
let inUniNames = programUniforms p
inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms
inTextureNames = programInTextures p
inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms
texUnis = [n | (n,_) <- inTextures, Map.member n (programUniforms p)]
let prgInTextures = Map.keys inTextureNames
uniInTextures = map fst inTextures
let valA = Map.toList $ attributes
valB = Map.toList $ programStreams p
let lcStreamName = fmap name (programStreams p)
return $ GLProgram
{ shaderObjects = objs
, programObject = po
, inputUniforms = Map.fromList inUniforms
, inputTextures = Map.fromList inTextures
, inputTextureUniforms = S.fromList $ texUnis
, inputStreams = Map.fromList [(n,(idx, attrName)) | (n,idx) <- Map.toList $ attributes, let attrName = fromMaybe (error $ "missing attribute: " ++ n) $ Map.lookup n lcStreamName]
}
compileRenderTarget :: Vector TextureDescriptor -> Vector GLTexture -> RenderTarget -> IO GLRenderTarget
compileRenderTarget texs glTexs (RenderTarget targets) = do
let isFB (Framebuffer _) = True
isFB _ = False
images = [img | TargetItem _ (Just img) <- V.toList targets]
case all isFB images of
True -> do
let bufs = [cvt img | TargetItem Color img <- V.toList targets]
cvt a = case a of
Nothing -> GL_NONE
Just (Framebuffer Color) -> GL_BACK_LEFT
_ -> error "internal error (compileRenderTarget)!"
return $ GLRenderTarget
{ framebufferObject = 0
, framebufferDrawbuffers = Just bufs
}
False -> do
when (any isFB images) $ fail "internal error (compileRenderTarget)!"
fbo <- alloca $! \pbo -> glGenFramebuffers 1 pbo >> peek pbo
glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo
let attach attachment (TextureImage texIdx level (Just layer)) =
glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attachment (glTextureTarget $ glTexs ! texIdx) (fromIntegral level) (fromIntegral layer)
attach attachment (TextureImage texIdx level Nothing) = do
let glTex = glTexs ! texIdx
tex = texs ! texIdx
txLevel = fromIntegral level
txTarget = glTextureTarget glTex
txObj = glTextureObject glTex
attachArray = glFramebufferTexture GL_DRAW_FRAMEBUFFER attachment txObj txLevel
attach2D = glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
case textureType tex of
Texture1D _ n
| n > 1 -> attachArray
| otherwise -> glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attachment txTarget txObj txLevel
Texture2D _ n
| n > 1 -> attachArray
| otherwise -> attach2D
Texture3D _ -> attachArray
TextureCube _ -> attachArray
TextureRect _ -> attach2D
Texture2DMS _ n _ _
| n > 1 -> attachArray
| otherwise -> attach2D
TextureBuffer _ -> fail "internalError (compileRenderTarget/TextureBuffer)!"
go a (TargetItem Stencil (Just img)) = do
fail "Stencil support is not implemented yet!"
return a
go a (TargetItem Depth (Just img)) = do
attach GL_DEPTH_ATTACHMENT img
return a
go (bufs,colorIdx) (TargetItem Color (Just img)) = do
let attachment = GL_COLOR_ATTACHMENT0 + fromIntegral colorIdx
attach attachment img
return (attachment : bufs, colorIdx + 1)
go (bufs,colorIdx) (TargetItem Color Nothing) = return (GL_NONE : bufs, colorIdx + 1)
go a _ = return a
(bufs,_) <- foldM go ([],0) targets
withArray (reverse bufs) $ glDrawBuffers (fromIntegral $ length bufs)
return $ GLRenderTarget
{ framebufferObject = fbo
, framebufferDrawbuffers = Nothing
}
compileStreamData :: StreamData -> IO GLStream
compileStreamData s = do
let withV w a f = w a (\p -> f $ castPtr p)
let compileAttr (VFloatArray v) = Array ArrFloat (V.length v) (withV (SV.unsafeWith . V.convert) v)
compileAttr (VIntArray v) = Array ArrInt32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
compileAttr (VWordArray v) = Array ArrWord32 (V.length v) (withV (SV.unsafeWith . V.convert) v)
(indexMap,arrays) = unzip [((n,i),compileAttr d) | (i,(n,d)) <- zip [0..] $ Map.toList $ streamData s]
getLength n = l `div` c
where
l = case Map.lookup n $ IR.streamData s of
Just (VFloatArray v) -> V.length v
Just (VIntArray v) -> V.length v
Just (VWordArray v) -> V.length v
_ -> error "compileStreamData - getLength"
c = case Map.lookup n $ IR.streamType s of
Just Bool -> 1
Just V2B -> 2
Just V3B -> 3
Just V4B -> 4
Just Word -> 1
Just V2U -> 2
Just V3U -> 3
Just V4U -> 4
Just Int -> 1
Just V2I -> 2
Just V3I -> 3
Just V4I -> 4
Just Float -> 1
Just V2F -> 2
Just V3F -> 3
Just V4F -> 4
Just M22F -> 4
Just M23F -> 6
Just M24F -> 8
Just M32F -> 6
Just M33F -> 9
Just M34F -> 12
Just M42F -> 8
Just M43F -> 12
Just M44F -> 16
_ -> error "compileStreamData - getLength element count"
buffer <- compileBuffer arrays
cmdRef <- newIORef []
let toStream (n,i) = (n,Stream
{ streamType = fromMaybe (error $ "missing attribute: " ++ n) $ toStreamType =<< Map.lookup n (IR.streamType s)
, streamBuffer = buffer
, streamArrIdx = i
, streamStart = 0
, streamLength = getLength n
})
return $ GLStream
{ glStreamCommands = cmdRef
, glStreamPrimitive = case streamPrimitive s of
Points -> PointList
Lines -> LineList
Triangles -> TriangleList
LinesAdjacency -> LineListAdjacency
TrianglesAdjacency -> TriangleListAdjacency
, glStreamAttributes = Map.fromList $ map toStream indexMap
, glStreamProgram = V.head $ streamPrograms s
}
createStreamCommands :: Map String (IORef GLint) -> Map String GLUniform -> Map String (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand]
createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd]
where
drawCmd = GLDrawArrays prim 0 (fromIntegral count)
where
prim = primitiveToGLType primitive
count = head [c | Stream _ _ _ _ c <- Map.elems attrs]
streamUniCmds = uniCmds ++ texCmds
where
uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n]
uniMap = Map.toList $ inputUniforms prg
topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis
texUnis = S.toList $ inputTextureUniforms prg
texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
| n <- texUnis
, let u = topUni n
, let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap
]
uniInputType (GLUniform ty _) = ty
streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let s = fromMaybe (error $ "missing attribute: " ++ name) $ Map.lookup name attrs]
where
attrMap = inputStreams prg
attrCmd i s = case s of
Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
Attribute_Word -> setIntAttrib 1
Attribute_V2U -> setIntAttrib 2
Attribute_V3U -> setIntAttrib 3
Attribute_V4U -> setIntAttrib 4
Attribute_Int -> setIntAttrib 1
Attribute_V2I -> setIntAttrib 2
Attribute_V3I -> setIntAttrib 3
Attribute_V4I -> setIntAttrib 4
Attribute_Float -> setFloatAttrib 1
Attribute_V2F -> setFloatAttrib 2
Attribute_V3F -> setFloatAttrib 3
Attribute_V4F -> setFloatAttrib 4
Attribute_M22F -> setFloatAttrib 4
Attribute_M23F -> setFloatAttrib 6
Attribute_M24F -> setFloatAttrib 8
Attribute_M32F -> setFloatAttrib 6
Attribute_M33F -> setFloatAttrib 9
Attribute_M34F -> setFloatAttrib 12
Attribute_M42F -> setFloatAttrib 8
Attribute_M43F -> setFloatAttrib 12
Attribute_M44F -> setFloatAttrib 16
where
setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
glType = arrayTypeToGLType arrType
ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
constAttr -> GLSetVertexAttrib i constAttr
allocRenderer :: Pipeline -> IO GLRenderer
allocRenderer p = do
smps <- V.mapM compileSampler $ samplers p
texs <- V.mapM compileTexture $ textures p
trgs <- V.mapM (compileRenderTarget (textures p) texs) $ targets p
prgs <- V.mapM compileProgram $ programs p
texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (Map.keys . programInTextures) $ programs p)
let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState
input <- newIORef Nothing
vao <- alloca $! \pvao -> glGenVertexArrays 1 pvao >> peek pvao
strs <- V.mapM compileStreamData $ streams p
return $ GLRenderer
{ glPrograms = prgs
, glTextures = texs
, glSamplers = smps
, glTargets = trgs
, glCommands = cmds
, glSlotPrograms = V.map (V.toList . slotPrograms) $ IR.slots p
, glInput = input
, glSlotNames = V.map slotName $ IR.slots p
, glVAO = vao
, glTexUnitMapping = texUnitMapRefs
, glStreams = strs
}
disposeRenderer :: GLRenderer -> IO ()
disposeRenderer p = do
setStorage' p Nothing
V.forM_ (glPrograms p) $ \prg -> do
glDeleteProgram $ programObject prg
mapM_ glDeleteShader $ shaderObjects prg
let targets = glTargets p
withArray (map framebufferObject $ V.toList targets) $ (glDeleteFramebuffers $ fromIntegral $ V.length targets)
let textures = glTextures p
withArray (map glTextureObject $ V.toList textures) $ (glDeleteTextures $ fromIntegral $ V.length textures)
let samplers = glSamplers p
withArray (map glSamplerObject $ V.toList samplers) $ (glDeleteSamplers . fromIntegral . V.length $ glSamplers p)
with (glVAO p) $ (glDeleteVertexArrays 1)
isSubTrie :: (a -> a -> Bool) -> Map String a -> Map String a -> Bool
isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset]
where
isMember a Nothing = False
isMember a (Just b) = eqFun a b
setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
setStorage p input' = setStorage' p (Just input')
setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
setStorage' p@GLRenderer{..} input' = do
readIORef glInput >>= \case
Nothing -> return ()
Just InputConnection{..} -> do
let slotRefs = slotVector icInput
modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)]
V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do
slot <- readIORef (slotRefs ! slotIdx)
forM_ (IM.elems $ objectMap slot) $ \obj -> do
modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)]
case input' of
Nothing -> writeIORef glInput Nothing >> return Nothing
Just input -> do
let pipelinesRef = pipelines input
oldPipelineV <- readIORef pipelinesRef
(idx,shouldExtend) <- case V.findIndex isNothing oldPipelineV of
Nothing -> do
let len = V.length oldPipelineV
modifyIORef pipelinesRef $ \v -> (V.concat [v,V.replicate len Nothing]) // [(len,Just p)]
return (len,Just len)
Just i -> do
modifyIORef pipelinesRef $ \v -> v // [(i,Just p)]
return (i,Nothing)
let sm = slotMap input
pToI = [i | n <- glSlotNames, let i = fromMaybe (error $ "missing object array: " ++ n) $ Map.lookup n sm]
iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
writeIORef glInput $ Just $ InputConnection idx input pToI iToP
let slotV = slotVector input
progV = glPrograms
topUnis = uniformSetup input
emptyV = V.replicate (V.length progV) []
extend v = case shouldExtend of
Nothing -> v
Just l -> V.concat [v,V.replicate l V.empty]
V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do
slot <- readIORef $ slotV ! slotIdx
forM_ (IM.elems $ objectMap slot) $ \obj -> do
let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
V.forM_ glStreams $ \s -> do
writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
return Nothing
renderSlot :: [GLObjectCommand] -> IO ()
renderSlot cmds = forM_ cmds $ \cmd -> do
case cmd of
GLSetVertexAttribArray idx buf size typ ptr -> do
glBindBuffer GL_ARRAY_BUFFER buf
glEnableVertexAttribArray idx
glVertexAttribPointer idx size typ (fromIntegral GL_FALSE) 0 ptr
GLSetVertexAttribIArray idx buf size typ ptr -> do
glBindBuffer GL_ARRAY_BUFFER buf
glEnableVertexAttribArray idx
glVertexAttribIPointer idx size typ 0 ptr
GLDrawArrays mode first count -> glDrawArrays mode first count
GLDrawElements mode count typ buf indicesPtr -> do
glBindBuffer GL_ELEMENT_ARRAY_BUFFER buf
glDrawElements mode count typ indicesPtr
GLSetUniform idx (GLUniform ty ref) -> setUniform idx ty ref
GLBindTexture txTarget tuRef (GLUniform _ ref) -> do
txObjVal <- readIORef ref
with txObjVal $ \txObjPtr -> do
txObj <- peek $ castPtr txObjPtr :: IO GLuint
texUnit <- readIORef tuRef
glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
glBindTexture txTarget txObj
GLSetVertexAttrib idx val -> do
glDisableVertexAttribArray idx
setVertexAttrib idx val
renderFrame :: GLRenderer -> IO ()
renderFrame glp = do
glBindVertexArray (glVAO glp)
forM_ (glCommands glp) $ \cmd -> do
case cmd of
GLSetRasterContext rCtx -> setupRasterContext rCtx
GLSetAccumulationContext aCtx -> setupAccumulationContext aCtx
GLSetRenderTarget rt bufs -> do
ic' <- readIORef $ glInput glp
case ic' of
Nothing -> return ()
Just ic -> do
let input = icInput ic
(w,h) <- readIORef $ screenSize input
glViewport 0 0 (fromIntegral w) (fromIntegral h)
glBindFramebuffer GL_DRAW_FRAMEBUFFER rt
case bufs of
Nothing -> return ()
Just bl -> withArray bl $ glDrawBuffers (fromIntegral $ length bl)
GLSetProgram p -> glUseProgram p
GLSetSamplerUniform i tu ref -> glUniform1i i tu >> writeIORef ref tu
GLSetTexture tu target tx -> glActiveTexture tu >> glBindTexture target tx
GLSetSampler tu s -> glBindSampler tu s
GLClearRenderTarget vals -> clearRenderTarget vals
GLGenerateMipMap tu target -> glActiveTexture tu >> glGenerateMipmap target
GLRenderStream streamIdx progIdx -> do
renderSlot =<< readIORef (glStreamCommands $ glStreams glp ! streamIdx)
GLRenderSlot slotIdx progIdx -> do
input <- readIORef (glInput glp)
case input of
Nothing -> putStrLn "Warning: No pipeline input!" >> return ()
Just ic -> do
let draw obj = do
enabled <- readIORef $ objEnabled obj
when enabled $ do
cmd <- readIORef $ objCommands obj
renderSlot ((cmd ! icId ic) ! progIdx)
readIORef (slotVector (icInput ic) ! (icSlotMapPipelineToInput ic ! slotIdx)) >>= \case
GLSlot _ objs Ordered -> forM_ objs $ draw . snd
GLSlot objMap _ _ -> forM_ objMap draw
data CGState
= CGState
{ currentProgram :: ProgramName
, textureBinding :: IntMap GLTexture
}
initCGState = CGState
{ currentProgram = error "CGState: empty currentProgram"
, textureBinding = IM.empty
}
type CG a = State CGState a
compileCommand :: Map String (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand
compileCommand texUnitMap samplers textures targets programs cmd = case cmd of
SetRasterContext rCtx -> return $ GLSetRasterContext rCtx
SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx
SetRenderTarget rt -> let GLRenderTarget fbo bufs = targets ! rt in return $ GLSetRenderTarget fbo bufs
SetProgram p -> do
modify (\s -> s {currentProgram = p})
return $ GLSetProgram $ programObject $ programs ! p
SetSamplerUniform n tu -> do
p <- currentProgram <$> get
case Map.lookup n (inputTextures $ programs ! p) of
Nothing -> return (GLSetProgram (programObject $ programs ! p) )
Just i -> case Map.lookup n texUnitMap of
Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd
Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r
SetTexture tu t -> do
let tex = textures ! t
modify (\s -> s {textureBinding = IM.insert tu tex $ textureBinding s})
return $ GLSetTexture (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex) (glTextureObject tex)
SetSampler tu s -> return $ GLSetSampler (GL_TEXTURE0 + fromIntegral tu) (maybe 0 (glSamplerObject . (samplers !)) s)
RenderSlot slot -> do
p <- currentProgram <$> get
return $ GLRenderSlot slot p
RenderStream stream -> do
p <- currentProgram <$> get
return $ GLRenderStream stream p
ClearRenderTarget vals -> return $ GLClearRenderTarget $ V.toList vals
GenerateMipMap tu -> do
tb <- textureBinding <$> get
case IM.lookup tu tb of
Nothing -> fail "internal error (GenerateMipMap)!"
Just tex -> return $ GLGenerateMipMap (GL_TEXTURE0 + fromIntegral tu) (glTextureTarget tex)