module Caramia.Render
(
draw
, runDraws
, Draw()
, drawR
, setPipeline
, setTextureBindings
, setBlending
, setTargetFramebuffer
, setFragmentPassTests
, setPolygonOffset
, DrawCommand(..)
, drawCommand
, DrawParams(..)
, defaultDrawParams
, SourceData(..)
, IndexType(..)
, Primitive(..)
, IndexTypeable(..)
, FragmentPassTests(..)
, defaultFragmentPassTests
, ComparisonFunc(..)
, StencilOp(..)
, Culling(..) )
where
import Caramia.Prelude
import qualified Caramia.VAO.Internal as VAO
import qualified Caramia.Shader.Internal as Shader
import qualified Caramia.Framebuffer as FBuf
import qualified Caramia.Framebuffer.Internal as FBuf
import qualified Caramia.Texture.Internal as Texture
import qualified Data.IntMap.Strict as IM
import Caramia.Render.Internal hiding ( setFragmentPassTests )
import qualified Caramia.Render.Internal as I
import Caramia.Blend
import Caramia.Blend.Internal
import Caramia.Texture
import Caramia.Texture.Internal ( withTextureBinding )
import Caramia.Resource
import Caramia.Buffer.Internal
import Caramia.Internal.OpenGLCApi
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
import Control.Exception
import Foreign
import Foreign.C.Types
data Primitive =
Triangles
| TriangleStrip
| TriangleFan
| Points
| Lines
| LineStrip
| LineLoop
| LinesAdjacency
| LineStripAdjacency
| TriangleStripAdjacency
| TrianglesAdjacency
deriving ( Eq, Ord, Show, Read )
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 )
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)
}
deriving ( Eq, 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) }
data DrawCommand = DrawCommand
{ primitiveType :: Primitive
, primitivesVAO :: VAO.VAO
, numIndices :: Int
, numInstances :: Int
, sourceData :: SourceData
}
deriving ( Eq, 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 :: DrawCommand -> DrawParams -> IO ()
draw cmd params = runDraws params (drawR cmd)
drawR :: DrawCommand -> Draw ()
drawR (DrawCommand {..})
| numIndices == 0 = return ()
| otherwise = Draw $ do
old_ebo <- boundEbo <$> get
liftIO $
withResource (VAO.resource primitivesVAO) $ \(VAO.VAO_ vao_name) ->
withBoundVAO vao_name $
case sourceData of
Primitives {..} ->
glDrawArraysInstanced
(toConstant primitiveType)
(safeFromIntegral firstIndex)
(safeFromIntegral numIndices)
(safeFromIntegral numInstances)
PrimitivesWithIndices {..} ->
withResource (resource indexBuffer) $
\(Buffer_ buf_name) -> do
when (buf_name /= old_ebo) $
setBoundElementBuffer buf_name
glDrawElementsInstanced
(toConstant primitiveType)
(safeFromIntegral numIndices)
(toConstantIT indexType)
(intPtrToPtr $
fromIntegral indexOffset)
(safeFromIntegral numInstances)
data DrawState = DrawState
{ boundPipeline :: !Shader.Pipeline
, boundEbo :: !GLuint
, boundTextures :: !(IM.IntMap Texture)
, boundBlending :: !BlendSpec
, boundFramebuffer :: !FBuf.Framebuffer
, boundFragmentPassTests :: !FragmentPassTests
, activeTexture :: !GLuint }
newtype Draw a = Draw (StateT DrawState IO a)
deriving ( Monad, Applicative, Functor, Typeable )
instance MonadIO Draw where
liftIO = Draw . liftIO
runDraws :: DrawParams
-> Draw a
-> IO a
runDraws params (Draw 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
, activeTexture = 0
}
st `seq` return result
withParams :: DrawParams -> IO a -> IO a
withParams (DrawParams {..}) action =
FBuf.withBinding targetFramebuffer $
withPipeline pipeline $
withFragmentPassTests fragmentPassTests $
withBlendings blending $
withBoundTextures bindTextures $
withBoundElementBuffer 0 $
withPolygonOffset polygonOffset $ do
old_active <- gi gl_ACTIVE_TEXTURE
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
finally (glActiveTexture gl_TEXTURE0 *>
action)
(glActiveTexture old_active *>
glViewport ox oy ow oh)
withPolygonOffset :: (Float, Float) -> IO a -> IO a
withPolygonOffset (factor, units) action = do
old_factor <- gf gl_POLYGON_OFFSET_FACTOR
old_units <- gf gl_POLYGON_OFFSET_UNITS
finally (do glPolygonOffset (CFloat factor) (CFloat units)
action) $
glPolygonOffset old_factor old_units
setActiveTexture :: GLuint -> Draw ()
setActiveTexture unit = Draw $ do
old_active <- activeTexture <$> get
when (old_active /= unit) $
liftIO (glActiveTexture $ gl_TEXTURE0 + unit) *>
modify (\old -> old { activeTexture = unit })
setTextureBindings :: IM.IntMap Texture -> Draw ()
setTextureBindings texes = do
old_texes <- Draw $ boundTextures <$> get
for_ (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
for_ (IM.assocs texes) $ \(index, tex) ->
case IM.lookup index old_texes of
Just _ -> pure ()
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
Draw $ modify (\old -> old { boundTextures = texes })
setPipeline :: Shader.Pipeline -> Draw ()
setPipeline pl = Draw $ do
old_pl <- boundPipeline <$> get
when (old_pl /= pl) $ do
liftIO $ withResource (Shader.resourcePL pl) $
\(Shader.Pipeline_ program) ->
setBoundProgram program
modify (\old -> old { boundPipeline = pl })
setBlending :: BlendSpec -> Draw ()
setBlending blends = Draw $ do
old_blending <- boundBlending <$> get
when (blends /= old_blending) $ do
liftIO $ setBlendings blends
modify (\old -> old { boundBlending = blends })
setFragmentPassTests :: FragmentPassTests -> Draw ()
setFragmentPassTests tests = Draw $ do
old_tests <- boundFragmentPassTests <$> get
when (old_tests /= tests) $ do
liftIO $ I.setFragmentPassTests tests
modify (\old -> old { boundFragmentPassTests = tests })
setPolygonOffset :: Float -> Float -> Draw ()
setPolygonOffset factor units = Draw $
liftIO $ glPolygonOffset (CFloat factor) (CFloat units)
setTargetFramebuffer :: FBuf.Framebuffer -> Draw ()
setTargetFramebuffer fbuf = Draw $ do
old_fbuf <- boundFramebuffer <$> get
when (old_fbuf /= fbuf) $ do
liftIO $ FBuf.setBinding fbuf
modify (\old -> old { boundFramebuffer = fbuf })
withBoundTextures :: IM.IntMap Texture -> IO a -> IO a
withBoundTextures (IM.assocs -> bindings) action = rec bindings
where
rec [] = action
rec ((unit, tex):rest) =
withTextureBinding tex unit $ rec rest
withPipeline :: Shader.Pipeline -> IO a -> IO a
withPipeline pipeline action =
withResource (Shader.resourcePL pipeline) $ \(Shader.Pipeline_ program) ->
withBoundProgram program action