GPipe-1.0.2: src/OutputMerger.hs
-----------------------------------------------------------------------------
--
-- Module : OutputMerger
-- Copyright : Tobias Bexelius
-- License : BSD3
--
-- Maintainer : Tobias Bexelius
-- Stability : Experimental
-- Portability : Portable
--
-- |
-----------------------------------------------------------------------------
module OutputMerger (
FragmentDepth,
ColorMask, Blending(..), BlendEquation(..), BlendingFactor(..), LogicOp(..),
ComparisonFunction(..), DepthFunction, DepthMask,
StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..),
FrameBuffer(),
newFrameBufferColor,
newFrameBufferColorDepth,
newFrameBufferColorDepthStencil,
newFrameBufferColorStencil,
newFrameBufferDepth,
newFrameBufferDepthStencil,
newFrameBufferStencil,
paintColor,
paintDepth,
paintColorDepth,
paintStencil,
paintDepthStencil,
paintColorStencil,
paintColorDepthStencil,
paintRastDepth,
paintColorRastDepth,
paintRastDepthStencil,
paintColorRastDepthStencil,
getFrameBufferCPUFormatByteSize,
getFrameBufferColor,
getFrameBufferDepth,
getFrameBufferStencil,
newWindow,
runFrameBufferInContext
) where
import Formats
import Shader
import GPUStream
import Resources
import Graphics.Rendering.OpenGL hiding (RGBA, Blend, stencilMask, Color, ColorBuffer, DepthBuffer, StencilBuffer, Vertex)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Vec (vec, (:.)(..), Vec2)
import qualified Graphics.UI.GLUT as GLUT
import Data.Int (Int32)
import Data.Word (Word32)
import Foreign.Ptr (Ptr)
import Graphics.UI.GLUT
(reshapeCallback, displayCallback, Window)
import Control.Monad (liftM)
import Data.Maybe (fromJust)
import Control.Monad.Reader (runReaderT)
import Control.Exception (evaluate)
type FragmentDepth = Fragment Float
-- | 'True' for each color component that should be written to the 'FrameBuffer'.
type ColorMask f = Color f Bool
-- | 'True' if the depth component should be written to the 'FrameBuffer'.
type DepthMask = Bool
-- | The function used to compare the fragment's depth and the depth buffers depth with.
type DepthFunction = ComparisonFunction
-- | Sets how the painted colors are blended with the 'FrameBuffer's previous value.
data Blending = NoBlending -- ^ The painted fragment completely overwrites the previous value .
| Blend (BlendEquation, BlendEquation)
((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))
(Color RGBAFormat Float) -- ^ Use blending equations to combine the fragment with the previous value.
-- The first 'BlendEquation' and 'BlendingFactor's is used for front faced triangles and other primitives,
-- and the second for back faced triangles.
| BlendLogicOp LogicOp -- ^ Use a 'LogicOp' to combine the fragment with the previous value.
deriving (Eq,Ord,Show)
-- | Sets the operations that should be performed on the 'FrameBuffer's stencil value
data StencilOps = StencilOps {
frontStencilOp :: StencilOp, -- ^ Used for front faced triangles and other primitives.
backStencilOp :: StencilOp -- ^ Used for back faced triangles.
} deriving (Eq,Ord,Show)
-- | Sets the tests that should be performed on the stencil value, first for front facing triangles and other primitives, then for back facing triangles.
data StencilTests = StencilTests StencilTest StencilTest deriving (Eq,Ord,Show)
-- | Sets a test that should be performed on the stencil value.
data StencilTest = StencilTest {
stencilComparision :: ComparisonFunction, -- ^ The function used to compare the @stencilReference@ and the stencil buffers value with.
stencilReference :: Int32, -- ^ The value to compare with the stencil buffer's value.
stencilMask :: Word32 -- ^ A bit mask with ones in each position that should be compared and written to the stencil buffer.
} deriving (Eq,Ord,Show)
------------------------------------------------------------------
-- | A polymorphic frame buffer. It is parameterized on the type of color buffer, depth buffer and stencil buffer.
-- Any instances of 'ColorFormat' can be used for color buffer, or '()' to denote "no color buffer".
-- For depth and stencil buffers, 'DepthFormat' and 'StencilFormat' marks the existance of buffer, while '()'
-- marks the inexistance.
data FrameBuffer c d s = FrameBuffer (ContextCacheIO ())
newFrameBufferColor :: ColorFormat f => Color f Float -> FrameBuffer f () ()
newFrameBufferColorDepth :: ColorFormat f => Color f Float -> Depth -> FrameBuffer f DepthFormat ()
newFrameBufferColorDepthStencil :: ColorFormat f => Color f Float -> Depth -> Stencil -> FrameBuffer f DepthFormat StencilFormat
newFrameBufferColorStencil :: ColorFormat f => Color f Float -> Stencil -> FrameBuffer f () StencilFormat
newFrameBufferDepth :: Depth -> FrameBuffer () DepthFormat ()
newFrameBufferDepthStencil :: Depth -> Stencil -> FrameBuffer () DepthFormat StencilFormat
newFrameBufferStencil :: Stencil -> FrameBuffer () () StencilFormat
ioEvaluateColor z e x = let (a:.b:.c:.d:.()) = fromColor z e x
in do a' <- ioEvaluate a
b' <- ioEvaluate b
c' <- ioEvaluate c
d' <- ioEvaluate d
return (a':.b':.c':.d':.())
setDefaultStates :: IO ()
setDefaultStates = do frontFace $= CCW
depthRange $= (0,1)
newFrameBufferColor c = FrameBuffer $ do
c' <- ioEvaluateColor 0 1 c
setContextWindow
liftIO $ do setDefaultStates
setNewColor c'
clear [GL.ColorBuffer]
newFrameBufferColorDepth c d = FrameBuffer $ do
c' <- ioEvaluateColor 0 1 c
d' <- ioEvaluate d
setContextWindow
liftIO $ do setDefaultStates
setNewColor c'
setNewDepth d'
clear [GL.ColorBuffer, GL.DepthBuffer]
newFrameBufferColorDepthStencil c d s = FrameBuffer $ do
c' <- ioEvaluateColor 0 1 c
d' <- ioEvaluate d
s' <- ioEvaluate s
setContextWindow
liftIO $ do setDefaultStates
setNewColor c'
setNewDepth d'
setNewStencil s'
clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
newFrameBufferColorStencil c s = FrameBuffer $ do
c' <- ioEvaluateColor 0 1 c
s' <- ioEvaluate s
setContextWindow
liftIO $ do setDefaultStates
setNewColor c'
setNewStencil s'
clear [GL.ColorBuffer, GL.StencilBuffer]
newFrameBufferDepth d = FrameBuffer $ do
d' <- ioEvaluate d
setContextWindow
liftIO $ do setDefaultStates
setNewDepth d'
clear [GL.DepthBuffer]
newFrameBufferDepthStencil d s = FrameBuffer $ do
d' <- ioEvaluate d
s' <- ioEvaluate s
setContextWindow
liftIO $ do setDefaultStates
setNewDepth d'
setNewStencil s'
clear [GL.DepthBuffer, GL.StencilBuffer]
newFrameBufferStencil s = FrameBuffer $ do
s' <- ioEvaluate s
setContextWindow
liftIO $ do setDefaultStates
setNewStencil s'
clear [GL.StencilBuffer]
setNewColor (x:.y:.z:.w:.()) = clearColor $= Color4 (realToFrac x) (realToFrac y) (realToFrac z) (realToFrac w)
setNewDepth d = clearDepth $= realToFrac d
setNewStencil s = clearStencil $= fromIntegral s
------------------------------------------------------------------
paintColor :: ColorFormat c => Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c d s -> FrameBuffer c d s
paintDepth :: DepthFunction -> DepthMask -> FragmentStream FragmentDepth -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s
paintColorDepth :: ColorFormat c => DepthFunction -> DepthMask -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float), FragmentDepth) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s
paintStencil :: StencilTests -> StencilOps -> StencilOps -> FragmentStream (Fragment a) -> FrameBuffer c d StencilFormat -> FrameBuffer c d StencilFormat
paintDepthStencil :: StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> FragmentStream FragmentDepth -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat
paintColorStencil :: ColorFormat c => StencilTests -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c d StencilFormat -> FrameBuffer c d StencilFormat
paintColorDepthStencil :: ColorFormat c => StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float), FragmentDepth) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat
paintRastDepth :: DepthFunction -> DepthMask -> FragmentStream (Fragment a) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s
paintColorRastDepth :: ColorFormat c => DepthFunction -> DepthMask -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c DepthFormat s -> FrameBuffer c DepthFormat s
paintRastDepthStencil :: StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> FragmentStream (Fragment a) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat
paintColorRastDepthStencil :: ColorFormat c => StencilTests -> StencilOps -> DepthFunction -> DepthMask -> StencilOps -> StencilOps -> Blending -> ColorMask c -> FragmentStream (Color c (Fragment Float)) -> FrameBuffer c DepthFormat StencilFormat -> FrameBuffer c DepthFormat StencilFormat
------------------------------------------------------------------
paintColor _ _ (FragmentStream []) fb = fb
paintColor b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
io
liftIO $ do
loadBlending b'
loadColorMask c'
depthFunc $= Nothing
stencilTest $= Disabled
paintDepth _ _ (FragmentStream []) fb = fb
paintDepth f d s (FrameBuffer io) = FrameBuffer $ loadFragmentDepthStream s $ do
f'<-ioEvaluate f
d'<-ioEvaluate d
io
liftIO $ do
depthFunc $= Just f'
depthMask $= toCapability d'
loadColorMask (vec False)
stencilTest $= Disabled
paintColorDepth _ _ _ _ (FragmentStream []) fb = fb
paintColorDepth f d b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorDepthStream s $ do
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
f'<-ioEvaluate f
d'<-ioEvaluate d
io
liftIO $ do
loadBlending b'
loadColorMask c'
depthFunc $= Just f'
depthMask $= toCapability d'
stencilTest $= Disabled
paintStencil _ _ _ (FragmentStream []) fb = fb
paintStencil t sf p s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
p'<-ioEvaluate p
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' sf' p'
depthFunc $= Nothing
loadColorMask (vec False)
paintDepthStencil _ _ _ _ _ _ (FragmentStream []) fb = fb
paintDepthStencil t sf f d df p s (FrameBuffer io) = FrameBuffer $ loadFragmentDepthStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
f'<-ioEvaluate f
d'<-ioEvaluate d
df'<-ioEvaluate df
p'<-ioEvaluate p
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' df' p'
depthFunc $= Just f'
depthMask $= toCapability d'
loadColorMask (vec False)
paintColorStencil _ _ _ _ _ (FragmentStream []) fb = fb
paintColorStencil t sf p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
p'<-ioEvaluate p
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' sf' p'
depthFunc $= Nothing
loadBlending b'
loadColorMask c'
paintColorDepthStencil _ _ _ _ _ _ _ _ (FragmentStream []) fb = fb
paintColorDepthStencil t sf f d df p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorDepthStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
f'<-ioEvaluate f
d'<-ioEvaluate d
df'<-ioEvaluate df
p'<-ioEvaluate p
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' df' p'
depthFunc $= Just f'
depthMask $= toCapability d'
loadBlending b'
loadColorMask c'
paintRastDepth _ _ (FragmentStream []) fb = fb
paintRastDepth f d s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do
f'<-ioEvaluate f
d'<-ioEvaluate d
io
liftIO $ do
depthFunc $= Just f'
depthMask $= toCapability d'
loadColorMask (vec False)
stencilTest $= Disabled
paintColorRastDepth _ _ _ _ (FragmentStream []) fb = fb
paintColorRastDepth f d b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do
f'<-ioEvaluate f
d'<-ioEvaluate d
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
io
liftIO $ do
loadBlending b'
loadColorMask c'
depthFunc $= Just f'
depthMask $= toCapability d'
stencilTest $= Disabled
paintRastDepthStencil _ _ _ _ _ _ (FragmentStream []) fb = fb
paintRastDepthStencil t sf f d df p s (FrameBuffer io) = FrameBuffer $ loadFragmentAnyStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
f'<-ioEvaluate f
d'<-ioEvaluate d
df'<-ioEvaluate df
p'<-ioEvaluate p
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' df' p'
depthFunc $= Just f'
depthMask $= toCapability d'
loadColorMask (vec False)
paintColorRastDepthStencil _ _ _ _ _ _ _ _ (FragmentStream []) fb = fb
paintColorRastDepthStencil t sf f d df p b c s (FrameBuffer io) = FrameBuffer $ loadFragmentColorStream s $ do
t'<-ioEvaluate t
sf'<-ioEvaluate sf
f'<-ioEvaluate f
d'<-ioEvaluate d
df'<-ioEvaluate df
p'<-ioEvaluate p
b'<-ioEvaluate b
c'<-ioEvaluateColor False False c
io
liftIO $ do
loadStencilTests t'
loadStencilOps sf' df' p'
depthFunc $= Just f'
depthMask $= toCapability d'
loadBlending b'
loadColorMask c'
--------------------------------------
-- | Returns the byte size needed to store a certain format and size of a framebuffer. Use this to
-- allocate memory before using 'getFrameBufferColor', 'getFrameBufferDepth' or 'getFrameBufferStencil'.
getFrameBufferCPUFormatByteSize :: StorableCPUFormat f
=> f -- ^ The format to store data to
-> Vec2 Int -- ^ The size to give the frame buffer
-> Int -- ^ The size in bytes of the data
getFrameBufferCPUFormatByteSize f (w:.h:.()) = h*formatRowByteSize f w
-- | Saves a 'FrameBuffer's color buffer to main memory.
getFrameBufferColor :: forall c d s a. GPUFormat c
=> CPUFormat c -- ^ The format to store data to
-> Vec2 Int -- ^ The size to give the frame buffer
-> FrameBuffer c d s -- ^ A frame buffer with a color buffer
-> Ptr a -- ^ A pointer to the memory where the data will be saved
-> IO ()
getFrameBufferColor f s@(w:.h:.()) fb p = do
cache <- getCurrentOrSetHiddenContext
runFrameBufferInContext cache s fb
readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData (toGLPixelFormat (undefined :: c)) (toGLDataType f) p)
-- | Saves a 'FrameBuffer's depth buffer to main memory.
getFrameBufferDepth :: CPUFormat DepthFormat -- ^ The format to store data to
-> Vec2 Int -- ^ The size to give the frame buffer
-> FrameBuffer c DepthFormat s -- ^ A frame buffer with a depth buffer
-> Ptr a -- ^ A pointer to the memory where the data will be saved
-> IO ()
getFrameBufferDepth f s@(w:.h:.()) fb p = do
cache <- getCurrentOrSetHiddenContext
runFrameBufferInContext cache s fb
readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData DepthComponent (toGLDataType f) p)
-- | Saves a 'FrameBuffer's stencil buffer to main memory.
getFrameBufferStencil :: CPUFormat StencilFormat -- ^ The format to store data to
-> Vec2 Int -- ^ The size to give the frame buffer
-> FrameBuffer c d StencilFormat -- ^ A frame buffer with a stencil buffer
-> Ptr a -- ^ A pointer to the memory where the data will be saved
-> IO ()
getFrameBufferStencil f s@(w:.h:.()) fb p = do
cache <- getCurrentOrSetHiddenContext
runFrameBufferInContext cache s fb
readPixels (Position 0 0) (Size (fromIntegral w) (fromIntegral h)) (PixelData StencilIndex (toGLDataType f) p)
-- | Cretes and shows a new GPipe window. Use the last parameter to add extra GLUT callbacks to the window. Note that you can't register your own 'displayCallback' and 'reshapeCallback'.
newWindow :: String -- ^ The window title
-> Vec2 Int -- ^ The window position
-> Vec2 Int -- ^ The window size
-> (IO (FrameBuffer c d s)) -- ^ This 'IO' action will be run every time the window needs to be redrawn, and the resulting 'FrameBuffer' will be drawn in the window.
-> (Window -> IO ()) -- ^ Extra optional initialization of the window. The provided 'Window' should not be used outside this function.
-> IO ()
newWindow name (x:.y:.()) (w:.h:.()) f xio =
do GLUT.initialWindowPosition $= Position (fromIntegral x) (fromIntegral y)
GLUT.initialWindowSize $= Size (fromIntegral w) (fromIntegral h)
GLUT.initialDisplayMode $= [ GLUT.DoubleBuffered, GLUT.RGBMode, GLUT.WithAlphaComponent, GLUT.WithDepthBuffer, GLUT.WithStencilBuffer] --Enable everything, it might be needed for textures
w <- GLUT.createWindow name
xio w
newContextCache w
displayCallback $= do FrameBuffer io <- f
cache <- liftM fromJust $ getContextCache w --We need to do this to get the correct size
runReaderT io cache
GLUT.swapBuffers
reshapeCallback $= Just (changeContextSize w)
runFrameBufferInContext :: ContextCache -> Vec2 Int -> FrameBuffer c d s -> IO ()
runFrameBufferInContext c (a:.b:.()) (FrameBuffer io) = do
a' <- evaluate a
b' <- evaluate b
runReaderT io $ c {contextViewPort = Size (fromIntegral a') (fromIntegral b')}
finish
--------------------------------------
-- Private
--
toCapability True = Enabled
toCapability False = Disabled
loadColorMask (r:.g:.b:.a:.()) = colorMask $= Color4 (toCapability r) (toCapability g) (toCapability b) (toCapability a)
loadBlending NoBlending = do blend $= Disabled
logicOp $= Nothing
loadBlending (Blend e f (RGBA (r:.g:.b:.()) a)) = do
blend $= Enabled
logicOp $= Nothing
blendColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
blendEquationSeparate $= e
blendFuncSeparate $= f
loadBlending (BlendLogicOp op) = logicOp $= Just op
loadStencilTests (StencilTests f b) = do stencilTest $= Enabled
stencilFuncSeparate Front $= (stencilComparision f, fromIntegral $ stencilReference f, fromIntegral $ stencilMask f)
stencilFuncSeparate Back $= (stencilComparision b, fromIntegral $ stencilReference b, fromIntegral $ stencilMask b)
loadStencilOps sf df p = do stencilOpSeparate Front $= (frontStencilOp sf, frontStencilOp df, frontStencilOp p)
stencilOpSeparate Back $= (backStencilOp sf, backStencilOp df, backStencilOp p)