module Graphics.Caramia.Render
(
draw
, runDraws
, DrawT()
, Draw
, drawR
, setBlending
, setFragmentPassTests
, setPipeline
, setPolygonOffset
, setPrimitiveRestart
, setTargetFramebuffer
, setTextureBindings
, DrawCommand(..)
, drawCommand
, DrawParams(..)
, defaultDrawParams
, SourceData(..)
, IndexType(..)
, Primitive(..)
, IndexTypeable(..)
, FragmentPassTests(..)
, defaultFragmentPassTests
, ComparisonFunc(..)
, StencilOp(..)
, Culling(..) )
where
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Trans.State.Strict
import qualified Data.IntMap.Strict as IM
import Foreign
import Foreign.C.Types
import Graphics.Caramia.Blend
import Graphics.Caramia.Blend.Internal
import Graphics.Caramia.Buffer.Internal
import qualified Graphics.Caramia.Framebuffer as FBuf
import qualified Graphics.Caramia.Framebuffer.Internal as FBuf
import Graphics.Caramia.Internal.OpenGLCApi
import Graphics.Caramia.Internal.Exception
import Graphics.Caramia.Prelude
import Graphics.Caramia.Render.Internal hiding ( setFragmentPassTests )
import qualified Graphics.Caramia.Render.Internal as I
import Graphics.Caramia.Resource
import qualified Graphics.Caramia.Shader.Internal as Shader
import Graphics.Caramia.Texture
import qualified Graphics.Caramia.Texture.Internal as Texture
import Graphics.Caramia.Texture.Internal ( withTextureBinding )
import qualified Graphics.Caramia.VAO.Internal as VAO
import Graphics.GL.Ext.NV.PrimitiveRestart
import Graphics.GL.Ext.ARB.DrawInstanced
data Primitive =
Triangles
| TriangleStrip
| TriangleFan
| Points
| Lines
| LineStrip
| LineLoop
| LinesAdjacency
| LineStripAdjacency
| TriangleStripAdjacency
| TrianglesAdjacency
deriving ( Eq, Ord, Show, Read, Typeable, Enum )
toConstant :: Primitive -> GLenum
toConstant Triangles = GL_TRIANGLES
toConstant TriangleStrip = GL_TRIANGLE_STRIP
toConstant TriangleFan = GL_TRIANGLE_FAN
toConstant Points = GL_POINTS
toConstant Lines = GL_LINES
toConstant LineStrip = GL_LINE_STRIP
toConstant LineLoop = GL_LINE_LOOP
toConstant LinesAdjacency = GL_LINES_ADJACENCY
toConstant LineStripAdjacency = GL_LINE_STRIP_ADJACENCY
toConstant TriangleStripAdjacency = GL_TRIANGLE_STRIP_ADJACENCY
toConstant TrianglesAdjacency = GL_TRIANGLES_ADJACENCY
data IndexType =
IWord32
| IWord16
| IWord8
deriving ( Eq, Ord, Show, Read, Typeable, Enum )
toConstantIT :: IndexType -> GLenum
toConstantIT IWord32 = GL_UNSIGNED_INT
toConstantIT IWord16 = GL_UNSIGNED_SHORT
toConstantIT IWord8 = GL_UNSIGNED_BYTE
class IndexTypeable a where
toIndexType :: a
-> IndexType
instance IndexTypeable Word32 where
toIndexType _ = IWord32
instance IndexTypeable Word16 where
toIndexType _ = IWord16
instance IndexTypeable Word8 where
toIndexType _ = IWord8
instance IndexTypeable CUInt where
toIndexType _ = IWord32
instance IndexTypeable CUShort where
toIndexType _ = IWord16
instance IndexTypeable CUChar where
toIndexType _ = IWord8
data DrawParams = DrawParams
{
pipeline :: Shader.Pipeline
, fragmentPassTests :: !FragmentPassTests
, blending :: BlendSpec
, targetFramebuffer :: FBuf.Framebuffer
, bindTextures :: IM.IntMap Texture
, polygonOffset :: !(Float, Float)
, primitiveRestart :: !(Maybe Word32)
}
deriving ( Eq, Ord, Typeable )
defaultDrawParams :: DrawParams
defaultDrawParams = DrawParams {
pipeline = error "defaultDrawParams: pipeline is not set."
, fragmentPassTests = defaultFragmentPassTests
, blending = preMultipliedAlpha
, bindTextures = IM.empty
, targetFramebuffer = FBuf.screenFramebuffer
, polygonOffset = (0, 0)
, primitiveRestart = Nothing }
data DrawCommand = DrawCommand
{ primitiveType :: Primitive
, primitivesVAO :: VAO.VAO
, numIndices :: Int
, numInstances :: Int
, sourceData :: SourceData
}
deriving ( Eq, Ord, Typeable )
drawCommand :: DrawCommand
drawCommand = DrawCommand
{ primitiveType = error "drawCommand: primitiveType is not set."
, primitivesVAO = error "drawCommand: primitivesVAO is not set."
, numIndices = error "drawCommand: numIndices is not set."
, sourceData = error "drawCommand: sourceData is not set."
, numInstances = 1 }
data SourceData =
Primitives
{ firstIndex :: Int }
| PrimitivesWithIndices
{ indexBuffer :: Buffer
, indexOffset :: Int
, indexType :: IndexType }
deriving ( Eq, Ord, Typeable )
draw :: (MonadIO m, MonadMask m) => DrawCommand -> DrawParams -> m ()
draw cmd params = runDraws params (drawR cmd)
drawR :: (MonadIO m, MonadMask m) => DrawCommand -> DrawT m ()
drawR (DrawCommand {..})
| numIndices == 0 = return ()
| otherwise = DrawT $ do
state <- get
liftIO $
withResource (VAO.resource primitivesVAO) $ \(VAO.VAO_ vao_name) ->
withBoundVAO vao_name $
case sourceData of
Primitives {..} ->
if gl_ARB_draw_instanced
then glDrawArraysInstancedARB
(toConstant primitiveType)
(safeFromIntegral firstIndex)
(safeFromIntegral numIndices)
(safeFromIntegral numInstances)
else if numInstances == 1
then glDrawArrays
(toConstant primitiveType)
(safeFromIntegral firstIndex)
(safeFromIntegral numIndices)
else nosupport
PrimitivesWithIndices {..} ->
withResource (resource indexBuffer) $
\(Buffer_ buf_name) -> do
when (buf_name /= boundEbo state) $
setBoundElementBuffer buf_name
if gl_ARB_draw_instanced
then glDrawElementsInstanced
(toConstant primitiveType)
(safeFromIntegral numIndices)
(toConstantIT indexType)
(intPtrToPtr $
fromIntegral indexOffset)
(safeFromIntegral numInstances)
else if numInstances == 1
then glDrawElements
(toConstant primitiveType)
(safeFromIntegral numIndices)
(toConstantIT indexType)
(intPtrToPtr $
fromIntegral indexOffset)
else nosupport
where
nosupport = throwM $ NoSupport $
"Instanced rendering requires GL_ARB_draw_instanced."
data DrawState = DrawState
{ boundPipeline :: !Shader.Pipeline
, boundEbo :: !GLuint
, boundTextures :: !(IM.IntMap Texture)
, boundBlending :: !BlendSpec
, boundFramebuffer :: !FBuf.Framebuffer
, boundFragmentPassTests :: !FragmentPassTests
, boundPrimitiveRestart :: !(Maybe Word32)
, activeTexture :: !GLuint }
deriving ( Eq, Ord, Typeable )
newtype DrawT m a = DrawT (StateT DrawState m a)
deriving ( Monad, Applicative, Functor, Typeable )
type Draw = DrawT IO
instance MonadIO m => MonadIO (DrawT m) where
liftIO = DrawT . liftIO
instance MonadTrans DrawT where
lift = DrawT . lift
runDraws :: (MonadIO m, MonadMask m)
=> DrawParams
-> DrawT m a
-> m a
runDraws params (DrawT cmd_stream) =
withParams params $ do
(result, st) <-
runStateT cmd_stream DrawState
{ boundPipeline = pipeline params
, boundFragmentPassTests = fragmentPassTests params
, boundEbo = 0
, boundBlending = blending params
, boundFramebuffer = targetFramebuffer params
, boundTextures = bindTextures params
, boundPrimitiveRestart = primitiveRestart params
, activeTexture = 0
}
st `seq` return result
withParams :: (MonadIO m, MonadMask m) => DrawParams -> m a -> m a
withParams (DrawParams {..}) action =
FBuf.withBinding targetFramebuffer $
withPipeline pipeline $
withFragmentPassTests fragmentPassTests $
withBlendings blending $
withBoundTextures bindTextures $
withBoundElementBuffer 0 $
withPrimitiveRestart primitiveRestart $
withPolygonOffset polygonOffset $ do
old_active <- gi GL_ACTIVE_TEXTURE
(ox, oy, ow, oh) <- liftIO $ allocaArray 4 $ \viewport_ptr -> do
glGetIntegerv GL_VIEWPORT viewport_ptr
ox <- peekElemOff viewport_ptr 0
oy <- peekElemOff viewport_ptr 1
ow <- peekElemOff viewport_ptr 2
oh <- peekElemOff viewport_ptr 3
return (ox, oy, ow, oh)
finally (glActiveTexture GL_TEXTURE0 >>
action)
$ do
glActiveTexture old_active
glViewport ox oy ow oh
data PrimitiveRestartFuns = PrimitiveRestartFuns {
prIndex :: !GLenum
, prRestart :: !GLenum
, prPrimitiveRestartIndex :: !(GLuint -> IO ()) }
withPrimitiveRestartFuns :: (Monad m, MonadIO m)
=> Bool -> m a -> (PrimitiveRestartFuns -> m a) -> m a
withPrimitiveRestartFuns do_backup backup_action action =
if | gl_NV_primitive_restart -> action nvfuns
| openGLVersion >= OpenGLVersion 3 1 -> action o31funs
| do_backup -> backup_action
| otherwise ->
liftIO $ throwM $ NoSupport "Primitive restart requires OpenGL 3.1 or GL_NV_primitive_restart."
where
nvfuns = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX_NV
GL_PRIMITIVE_RESTART_NV
glPrimitiveRestartIndexNV
o31funs = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX
GL_PRIMITIVE_RESTART
glPrimitiveRestartIndex
withPrimitiveRestart :: (MonadIO m, MonadMask m) => Maybe Word32 -> m a -> m a
withPrimitiveRestart pr action =
withPrimitiveRestartFuns (isNothing pr) action $ \funs@(PrimitiveRestartFuns{..}) -> do
old_primitive_restart_enabled <- liftIO $ glIsEnabled prRestart
old_i <- gi prIndex
finally (activate funs >> action)
(do if old_primitive_restart_enabled /= 0
then glEnable prRestart
else glDisable prRestart
liftIO $ prPrimitiveRestartIndex old_i)
where
activate (PrimitiveRestartFuns{..}) = case pr of
Nothing -> glDisable prRestart
Just value -> do
glEnable prRestart
liftIO $ prPrimitiveRestartIndex (fromIntegral value)
withPolygonOffset :: (MonadIO m, MonadMask m) => (Float, Float) -> m a -> m a
withPolygonOffset (factor, units) action = do
old_factor <- gf GL_POLYGON_OFFSET_FACTOR
old_units <- gf GL_POLYGON_OFFSET_UNITS
finally (glPolygonOffset factor units >>
action) $
glPolygonOffset old_factor old_units
setActiveTexture :: MonadIO m => GLuint -> DrawT m ()
setActiveTexture unit = DrawT $ do
state <- get
when (activeTexture state /= unit) $
glActiveTexture (GL_TEXTURE0 + unit) >>
modify (\old -> old { activeTexture = unit })
setPrimitiveRestart :: MonadIO m => Maybe Word32 -> DrawT m ()
setPrimitiveRestart restart = DrawT $
withPrimitiveRestartFuns (isNothing restart) (return ()) $ \PrimitiveRestartFuns{..} -> do
pr <- return . boundPrimitiveRestart =<< get
liftIO $ case (pr, restart) of
(Nothing, Just x) -> do
glEnable prRestart
prPrimitiveRestartIndex (fromIntegral x)
(Just _, Nothing) -> do
glDisable prRestart
(Just y, Just x) | y /= x ->
prPrimitiveRestartIndex (fromIntegral x)
_ -> return ()
modify (\old -> old { boundPrimitiveRestart = restart })
setTextureBindings :: MonadIO m => IM.IntMap Texture -> DrawT m ()
setTextureBindings texes = do
state <- DrawT get
let old_texes = boundTextures state
forM_ (IM.assocs old_texes) $ \(index, tex) ->
case IM.lookup index texes of
Nothing -> setActiveTexture (safeFromIntegral index) >>
let (bind_target, _) =
Texture.getTopologyBindPoints $
topology $ viewSpecification tex
in liftIO $ glBindTexture bind_target 0
Just new_tex -> do
old_name <-
liftIO $ withResource (Texture.resource tex) $
\(Texture.Texture_ old_name) -> return old_name
name <-
liftIO $ withResource (Texture.resource new_tex) $
\(Texture.Texture_ name) -> return name
when (name /= old_name) $ do
setActiveTexture (safeFromIntegral index)
let (bind_target, _) =
Texture.getTopologyBindPoints $
topology $ viewSpecification new_tex
in liftIO $ glBindTexture bind_target name
forM_ (IM.assocs texes) $ \(index, tex) ->
case IM.lookup index old_texes of
Just _ -> return ()
Nothing -> do
name <- liftIO $ withResource (Texture.resource tex) $
\(Texture.Texture_ name) -> return name
setActiveTexture (safeFromIntegral index)
let (bind_target, _) =
Texture.getTopologyBindPoints $
topology $ viewSpecification tex
in liftIO $ glBindTexture bind_target name
DrawT $ modify (\old -> old { boundTextures = texes })
setPipeline :: MonadIO m => Shader.Pipeline -> DrawT m ()
setPipeline pl = DrawT $ do
state <- get
when (boundPipeline state /= pl) $ do
liftIO $ withResource (Shader.resourcePL pl) $
\(Shader.Pipeline_ program) ->
setBoundProgram program
modify (\old -> old { boundPipeline = pl })
setBlending :: MonadIO m => BlendSpec -> DrawT m ()
setBlending blends = DrawT $ do
state <- get
when (boundBlending state /= blends) $ do
setBlendings blends
modify (\old -> old { boundBlending = blends })
setFragmentPassTests :: MonadIO m => FragmentPassTests -> DrawT m ()
setFragmentPassTests tests = DrawT $ do
state <- get
when (boundFragmentPassTests state /= tests) $ do
liftIO $ I.setFragmentPassTests tests
modify (\old -> old { boundFragmentPassTests = tests })
setPolygonOffset :: MonadIO m => Float -> Float -> DrawT m ()
setPolygonOffset factor units = glPolygonOffset factor units
setTargetFramebuffer :: MonadIO m => FBuf.Framebuffer -> DrawT m ()
setTargetFramebuffer fbuf = DrawT $ do
state <- get
when (boundFramebuffer state /= fbuf) $ do
liftIO $ FBuf.setBinding fbuf
modify (\old -> old { boundFramebuffer = fbuf })
withBoundTextures :: (MonadIO m, MonadMask m) => IM.IntMap Texture -> m a -> m a
withBoundTextures (IM.assocs -> bindings) action = rec bindings
where
rec [] = action
rec ((unit, tex):rest) =
withTextureBinding tex unit $ rec rest
withPipeline :: (MonadIO m, MonadMask m) => Shader.Pipeline -> m a -> m a
withPipeline pipeline action =
withResource (Shader.resourcePL pipeline) $ \(Shader.Pipeline_ program) ->
withBoundProgram program action