module Graphics.Caramia.Render.Internal where
import Graphics.Caramia.Prelude
import Graphics.Caramia.Internal.OpenGLCApi
import Control.Monad.IO.Class
import Control.Monad.Catch
data ComparisonFunc =
Never
| Less
| Equal
| LEqual
| Greater
| NotEqual
| GEqual
| Always
deriving ( Eq, Ord, Show, Read, Typeable )
comparisonFuncToConstant :: ComparisonFunc -> GLenum
comparisonFuncToConstant Never = GL_NEVER
comparisonFuncToConstant Less = GL_LESS
comparisonFuncToConstant Equal = GL_EQUAL
comparisonFuncToConstant LEqual = GL_LEQUAL
comparisonFuncToConstant Greater = GL_GREATER
comparisonFuncToConstant NotEqual = GL_NOTEQUAL
comparisonFuncToConstant GEqual = GL_GEQUAL
comparisonFuncToConstant Always = GL_ALWAYS
data StencilOp =
Keep
| Zero
| Replace
| Increment
| IncrementAndWrap
| Decrease
| DecreaseAndWrap
| Invert
deriving ( Eq, Ord, Show, Read, Typeable )
stencilOpToConstant :: StencilOp -> GLenum
stencilOpToConstant Keep = GL_KEEP
stencilOpToConstant Zero = GL_ZERO
stencilOpToConstant Replace = GL_REPLACE
stencilOpToConstant Increment = GL_INCR
stencilOpToConstant IncrementAndWrap = GL_INCR_WRAP
stencilOpToConstant Decrease = GL_DECR
stencilOpToConstant DecreaseAndWrap = GL_DECR_WRAP
stencilOpToConstant Invert = GL_INVERT
setStencilFunc :: MonadIO m
=> ComparisonFunc
-> StencilOp
-> StencilOp
-> StencilOp
-> Word32
-> Word32
-> m ()
setStencilFunc func op1 op2 op3 ref mask = do
glStencilFunc (comparisonFuncToConstant func)
(fromIntegral ref)
(fromIntegral mask)
glStencilOp (stencilOpToConstant op1)
(stencilOpToConstant op2)
(stencilOpToConstant op3)
withStencilFunc :: (MonadIO m, MonadMask m)
=> ComparisonFunc
-> StencilOp
-> StencilOp
-> StencilOp
-> Word32
-> Word32
-> m a
-> m a
withStencilFunc func op1 op2 op3 ref mask action = do
old_func <- gi GL_STENCIL_FUNC
old_ref <- gi GL_STENCIL_REF
old_mask <- gi GL_STENCIL_VALUE_MASK
old_op1 <- gi GL_STENCIL_FAIL
old_op2 <- gi GL_STENCIL_PASS_DEPTH_FAIL
old_op3 <- gi GL_STENCIL_PASS_DEPTH_PASS
finally (setStencilFunc func op1 op2 op3 ref mask >> action)
(do
glStencilFunc old_func (fromIntegral old_ref) old_mask
glStencilOp old_op1 old_op2 old_op3)
withCulling :: (MonadIO m, MonadMask m) => Culling -> m a -> m a
withCulling culling action = do
old_culling <- gi GL_CULL_FACE_MODE
was_enabled <- glIsEnabled GL_CULL_FACE
finally (setCulling culling >> action)
(liftIO $ do
if was_enabled == GL_TRUE
then glEnable GL_CULL_FACE
else glDisable GL_CULL_FACE
glCullFace old_culling)
setCulling :: (MonadIO m, MonadMask m) => Culling -> m ()
setCulling NoCulling = glDisable GL_CULL_FACE
setCulling x = mask_ $
glEnable GL_CULL_FACE >>
glCullFace (cullingToConstant x)
setDepthFunc :: MonadIO m => ComparisonFunc -> Bool -> m ()
setDepthFunc func write_depth = do
glDepthFunc (comparisonFuncToConstant func)
glDepthMask (if write_depth then GL_TRUE else GL_FALSE)
withDepthFunc :: (MonadIO m, MonadMask m) => ComparisonFunc -> Bool -> m a -> m a
withDepthFunc func write_depth action = do
old_depth_func <- gi GL_DEPTH_FUNC
old_depth_write <- gi GL_DEPTH_WRITEMASK
finally (setDepthFunc func write_depth >> action)
(do
glDepthFunc old_depth_func
glDepthMask (fromIntegral old_depth_write))
setFragmentPassTests :: (MonadIO m, MonadMask m) => FragmentPassTests -> m ()
setFragmentPassTests (FragmentPassTests {..}) = do
case depthTest of
Nothing -> glDisable GL_DEPTH_TEST
Just dt -> glEnable GL_DEPTH_TEST >>
setDepthFunc dt writeDepth
case stencilTest of
Nothing -> glDisable GL_STENCIL_TEST
Just st -> glEnable GL_STENCIL_TEST >>
setStencilFunc st
failStencilOp
depthFailStencilOp
depthPassStencilOp
stencilReference
stencilMask
setCulling cullFace
withFragmentPassTests :: (MonadIO m, MonadMask m) => FragmentPassTests -> m a -> m a
withFragmentPassTests (FragmentPassTests {..}) action = do
was_it_enabled <- glIsEnabled GL_DEPTH_TEST
finally
(case depthTest of
Nothing -> glDisable GL_DEPTH_TEST >> next
Just dt -> glEnable GL_DEPTH_TEST >>
withDepthFunc dt writeDepth next) $
if was_it_enabled == GL_TRUE
then glEnable GL_DEPTH_TEST
else glDisable GL_DEPTH_TEST
where
next = do
was_it_enabled <- glIsEnabled GL_STENCIL_TEST
finally
(case stencilTest of
Nothing -> glDisable GL_STENCIL_TEST >> next'
Just st -> glEnable GL_STENCIL_TEST >>
withStencilFunc st
failStencilOp
depthFailStencilOp
depthPassStencilOp
stencilReference
stencilMask
next') $
if was_it_enabled == GL_TRUE
then glEnable GL_STENCIL_TEST
else glDisable GL_STENCIL_TEST
next' = withCulling cullFace action
data Culling =
Back
| Front
| FrontAndBack
| NoCulling
deriving ( Eq, Ord, Show, Read, Typeable )
cullingToConstant :: Culling -> GLenum
cullingToConstant Back = GL_BACK
cullingToConstant Front = GL_FRONT
cullingToConstant FrontAndBack = GL_FRONT_AND_BACK
cullingToConstant NoCulling = 0
data FragmentPassTests = FragmentPassTests {
depthTest :: !(Maybe ComparisonFunc)
, writeDepth :: Bool
, stencilTest :: !(Maybe ComparisonFunc)
, stencilReference :: !Word32
, stencilMask :: !Word32
, failStencilOp :: !StencilOp
, depthFailStencilOp :: !StencilOp
, depthPassStencilOp :: !StencilOp
, cullFace :: !Culling
}
deriving ( Eq, Ord, Show, Read, Typeable )
defaultFragmentPassTests :: FragmentPassTests
defaultFragmentPassTests = FragmentPassTests
{ depthTest = Nothing
, writeDepth = True
, stencilTest = Nothing
, stencilReference = 0
, stencilMask = 0xffffffff
, failStencilOp = Keep
, depthFailStencilOp = Keep
, depthPassStencilOp = Keep
, cullFace = Back }