ombra 0.2.1.0 → 0.2.2.0
raw patch · 13 files changed
+485/−348 lines, 13 files
Files
- Graphics/Rendering/Ombra/Blend.hs +10/−64
- Graphics/Rendering/Ombra/Blend/Internal.hs +66/−0
- Graphics/Rendering/Ombra/D2.hs +1/−1
- Graphics/Rendering/Ombra/D3.hs +1/−1
- Graphics/Rendering/Ombra/Draw/Internal.hs +54/−36
- Graphics/Rendering/Ombra/Internal/Resource.hs +5/−1
- Graphics/Rendering/Ombra/Layer.hs +63/−156
- Graphics/Rendering/Ombra/Layer/Internal.hs +199/−17
- Graphics/Rendering/Ombra/Shader.hs +1/−2
- Graphics/Rendering/Ombra/Stencil.hs +9/−67
- Graphics/Rendering/Ombra/Stencil/Internal.hs +68/−0
- Graphics/Rendering/Ombra/Texture.hs +6/−1
- ombra.cabal +2/−2
Graphics/Rendering/Ombra/Blend.hs view
@@ -1,66 +1,12 @@-module Graphics.Rendering.Ombra.Blend where--import Data.Vect.Float (Vec4(..))-import Data.Vect.Float.Instances ()-import Graphics.Rendering.Ombra.Internal.GL---- | Blend mode-data Mode = Mode {- constantColor :: Maybe Vec4,- rgbOperator :: Operator,- rgbParameters :: Maybe (Parameter, Parameter),- alphaOperator :: Operator,- alphaParameters :: Maybe (Parameter, Parameter)-} deriving Eq---- | Blend operator.-data Operator = Add | Subtract | ReverseSubtract {- Min | Max -} deriving Eq---- | Blend function parameters.-data Parameter = Zero | One | SourceColor | DestinationColor | ConstantColor- | SourceAlpha | DestinationAlpha | ConstantAlpha- | OneMinus Parameter deriving Eq---- | Standard transparency (default).-transparency :: Mode-transparency = Mode Nothing Add (Just (SourceAlpha, OneMinus SourceAlpha))- Add (Just (SourceAlpha, OneMinus SourceAlpha))---- | Additive blend mode.-additive :: Mode-additive = Mode Nothing Add (Just (One, One)) Add (Just (One, One))+module Graphics.Rendering.Ombra.Blend (+ -- * Types+ Mode(..),+ Operator(..),+ Parameter(..), -equation :: GLES => Mode -> (GLEnum, GLEnum)-equation m = (mode $ rgbOperator m, mode $ alphaOperator m)- where mode Add = gl_FUNC_ADD- mode Subtract = gl_FUNC_SUBTRACT- mode ReverseSubtract = gl_FUNC_REVERSE_SUBTRACT- -- mode Min = gl_MIN- -- mode Max = gl_MAX+ -- * Blending modes+ transparency,+ additive+) where -function :: GLES => Mode -> (GLEnum, GLEnum, GLEnum, GLEnum)-function m = (rgbs, rgbd, alphas, alphad)- where (rgbs, rgbd) = case rgbParameters m of- Just (p, p') -> (param p, param p')- Nothing -> (gl_ZERO, gl_ZERO)- (alphas, alphad) = case alphaParameters m of- Just (p, p') -> (param p, param p')- Nothing -> (gl_ZERO, gl_ZERO)- param Zero = gl_ZERO- param One = gl_ONE- param SourceColor = gl_SRC_COLOR- param DestinationColor = gl_DST_COLOR- param ConstantColor = gl_CONSTANT_COLOR- param SourceAlpha = gl_SRC_ALPHA- param DestinationAlpha = gl_DST_ALPHA- param ConstantAlpha = gl_CONSTANT_ALPHA- param (OneMinus Zero) = gl_ONE- param (OneMinus One) = gl_ZERO- param (OneMinus SourceColor) = gl_ONE_MINUS_SRC_COLOR- param (OneMinus DestinationColor) = gl_ONE_MINUS_DST_COLOR- param (OneMinus ConstantColor) = gl_ONE_MINUS_CONSTANT_COLOR- param (OneMinus SourceAlpha) = gl_ONE_MINUS_SRC_ALPHA- param (OneMinus DestinationAlpha) = gl_ONE_MINUS_DST_ALPHA- param (OneMinus ConstantAlpha) = gl_ONE_MINUS_CONSTANT_ALPHA- param (OneMinus _) =- error "Invalid blend function (nested OneMinus)"+import Graphics.Rendering.Ombra.Blend.Internal
+ Graphics/Rendering/Ombra/Blend/Internal.hs view
@@ -0,0 +1,66 @@+module Graphics.Rendering.Ombra.Blend.Internal where++import Data.Vect.Float (Vec4(..))+import Data.Vect.Float.Instances ()+import Graphics.Rendering.Ombra.Internal.GL++-- | Blend mode+data Mode = Mode {+ constantColor :: Maybe Vec4,+ rgbOperator :: Operator,+ rgbParameters :: Maybe (Parameter, Parameter),+ alphaOperator :: Operator,+ alphaParameters :: Maybe (Parameter, Parameter)+} deriving Eq++-- | Blend operator.+data Operator = Add | Subtract | ReverseSubtract {- Min | Max -} deriving Eq++-- | Blend function parameters.+data Parameter = Zero | One | SourceColor | DestinationColor | ConstantColor+ | SourceAlpha | DestinationAlpha | ConstantAlpha+ | OneMinus Parameter deriving Eq++-- | Standard transparency (default).+transparency :: Mode+transparency = Mode Nothing Add (Just (SourceAlpha, OneMinus SourceAlpha))+ Add (Just (SourceAlpha, OneMinus SourceAlpha))++-- | Additive blend mode.+additive :: Mode+additive = Mode Nothing Add (Just (One, One)) Add (Just (One, One))++equation :: GLES => Mode -> (GLEnum, GLEnum)+equation m = (mode $ rgbOperator m, mode $ alphaOperator m)+ where mode Add = gl_FUNC_ADD+ mode Subtract = gl_FUNC_SUBTRACT+ mode ReverseSubtract = gl_FUNC_REVERSE_SUBTRACT+ -- mode Min = gl_MIN+ -- mode Max = gl_MAX++function :: GLES => Mode -> (GLEnum, GLEnum, GLEnum, GLEnum)+function m = (rgbs, rgbd, alphas, alphad)+ where (rgbs, rgbd) = case rgbParameters m of+ Just (p, p') -> (param p, param p')+ Nothing -> (gl_ZERO, gl_ZERO)+ (alphas, alphad) = case alphaParameters m of+ Just (p, p') -> (param p, param p')+ Nothing -> (gl_ZERO, gl_ZERO)+ param Zero = gl_ZERO+ param One = gl_ONE+ param SourceColor = gl_SRC_COLOR+ param DestinationColor = gl_DST_COLOR+ param ConstantColor = gl_CONSTANT_COLOR+ param SourceAlpha = gl_SRC_ALPHA+ param DestinationAlpha = gl_DST_ALPHA+ param ConstantAlpha = gl_CONSTANT_ALPHA+ param (OneMinus Zero) = gl_ONE+ param (OneMinus One) = gl_ZERO+ param (OneMinus SourceColor) = gl_ONE_MINUS_SRC_COLOR+ param (OneMinus DestinationColor) = gl_ONE_MINUS_DST_COLOR+ param (OneMinus ConstantColor) = gl_ONE_MINUS_CONSTANT_COLOR+ param (OneMinus SourceAlpha) = gl_ONE_MINUS_SRC_ALPHA+ param (OneMinus DestinationAlpha) = gl_ONE_MINUS_DST_ALPHA+ param (OneMinus ConstantAlpha) = gl_ONE_MINUS_CONSTANT_ALPHA+ param (OneMinus _) =+ error "Invalid blend function (nested OneMinus)"
Graphics/Rendering/Ombra/D2.hs view
@@ -102,7 +102,7 @@ :~> mconcat os -- | A 'Layer' with the standard 2D program.-layerS :: IsObject2D gs is => Object gs is -> Layer+layerS :: IsObject2D gs is => Object gs is -> Layer' s t () layerS = layer defaultProgram2D -- | Translate a 2D 'Object'.
Graphics/Rendering/Ombra/D3.hs view
@@ -113,7 +113,7 @@ where tupleToVec (w, h) = Vec2 (fromIntegral w) (fromIntegral h) -- | A 'Layer' with the standard 3D program.-layerS :: IsObject3D gs is => Object gs is -> Layer+layerS :: IsObject3D gs is => Object gs is -> Layer' s t () layerS = layer defaultProgram3D -- | Translate a 3D Object.
Graphics/Rendering/Ombra/Draw/Internal.hs view
@@ -23,15 +23,13 @@ execDraw, evalDraw, gl,- renderLayer,- layerToTexture, drawGet ) where -import qualified Graphics.Rendering.Ombra.Blend as Blend+import qualified Graphics.Rendering.Ombra.Blend.Internal as Blend import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Geometry.Internal-import Graphics.Rendering.Ombra.Layer.Internal+import Graphics.Rendering.Ombra.Layer.Internal hiding (clear) import Graphics.Rendering.Ombra.Object.Internal import Graphics.Rendering.Ombra.Texture.Internal import Graphics.Rendering.Ombra.Backend (GLES)@@ -45,7 +43,7 @@ import Graphics.Rendering.Ombra.Shader.GLSL import Graphics.Rendering.Ombra.Shader.Program import Graphics.Rendering.Ombra.Shader.ShaderVar-import qualified Graphics.Rendering.Ombra.Stencil as Stencil+import qualified Graphics.Rendering.Ombra.Stencil.Internal as Stencil import Data.Hashable (Hashable) import Data.Vect.Float@@ -193,15 +191,49 @@ removeProgram = removeDrawResource gl programs -- | Draw a 'Layer'.-drawLayer :: GLES => Layer -> Draw ()-drawLayer (Layer prg grp) = setProgram prg >> drawObject grp-drawLayer (SubLayer rl) =- do (layer, textures) <- renderLayer rl- drawLayer layer- mapM_ removeTexture textures-drawLayer (OverLayer top behind) = drawLayer behind >> drawLayer top-drawLayer (ClearLayer bufs l) = clearBuffers bufs >> drawLayer l+drawLayer :: GLES => Layer' Drawable t a -> Draw a+drawLayer = fmap fst . flip drawLayer' [] +drawLayer' :: GLES+ => Layer' s t a+ -> [TTexture t]+ -> Draw (a, [TTexture t])+drawLayer' (Layer prg grp) ts = do setProgram prg+ drawObject grp+ return ((), ts)+drawLayer' (TextureLayer drawBufs stypes (w, h) (rx, ry, rw, rh)+ inspCol inspDepth layer) tts0 =+ do (x, tts1, ts, mcol, mdepth) <-+ layerToTexture drawBufs stypes w h layer+ (mayInspect inspCol) (mayInspect inspDepth) tts0+ let tts2 = map (TTexture . LoadedTexture gw gh) ts+ return ((x, tts2, mcol, mdepth), tts1 ++ tts2)+ where (gw, gh) = (fromIntegral w, fromIntegral h)+ + mayInspect :: Bool+ -> Either (Maybe [r])+ ([r] -> Draw (Maybe [r]), Int, Int, Int, Int)+ mayInspect True = Right (return . Just, rx, ry, rw, rh)+ mayInspect False = Left Nothing+drawLayer' (Permanent tt@(TTexture lt)) tts = + do let t = TextureLoaded lt+ gl $ unloader t (Nothing :: Maybe TextureImage) lt+ return (t, filter (/= tt) tts)+drawLayer' (WithTTextures ets f) tts =+ do drawLayer . f $ map (\(TTexture lt) -> TextureLoaded lt) ets+ return ((), tts)+drawLayer' (Free layer) tts =+ do (x, tts') <- drawLayer' layer []+ mapM_ (\(TTexture lt) -> removeTexture $ TextureLoaded lt) tts'+ return (x, tts)+drawLayer' (Clear bufs) tts = clearBuffers bufs >> return ((), tts)+drawLayer' (Cast layer) tts =+ do (x, tts') <- drawLayer' layer $ map castTTexture tts+ return (x, map castTTexture tts')+drawLayer' (Bind lx f) tts0 = drawLayer' lx tts0 >>=+ \(x, tts1) -> drawLayer' (f x) tts1+drawLayer' (Return x) tts = return (x, tts)+ -- | Draw an 'Object'. drawObject :: GLES => Object gs is -> Draw () drawObject (g :~> o) = withGlobal g $ drawObject o@@ -305,28 +337,13 @@ getProgram :: GLES => Program gs is -> Draw (Either String LoadedProgram) getProgram = getDrawResource gl programs --- | Realize a 'RenderLayer'. It returns the list of allocated 'Texture's so--- that you can free them if you want.-renderLayer :: GLES => RenderLayer a -> Draw (a, [Texture])-renderLayer (RenderLayer drawBufs stypes w h rx ry rw rh- inspCol inspDepth layer f) =- do (ts, mcol, mdepth) <- layerToTexture drawBufs stypes w h layer- (mayInspect inspCol)- (mayInspect inspDepth)- return (f ts mcol mdepth, ts)- where mayInspect :: Bool- -> Either (Maybe [r])- ([r] -> Draw (Maybe [r]), Int, Int, Int, Int)- mayInspect True = Right (return . Just, rx, ry, rw, rh)- mayInspect False = Left Nothing- -- | Draw a 'Layer' on some textures. layerToTexture :: (GLES, Integral a) => Bool -- ^ Draw buffers -> [LayerType] -- ^ Textures contents -> a -- ^ Width -> a -- ^ Height- -> Layer -- ^ Layer to draw+ -> Layer' s t x -- ^ Layer to draw -> Either b ( [Color] -> Draw b , Int, Int, Int, Int) -- ^ Color inspecting -- function, start x,@@ -335,16 +352,17 @@ -> Either c ( [Word8] -> Draw c , Int, Int, Int, Int) -- ^ Depth inspecting, -- function, etc.- -> Draw ([Texture], b ,c)-layerToTexture drawBufs stypes wp hp layer einspc einspd = do- (ts, (colRes, depthRes)) <- renderToTexture drawBufs (map arguments- stypes) w h $- do drawLayer layer+ -> [TTexture t]+ -> Draw (x, [TTexture t], [GL.Texture], b ,c)+layerToTexture drawBufs stypes wp hp layer einspc einspd tts = do+ (ts, (x, tts', colRes, depthRes)) <-+ renderToTexture drawBufs (map arguments stypes) w h $+ do (x, tts') <- drawLayer' layer tts colRes <- inspect einspc gl_RGBA wordsToColors 4 depthRes <- inspect einspd gl_DEPTH_COMPONENT id 1- return (colRes, depthRes)+ return (x, tts', colRes, depthRes) - return (map (TextureLoaded . LoadedTexture w h) ts, colRes, depthRes)+ return (x, tts', ts, colRes, depthRes) where (w, h) = (fromIntegral wp, fromIntegral hp) arguments stype =
Graphics/Rendering/Ombra/Internal/Resource.hs view
@@ -9,7 +9,8 @@ newResMap, addResource, getResource,- removeResource+ removeResource,+ unloader ) where import Control.Monad.IO.Class@@ -88,3 +89,6 @@ Loaded r -> unloadResource mi r _ -> return () liftIO $ H.delete map i++unloader :: (Resource i r m, EmbedIO m) => k -> Maybe i -> r -> m ()+unloader k i r = embedIO (addFinalizer k) $ unloadResource i r
Graphics/Rendering/Ombra/Layer.hs view
@@ -21,6 +21,26 @@ buffersSubLayer, buffersDepthSubLayer, buffersStencilSubLayer,+ -- * Layers with return values+ -- $extlayers+ Layer',+ LayerStatus(..),+ drawable,+ castLayer,+ -- ** Temporary textures+ TTexture,+ withTTexture,+ permanent,+ -- ** Drawing to textures+ depthToTexture,+ colorDepthToTexture,+ colorStencilToTexture,+ colorToTexture',+ depthToTexture',+ colorDepthToTexture',+ colorStencilToTexture',+ buffersDepthToTexture,+ buffersStencilToTexture ) where import Data.Word (Word8)@@ -34,7 +54,7 @@ -- | Create a simple Layer from a Program and an Object. layer :: (Subset progAttr grpAttr, Subset progUni grpUni)- => Program progUni progAttr -> Object grpUni grpAttr -> Layer+ => Program progUni progAttr -> Object grpUni grpAttr -> Layer' s t () layer = Layer infixl 1 `over`@@ -42,16 +62,7 @@ -- will use the same buffers (color, depth, stencil) of the second, but -- the visibility of the objects still depends on their depth. over :: Layer -> Layer -> Layer-over = OverLayer---- TODO: document buffers.--- | Clear some buffers before drawing a Layer.-clear :: [Buffer] -> Layer -> Layer-clear = ClearLayer---- | Generate a 1x1 texture.-colorTex :: GLES => Color -> Texture-colorTex c = mkTexture 1 1 [ c ]+over = flip (>>) -- | Alias for 'colorSubLayer'. subLayer :: Int -> Int -> Layer -> (Texture -> Layer) -> Layer@@ -63,7 +74,7 @@ -> Layer -- ^ Layer to draw on a 'Texture'. -> (Texture -> Layer) -- ^ Layers using the texture. -> Layer-colorSubLayer w h l = subRenderLayer . renderColor w h l+colorSubLayer w h l = colorDepthSubLayer w h l . flip . const -- | Use a 'Layer' as a depth 'Texture' on another. depthSubLayer :: Int -- ^ Texture width.@@ -72,7 +83,8 @@ -- depth 'Texture'. -> (Texture -> Layer) -- ^ Layers using the texture. -> Layer-depthSubLayer w h l = subRenderLayer . renderDepth w h l+depthSubLayer w h l f = drawable $+ depthToTexture w h (castLayer l) >>= \(_, t) -> withTTexture t f -- | Combination of 'colorSubLayer' and 'depthSubLayer'. colorDepthSubLayer :: Int -- ^ Texture width.@@ -81,7 +93,10 @@ -- 'Texture's. -> (Texture -> Texture -> Layer) -- ^ Color, depth. -> Layer-colorDepthSubLayer w h l = subRenderLayer . renderColorDepth w h l+colorDepthSubLayer w h l f = drawable $+ colorDepthToTexture w h (castLayer l) >>=+ \(_, ct, dt) -> withTTextures [ct, dt] $+ \[ct', dt'] -> f ct' dt' -- | 'colorSubLayer' with a stencil buffer. colorStencilSubLayer :: Int -- ^ Texture width.@@ -89,68 +104,74 @@ -> Layer -- ^ Layer to draw on a 'Texture' -> (Texture -> Layer) -- ^ Color. -> Layer-colorStencilSubLayer w h l = subRenderLayer . renderColorStencil w h l+colorStencilSubLayer w h l f = drawable $+ colorStencilToTexture w h (castLayer l) >>= \(_, t) -> withTTexture t f -- | Extended version of 'colorSubLayer' that reads and converts the Texture -- pixels. colorSubLayer' :: Int -- ^ Texture width. -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a 'Texture'. -> Int -- ^ First pixel to read X -> Int -- ^ First pixel to read Y -> Int -- ^ Width of the rectangle to read -> Int -- ^ Height of the rectangle to read+ -> Layer -- ^ Layer to draw on a 'Texture'. -> (Texture -> [Color] -> Layer) -- ^ Function using the texture. -> Layer-colorSubLayer' w h l rx ry rw rh =- subRenderLayer . renderColorInspect w h l rx ry rw rh+colorSubLayer' w h rx ry rw rh l f = drawable $+ colorToTexture' w h rx ry rw rh (castLayer l) >>=+ \(_, t, c) -> withTTexture t $ flip f c -- | Extended version of 'depthSubLayer'. Not supported on WebGL. depthSubLayer' :: Int -- ^ Texture width. -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a depth 'Texture'. -> Int -- ^ First pixel to read X -> Int -- ^ First pixel to read Y -> Int -- ^ Width of the rectangle to read -> Int -- ^ Height of the rectangle to read+ -> Layer -- ^ Layer to draw on a depth 'Texture'. -> (Texture -> [Word8] -> Layer) -- ^ Layers using the texture. -> Layer-depthSubLayer' w h l rx ry rw rh =- subRenderLayer . renderDepthInspect w h l rx ry rw rh+depthSubLayer' w h rx ry rw rh l f = drawable $+ depthToTexture' w h rx ry rw rh (castLayer l) >>=+ \(_, t, d) -> withTTexture t $ flip f d -- | Extended version of 'colorDepthSubLayer'. Not supported on WebGL. colorDepthSubLayer' :: Int -- ^ Texture width. -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a 'Texture' -> Int -- ^ First pixel to read X -> Int -- ^ First pixel to read Y -> Int -- ^ Width of the rectangle to read -> Int -- ^ Height of the rectangle to read+ -> Layer -- ^ Layer to draw on a 'Texture' -> (Texture -> Texture -> [Color] -> [Word8] -> Layer) -- ^ Layers using -- the texture. -> Layer-colorDepthSubLayer' w h l rx ry rw rh =- subRenderLayer . renderColorDepthInspect w h l rx ry rw rh+colorDepthSubLayer' w h rx ry rw rh l f = drawable $+ colorDepthToTexture' w h rx ry rw rh (castLayer l) >>=+ \(_, ct, dt, c, d) -> withTTextures [ct, dt] $+ \[ct', dt'] -> f ct' dt' c d -- | 'colorSubLayer'' with an additional stencil buffer. colorStencilSubLayer' :: Int -- ^ Texture width. -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a 'Texture'. -> Int -- ^ First pixel to read X -> Int -- ^ First pixel to read Y -> Int -- ^ Width of the rectangle to read -> Int -- ^ Height of the rectangle to read+ -> Layer -- ^ Layer to draw on a 'Texture'. -> (Texture -> [Color] -> Layer) -- ^ Function using the texture. -> Layer-colorStencilSubLayer' w h l rx ry rw rh =- subRenderLayer . renderColorStencilInspect w h l rx ry rw rh+colorStencilSubLayer' w h rx ry rw rh l f = drawable $+ colorStencilToTexture' w h rx ry rw rh (castLayer l) >>=+ \(_, t, c) -> withTTexture t $ flip f c --- | Render a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) in some 'Texture's and use them to+-- | Draw a 'Layer' with multiple floating point colors+-- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's and use them to -- create another Layer. buffersSubLayer :: Int -- ^ Textures width. -> Int -- ^ Textures height.@@ -158,7 +179,7 @@ -> Layer -- ^ Layer to draw. -> ([Texture] -> Layer) -- ^ Function using the textures. -> Layer-buffersSubLayer w h n l = subRenderLayer . renderBuffers w h n l+buffersSubLayer w h n l = buffersDepthSubLayer w h n l . flip . const -- | Combination of 'buffersSubLayer' and 'depthSubLayer'. buffersDepthSubLayer :: Int -- ^ Textures width.@@ -169,7 +190,10 @@ -- buffers textures and -- the depth texture. -> Layer-buffersDepthSubLayer w h n l = subRenderLayer . renderBuffersDepth w h n l+buffersDepthSubLayer w h n l f = drawable $+ buffersDepthToTexture w h n (castLayer l) >>=+ \(_, bts, dt) -> withTTextures (dt : bts) $+ \(dt' : bts') -> f bts' dt' -- | 'buffersSubLayer' with an additional stencil buffer. buffersStencilSubLayer :: Int -- ^ Textures width.@@ -178,129 +202,12 @@ -> Layer -- ^ Layer to draw. -> ([Texture] -> Layer) -- ^ Function using the texture. -> Layer-buffersStencilSubLayer w h n l = subRenderLayer . renderBuffersStencil w h n l--subRenderLayer :: RenderLayer Layer -> Layer-subRenderLayer = SubLayer---- | Render a 'Layer' in a 'Texture'.-renderColor :: Int -> Int -> Layer -> (Texture -> a) -> RenderLayer a-renderColor w h l f = RenderLayer False [ColorLayer, DepthLayer] w h 0 0 0 0- False False l $ \[t, _] _ _ -> f t---- | Render a 'Layer' in a depth 'Texture'.-renderDepth :: Int -> Int -> Layer -> (Texture -> a) -> RenderLayer a-renderDepth w h l f =- RenderLayer False [DepthLayer] w h 0 0 0 0 False False l $- \[t] _ _ -> f t---- | Combination of 'renderColor' and 'renderDepth'.-renderColorDepth :: Int- -> Int- -> Layer- -> (Texture -> Texture -> a)- -> RenderLayer a-renderColorDepth w h l f =- RenderLayer False [ColorLayer, DepthLayer] w h 0 0 0 0 False False l $- \[ct, dt] _ _ -> f ct dt---- | 'renderColor' with an additional stencil buffer.-renderColorStencil :: Int- -> Int- -> Layer- -> (Texture -> a)- -> RenderLayer a-renderColorStencil w h l f =- RenderLayer False [ColorLayer, DepthStencilLayer] w h 0 0 0 0- False False l $- \[ct, _] _ _ -> f ct---- | Render a 'Layer' in a 'Texture', reading the content of the texture.-renderColorInspect :: Int- -> Int- -> Layer- -> Int- -> Int- -> Int- -> Int- -> (Texture -> [Color] -> a)- -> RenderLayer a-renderColorInspect w h l rx ry rw rh f =- RenderLayer False [ColorLayer, DepthLayer] w h rx ry- rw rh True False l $- \[t, _] (Just c) _ -> f t c---- | Render a 'Layer' in a depth 'Texture', reading the content of the texture.--- Not supported on WebGL.-renderDepthInspect :: Int- -> Int- -> Layer- -> Int- -> Int- -> Int- -> Int- -> (Texture -> [Word8] -> a)- -> RenderLayer a-renderDepthInspect w h l rx ry rw rh f =- RenderLayer False [DepthLayer] w h rx ry rw rh False True l $- \[t] _ (Just d) -> f t d---- | Combination of 'renderColorInspect' and 'renderDepthInspect'. Not supported--- on WebGL.-renderColorDepthInspect :: Int- -> Int- -> Layer- -> Int- -> Int- -> Int- -> Int- -> (Texture -> Texture -> [Color] -> [Word8] -> a)-- -> RenderLayer a-renderColorDepthInspect w h l rx ry rw rh f =- RenderLayer False [ColorLayer, DepthLayer] w h rx ry rw rh True True l $- \[ct, dt] (Just c) (Just d) -> f ct dt c d---- | 'renderColorInspect' with an additional stencil buffer.-renderColorStencilInspect :: Int- -> Int- -> Layer- -> Int- -> Int- -> Int- -> Int- -> (Texture -> [Color] -> a)- -> RenderLayer a-renderColorStencilInspect w h l rx ry rw rh f =- RenderLayer False [ColorLayer, DepthStencilLayer] w h rx ry- rw rh True False l $- \[t, _] (Just c) _ -> f t c---- | Render a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) in some 'Texture's.-renderBuffers :: Int -> Int -> Int -> Layer -> ([Texture] -> a) -> RenderLayer a-renderBuffers w h n l f =- RenderLayer True (DepthLayer : map BufferLayer [0 .. n - 1]) w h- 0 0 0 0 False False l $ \(_ : ts) _ _ -> f ts---- | Combination of 'renderBuffers' and 'renderDepth'.-renderBuffersDepth :: Int- -> Int- -> Int- -> Layer- -> ([Texture] -> Texture -> a)- -> RenderLayer a-renderBuffersDepth w h n l f =- RenderLayer True (DepthLayer : map BufferLayer [0 .. n - 1]) w h- 0 0 0 0 False False l $ \(dt : ts) _ _ -> f ts dt+buffersStencilSubLayer w h n l f = drawable $+ buffersStencilToTexture w h n (castLayer l) >>=+ \(_, bts) -> withTTextures bts f --- | 'renderBuffers' with an additional stencil buffer.-renderBuffersStencil :: Int- -> Int- -> Int- -> Layer- -> ([Texture] -> a)- -> RenderLayer a-renderBuffersStencil w h n l f =- RenderLayer True (DepthStencilLayer : map BufferLayer [0 .. n - 1]) w h- 0 0 0 0 False False l $ \(_ : ts) _ _ -> f ts+-- $extlayers+-- Functions like 'subLayer' create temporary textures that usually have to be+-- freed immediately after drawing the layer, otherwise they may waste a lot of+-- GPU memory if @subLayer@ is called in every frame. The 'Layer'' type lets+-- you extract those textures after having made permanent.
Graphics/Rendering/Ombra/Layer/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs, RankNTypes, DataKinds, KindSignatures #-} module Graphics.Rendering.Ombra.Layer.Internal where @@ -7,29 +7,211 @@ import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Object.Internal import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Texture+import Graphics.Rendering.Ombra.Texture.Internal -- | An 'Object' associated with a program.-data Layer = forall oi pi og pg. (Subset pi oi, Subset pg og)- => Layer (Program pg pi) (Object og oi)- | SubLayer (RenderLayer Layer)- | OverLayer Layer Layer- | ClearLayer [Buffer] Layer+type Layer = Layer' Drawable () () -data Buffer = ColorBuffer | DepthBuffer | StencilBuffer+-- | A layer with a return value. It may also be 'NonDrawable', this means that+-- there are some protected temporary resources and you have to call 'drawable'+-- to turn it into a normal layer. The second parameter prevents the 'TTexture's+-- from being returned by a @NonDrawable@ layer in a @drawable@ operation.+--+-- Note that layers are monads: @flip ('>>')@ is equivalent to 'over' for+-- Drawable layers, while ('>>='), in combination with the *ToTexture functions,+-- can be used to achieve the same effect of the subLayer functions.+data Layer' (s :: LayerStatus) t a where+ Layer :: (Subset pi oi, Subset pg og)+ => Program pg pi+ -> Object og oi+ -> Layer' s t ()+ TextureLayer :: Bool -- Use drawBuffers+ -> [LayerType] -- Attachments+ -> (Int, Int) -- Width, height+ -> (Int, Int, Int, Int) -- Inspect rectangle+ -> Bool -- Inspect color+ -> Bool -- Inspect depth+ -> Layer' s t a -- Layer to draw+ -> Layer' NonDrawable t+ (a, [TTexture t], Maybe [Color], Maybe [Word8])+ Permanent :: TTexture t -> Layer' NonDrawable t Texture+ WithTTextures :: [TTexture t]+ -> ([Texture] -> Layer)+ -> Layer' NonDrawable t ()+ Free :: (forall t. Layer' NonDrawable t a) -> Layer' s t a+ Clear :: [Buffer] -> Layer' s t ()+ Cast :: Layer' Drawable t a -> Layer' Drawable t' a+ Bind :: Layer' s t a -> (a -> Layer' s t b) -> Layer' s t b+ Return :: a -> Layer' s t a --- | Represents a 'Layer' drawn on a 'Texture'.-data RenderLayer a = RenderLayer Bool -- Use drawBuffers- [LayerType] -- Attachments- Int Int -- Width, height- Int Int Int Int -- Inspect rectangle- Bool Bool -- Inspect color, depth- Layer -- Layer to draw- ([Texture] -> Maybe [Color] ->- Maybe [Word8] -> a) -- Accepting function+-- | Temporary texture.+newtype TTexture t = TTexture LoadedTexture deriving Eq +data LayerStatus = Drawable | NonDrawable++data Buffer = ColorBuffer | DepthBuffer | StencilBuffer+ data LayerType = ColorLayer | DepthLayer | DepthStencilLayer | BufferLayer Int deriving Eq +instance Functor (Layer' s t) where+ fmap f = flip Bind $ Return . f++instance Applicative (Layer' s t) where+ lf <*> lx = Bind lf $ \f -> Bind lx $ \x -> Return $ f x+ pure = Return++instance Monad (Layer' s t) where+ (>>=) = Bind+ return = Return++-- TODO: document buffers.+-- | Clear some buffers before drawing a Layer.+clear :: [Buffer] -> Layer' s t a -> Layer' s t a+clear bs = (Clear bs >>)++-- | Free the temporary resources associated with a NonDrawable layer, before+-- drawing it.+drawable :: (forall t. Layer' NonDrawable t a) -> Layer' s t a+drawable = Free++castDrawable :: Layer' Drawable t a -> Layer' Drawable t' a+castDrawable = Cast++-- | Make the type of a simple 'Layer' more generic.+castLayer :: Layer -> Layer' Drawable t ()+castLayer = castDrawable++-- | Make a 'TTexture' permanent. Its lifetime is still bound to the 'Texture'+-- returned.+permanent :: TTexture t -> Layer' NonDrawable t Texture+permanent = Permanent++-- | Draw a Layer using a temporary texture.+withTTexture :: TTexture t -> (Texture -> Layer) -> Layer' NonDrawable t ()+withTTexture pt f = WithTTextures [pt] $ \[t] -> f t++-- | Draw a Layer using a list of temporary textures.+withTTextures :: [TTexture t] -> ([Texture] -> Layer) -> Layer' NonDrawable t ()+withTTextures = WithTTextures++castTTexture :: TTexture t -> TTexture t'+castTTexture (TTexture lt) = TTexture lt++-- | Draw a 'Layer' to a depth 'Texture'.+depthToTexture :: Int -- ^ Textures width.+ -> Int -- ^ Textures height.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, TTexture t)+depthToTexture w h l =+ fmap (\(x, [t], _, _) -> (x, t)) $+ TextureLayer False [DepthLayer] (w, h) (0, 0, 0, 0)+ False False l++-- | Draw a 'Layer' to a color 'Texture' and a depth 'Texture'.+colorDepthToTexture :: Int -- ^ Textures width.+ -> Int -- ^ Textures height.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, TTexture t, TTexture t)+colorDepthToTexture w h l =+ fmap (\(x, [ct, dt], _, _) -> (x, ct, dt)) $+ TextureLayer False [ColorLayer, DepthLayer] (w, h) (0, 0, 0, 0)+ False False l++-- | Draw a 'Layer' to a color 'Texture' with an additional stencil buffer.+colorStencilToTexture :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Layer' s t a+ -> Layer' NonDrawable t (a, TTexture t)+colorStencilToTexture w h l =+ fmap (\(x, [ct, _], _, _) -> (x, ct)) $+ TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)+ (0, 0, 0, 0) False False l++-- | Draw a 'Layer' to a 'Texture', reading the content of the texture.+colorToTexture' :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ First pixel to read X.+ -> Int -- ^ First pixel to read Y.+ -> Int -- ^ Width of the rectangle to read.+ -> Int -- ^ Height of the rectangle to read.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, TTexture t, [Color])+colorToTexture' w h rx ry rw rh l =+ fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $+ TextureLayer False [ColorLayer, DepthLayer] (w, h)+ (rx, ry, rw, rh) True False l++-- | Draw a 'Layer' to a depth 'Texture', reading the content of the texture.+-- Not supported on WebGL.+depthToTexture' :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ First pixel to read X.+ -> Int -- ^ First pixel to read Y.+ -> Int -- ^ Width of the rectangle to read.+ -> Int -- ^ Height of the rectangle to read.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, TTexture t, [Word8])+depthToTexture' w h rx ry rw rh l =+ fmap (\(x, [t], _, Just d) -> (x, t, d)) $+ TextureLayer False [DepthLayer] (w, h) (rx, ry, rw, rh)+ False True l++-- | Combination of 'colorToTexture'' and 'depthToTexture''. Not supported+-- on WebGL.+colorDepthToTexture' :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ First pixel to read X.+ -> Int -- ^ First pixel to read Y.+ -> Int -- ^ Width of the rectangle to read.+ -> Int -- ^ Height of the rectangle to read.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t+ (a, TTexture t, TTexture t, [Color], [Word8])+colorDepthToTexture' w h rx ry rw rh l =+ fmap (\(x, [ct, dt], Just c, Just d) -> (x, ct, dt, c, d)) $+ TextureLayer False [ColorLayer, DepthLayer] (w, h)+ (rx, ry, rw, rh) True True l++-- | 'colorToTexture'' with an additional stencil buffer.+colorStencilToTexture' :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ First pixel to read X.+ -> Int -- ^ First pixel to read Y.+ -> Int -- ^ Width of the rectangle to read.+ -> Int -- ^ Height of the rectangle to read.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, TTexture t, [Color])+colorStencilToTexture' w h rx ry rw rh l =+ fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $+ TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)+ (rx, ry, rw, rh) True False l++-- | Draw a 'Layer' with multiple floating point colors+-- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's and to a depth+-- Texture.+buffersDepthToTexture :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ Number of colors.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, [TTexture t], TTexture t)+buffersDepthToTexture w h n l =+ fmap (\(x, dt : ts, _, _) -> (x, ts, dt)) $+ TextureLayer True (DepthLayer : map BufferLayer [0 .. n - 1])+ (w, h) (0, 0, 0, 0) False False l++-- | Draw a 'Layer' with multiple floating point colors+-- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's with an additional+-- stencil buffer.+buffersStencilToTexture :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Int -- ^ Number of colors.+ -> Layer' s t a -- ^ Layer to draw.+ -> Layer' NonDrawable t (a, [TTexture t])+buffersStencilToTexture w h n l =+ fmap (\(x, _ : ts, _, _) -> (x, ts)) $+ TextureLayer True+ (DepthStencilLayer : map BufferLayer [0 .. n - 1])+ (w, h) (0, 0, 0, 0) False False l
Graphics/Rendering/Ombra/Shader.hs view
@@ -32,8 +32,7 @@ Required extensions: @-\{\-# LANGUAGE DataKinds, RebindableSyntax, DeriveDataTypeable,- GeneralizedNewtypeDeriving, GADTs #\-\}+\{\-# LANGUAGE DataKinds, RebindableSyntax, DeriveGeneric, GADTs #\-\} @ -}
Graphics/Rendering/Ombra/Stencil.hs view
@@ -1,68 +1,10 @@-module Graphics.Rendering.Ombra.Stencil where--import Graphics.Rendering.Ombra.Internal.GL---- | Stencil mode.-data Mode = Mode (Side Function) (Side Operation) deriving Eq--data Side a = FrontBack a -- ^ Use the same value for both sides.- | Separate a a -- ^ Use a different value for each side (front- -- and back).- deriving Eq---- | Function type, fragment stencil value and mask.-data Function = Function FunctionType Int Word deriving Eq---- | Operation to perform between the masked fragment stencil value and the--- masked destination stencil value.-data FunctionType = Never -- ^ Never pass.- | Always -- ^ Always pass.- | Less -- ^ <- | LessOrEqual -- ^ <=- | Greater -- ^ >- | GreaterOrEqual -- ^ >=- | Equal -- ^ ==- | NotEqual -- ^ /=- deriving Eq---- | Operations to perform if the stencil test fails, if the stencil test passes--- but the depth test fails, and if both the stencil test and the depth test--- pass.-data Operation = Operation OperationType OperationType OperationType deriving Eq---- | Operation to perform to the stencil value in the buffer.-data OperationType = Keep -- ^ Keep it unchanged.- | Invert -- ^ Invert it.- | Zero -- ^ Set it to zero.- | Replace -- ^ Replace it with the masked fragment value.- | Increment -- ^ Increment it if not maximum.- | Decrement -- ^ Decrement it if not zero.- | IncWrap -- ^ Increment it, wrapping it if it would- -- overflow.- | DecWrap -- ^ Decrement it, wrapping it if it would- -- underflow.- deriving Eq--function :: GLES => Function -> (GLEnum, GLInt, GLUInt)-function (Function ty value mask) = ( getType ty- , fromIntegral value- , fromIntegral mask )- where getType Never = gl_NEVER- getType Always = gl_ALWAYS- getType Less = gl_LESS- getType LessOrEqual = gl_LEQUAL- getType Greater = gl_GREATER- getType GreaterOrEqual = gl_GEQUAL- getType Equal = gl_EQUAL- getType NotEqual = gl_NOTEQUAL+module Graphics.Rendering.Ombra.Stencil (+ Mode(..),+ Side(..),+ Function(..),+ FunctionType(..),+ Operation(..),+ OperationType(..)+) where -operation :: GLES => Operation -> (GLEnum, GLEnum, GLEnum)-operation (Operation sf spdf spdp) = (getOp sf, getOp spdf, getOp spdp)- where getOp Keep = gl_KEEP- getOp Invert = gl_INVERT- getOp Zero = gl_ZERO- getOp Replace = gl_REPLACE- getOp Increment = gl_INCR- getOp Decrement = gl_DECR- getOp IncWrap = gl_INCR_WRAP- getOp DecWrap = gl_DECR_WRAP+import Graphics.Rendering.Ombra.Stencil.Internal
+ Graphics/Rendering/Ombra/Stencil/Internal.hs view
@@ -0,0 +1,68 @@+module Graphics.Rendering.Ombra.Stencil.Internal where++import Graphics.Rendering.Ombra.Internal.GL++-- | Stencil mode.+data Mode = Mode (Side Function) (Side Operation) deriving Eq++data Side a = FrontBack a -- ^ Use the same value for both sides.+ | Separate a a -- ^ Use a different value for each side (front+ -- and back).+ deriving Eq++-- | Function type, fragment stencil value and mask.+data Function = Function FunctionType Int Word deriving Eq++-- | Operation to perform between the masked fragment stencil value and the+-- masked destination stencil value.+data FunctionType = Never -- ^ Never pass.+ | Always -- ^ Always pass.+ | Less -- ^ <+ | LessOrEqual -- ^ <=+ | Greater -- ^ >+ | GreaterOrEqual -- ^ >=+ | Equal -- ^ ==+ | NotEqual -- ^ /=+ deriving Eq++-- | Operations to perform if the stencil test fails, if the stencil test passes+-- but the depth test fails, and if both the stencil test and the depth test+-- pass.+data Operation = Operation OperationType OperationType OperationType deriving Eq++-- | Operation to perform to the stencil value in the buffer.+data OperationType = Keep -- ^ Keep it unchanged.+ | Invert -- ^ Invert it.+ | Zero -- ^ Set it to zero.+ | Replace -- ^ Replace it with the masked fragment value.+ | Increment -- ^ Increment it if not maximum.+ | Decrement -- ^ Decrement it if not zero.+ | IncWrap -- ^ Increment it, wrapping it if it would+ -- overflow.+ | DecWrap -- ^ Decrement it, wrapping it if it would+ -- underflow.+ deriving Eq++function :: GLES => Function -> (GLEnum, GLInt, GLUInt)+function (Function ty value mask) = ( getType ty+ , fromIntegral value+ , fromIntegral mask )+ where getType Never = gl_NEVER+ getType Always = gl_ALWAYS+ getType Less = gl_LESS+ getType LessOrEqual = gl_LEQUAL+ getType Greater = gl_GREATER+ getType GreaterOrEqual = gl_GEQUAL+ getType Equal = gl_EQUAL+ getType NotEqual = gl_NOTEQUAL++operation :: GLES => Operation -> (GLEnum, GLEnum, GLEnum)+operation (Operation sf spdf spdp) = (getOp sf, getOp spdf, getOp spdp)+ where getOp Keep = gl_KEEP+ getOp Invert = gl_INVERT+ getOp Zero = gl_ZERO+ getOp Replace = gl_REPLACE+ getOp Increment = gl_INCR+ getOp Decrement = gl_DECR+ getOp IncWrap = gl_INCR_WRAP+ getOp DecWrap = gl_DECR_WRAP
Graphics/Rendering/Ombra/Texture.hs view
@@ -4,7 +4,8 @@ mkTextureFloat, mkTextureRaw, Filter(..),- setFilter+ setFilter,+ colorTex ) where import Data.Hashable@@ -58,3 +59,7 @@ setFilter min mag (TextureImage (TextureFloat c _ _ w h s)) = TextureImage (TextureFloat c min mag w h s) setFilter _ _ t = t++-- | Generate a 1x1 texture.+colorTex :: GLES => Color -> Texture+colorTex c = mkTexture 1 1 [ c ]
ombra.cabal view
@@ -1,5 +1,5 @@ name: ombra-version: 0.2.1.0+version: 0.2.2.0 synopsis: Render engine. description: Type-safe render engine, with a purely functional API and a shader EDSL. Ombra supports both OpenGL (2.0 with some extensions) and WebGL, through GHCJS. homepage: https://github.com/ziocroc/Ombra@@ -28,7 +28,7 @@ library exposed-modules: Graphics.Rendering.Ombra, Graphics.Rendering.Ombra.Blend, Graphics.Rendering.Ombra.Layer, Graphics.Rendering.Ombra.Object, Graphics.Rendering.Ombra.Texture, Graphics.Rendering.Ombra.Stencil, Graphics.Rendering.Ombra.Shader, Graphics.Rendering.Ombra.Transformation, Graphics.Rendering.Ombra.Draw, Graphics.Rendering.Ombra.D2, Graphics.Rendering.Ombra.Geometry, Graphics.Rendering.Ombra.D3, Graphics.Rendering.Ombra.Color, Graphics.Rendering.Ombra.Backend, Graphics.Rendering.Ombra.Shapes, Graphics.Rendering.Ombra.Internal.GL, Graphics.Rendering.Ombra.Shader.Default3D, Graphics.Rendering.Ombra.Shader.Default2D- other-modules: Graphics.Rendering.Ombra.Internal.Resource, Graphics.Rendering.Ombra.Internal.TList, Graphics.Rendering.Ombra.Shader.ShaderVar, Graphics.Rendering.Ombra.Shader.GLSL, Graphics.Rendering.Ombra.Shader.Stages, Graphics.Rendering.Ombra.Shader.Program, Graphics.Rendering.Ombra.Shader.CPU, Graphics.Rendering.Ombra.Shader.Language.Types, Graphics.Rendering.Ombra.Shader.Language.Functions, Graphics.Rendering.Ombra.Draw.Internal, Graphics.Rendering.Ombra.Layer.Internal, Graphics.Rendering.Ombra.Object.Internal, Graphics.Rendering.Ombra.Geometry.Internal, Graphics.Rendering.Ombra.Texture.Internal+ other-modules: Graphics.Rendering.Ombra.Internal.Resource, Graphics.Rendering.Ombra.Internal.TList, Graphics.Rendering.Ombra.Shader.ShaderVar, Graphics.Rendering.Ombra.Shader.GLSL, Graphics.Rendering.Ombra.Shader.Stages, Graphics.Rendering.Ombra.Shader.Program, Graphics.Rendering.Ombra.Shader.CPU, Graphics.Rendering.Ombra.Shader.Language.Types, Graphics.Rendering.Ombra.Shader.Language.Functions, Graphics.Rendering.Ombra.Draw.Internal, Graphics.Rendering.Ombra.Layer.Internal, Graphics.Rendering.Ombra.Object.Internal, Graphics.Rendering.Ombra.Geometry.Internal, Graphics.Rendering.Ombra.Texture.Internal, Graphics.Rendering.Ombra.Blend.Internal, Graphics.Rendering.Ombra.Stencil.Internal if flag(webgl) exposed-modules: Graphics.Rendering.Ombra.Backend.WebGL