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
type ColorMask f = Color f Bool
type DepthMask = Bool
type DepthFunction = ComparisonFunction
data Blending = NoBlending
| Blend (BlendEquation, BlendEquation)
((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))
(Color RGBAFormat Float)
| BlendLogicOp LogicOp
deriving (Eq,Ord,Show)
data StencilOps = StencilOps {
frontStencilOp :: StencilOp,
backStencilOp :: StencilOp
} deriving (Eq,Ord,Show)
data StencilTests = StencilTests StencilTest StencilTest deriving (Eq,Ord,Show)
data StencilTest = StencilTest {
stencilComparision :: ComparisonFunction,
stencilReference :: Int32,
stencilMask :: Word32
} deriving (Eq,Ord,Show)
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'
getFrameBufferCPUFormatByteSize :: StorableCPUFormat f
=> f
-> Vec2 Int
-> Int
getFrameBufferCPUFormatByteSize f (w:.h:.()) = h*formatRowByteSize f w
getFrameBufferColor :: forall c d s a. GPUFormat c
=> CPUFormat c
-> Vec2 Int
-> FrameBuffer c d s
-> Ptr a
-> 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)
getFrameBufferDepth :: CPUFormat DepthFormat
-> Vec2 Int
-> FrameBuffer c DepthFormat s
-> Ptr a
-> 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)
getFrameBufferStencil :: CPUFormat StencilFormat
-> Vec2 Int
-> FrameBuffer c d StencilFormat
-> Ptr a
-> 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)
newWindow :: String
-> Vec2 Int
-> Vec2 Int
-> (Vec2 Int -> IO (FrameBuffer c d s))
-> (Window -> IO ())
-> 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]
w <- GLUT.createWindow name
xio w
newContextCache w
displayCallback $= do cache <- liftM fromJust $ getContextCache w
let Size x y = contextViewPort cache
FrameBuffer io <- f (fromIntegral x :. fromIntegral y :. ())
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
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)