module Graphics.Caramia.Render
(
draw
, runDraws
, DrawT()
, Draw
, drawR
, setBlending
, setFragmentPassTests
, setPipeline
, setPolygonOffset
, setPrimitiveRestart
, setTargetFramebuffer
, setTextureBindings
, hoistDrawT
, DrawCommand(..)
, drawCommand
, DrawParams(..)
, defaultDrawParams
, SourceData(..)
, IndexType(..)
, Primitive(..)
, IndexTypeable(..)
, FragmentPassTests(..)
, defaultFragmentPassTests
, ComparisonFunc(..)
, StencilOp(..)
, Culling(..) )
where
import Control.Monad.Catch
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.RWS.Class
import Control.Monad.State.Strict hiding ( forM_, sequence_ )
import Data.Data ( Data )
import qualified Data.IntMap.Strict as IM
import Foreign
import Foreign.C.Types
import GHC.Generics
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, Data, Generic )
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, Data, Generic )
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)
, restoreTextures :: !(IM.IntMap (DrawT IO ()))
, boundBlending :: !BlendSpec
, boundFramebuffer :: !FBuf.Framebuffer
, boundFragmentPassTests :: !FragmentPassTests
, boundPrimitiveRestart :: !(Maybe Word32)
, activeTexture :: !GLuint }
deriving ( Typeable )
newtype DrawT m a = DrawT (StateT DrawState m a)
deriving ( Monad, Applicative, Functor, Typeable )
deriving instance MonadCont m => MonadCont (DrawT m)
deriving instance MonadError e m => MonadError e (DrawT m)
deriving instance MonadReader r m => MonadReader r (DrawT m)
deriving instance MonadRWS r w s m => MonadRWS r w s (DrawT m)
deriving instance MonadWriter w m => MonadWriter w (DrawT m)
type Draw = DrawT IO
instance MonadIO m => MonadIO (DrawT m) where
liftIO = DrawT . liftIO
instance MonadTrans DrawT where
lift = DrawT . lift
instance MonadState s m => MonadState s (DrawT m) where
get = DrawT $ lift get
put = DrawT . lift . put
state = DrawT . lift . state
hoistDrawT :: Monad n => (forall a. m a -> n a) -> DrawT m a -> DrawT n a
hoistDrawT changer (DrawT action) = DrawT $ do
old_st <- get
(result, new_st) <- lift $ changer $ runStateT action old_st
put new_st
return result
runDraws :: (MonadIO m, MonadMask m)
=> DrawParams
-> DrawT m a
-> m a
runDraws params (DrawT cmd_stream) =
withParams params $ do
(result, st) <-
runStateT commands DrawState
{ boundPipeline = pipeline params
, boundFragmentPassTests = fragmentPassTests params
, boundEbo = 0
, boundBlending = blending params
, boundFramebuffer = targetFramebuffer params
, boundTextures = bind_textures
, restoreTextures = fmap (const (return ())) bind_textures
, boundPrimitiveRestart = primitiveRestart params
, activeTexture = 0
}
st `seq` return result
where
bind_textures = bindTextures params
commands = finally cmd_stream $ do
st <- get
sequence_ $ fmap (unwrapDrawT . hoistDrawT liftIO) $ restoreTextures st
unwrapDrawT (DrawT ac) = ac
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 ())
, prEnable :: !(GLenum -> IO ())
, prDisable :: !(GLenum -> IO ()) }
withPrimitiveRestartFuns :: (Monad m, MonadIO m)
=> Bool -> m a -> (PrimitiveRestartFuns -> m a) -> m a
withPrimitiveRestartFuns do_backup backup_action action =
if | openGLVersion >= OpenGLVersion 3 1 -> action o31funs
| gl_NV_primitive_restart -> action nvfuns
| 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
glEnableClientState
glDisableClientState
o31funs = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX
GL_PRIMITIVE_RESTART
glPrimitiveRestartIndex
glEnable
glDisable
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)
(liftIO $ do if old_primitive_restart_enabled /= 0
then prEnable prRestart
else prDisable prRestart
prPrimitiveRestartIndex old_i)
where
activate (PrimitiveRestartFuns{..}) = liftIO $ case pr of
Nothing -> prDisable prRestart
Just value -> do
prEnable prRestart
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
prEnable prRestart
prPrimitiveRestartIndex (fromIntegral x)
(Just _, Nothing) -> do
prDisable 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
old_restorations = restoreTextures 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
new_restorations <-
flip execStateT old_restorations $
forM_ (IM.assocs texes) $ \(index, tex) -> do
restorations <- get
case IM.lookup index restorations of
Just _ -> return ()
Nothing -> do
lift $ setActiveTexture (safeFromIntegral index)
let (bind_point, bind_point_get) =
Texture.getTopologyBindPoints $
topology $ viewSpecification tex
old_tex <- gi bind_point_get
modify $ IM.insert index $ do
setActiveTexture (safeFromIntegral index)
glBindTexture bind_point old_tex
case IM.lookup index old_texes of
Just _ -> return ()
Nothing -> do
name <- liftIO $ withResource (Texture.resource tex) $
\(Texture.Texture_ name) -> return name
lift $ setActiveTexture (safeFromIntegral index)
let (bind_target, _) =
Texture.getTopologyBindPoints $
topology $ viewSpecification tex
in liftIO $ glBindTexture bind_target name
DrawT $ modify (\old -> old { boundTextures = texes
, restoreTextures = new_restorations })
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