ombra 0.1.1.0 → 0.2.0.0
raw patch · 19 files changed
+1167/−1210 lines, 19 filesdep −vector
Dependencies removed: vector
Files
- Graphics/Rendering/Ombra.hs +34/−0
- Graphics/Rendering/Ombra/Backend/WebGL.hs +33/−13
- Graphics/Rendering/Ombra/D2.hs +27/−36
- Graphics/Rendering/Ombra/D3.hs +18/−29
- Graphics/Rendering/Ombra/Draw.hs +3/−3
- Graphics/Rendering/Ombra/Draw/Internal.hs +80/−99
- Graphics/Rendering/Ombra/Generic.hs +0/−551
- Graphics/Rendering/Ombra/Geometry.hs +7/−233
- Graphics/Rendering/Ombra/Geometry/Internal.hs +246/−0
- Graphics/Rendering/Ombra/Internal/Resource.hs +6/−4
- Graphics/Rendering/Ombra/Layer.hs +306/−0
- Graphics/Rendering/Ombra/Layer/Internal.hs +35/−0
- Graphics/Rendering/Ombra/Object.hs +213/−0
- Graphics/Rendering/Ombra/Object/Internal.hs +54/−0
- Graphics/Rendering/Ombra/Shapes.hs +0/−1
- Graphics/Rendering/Ombra/Texture.hs +5/−57
- Graphics/Rendering/Ombra/Texture/Internal.hs +90/−0
- Graphics/Rendering/Ombra/Types.hs +0/−161
- ombra.cabal +10/−23
+ Graphics/Rendering/Ombra.hs view
@@ -0,0 +1,34 @@+{-|+This module re-exports all the modules used to build scenes with Ombra.++++You may also want to import:++"Graphics.Rendering.Ombra.D3": 3D graphics++"Graphics.Rendering.Ombra.D2": 2D graphics++"Graphics.Rendering.Ombra.Shader": to write shaders++"Graphics.Rendering.Ombra.Draw": to render the layers+-}+module Graphics.Rendering.Ombra (+ module Graphics.Rendering.Ombra.Color,+ module Graphics.Rendering.Ombra.Geometry,+ module Graphics.Rendering.Ombra.Layer,+ module Graphics.Rendering.Ombra.Object,+ module Graphics.Rendering.Ombra.Texture,+ module Data.Vect.Float,++ -- * Backend constraint+ GLES+) where++import Data.Vect.Float+import Graphics.Rendering.Ombra.Backend+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Geometry+import Graphics.Rendering.Ombra.Layer+import Graphics.Rendering.Ombra.Object+import Graphics.Rendering.Ombra.Texture
Graphics/Rendering/Ombra/Backend/WebGL.hs view
@@ -39,6 +39,28 @@ foreign import javascript unsafe "eval('null')" nullFloat32Array :: IO Float32Array +foreign import javascript unsafe "Float32Array.from([$1, $2, $3, $4])"+ encodeMat2JS :: Float -> Float -> Float -> Float -> IO Float32Array++foreign import javascript unsafe "Float32Array.from([$1, $2, $3, \+ \ $4, $5, $6, \+ \ $7, $8, $9])"+ encodeMat3JS :: Float -> Float -> Float+ -> Float -> Float -> Float+ -> Float -> Float -> Float+ -> IO Float32Array++foreign import javascript unsafe "Float32Array.from([$1, $2, $3, $4, \+ \ $5, $6, $7, $8, \+ \ $9, $10, $11, $12, \+ \ $13, $14, $15, $16])"+ encodeMat4JS :: Float -> Float -> Float -> Float+ -> Float -> Float -> Float -> Float+ -> Float -> Float -> Float -> Float+ -> Float -> Float -> Float -> Float+ -> IO Float32Array++ data TagTex = TagTex Int JS.Texture instance Eq TagTex where@@ -114,31 +136,29 @@ noVAO = JS.noVAO encodeMat2 (Mat2 (Vec2 a1 a2) (Vec2 b1 b2)) =- JSArray.fromList <$> mapM toJSVal [a1, a2, b1, b2]- >>= JS.float32ArrayFrom+ encodeMat2JS a1 a2+ b1 b2 encodeMat3 (Mat3 (Vec3 a1 a2 a3) (Vec3 b1 b2 b3)- (Vec3 c1 c2 c3)) = JSArray.fromList <$> mapM toJSVal- [ a1, a2, a3- , b1, b2, b3- , c1, c2, c3 ]- >>= JS.float32ArrayFrom+ (Vec3 c1 c2 c3)) =+ encodeMat3JS a1 a2 a3+ b1 b2 b3+ c1 c2 c3 encodeMat4 (Mat4 (Vec4 a1 a2 a3 a4) (Vec4 b1 b2 b3 b4) (Vec4 c1 c2 c3 c4) (Vec4 d1 d2 d3 d4) ) =- JSArray.fromList <$> mapM toJSVal [ a1, a2, a3, a4- , b1, b2, b3, b4- , c1, c2, c3, c4- , d1, d2, d3, d4 ]- >>= JS.float32ArrayFrom+ encodeMat4JS a1 a2 a3 a4+ b1 b2 b3 b4+ c1 c2 c3 c4+ d1 d2 d3 d4 encodeFloats v = JSArray.fromList <$> mapM toJSVal v >>= JS.float32ArrayFrom encodeInts v = JSArray.fromList <$> mapM toJSVal v >>= JS.int32ArrayFrom - -- TODO: decent implementation+ -- TODO: faster implementation encodeVec2s v = toJSArray next (False, v) >>= JS.float32ArrayFrom where next (False, xs@(Vec2 x _ : _)) = Just (x, (True, xs)) next (True, Vec2 _ y : xs) = Just (y, (False, xs))
Graphics/Rendering/Ombra/D2.hs view
@@ -3,21 +3,14 @@ {-| Simplified 2D graphics system. -} module Graphics.Rendering.Ombra.D2 (- module Graphics.Rendering.Ombra.Generic,- module Data.Vect.Float,- -- * 2D Objects and Groups+ -- * 2D Objects Object2D, IsObject2D,- Group2D,- IsGroup2D, rect, image, sprite, depth,- -- ** Geometry- Geometry2D, poly,- mkGeometry2D, -- * Transformations trans, rot,@@ -47,32 +40,24 @@ import Data.Vect.Float import Graphics.Rendering.Ombra.Backend hiding (Texture, Program) import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Generic import Graphics.Rendering.Ombra.Draw+import Graphics.Rendering.Ombra.Layer+import Graphics.Rendering.Ombra.Object import Graphics.Rendering.Ombra.Shapes-import Graphics.Rendering.Ombra.Types import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Shader.Default2D (Image(..), Depth(..), Transform2(..), View2(..)) import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Texture import Graphics.Rendering.Ombra.Transformation type Uniforms2D = '[Image, Depth, Transform2] --- | A standard 2D object.+-- | A simple 2D Object, without the 'View2' matrix. type Object2D = Object Uniforms2D Geometry2D --- | A standard 2D object group.-type Group2D = Group (View2 ': Uniforms2D) Geometry2D- -- | 2D objects compatible with the standard 2D shader program.-type IsObject2D globals inputs = ( Subset Geometry2D inputs- , Subset Uniforms2D globals- , ShaderVars inputs, ShaderVars globals- )---- | 2D object groups compatible with the standard 2D shader program.-type IsGroup2D gs is = ( Subset Geometry2D is, Subset (View2 ': Uniforms2D) gs- , ShaderVars is, ShaderVars gs )+type IsObject2D gs is = ( Subset Geometry2D is, Subset (View2 ': Uniforms2D) gs+ , ShaderVars is, ShaderVars gs ) -- | A rectangle with a specified 'Texture'. rect :: GLES => Texture -> Object2D@@ -80,7 +65,7 @@ -- | A 2D object with a specified 'Geometry'. poly :: GLES => Texture -> Geometry is -> Object Uniforms2D is-poly t g = globalTexture Image t :~>+poly t g = withTexture t (Image -=) :~> Depth -= 0 :~> Transform2 -= idmtx :~> geom g@@ -101,22 +86,23 @@ -- | Create a group of objects with a view matrix. view :: (ShaderVars gs, ShaderVars is, GLES)- => Mat3 -> [Object gs is] -> Group (View2 ': gs) is+ => Mat3 -> [Object gs is] -> Object (View2 ': gs) is view m = viewVP $ const m -- | Create a group of objects with a view matrix and 'screenMat3'. viewScreen :: (ShaderVars gs, ShaderVars is, GLES)- => Mat3 -> [Object gs is] -> Group (View2 ': gs) is+ => Mat3 -> [Object gs is] -> Object (View2 ': gs) is viewScreen m = viewVP $ \s -> screenMat3 s .*. m -- | Create a group of objects with a view matrix, depending on the size of the -- framebuffer. viewVP :: (ShaderVars gs, ShaderVars is, GLES)- => (Vec2 -> Mat3) -> [Object gs is] -> Group (View2 ': gs) is-viewVP mf = groupGlobal (globalFramebufferSize View2 mf) . group+ => (Vec2 -> Mat3) -> [Object gs is] -> Object (View2 ': gs) is+viewVP mf os = withFramebufferSize (\s -> View2 -= mf (tupleToVec s))+ :~> mconcat os -- | A 'Layer' with the standard 2D program.-layerS :: IsGroup2D gs is => Group gs is -> Layer+layerS :: IsObject2D gs is => Object gs is -> Layer layerS = layer defaultProgram2D -- | Translate a 2D 'Object'.@@ -143,26 +129,28 @@ -- 'viewScreen' or 'screenMat3'. scaleTex :: (MemberGlobal Transform2 gs, GLES) => Texture -> Object gs is -> Object gs is-scaleTex t = transformDraw $- (\(w, h) -> scaleMat3 $ Vec2 w h) <$> textureSize t+scaleTex t = transform' t $ scaleMat3 -- | Scale an 'Object' so that it has the same aspect ratio as the 'Texture' -- -- > scaleV $ Vec2 1 (texture height / texture width). scaleTexAR :: (MemberGlobal Transform2 gs, GLES) => Texture -> Object gs is -> Object gs is-scaleTexAR t = transformDraw $- (\(w, h) -> scaleMat3 $ Vec2 1 (h / w)) <$> textureSize t+scaleTexAR t = transform' t $ (\(Vec2 w h) -> scaleMat3 $ Vec2 1 (h / w)) -- | Transform a 2D 'Object'. transform :: (MemberGlobal Transform2 gs, GLES) => Mat3 -> Object gs is -> Object gs is-transform m' o = (\m -> Transform2 := (.*. m') <$> m) ~~> o+transform m' o = (\m -> Transform2 -= m .*. m') ~~> o -- | Transform a 2D 'Object'.-transformDraw :: (MemberGlobal Transform2 gs, GLES)- => Draw Mat3 -> Object gs is -> Object gs is-transformDraw m' o = (\m -> Transform2 := (.*.) <$> m <*> m') ~~> o+transform' :: (MemberGlobal Transform2 gs, GLES)+ => Texture+ -> (Vec2 -> Mat3)+ -> Object gs is+ -> Object gs is+transform' t m' o = (\m -> withTexSize t $+ \s -> Transform2 -= m .*. m' (tupleToVec s)) ~~> o -- | Convert the screen coordinates to GL coordinates. screenMat3 :: Vec2 -- ^ Viewport size.@@ -170,3 +158,6 @@ screenMat3 (Vec2 w h) = Mat3 (Vec3 (2 / w) 0 0 ) (Vec3 0 (- 2 / h) 0 ) (Vec3 (- 1) 1 1 )++tupleToVec :: (Int, Int) -> Vec2+tupleToVec (w, h) = Vec2 (fromIntegral w) (fromIntegral h)
Graphics/Rendering/Ombra/D3.hs view
@@ -4,19 +4,11 @@ {-| Simplified 3D graphics system. -} module Graphics.Rendering.Ombra.D3 (- module Graphics.Rendering.Ombra.Generic,- module Data.Vect.Float, -- * 3D Objects Object3D, IsObject3D,- Group3D,- IsGroup3D, cube,- -- ** Geometry- Geometry3D, mesh,- mkGeometry3D,- positionOnly, -- * Transformations trans, rotX,@@ -58,30 +50,23 @@ import Graphics.Rendering.Ombra.Geometry import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Draw-import Graphics.Rendering.Ombra.Generic+import Graphics.Rendering.Ombra.Layer+import Graphics.Rendering.Ombra.Object import Graphics.Rendering.Ombra.Shapes-import Graphics.Rendering.Ombra.Types import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Shader.Default3D (Texture2(..), Transform3(..), View3(..)) import Graphics.Rendering.Ombra.Shader.Program hiding (program)+import Graphics.Rendering.Ombra.Texture import Graphics.Rendering.Ombra.Transformation type Uniforms3D = '[Transform3, Texture2] --- | A standard 3D object.+-- | A standard 3D object, without the 'View3' matrix. type Object3D = Object Uniforms3D Geometry3D --- | A standard 3D group.-type Group3D = Group (View3 ': Uniforms3D) Geometry3D- -- | 3D objects compatible with the standard 3D shader program.-type IsObject3D globals inputs = ( Subset Geometry3D inputs- , Subset Uniforms3D globals- , ShaderVars inputs, ShaderVars globals )---- | 3D object groups compatible with the standard 3D shader program.-type IsGroup3D gs is = ( Subset Geometry3D is, Subset (View3 ': Uniforms3D) gs- , ShaderVars is, ShaderVars gs )+type IsObject3D gs is = ( Subset Geometry3D is, Subset (View3 ': Uniforms3D) gs+ , ShaderVars is, ShaderVars gs ) -- | A cube with a specified 'Texture'. cube :: GLES => Texture -> Object3D@@ -89,11 +74,11 @@ -- | A 3D object with a specified 'Geometry'. mesh :: GLES => Texture -> Geometry is -> Object Uniforms3D is-mesh t g = Transform3 -= idmtx :~> globalTexture Texture2 t :~> geom g+mesh t g = Transform3 -= idmtx :~> withTexture t (Texture2 -=) :~> geom g -- | Create a group of objects with a view matrix. view :: (GLES, ShaderVars gs, ShaderVars is)- => Mat4 -> [Object gs is] -> Group (View3 ': gs) is+ => Mat4 -> [Object gs is] -> Object (View3 ': gs) is view m = viewVP $ const m -- | Create a group of objects with a view matrix and perspective projection.@@ -102,7 +87,8 @@ -> Float -- ^ Far -> Float -- ^ FOV -> Mat4 -- ^ View matrix- -> [Object gs is] -> Group (View3 ': gs) is+ -> [Object gs is]+ -> Object (View3 ': gs) is viewPersp n f fov m = viewVP $ \s -> m .*. perspectiveMat4Size n f fov s -- | Create a group of objects with a view matrix and orthographic projection.@@ -114,17 +100,20 @@ -> Float -- ^ Bottom -> Float -- ^ Top -> Mat4 -- ^ View matrix- -> [Object gs is] -> Group (View3 ': gs) is+ -> [Object gs is]+ -> Object (View3 ': gs) is viewOrtho n f l r b t m = view $ m .*. orthoMat4 n f l r b t -- | Create a group of objects with a view matrix, depending on the size of the -- framebuffer. viewVP :: (GLES, ShaderVars gs, ShaderVars is)- => (Vec2 -> Mat4) -> [Object gs is] -> Group (View3 ': gs) is-viewVP mf = groupGlobal (globalFramebufferSize View3 mf) . group+ => (Vec2 -> Mat4) -> [Object gs is] -> Object (View3 ': gs) is+viewVP mf o = withFramebufferSize (\s -> View3 -= mf (tupleToVec s))+ :~> mconcat o+ where tupleToVec (w, h) = Vec2 (fromIntegral w) (fromIntegral h) -- | A 'Layer' with the standard 3D program.-layerS :: IsGroup3D gs is => Group gs is -> Layer+layerS :: IsObject3D gs is => Object gs is -> Layer layerS = layer defaultProgram3D -- | Translate a 3D Object.@@ -166,7 +155,7 @@ -- | Transform a 3D 'Object'. transform :: (MemberGlobal Transform3 gs, GLES) => Mat4 -> Object gs is -> Object gs is-transform m' o = (\m -> Transform3 := (.*. m') <$> m) ~~> o+transform m' o = (\m -> Transform3 -= m .*. m') ~~> o -- | 4x4 perspective projection matrix, using width and height instead of the -- aspect ratio.
Graphics/Rendering/Ombra/Draw.hs view
@@ -1,5 +1,7 @@ module Graphics.Rendering.Ombra.Draw ( Buffer(..),+ DrawState,+ Ctx, refDrawCtx, runDrawCtx, execDrawCtx,@@ -12,8 +14,6 @@ removeGeometry, removeTexture, removeProgram,- textureUniform,- textureSize, resizeViewport, renderLayer, gl@@ -22,7 +22,7 @@ import Data.IORef import Graphics.Rendering.Ombra.Draw.Internal import Graphics.Rendering.Ombra.Internal.GL hiding (Buffer)-import Graphics.Rendering.Ombra.Types (Buffer(..))+import Graphics.Rendering.Ombra.Layer -- | Run a Draw action using an IORef and a context. refDrawCtx :: GLES => Ctx -> Draw a -> IORef DrawState -> IO a
Graphics/Rendering/Ombra/Draw/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances,- FlexibleInstances, MultiParamTypeClasses, KindSignatures #-}+ FlexibleInstances, MultiParamTypeClasses, KindSignatures,+ GeneralizedNewtypeDeriving #-} module Graphics.Rendering.Ombra.Draw.Internal ( Draw,@@ -8,12 +9,10 @@ drawInit, clearBuffers, drawLayer,- drawGroup, drawObject, removeGeometry, removeTexture, removeProgram,- textureUniform, textureSize, setProgram, resizeViewport,@@ -27,10 +26,11 @@ ) where import qualified Graphics.Rendering.Ombra.Blend as Blend-import Graphics.Rendering.Ombra.Geometry import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Types-import Graphics.Rendering.Ombra.Texture+import Graphics.Rendering.Ombra.Geometry.Internal+import Graphics.Rendering.Ombra.Layer.Internal+import Graphics.Rendering.Ombra.Object.Internal+import Graphics.Rendering.Ombra.Texture.Internal import Graphics.Rendering.Ombra.Backend (GLES) import qualified Graphics.Rendering.Ombra.Backend as GL import Graphics.Rendering.Ombra.Internal.GL hiding (Texture, Program, Buffer,@@ -45,13 +45,41 @@ import qualified Graphics.Rendering.Ombra.Stencil as Stencil import Data.Hashable (Hashable)-import qualified Data.Vector as V import Data.Vect.Float import Data.Word (Word8) import Control.Monad (when)+import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State +-- | The state of the 'Draw' monad.+data DrawState = DrawState {+ currentProgram :: Maybe (Program '[] '[]),+ loadedProgram :: Maybe LoadedProgram,+ programs :: ResMap (Program '[] '[]) LoadedProgram,+ uniforms :: ResMap (LoadedProgram, String) UniformLocation,+ gpuBuffers :: ResMap (Geometry '[]) GPUBufferGeometry,+ gpuVAOs :: ResMap (Geometry '[]) GPUVAOGeometry,+ textureImages :: ResMap TextureImage LoadedTexture,+ activeTextures :: Int,+ viewportSize :: (Int, Int),+ blendMode :: Maybe Blend.Mode,+ stencilMode :: Maybe Stencil.Mode,+ cullFace :: Maybe CullFace,+ depthTest :: Bool,+ depthMask :: Bool,+ colorMask :: (Bool, Bool, Bool, Bool)+}++newtype UniformLocation = UniformLocation GL.UniformLocation++-- | A state monad on top of 'GL'.+newtype Draw a = Draw { unDraw :: StateT DrawState GL a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance EmbedIO Draw where+ embedIO f (Draw a) = Draw get >>= Draw . lift . embedIO f . evalStateT a+ -- | Create a 'DrawState'. drawState :: GLES => Int -- ^ Viewport width@@ -69,8 +97,7 @@ , gpuVAOs = gpuVAOs , uniforms = uniforms , textureImages = textureImages- , activeTextures =- V.replicate 16 Nothing+ , activeTextures = 0 , viewportSize = (w, h) , blendMode = Nothing , depthTest = True@@ -152,10 +179,7 @@ -- | Draw a 'Layer'. drawLayer :: GLES => Layer -> Draw ()--- TODO: freeActiveTextures should not be here-drawLayer (Layer prg grp) = freeActiveTextures >>- setProgram prg >>- drawGroup initialGroupState grp+drawLayer (Layer prg grp) = setProgram prg >> drawObject grp drawLayer (SubLayer rl) = do (layer, textures) <- renderLayer rl drawLayer layer@@ -163,64 +187,40 @@ drawLayer (OverLayer top behind) = drawLayer behind >> drawLayer top drawLayer (ClearLayer bufs l) = clearBuffers bufs >> drawLayer l -data GroupState = GroupState {- hasBlend :: Bool,- hasStencil :: Bool,- hasDepthTest :: Bool,- hasDepthMask :: Bool,- hasColorMask :: Bool,- hasCull :: Bool-}--initialGroupState :: GroupState-initialGroupState = GroupState False False False False False False+-- | Draw an 'Object'.+drawObject :: GLES => Object gs is -> Draw ()+drawObject (g :~> o) = withGlobal g $ drawObject o+drawObject (Mesh g) = withRes_ (getGPUVAOGeometry $ castGeometry g)+ drawGPUVAOGeometry+drawObject NoMesh = return ()+drawObject (Prop p o) = withObjProp p $ drawObject o+drawObject (Append o o') = drawObject o >> drawObject o' --- | Draw a 'Group'.-drawGroup :: GLES => GroupState -> Group gs is -> Draw ()-drawGroup _ Empty = return ()-drawGroup _ (Object o) = drawObject o-drawGroup s (Global (g := c) o) = do c >>= uniform single (g undefined)- drawGroup s o-drawGroup s (Global (Mirror g c) o) = do c >>= uniform mirror- (varBuild (const undefined) g)- drawGroup s o-drawGroup _ (Append g g') = do drawGroup initialGroupState g- drawGroup initialGroupState g'-drawGroup s (Blend m g) | hasBlend s = drawGroup s g- | otherwise = stateReset blendMode setBlendMode m $- drawGroup (s { hasBlend = True }) g-drawGroup s (Stencil m g) | hasStencil s = drawGroup s g- | otherwise = stateReset stencilMode setStencilMode m $- drawGroup (s { hasStencil = True }) g-drawGroup s (DepthTest d g) | hasDepthTest s = drawGroup s g- | otherwise = stateReset depthTest setDepthTest d $- drawGroup (s { hasDepthTest = True }) g-drawGroup s (DepthMask d g) | hasDepthTest s = drawGroup s g- | otherwise = stateReset depthMask setDepthMask d $- drawGroup (s { hasDepthMask = True }) g-drawGroup s (ColorMask d g) | hasColorMask s = drawGroup s g- | otherwise = stateReset colorMask setColorMask d $- drawGroup (s { hasColorMask = True }) g-drawGroup s (Cull face g) | hasCull s = drawGroup s g- | otherwise = stateReset cullFace setCullFace face $- drawGroup (s { hasCull = True }) g+withObjProp :: GLES => ObjProp -> Draw a -> Draw a+withObjProp (Blend m) a = stateReset blendMode setBlendMode m a+withObjProp (Stencil m) a = stateReset stencilMode setStencilMode m a+withObjProp (DepthTest d) a = stateReset depthTest setDepthTest d a+withObjProp (DepthMask d) a = stateReset depthMask setDepthMask d a+withObjProp (ColorMask d) a = stateReset colorMask setColorMask d a+withObjProp (Cull face) a = stateReset cullFace setCullFace face a -stateReset :: (DrawState -> a) -> (a -> Draw ()) -> a -> Draw () -> Draw ()+stateReset :: (DrawState -> a) -> (a -> Draw ()) -> a -> Draw b -> Draw b stateReset getOld set new act = do old <- getOld <$> Draw get set new- act+ b <- act set old+ return b --- | Draw an 'Object'.-drawObject :: GLES => Object gs is -> Draw ()-drawObject NoMesh = return ()-drawObject (Mesh g) = withRes_ (getGPUVAOGeometry $ castGeometry g)- drawGPUVAOGeometry-drawObject ((g := c) :~> o) = c >>= uniform single (g undefined) >> drawObject o-drawObject (Mirror g c :~> o) = do c >>= uniform mirror- (varBuild (const undefined) g)- drawObject o+withGlobal :: GLES => Global g -> Draw () -> Draw ()+withGlobal (Single g c) a = uniform single (g undefined) c >> a+withGlobal (Mirror g c) a = uniform mirror (varBuild (const undefined) g) c >> a+withGlobal (WithTexture t gf) a = withActiveTexture t $ flip withGlobal a . gf+withGlobal (WithTextureSize t gf) a = textureSize t >>= flip withGlobal a . gf+withGlobal (WithFramebufferSize gf) a = viewportSize <$> drawGet >>=+ flip withGlobal a . gf + where tupleToVec (x, y) = Vec2 (fromIntegral x) (fromIntegral y)+ uniform :: (GLES, ShaderVar g, Uniform s g) => proxy (s :: CPUSetterType *) -> g -> CPU s g -> Draw () uniform p g c = withUniforms p g c $@@ -228,14 +228,21 @@ \(UniformLocation l) -> gl $ setUniform l ug uc --- | This helps you set the uniforms of type 'Graphics.Rendering.Ombra.Shader.Sampler2D'.-textureUniform :: GLES => Texture -> Draw ActiveTexture-textureUniform tex = withRes (getTexture tex) (return $ ActiveTexture 0)- $ \(LoadedTexture _ _ wtex) ->- do at <- makeActive tex- gl $ bindTexture gl_TEXTURE_2D wtex- return at+withActiveTexture :: GLES => Texture -> (ActiveTexture -> Draw ()) -> Draw ()+withActiveTexture tex f =+ withRes (getTexture tex) (return ()) $+ \(LoadedTexture _ _ wtex) -> makeActive tex $+ \at -> do gl $ bindTexture gl_TEXTURE_2D wtex+ f at +makeActive :: GLES => Texture -> (ActiveTexture -> Draw a) -> Draw a+makeActive t f = do atn <- activeTextures <$> Draw get+ Draw . modify $ \ds -> ds { activeTextures = atn + 1 }+ gl . activeTexture $ gl_TEXTURE0 + fromIntegral atn+ ret <- f . ActiveTexture . fromIntegral $ atn+ Draw . modify $ \ds -> ds { activeTextures = atn }+ return ret+ -- | Get the dimensions of a 'Texture'. textureSize :: (GLES, Num a) => Texture -> Draw (a, a) textureSize tex = withRes (getTexture tex) (return (0, 0))@@ -250,7 +257,8 @@ \lp@(LoadedProgram glp _ _) -> do Draw . modify $ \s -> s { currentProgram = Just $ castProgram p,- loadedProgram = Just lp+ loadedProgram = Just lp,+ activeTextures = 0 } gl $ useProgram glp @@ -286,33 +294,6 @@ getProgram :: GLES => Program '[] '[] -> Draw (Either String LoadedProgram) getProgram = getDrawResource gl programs--freeActiveTextures :: GLES => Draw ()-freeActiveTextures = Draw . modify $ \ds ->- ds { activeTextures = V.replicate 16 Nothing }--makeActive :: GLES => Texture -> Draw ActiveTexture-makeActive t = do ats <- activeTextures <$> Draw get- let (at@(ActiveTexture atn), ats') =- case V.elemIndex (Just t) ats of- Just n -> (ActiveTexture $ fromIntegral n, ats)- Nothing ->- case V.elemIndex Nothing ats of- Just n -> ( ActiveTexture $- fromIntegral n- , ats )- Nothing -> let l = V.length ats- grow = V.replicate- l Nothing- in ( ActiveTexture $- fromIntegral l- , ats V.++ grow )- gl . activeTexture $ gl_TEXTURE0 + fromIntegral atn- Draw . modify $ \ds ->- ds { activeTextures =- ats' V.// [(fromIntegral atn, Just t)] }- return at- -- | Realize a 'RenderLayer'. It returns the list of allocated 'Texture's so -- that you can free them if you want.
− Graphics/Rendering/Ombra/Generic.hs
@@ -1,551 +0,0 @@-{-# LANGUAGE TypeOperators, DataKinds, ConstraintKinds, MultiParamTypeClasses,- TypeFamilies, FlexibleContexts, FlexibleInstances #-}--module Graphics.Rendering.Ombra.Generic (- -- * Objects- Object((:~>)),- MemberGlobal((~~>)),- RemoveGlobal((*~>)),- nothing,- geom,- modifyGeometry,-- -- * Groups- Group,- group,- (~~),- groupEmpty,- groupGlobal,- depthTest,- depthMask,- colorMask,- ShaderVars,- VOShaderVars,- -- ** Blending- blend,- noBlend,- Blend.transparency,- Blend.additive,- -- ** Stencil test- stencil,- noStencil,- -- ** Culling- CullFace(..),- cull,- noCull,-- -- * Layers- Buffer(..),- Layer,- layer,- over,- clear,- -- ** Sublayers- subLayer,- colorSubLayer,- depthSubLayer,- colorDepthSubLayer,- colorStencilSubLayer,- colorSubLayer',- depthSubLayer',- colorDepthSubLayer',- colorStencilSubLayer',- buffersSubLayer,- buffersDepthSubLayer,- buffersStencilSubLayer,-- -- * Shaders- Compatible,- Program,- program,- Global,- (-=),- globalTexture,- globalTexSize,- globalFramebufferSize,- CPUMirror,- globalMirror,- globalMirror',-- -- * Geometries- Geometry,- AttrList(..),- mkGeometry,- extend,- remove,-- -- * Textures- Texture,- ActiveTexture,- mkTexture,- mkTextureFloat,- Filter(..),- setFilter,- -- ** Colors- Color(..),- colorTex,-- GLES,- module Data.Vect.Float,- module Graphics.Rendering.Ombra.Color-) where--import Data.Typeable-import Data.Type.Equality-import Data.Vect.Float-import Data.Word (Word8)-import Graphics.Rendering.Ombra.Backend (GLES)-import qualified Graphics.Rendering.Ombra.Blend as Blend-import qualified Graphics.Rendering.Ombra.Stencil as Stencil-import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Draw-import Graphics.Rendering.Ombra.Types hiding (depthTest, depthMask, colorMask)-import Graphics.Rendering.Ombra.Internal.GL (ActiveTexture)-import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Shader.ShaderVar-import Graphics.Rendering.Ombra.Shader.Stages-import Graphics.Rendering.Ombra.Texture---- | An empty group.-groupEmpty :: Group gs is-groupEmpty = Empty---- | Set a global uniform for a 'Group'.-groupGlobal :: Global g -> Group gs is -> Group (g ': gs) is-groupGlobal = Global---- | Enable blending and set the blending mode for a 'Group' of objects.-blend :: Blend.Mode -> Group gs is -> Group gs is-blend m = Blend $ Just m---- | Disable blending for a 'Group'.-noBlend :: Group gs is -> Group gs is-noBlend = Blend Nothing---- | Enable stencil testing and set the stencil mode for a 'Group' of objects.-stencil :: Stencil.Mode -> Group gs is -> Group gs is-stencil m = Stencil $ Just m---- | Disable stencil testing on a 'Group' of objects.-noStencil :: Group gs is -> Group gs is-noStencil = Stencil Nothing---- | Enable/disable depth testing for a 'Group'.-depthTest :: Bool -> Group gs is -> Group gs is-depthTest = DepthTest---- | Enable/disable writing into the depth buffer for a 'Group'.-depthMask :: Bool -> Group gs is -> Group gs is-depthMask = DepthMask---- | Enable/disable writing into the four channels of the color buffer for a--- 'Group'.-colorMask :: (Bool, Bool, Bool, Bool) -> Group gs is -> Group gs is-colorMask = ColorMask--- TODO: should search and modify existing DepthMask---- | Enable face culling.-cull :: CullFace -> Group gs is -> Group gs is-cull m = Cull $ Just m--- TODO: should search and modify existing Cull---- | Disable face culling.-noCull :: Group gs is -> Group gs is-noCull = Cull Nothing--- TODO: should search and modify existing Cull---- | An empty object.-nothing :: Object '[] '[]-nothing = NoMesh---- | An object with a specified 'Geometry'.-geom :: Geometry i -> Object '[] i-geom = Mesh--class MemberGlobal g gs where- -- | Modify the global of an 'Object'. This doesn't work with mirror- -- globals.- (~~>) :: (Uniform 'S g)- => (Draw (CPU 'S g) -> Global g) -- ^ Changing function- -> Object gs is- -> Object gs is--instance {-# OVERLAPPING #-} MemberGlobal g (g ': gs) where- f ~~> (_ := c :~> o) = f c :~> o- _ ~~> (glob :~> o) = glob :~> o--instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, MemberGlobal g gs) =>- MemberGlobal g (g1 ': gs) where- f ~~> (g :~> o) = g :~> (f ~~> o)--infixr 2 ~~>--class RemoveGlobal g gs gs' where- -- | Remove a global from an 'Object'.- (*~>) :: (a -> g) -> Object gs is -> Object gs' is--instance {-# OVERLAPPING #-} RemoveGlobal g (g ': gs) gs where- _ *~> (_ :~> o) = o--instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, RemoveGlobal g gs gs') =>- RemoveGlobal g (g1 ': gs) (g1 ': gs') where- r *~> (g :~> o) = g :~> (r *~> o)--infixr 2 *~>---- | Modify the geometry of an 'Object'.-modifyGeometry :: (Empty is ~ False)- => (Geometry is -> Geometry is')- -> Object gs is -> Object gs is'-modifyGeometry fg (g :~> o) = g :~> modifyGeometry fg o-modifyGeometry fg (Mesh g) = Mesh $ fg g---- | Create a 'Global' from a pure value. The first argument is ignored,--- it just provides the type (you can use the constructor of the GPU type).--- You can use this to set the value of a shader uniform.-(-=) :: (ShaderVar g, Uniform 'S g) => (a -> g) -> CPU 'S g -> Global g-g -= c = g := return c--infixr 4 -=---- TODO: polymorphic -= instead of globalTexture--- | Create a 'Global' of CPU type 'ActiveTexture' using a 'Texture'.-globalTexture :: (Uniform 'S g, CPU 'S g ~ ActiveTexture, ShaderVar g, GLES)- => (a -> g) -> Texture -> Global g-globalTexture g c = g := textureUniform c---- | Create a 'Global' using the size of a 'Texture'.-globalTexSize :: (ShaderVar g, Uniform 'S g, GLES)- => (a -> g) -> Texture- -> ((Int, Int) -> CPU 'S g) -> Global g-globalTexSize g t fc = g := (fc <$> textureSize t)---- | Create a 'Global' using the size of the framebuffer.-globalFramebufferSize :: (ShaderVar g, Uniform 'S g) => (a -> g)- -> (Vec2 -> CPU 'S g) -> Global g-globalFramebufferSize g fc = g := (fc . tupleToVec <$>- (viewportSize <$> drawGet))--tupleToVec :: (Int, Int) -> Vec2-tupleToVec (x, y) = Vec2 (fromIntegral x) (fromIntegral y)---- | Like '-=' but for mirror types.-globalMirror :: (ShaderVar g, Uniform 'M g) => Proxy g -> CPU 'M g -> Global g-globalMirror g c = Mirror g $ return c---- | Extended version of 'globalMirror'.-globalMirror' :: (GLES, ShaderVar g, Uniform 'M g)- => Proxy g- -> [Texture] -- ^ Textures to make active. Remember that- -- the CPU version of 'Sampler2D' is- -- 'ActiveTexture', not 'Texture'.- -> ([(ActiveTexture, (Int, Int))] -> Vec2 -> CPU 'M g)- -- ^ Function that, given a list of active- -- textures (the same passed in the second- -- argument) and their size, and the- -- framebuffer value, build the CPU value of- -- the global.- -> Global g-globalMirror' g ts f = Mirror g $ f <$> mapM ( \t -> (,) <$> textureUniform t- <*> textureSize t) ts- <*> (tupleToVec . viewportSize <$> drawGet)---- | Create a 'Group' from a list of 'Object's.-group :: (ShaderVars gs, ShaderVars is) => [Object gs is] -> Group gs is-group = foldr (\obj grp -> grp ~~ Object obj) groupEmpty--type EqualMerge x y v = EqualOrErr x y (Text "Can't merge groups with " :<>:- Text "different " :<>: v :<>:- Text "." :$$:- Text " Left group " :<>: v :<>:- Text ": " :<>: ShowType x :$$:- Text " Right group " :<>: v :<>:- Text ": " :<>: ShowType y)----- | Merge two groups.-(~~) :: (EqualMerge gs gs' (Text "globals"), EqualMerge is is' (Text "inputs"))- => Group gs is -> Group gs' is'- -> Group (Union gs gs') (Union is is')-(~~) = Append--{---- | Merge two groups, even if they don't provide the same variables.-unsafeMerge :: Group gs is -> Group gs' is'- -> Group (Union gs gs') (Union is is')-unsafeMerge = Append--}---- | Associate a group with a program.-layer :: (Subset progAttr grpAttr, Subset progUni grpUni)- => Program progUni progAttr -> Group grpUni grpAttr -> Layer-layer = Layer--infixl 1 `over`--- | Draw the first Layer over the second one. The first Layer will use the same--- buffers (color, depth, stencil) of the second one.-over :: Layer -> Layer -> Layer-over = OverLayer---- | 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 ]---- | Alias for 'colorSubLayer'.-subLayer :: Int -> Int -> Layer -> (Texture -> Layer) -> Layer-subLayer = colorSubLayer---- | Use a 'Layer' as a 'Texture' on another.-colorSubLayer :: Int -- ^ Texture width.- -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a 'Texture'.- -> (Texture -> Layer) -- ^ Layers using the texture.- -> Layer-colorSubLayer w h l = subRenderLayer . renderColor w h l---- | Use a 'Layer' as a depth 'Texture' on another.-depthSubLayer :: Int -- ^ Texture width.- -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a- -- depth 'Texture'.- -> (Texture -> Layer) -- ^ Layers using the texture.- -> Layer-depthSubLayer w h l = subRenderLayer . renderDepth w h l---- | Combination of 'colorSubLayer' and 'depthSubLayer'.-colorDepthSubLayer :: Int -- ^ Texture width.- -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on the- -- 'Texture's.- -> (Texture -> Texture -> Layer) -- ^ Color, depth.- -> Layer-colorDepthSubLayer w h l = subRenderLayer . renderColorDepth w h l---- | 'colorSubLayer' with a stencil buffer.-colorStencilSubLayer :: Int -- ^ Texture width.- -> Int -- ^ Texture height.- -> Layer -- ^ Layer to draw on a 'Texture'- -> (Texture -> Layer) -- ^ Color.- -> Layer-colorStencilSubLayer w h l = subRenderLayer . renderColorStencil w h l---- | 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- -> (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---- | 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- -> (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---- | 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- -> (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---- | '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- -> (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---- | Render a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) in some 'Texture's and use them to--- create another Layer.-buffersSubLayer :: Int -- ^ Textures width.- -> Int -- ^ Textures height.- -> Int -- ^ Number of colors.- -> Layer -- ^ Layer to draw.- -> ([Texture] -> Layer) -- ^ Function using the textures.- -> Layer-buffersSubLayer w h n l = subRenderLayer . renderBuffers w h n l---- | Combination of 'buffersSubLayer' and 'depthSubLayer'.-buffersDepthSubLayer :: Int -- ^ Textures width.- -> Int -- ^ Textures height.- -> Int -- ^ Number of colors.- -> Layer -- ^ Layer to draw.- -> ([Texture] -> Texture -> Layer) -- ^ Function using the- -- buffers textures and- -- the depth texture.- -> Layer-buffersDepthSubLayer w h n l = subRenderLayer . renderBuffersDepth w h n l---- | 'buffersSubLayer' with an additional stencil buffer.-buffersStencilSubLayer :: Int -- ^ Textures width.- -> Int -- ^ Textures height.- -> Int -- ^ Number of colors.- -> 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---- | '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
Graphics/Rendering/Ombra/Geometry.hs view
@@ -1,240 +1,14 @@-{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,- MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables,- PolyKinds #-}- module Graphics.Rendering.Ombra.Geometry (- AttrList(..),- Geometry(..),- Geometry2D,- Geometry3D,- GPUBufferGeometry(..),- GPUVAOGeometry(..),+ Geometry,+ emptyGeometry, extend, remove,- positionOnly,- withGPUBufferGeometry,- mkGeometry,+ -- ** 2D and 3D geometries+ Geometry2D,+ Geometry3D, mkGeometry2D, mkGeometry3D,- castGeometry+ positionOnly ) where -import Control.Monad.Trans.Class-import Control.Monad.Trans.State-import qualified Data.Hashable as H-import Data.Typeable-import Data.Vect.Float hiding (Normal3)-import Data.Word (Word16)-import Unsafe.Coerce--import Graphics.Rendering.Ombra.Internal.GL-import Graphics.Rendering.Ombra.Internal.Resource-import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.Default2D (Position2)-import Graphics.Rendering.Ombra.Shader.Default3D (Position3, Normal3)-import qualified Graphics.Rendering.Ombra.Shader.Default2D as D2-import qualified Graphics.Rendering.Ombra.Shader.Default3D as D3-import Graphics.Rendering.Ombra.Shader.Language.Types (ShaderType(size))---- | A heterogeneous list of attributes.-data AttrList (is :: [*]) where- AttrListNil :: AttrList '[]- AttrListCons :: (H.Hashable (CPU S i), Attribute S i)- => (a -> i)- -> [CPU S i]- -> AttrList is- -> AttrList (i ': is)---- | A set of attributes and indices.-data Geometry (is :: [*]) = Geometry (AttrList is) [Word16] Int--data GPUBufferGeometry = GPUBufferGeometry {- attributeBuffers :: [(Buffer, GLUInt, GLUInt -> GL ())],- elementBuffer :: Buffer,- elementCount :: Int,- geometryHash :: Int-}--data GPUVAOGeometry = GPUVAOGeometry {- vaoBoundBuffers :: [Buffer],- vaoElementCount :: Int,- vao :: VertexArrayObject-}---- | A 3D geometry.-type Geometry3D = '[Position3, D3.UV, Normal3]---- | A 2D geometry.-type Geometry2D = '[Position2, D2.UV]--instance H.Hashable (AttrList is) where- hashWithSalt salt AttrListNil = salt- hashWithSalt salt (AttrListCons _ i is) = H.hashWithSalt salt (i, is)--instance H.Hashable (Geometry is) where- hashWithSalt salt (Geometry _ _ h) = H.hashWithSalt salt h--instance Eq (Geometry is) where- (Geometry _ _ h) == (Geometry _ _ h') = h == h'--instance H.Hashable GPUBufferGeometry where- hashWithSalt salt = H.hashWithSalt salt . geometryHash--instance Eq GPUBufferGeometry where- g == g' = geometryHash g == geometryHash g'---- | Create a 3D 'Geometry'. The first three lists should have the same length.-mkGeometry3D :: GLES- => [Vec3] -- ^ List of vertices.- -> [Vec2] -- ^ List of UV coordinates.- -> [Vec3] -- ^ List of normals.- -> [Word16] -- ^ Triangles expressed as triples of indices to the- -- three lists above.- -> Geometry Geometry3D-mkGeometry3D v u n = mkGeometry (AttrListCons D3.Position3 v $- AttrListCons D3.UV u $- AttrListCons D3.Normal3 n- AttrListNil)---- | Create a 2D 'Geometry'. The first two lists should have the same length.-mkGeometry2D :: GLES- => [Vec2] -- ^ List of vertices.- -> [Vec2] -- ^ List of UV coordinates.- -> [Word16] -- ^ Triangles expressed as triples of indices to the- -- two lists above.- -> Geometry Geometry2D-mkGeometry2D v u = mkGeometry (AttrListCons D2.Position2 v $- AttrListCons D2.UV u- AttrListNil)----- | Add an attribute to a geometry.-extend :: (Attribute 'S i, H.Hashable (CPU 'S i), ShaderType i, GLES)- => (a -> i) -- ^ Attribute constructor (or any other- -- function with that type).- -> [CPU 'S i] -- ^ List of values- -> Geometry is- -> Geometry (i ': is)-extend g c (Geometry al es _) = mkGeometry (AttrListCons g c al) es---- | Remove an attribute from a geometry.-remove :: (RemoveAttr i is is', GLES)- => (a -> i) -- ^ Attribute constructor (or any other function with- -- that type).- -> Geometry is -> Geometry is'-remove g (Geometry al es _) = mkGeometry (removeAttr g al) es---- | Remove the 'UV' and 'Normal3' attributes from a 3D Geometry.-positionOnly :: Geometry Geometry3D -> Geometry '[Position3]-positionOnly (Geometry (AttrListCons pg pc _) es h) =- Geometry (AttrListCons pg pc AttrListNil) es h--class RemoveAttr i is is' where- removeAttr :: (a -> i) -> AttrList is -> AttrList is'--instance RemoveAttr i (i ': is) is where- removeAttr _ (AttrListCons _ _ al) = al--instance RemoveAttr i is is' =>- RemoveAttr i (i1 ': is) (i1 ': is') where- removeAttr g (AttrListCons g' c al) =- AttrListCons g' c $ removeAttr g al---- | Create a custom 'Geometry'.-mkGeometry :: AttrList is -> [Word16] -> Geometry is-mkGeometry al e = Geometry al e $ H.hash (al, e)--castGeometry :: Geometry is -> Geometry is'-castGeometry = unsafeCoerce--instance GLES => Resource (Geometry i) GPUBufferGeometry GL where- loadResource i = Right <$> loadGeometry i- unloadResource _ = deleteGPUBufferGeometry--instance GLES => Resource GPUBufferGeometry GPUVAOGeometry GL where- loadResource i = Right <$> loadGPUVAOGeometry i- unloadResource _ = deleteGPUVAOGeometry--loadGPUVAOGeometry :: GLES- => GPUBufferGeometry- -> GL GPUVAOGeometry-loadGPUVAOGeometry g =- do vao <- createVertexArray- bindVertexArray vao- (ec, bufs) <- withGPUBufferGeometry g $- \ec bufs -> bindVertexArray noVAO >> return (ec, bufs)- return $ GPUVAOGeometry bufs ec vao--loadGeometry :: GLES => Geometry i -> GL GPUBufferGeometry-loadGeometry (Geometry al es h) =- GPUBufferGeometry <$> loadAttrList al- <*> (liftIO (encodeUShorts es) >>=- loadBuffer gl_ELEMENT_ARRAY_BUFFER .- fromUInt16Array)- <*> pure (length es)- <*> pure h--loadAttrList :: GLES => AttrList is -> GL [(Buffer, GLUInt, GLUInt -> GL ())]-loadAttrList = loadFrom 0- where loadFrom :: GLUInt -> AttrList is- -> GL [(Buffer, GLUInt, GLUInt -> GL ())]- loadFrom _ AttrListNil = return []- loadFrom idx (AttrListCons g c al) =- do (newIdx, attrInfo) <- loadAttribute idx (g undefined) c- (attrInfo ++) <$> loadFrom newIdx al- - loadAttribute :: Attribute 'S g => GLUInt -> g -> [CPU 'S g]- -> GL (GLUInt, [(Buffer, GLUInt, GLUInt -> GL ())])- loadAttribute ii g c = flip execStateT (ii, []) $- withAttributes (Proxy :: Proxy 'S) g c $ \_ (g :: Proxy g) c ->- do (i, infos) <- get- arr <- lift $ encodeAttribute g c- buf <- lift $ loadBuffer gl_ARRAY_BUFFER arr- put ( i + fromIntegral (size (undefined :: g))- , (buf, i, setAttribute g) : infos )--withGPUBufferGeometry :: GLES- => GPUBufferGeometry -> (Int -> [Buffer] -> GL a) -> GL a-withGPUBufferGeometry (GPUBufferGeometry abs eb ec _) f =- do bindBuffer gl_ARRAY_BUFFER noBuffer- (_, bufs) <- unzip <$>- mapM (\(buf, loc, setAttr) ->- do bindBuffer gl_ARRAY_BUFFER buf- enableVertexAttribArray loc- setAttr loc- return (loc, buf)- ) abs-- bindBuffer gl_ELEMENT_ARRAY_BUFFER eb- r <- f ec $ eb : bufs- bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer- bindBuffer gl_ARRAY_BUFFER noBuffer- -- mapM_ (disableVertexAttribArray . fromIntegral) locs- return r--deleteGPUVAOGeometry :: GLES => GPUVAOGeometry -> GL ()-deleteGPUVAOGeometry (GPUVAOGeometry bufs _ vao) =- do mapM_ deleteBuffer bufs- deleteVertexArray vao---deleteGPUBufferGeometry :: GLES => GPUBufferGeometry -> GL ()-deleteGPUBufferGeometry (GPUBufferGeometry abs eb _ _) =- mapM_ (\(buf, _, _) -> deleteBuffer buf) abs >> deleteBuffer eb--loadBuffer :: GLES => GLEnum -> AnyArray -> GL Buffer-loadBuffer ty bufData =- do buffer <- createBuffer- bindBuffer ty buffer- bufferData ty bufData gl_STATIC_DRAW- bindBuffer ty noBuffer- return buffer--instance H.Hashable Vec2 where- hashWithSalt s (Vec2 x y) = H.hashWithSalt s (x, y)--instance H.Hashable Vec3 where- hashWithSalt s (Vec3 x y z) = H.hashWithSalt s (x, y, z)--instance H.Hashable Vec4 where- hashWithSalt s (Vec4 x y z w) = H.hashWithSalt s (x, y, z, w)+import Graphics.Rendering.Ombra.Geometry.Internal
+ Graphics/Rendering/Ombra/Geometry/Internal.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,+ MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables,+ PolyKinds #-}++module Graphics.Rendering.Ombra.Geometry.Internal (+ AttrList(..),+ Geometry(..),+ Geometry2D,+ Geometry3D,+ GPUBufferGeometry(..),+ GPUVAOGeometry(..),+ emptyGeometry,+ extend,+ remove,+ positionOnly,+ withGPUBufferGeometry,+ mkGeometry,+ mkGeometry2D,+ mkGeometry3D,+ castGeometry+) where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import qualified Data.Hashable as H+import Data.Typeable+import Data.Vect.Float hiding (Normal3)+import Data.Word (Word16)+import Unsafe.Coerce++import Graphics.Rendering.Ombra.Internal.GL+import Graphics.Rendering.Ombra.Internal.Resource+import Graphics.Rendering.Ombra.Shader.CPU+import Graphics.Rendering.Ombra.Shader.Default2D (Position2)+import Graphics.Rendering.Ombra.Shader.Default3D (Position3, Normal3)+import qualified Graphics.Rendering.Ombra.Shader.Default2D as D2+import qualified Graphics.Rendering.Ombra.Shader.Default3D as D3+import Graphics.Rendering.Ombra.Shader.Language.Types (ShaderType(size))++-- | A heterogeneous list of attributes.+data AttrList (is :: [*]) where+ AttrListNil :: AttrList '[]+ AttrListCons :: (H.Hashable (CPU S i), Attribute S i)+ => (a -> i)+ -> [CPU S i]+ -> AttrList is+ -> AttrList (i ': is)++-- | A set of attributes and indices.+data Geometry (is :: [*]) = Geometry (AttrList is) [Word16] Int++data GPUBufferGeometry = GPUBufferGeometry {+ attributeBuffers :: [(Buffer, GLUInt, GLUInt -> GL ())],+ elementBuffer :: Buffer,+ elementCount :: Int,+ geometryHash :: Int+}++data GPUVAOGeometry = GPUVAOGeometry {+ vaoBoundBuffers :: [Buffer],+ vaoElementCount :: Int,+ vao :: VertexArrayObject+}++-- | A 3D geometry.+type Geometry3D = '[Position3, D3.UV, Normal3]++-- | A 2D geometry.+type Geometry2D = '[Position2, D2.UV]++instance H.Hashable (AttrList is) where+ hashWithSalt salt AttrListNil = salt+ hashWithSalt salt (AttrListCons _ i is) = H.hashWithSalt salt (i, is)++instance H.Hashable (Geometry is) where+ hashWithSalt salt (Geometry _ _ h) = H.hashWithSalt salt h++instance Eq (Geometry is) where+ (Geometry _ _ h) == (Geometry _ _ h') = h == h'++instance H.Hashable GPUBufferGeometry where+ hashWithSalt salt = H.hashWithSalt salt . geometryHash++instance Eq GPUBufferGeometry where+ g == g' = geometryHash g == geometryHash g'++-- | Create a 3D 'Geometry'. The first three lists should have the same length.+mkGeometry3D :: GLES+ => [Vec3] -- ^ List of vertices.+ -> [Vec2] -- ^ List of UV coordinates.+ -> [Vec3] -- ^ List of normals.+ -> [Word16] -- ^ Triangles expressed as triples of indices to the+ -- three lists above.+ -> Geometry Geometry3D+mkGeometry3D v u n = mkGeometry (AttrListCons D3.Position3 v $+ AttrListCons D3.UV u $+ AttrListCons D3.Normal3 n+ AttrListNil)++-- | Create a 2D 'Geometry'. The first two lists should have the same length.+mkGeometry2D :: GLES+ => [Vec2] -- ^ List of vertices.+ -> [Vec2] -- ^ List of UV coordinates.+ -> [Word16] -- ^ Triangles expressed as triples of indices to the+ -- two lists above.+ -> Geometry Geometry2D+mkGeometry2D v u = mkGeometry (AttrListCons D2.Position2 v $+ AttrListCons D2.UV u+ AttrListNil)+++-- | Add an attribute to a geometry.+extend :: (Attribute 'S i, H.Hashable (CPU 'S i), ShaderType i, GLES)+ => (a -> i) -- ^ Attribute constructor (or any other+ -- function with that type).+ -> [CPU 'S i] -- ^ List of values+ -> Geometry is+ -> Geometry (i ': is)+extend g c (Geometry al es _) = mkGeometry (AttrListCons g c al) es++-- | Remove an attribute from a geometry.+remove :: (RemoveAttr i is is', GLES)+ => (a -> i) -- ^ Attribute constructor (or any other function with+ -- that type).+ -> Geometry is -> Geometry is'+remove g (Geometry al es _) = mkGeometry (removeAttr g al) es++-- | Remove the 'UV' and 'Normal3' attributes from a 3D Geometry.+positionOnly :: Geometry Geometry3D -> Geometry '[Position3]+positionOnly (Geometry (AttrListCons pg pc _) es h) =+ Geometry (AttrListCons pg pc AttrListNil) es h++class RemoveAttr i is is' where+ removeAttr :: (a -> i) -> AttrList is -> AttrList is'++instance RemoveAttr i (i ': is) is where+ removeAttr _ (AttrListCons _ _ al) = al++instance RemoveAttr i is is' =>+ RemoveAttr i (i1 ': is) (i1 ': is') where+ removeAttr g (AttrListCons g' c al) =+ AttrListCons g' c $ removeAttr g al++-- | Create a 'Geometry' without attributes. You can add them using 'extend'.+emptyGeometry :: [Word16] -- ^ Triangles.+ -> Geometry '[]+emptyGeometry = mkGeometry AttrListNil++-- | Create a custom 'Geometry'.+mkGeometry :: AttrList is -> [Word16] -> Geometry is+mkGeometry al e = Geometry al e $ H.hash (al, e)++castGeometry :: Geometry is -> Geometry is'+castGeometry = unsafeCoerce++instance GLES => Resource (Geometry i) GPUBufferGeometry GL where+ loadResource i = Right <$> loadGeometry i+ unloadResource _ = deleteGPUBufferGeometry++instance GLES => Resource GPUBufferGeometry GPUVAOGeometry GL where+ loadResource i = Right <$> loadGPUVAOGeometry i+ unloadResource _ = deleteGPUVAOGeometry++loadGPUVAOGeometry :: GLES+ => GPUBufferGeometry+ -> GL GPUVAOGeometry+loadGPUVAOGeometry g =+ do vao <- createVertexArray+ bindVertexArray vao+ (ec, bufs) <- withGPUBufferGeometry g $+ \ec bufs -> bindVertexArray noVAO >> return (ec, bufs)+ return $ GPUVAOGeometry bufs ec vao++loadGeometry :: GLES => Geometry i -> GL GPUBufferGeometry+loadGeometry (Geometry al es h) =+ GPUBufferGeometry <$> loadAttrList al+ <*> (liftIO (encodeUShorts es) >>=+ loadBuffer gl_ELEMENT_ARRAY_BUFFER .+ fromUInt16Array)+ <*> pure (length es)+ <*> pure h++loadAttrList :: GLES => AttrList is -> GL [(Buffer, GLUInt, GLUInt -> GL ())]+loadAttrList = loadFrom 0+ where loadFrom :: GLUInt -> AttrList is+ -> GL [(Buffer, GLUInt, GLUInt -> GL ())]+ loadFrom _ AttrListNil = return []+ loadFrom idx (AttrListCons g c al) =+ do (newIdx, attrInfo) <- loadAttribute idx (g undefined) c+ (attrInfo ++) <$> loadFrom newIdx al+ + loadAttribute :: Attribute 'S g => GLUInt -> g -> [CPU 'S g]+ -> GL (GLUInt, [(Buffer, GLUInt, GLUInt -> GL ())])+ loadAttribute ii g c = flip execStateT (ii, []) $+ withAttributes (Proxy :: Proxy 'S) g c $ \_ (g :: Proxy g) c ->+ do (i, infos) <- get+ arr <- lift $ encodeAttribute g c+ buf <- lift $ loadBuffer gl_ARRAY_BUFFER arr+ put ( i + fromIntegral (size (undefined :: g))+ , (buf, i, setAttribute g) : infos )++withGPUBufferGeometry :: GLES+ => GPUBufferGeometry -> (Int -> [Buffer] -> GL a) -> GL a+withGPUBufferGeometry (GPUBufferGeometry abs eb ec _) f =+ do bindBuffer gl_ARRAY_BUFFER noBuffer+ (_, bufs) <- unzip <$>+ mapM (\(buf, loc, setAttr) ->+ do bindBuffer gl_ARRAY_BUFFER buf+ enableVertexAttribArray loc+ setAttr loc+ return (loc, buf)+ ) abs++ bindBuffer gl_ELEMENT_ARRAY_BUFFER eb+ r <- f ec $ eb : bufs+ bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer+ bindBuffer gl_ARRAY_BUFFER noBuffer+ -- mapM_ (disableVertexAttribArray . fromIntegral) locs+ return r++deleteGPUVAOGeometry :: GLES => GPUVAOGeometry -> GL ()+deleteGPUVAOGeometry (GPUVAOGeometry bufs _ vao) =+ do mapM_ deleteBuffer bufs+ deleteVertexArray vao+++deleteGPUBufferGeometry :: GLES => GPUBufferGeometry -> GL ()+deleteGPUBufferGeometry (GPUBufferGeometry abs eb _ _) =+ mapM_ (\(buf, _, _) -> deleteBuffer buf) abs >> deleteBuffer eb++loadBuffer :: GLES => GLEnum -> AnyArray -> GL Buffer+loadBuffer ty bufData =+ do buffer <- createBuffer+ bindBuffer ty buffer+ bufferData ty bufData gl_STATIC_DRAW+ bindBuffer ty noBuffer+ return buffer++instance H.Hashable Vec2 where+ hashWithSalt s (Vec2 x y) = H.hashWithSalt s (x, y)++instance H.Hashable Vec3 where+ hashWithSalt s (Vec3 x y z) = H.hashWithSalt s (x, y, z)++instance H.Hashable Vec4 where+ hashWithSalt s (Vec4 x y z w) = H.hashWithSalt s (x, y, z, w)
Graphics/Rendering/Ombra/Internal/Resource.hs view
@@ -18,7 +18,7 @@ import System.Mem.Weak data ResMap i r = forall m. (Resource i r m, Hashable i) =>- ResMap (H.BasicHashTable Int (Either String r))+ ResMap (H.LinearHashTable Int (Either String r)) data ResStatus r = Loaded r | Unloaded@@ -50,7 +50,7 @@ return $ case m of Just (Right r) -> Loaded r Just (Left e) -> Error e- Nothing ->Unloaded+ Nothing -> Unloaded getResource :: (Resource i r m, Hashable i) => i -> ResMap i r@@ -66,8 +66,10 @@ Right r -> H.insert map ihash $ Right r embedIO (addFinalizer i) $ removeResource' ihash rmap- Just eRes <- liftIO . H.lookup map $ hash i- return eRes+ meRes <- liftIO . H.lookup map $ hash i+ return $ case meRes of+ Just eRes -> eRes+ Nothing -> Left "Resource finalized" Error s -> return $ Left s Loaded r -> return $ Right r where ihash = hash i
+ Graphics/Rendering/Ombra/Layer.hs view
@@ -0,0 +1,306 @@+module Graphics.Rendering.Ombra.Layer (+ Buffer(..),+ Layer,+ layer,+ over,+ clear,+ -- * Programs+ Compatible,+ Program,+ program,+ -- * Sublayers+ subLayer,+ colorSubLayer,+ depthSubLayer,+ colorDepthSubLayer,+ colorStencilSubLayer,+ colorSubLayer',+ depthSubLayer',+ colorDepthSubLayer',+ colorStencilSubLayer',+ buffersSubLayer,+ buffersDepthSubLayer,+ buffersStencilSubLayer,+) where++import Data.Word (Word8)+import Graphics.Rendering.Ombra.Backend (GLES)+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Layer.Internal+import Graphics.Rendering.Ombra.Object+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Texture++-- | Create a simple Layer from a Program and an Object.+layer :: (Subset progAttr grpAttr, Subset progUni grpUni)+ => Program progUni progAttr -> Object grpUni grpAttr -> Layer+layer = Layer++infixl 1 `over`+-- | Draw the first Layer over the second one. This means that the first Layer+-- 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 ]++-- | Alias for 'colorSubLayer'.+subLayer :: Int -> Int -> Layer -> (Texture -> Layer) -> Layer+subLayer = colorSubLayer++-- | Use a 'Layer' as a 'Texture' on another.+colorSubLayer :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Layer -- ^ Layer to draw on a 'Texture'.+ -> (Texture -> Layer) -- ^ Layers using the texture.+ -> Layer+colorSubLayer w h l = subRenderLayer . renderColor w h l++-- | Use a 'Layer' as a depth 'Texture' on another.+depthSubLayer :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Layer -- ^ Layer to draw on a+ -- depth 'Texture'.+ -> (Texture -> Layer) -- ^ Layers using the texture.+ -> Layer+depthSubLayer w h l = subRenderLayer . renderDepth w h l++-- | Combination of 'colorSubLayer' and 'depthSubLayer'.+colorDepthSubLayer :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Layer -- ^ Layer to draw on the+ -- 'Texture's.+ -> (Texture -> Texture -> Layer) -- ^ Color, depth.+ -> Layer+colorDepthSubLayer w h l = subRenderLayer . renderColorDepth w h l++-- | 'colorSubLayer' with a stencil buffer.+colorStencilSubLayer :: Int -- ^ Texture width.+ -> Int -- ^ Texture height.+ -> Layer -- ^ Layer to draw on a 'Texture'+ -> (Texture -> Layer) -- ^ Color.+ -> Layer+colorStencilSubLayer w h l = subRenderLayer . renderColorStencil w h l++-- | 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+ -> (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++-- | 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+ -> (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++-- | 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+ -> (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++-- | '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+ -> (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++-- | Render a 'Layer' with multiple floating point colors+-- (use 'Fragment2', 'Fragment3', etc.) in some 'Texture's and use them to+-- create another Layer.+buffersSubLayer :: Int -- ^ Textures width.+ -> Int -- ^ Textures height.+ -> Int -- ^ Number of colors.+ -> Layer -- ^ Layer to draw.+ -> ([Texture] -> Layer) -- ^ Function using the textures.+ -> Layer+buffersSubLayer w h n l = subRenderLayer . renderBuffers w h n l++-- | Combination of 'buffersSubLayer' and 'depthSubLayer'.+buffersDepthSubLayer :: Int -- ^ Textures width.+ -> Int -- ^ Textures height.+ -> Int -- ^ Number of colors.+ -> Layer -- ^ Layer to draw.+ -> ([Texture] -> Texture -> Layer) -- ^ Function using the+ -- buffers textures and+ -- the depth texture.+ -> Layer+buffersDepthSubLayer w h n l = subRenderLayer . renderBuffersDepth w h n l++-- | 'buffersSubLayer' with an additional stencil buffer.+buffersStencilSubLayer :: Int -- ^ Textures width.+ -> Int -- ^ Textures height.+ -> Int -- ^ Number of colors.+ -> 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++-- | '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
+ Graphics/Rendering/Ombra/Layer/Internal.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ExistentialQuantification #-}++module Graphics.Rendering.Ombra.Layer.Internal where++import Data.Word (Word8)+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Object.Internal+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Texture++-- | 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++data Buffer = ColorBuffer | DepthBuffer | StencilBuffer++-- | 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++data LayerType = ColorLayer+ | DepthLayer+ | DepthStencilLayer+ | BufferLayer Int deriving Eq+
+ Graphics/Rendering/Ombra/Object.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE TypeOperators, DataKinds, ConstraintKinds, MultiParamTypeClasses,+ TypeFamilies, FlexibleContexts, FlexibleInstances #-}++module Graphics.Rendering.Ombra.Object (+ -- * Creating and modifying objects+ Object((:~>)),+ nothing,+ -- merge,+ geom,+ modifyGeometry,++ -- * Object properties+ depthTest,+ depthMask,+ colorMask,+ ShaderVars,+ VOShaderVars,+ -- ** Blending+ blend,+ noBlend,+ Blend.transparency,+ Blend.additive,+ -- ** Stencil test+ stencil,+ noStencil,+ -- ** Culling+ CullFace(..),+ cull,+ noCull,++ -- * Globals+ Global,+ (-=),+ withTexture,+ withTexSize,+ withFramebufferSize,+ -- ** Mirror globals+ mirror,+ CPUMirror,+ -- ** Modifying globals+ MemberGlobal((~~>)),+ RemoveGlobal((*~>)),+) where++import Data.Typeable+import Data.Type.Equality+import Data.Vect.Float+import Data.Word (Word8)+import Graphics.Rendering.Ombra.Backend (GLES)+import qualified Graphics.Rendering.Ombra.Blend as Blend+import qualified Graphics.Rendering.Ombra.Stencil as Stencil+import Graphics.Rendering.Ombra.Geometry+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Object.Internal+import Graphics.Rendering.Ombra.Internal.GL (ActiveTexture)+import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Shader.CPU hiding (mirror)+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Shader.ShaderVar+import Graphics.Rendering.Ombra.Shader.Stages+import Graphics.Rendering.Ombra.Texture++-- | Enable blending and set the blending mode for an 'Object'.+blend :: Blend.Mode -> Object gs is -> Object gs is+blend m = Prop . Blend $ Just m++-- | Disable blending for a 'Object'.+noBlend :: Object gs is -> Object gs is+noBlend = Prop $ Blend Nothing++-- | Enable stencil testing and set the stencil mode for an 'Object'.+stencil :: Stencil.Mode -> Object gs is -> Object gs is+stencil m = Prop . Stencil $ Just m++-- | Disable stencil testing on a 'Object' of objects.+noStencil :: Object gs is -> Object gs is+noStencil = Prop $ Stencil Nothing++-- | Enable/disable depth testing for a 'Object'.+depthTest :: Bool -> Object gs is -> Object gs is+depthTest d = Prop $ DepthTest d++-- | Enable/disable writing into the depth buffer for a 'Object'.+depthMask :: Bool -> Object gs is -> Object gs is+depthMask m = Prop $ DepthMask m++-- | Enable/disable writing into the four channels of the color buffer for a+-- 'Object'.+colorMask :: (Bool, Bool, Bool, Bool) -> Object gs is -> Object gs is+colorMask m = Prop $ ColorMask m++-- | Enable face culling.+cull :: CullFace -> Object gs is -> Object gs is+cull m = Prop . Cull $ Just m++-- | Disable face culling.+noCull :: Object gs is -> Object gs is+noCull = Prop $ Cull Nothing++-- | An empty object.+nothing :: Object '[] '[]+nothing = NoMesh++-- | An object with a specified 'Geometry'.+geom :: Geometry i -> Object '[] i+geom = Mesh++-- TODO: Either (CPU 'S g) (CPU 'M g) ???+class MemberGlobal g gs where+ -- | Modify the global of an 'Object'. This doesn't work with mirror+ -- globals.+ (~~>) :: (Uniform 'S g)+ => (CPU 'S g -> Global g) -- ^ Changing function+ -> Object gs is+ -> Object gs is++instance {-# OVERLAPPING #-} MemberGlobal g (g ': gs) where+ f ~~> (g :~> o) = globalApply f g :~> o+ f ~~> (Prop p o) = Prop p $ f ~~> o+ f ~~> (Append o o') = Append (f ~~> o) (f ~~> o')++instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, MemberGlobal g gs) =>+ MemberGlobal g (g1 ': gs) where+ f ~~> (g :~> o) = g :~> (f ~~> o)+ f ~~> (Prop p o) = Prop p $ f ~~> o+ f ~~> (Append o o') = Append (f ~~> o) (f ~~> o')+ +globalApply :: (Uniform 'S g)+ => (CPU 'S g -> Global g)+ -> Global g+ -> Global g+globalApply f (Single g c) = f c+globalApply f (WithTexture t g) = WithTexture t $ globalApply f . g+globalApply f (WithTextureSize t g) = WithTextureSize t $ globalApply f . g+globalApply f (WithFramebufferSize g) = WithFramebufferSize $ globalApply f . g+globalApply f g = g++infixr 2 ~~>++class RemoveGlobal g gs gs' where+ -- | Remove a global from an 'Object'.+ (*~>) :: (a -> g) -> Object gs is -> Object gs' is++instance {-# OVERLAPPING #-} RemoveGlobal g (g ': gs) gs where+ _ *~> (_ :~> o) = o+ r *~> (Prop p o) = Prop p $ r *~> o+ r *~> (Append o o') = Append (r *~> o) (r *~> o')++instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, RemoveGlobal g gs gs') =>+ RemoveGlobal g (g1 ': gs) (g1 ': gs') where+ r *~> (g :~> o) = g :~> (r *~> o)+ r *~> (Prop p o) = Prop p $ r *~> o+ r *~> (Append o o') = Append (r *~> o) (r *~> o')++infixr 2 *~>++-- | Modify the geometry of an 'Object'.+modifyGeometry :: (Geometry (i ': is) -> Geometry is')+ -> Object gs (i ': is) -> Object gs is'+modifyGeometry fg (g :~> o) = g :~> modifyGeometry fg o+modifyGeometry fg (Mesh g) = Mesh $ fg g+modifyGeometry fg (Prop p o) = Prop p $ modifyGeometry fg o+modifyGeometry fg (Append o o') = Append (modifyGeometry fg o)+ (modifyGeometry fg o')++-- | Create a 'Global' from a pure value. The first argument is ignored,+-- it just provides the type (you can use the constructor of the GPU type).+-- You can use this to set the value of a shader uniform.+(-=) :: (ShaderVar g, Uniform 'S g) => (a -> g) -> CPU 'S g -> Global g+(-=) = Single++infixr 4 -=++-- | Create a 'Global' activating a 'Texture'. Note that the corresponding CPU+-- type of 'Sampler2D' is 'ActiveTexture', not Texture.+withTexture :: Texture -> (ActiveTexture -> Global g) -> Global g+withTexture = WithTexture++-- | Create a 'Global' using the size of a 'Texture'.+withTexSize :: Texture -> ((Int, Int) -> Global g) -> Global g+withTexSize = WithTextureSize++-- | Create a 'Global' using the size of the framebuffer.+withFramebufferSize :: ((Int, Int) -> Global g) -> Global g+withFramebufferSize = WithFramebufferSize++-- | Like '-=' but for mirror types.+mirror :: (ShaderVar g, Uniform 'M g) => Proxy g -> CPU 'M g -> Global g+mirror = Mirror++{-+type EqualMerge x y v = EqualOrErr x y (Text "Can't merge groups with " :<>:+ Text "different " :<>: v :<>:+ Text "." :$$:+ Text " Left group " :<>: v :<>:+ Text ": " :<>: ShowType x :$$:+ Text " Right group " :<>: v :<>:+ Text ": " :<>: ShowType y)+++-- | Merge two objects. This is more generic than 'mappend'.+merge :: (EqualMerge gs gs' (Text "globals"), EqualMerge is is' (Text "inputs"))+ => Object gs is -> Object gs' is'+ -> Object (Union gs gs') (Union is is')+merge = Append+-}++{-+-- | Merge two objects, even if they don't provide the same variables.+unsafeMerge :: Object gs is -> Object gs' is'+ -> Object (Union gs gs') (Union is is')+unsafeMerge = Append+-}
+ Graphics/Rendering/Ombra/Object/Internal.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators,+ FlexibleContexts #-}++module Graphics.Rendering.Ombra.Object.Internal where++import Data.Proxy (Proxy)+import Data.Monoid+import Data.Vect.Float+import qualified Graphics.Rendering.Ombra.Blend as Blend+import qualified Graphics.Rendering.Ombra.Stencil as Stencil+import Graphics.Rendering.Ombra.Geometry+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.GL (ActiveTexture)+import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Shader.CPU+import Graphics.Rendering.Ombra.Shader.ShaderVar+import Graphics.Rendering.Ombra.Texture++-- | A geometry associated with some uniforms.+data Object (gs :: [*]) (is :: [*]) where+ -- | Add a Global to an Object.+ (:~>) :: Global g -> Object gs is -> Object (g ': gs) is+ Mesh :: Geometry is -> Object '[] is+ NoMesh :: Object gs is+ Prop :: ObjProp -> Object gs is -> Object gs is+ Append :: Object gs is -> Object gs is -> Object gs is++data ObjProp = Blend (Maybe Blend.Mode)+ | Stencil (Maybe Stencil.Mode)+ | Cull (Maybe CullFace)+ | DepthTest Bool+ | DepthMask Bool+ | ColorMask (Bool, Bool, Bool, Bool)++infixr 2 :~>++-- | The value of a GPU uniform.+data Global g where+ Single :: (ShaderVar g, Uniform 'S g)+ => (a -> g) -> (CPU 'S g) -> Global g+ Mirror :: (ShaderVar g, Uniform 'M g)+ => Proxy g -> (CPU 'M g) -> Global g+ WithTexture :: Texture -> (ActiveTexture -> Global g) -> Global g+ WithTextureSize :: Texture -> ((Int, Int) -> Global g) -> Global g+ WithFramebufferSize :: ((Int, Int) -> Global g) -> Global g+++-- Side(s) to be culled.+data CullFace = CullFront | CullBack | CullFrontBack deriving Eq++-- TODO: should be Semigroup, mempty is unsafe+instance (ShaderVars gs, ShaderVars is) => Monoid (Object gs is) where+ mempty = NoMesh+ mappend = Append
Graphics/Rendering/Ombra/Shapes.hs view
@@ -2,7 +2,6 @@ import Data.Vect.Float import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Types import Graphics.Rendering.Ombra.Internal.GL (GLES) rectGeometry :: GLES => Vec2 -> Geometry Geometry2D
Graphics/Rendering/Ombra/Texture.hs view
@@ -1,23 +1,18 @@-{-# LANGUAGE MultiParamTypeClasses #-}- module Graphics.Rendering.Ombra.Texture (+ Texture, mkTexture,- mkTextureRaw, mkTextureFloat,- setFilter,- emptyTexture+ mkTextureRaw,+ Filter(..),+ setFilter ) where import Data.Hashable- import Data.Vect.Float import Graphics.Rendering.Ombra.Backend (GLES)-import qualified Graphics.Rendering.Ombra.Backend as GL import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Types import Graphics.Rendering.Ombra.Internal.GL hiding (Texture)-import qualified Graphics.Rendering.Ombra.Internal.GL as GL-import Graphics.Rendering.Ombra.Internal.Resource+import Graphics.Rendering.Ombra.Texture.Internal -- | Creates a 'Texture' from a list of pixels. mkTexture :: GLES@@ -63,50 +58,3 @@ setFilter min mag (TextureImage (TextureFloat c _ _ w h s)) = TextureImage (TextureFloat c min mag w h s) setFilter _ _ t = t--instance GLES => Resource TextureImage LoadedTexture GL where- loadResource i = Right <$> loadTextureImage i- unloadResource _ (LoadedTexture _ _ t) = deleteTexture t--loadTextureImage :: GLES => TextureImage -> GL LoadedTexture-loadTextureImage (TexturePixels ps min mag w h hash) =- do arr <- liftIO . encodeUInt8s . take (fromIntegral $ w * h * 4) $- ps >>= \(Color r g b a) -> [r, g, b, a]- loadTextureImage $ TextureRaw arr min mag w h hash-loadTextureImage (TextureRaw arr min mag w h _) =- do t <- emptyTexture min mag- texImage2DUInt gl_TEXTURE_2D 0- (fromIntegral gl_RGBA)- w h 0- gl_RGBA- gl_UNSIGNED_BYTE- arr- return $ LoadedTexture (fromIntegral w)- (fromIntegral h)- t-loadTextureImage (TextureFloat ps min mag w h hash) =- do arr <- liftIO . encodeFloats . take (fromIntegral $ w * h * 4) $ ps- t <- emptyTexture min mag- texImage2DFloat gl_TEXTURE_2D 0- (fromIntegral gl_RGBA32F)- w h 0- gl_RGBA- gl_FLOAT- arr- return $ LoadedTexture (fromIntegral w)- (fromIntegral h)- t--emptyTexture :: GLES => Filter -> Filter -> GL GL.Texture-emptyTexture minf magf = do t <- createTexture- bindTexture gl_TEXTURE_2D t- param gl_TEXTURE_MIN_FILTER $ f minf- param gl_TEXTURE_MAG_FILTER $ f magf- param gl_TEXTURE_WRAP_S gl_REPEAT- param gl_TEXTURE_WRAP_T gl_REPEAT- return t- where f Linear = gl_LINEAR- f Nearest = gl_NEAREST-- param :: GLES => GLEnum -> GLEnum -> GL ()- param p v = texParameteri gl_TEXTURE_2D p $ fromIntegral v
+ Graphics/Rendering/Ombra/Texture/Internal.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Graphics.Rendering.Ombra.Texture.Internal where++import Data.Hashable+import Graphics.Rendering.Ombra.Backend (GLES)+import qualified Graphics.Rendering.Ombra.Backend as GL+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.GL hiding (Texture)+import qualified Graphics.Rendering.Ombra.Internal.GL as GL+import Graphics.Rendering.Ombra.Internal.Resource++-- | A texture.+data Texture = TextureImage TextureImage+ | TextureLoaded LoadedTexture+ deriving Eq+ +data TextureImage = TexturePixels [Color] Filter Filter GLSize GLSize Int+ | TextureRaw UInt8Array Filter Filter GLSize GLSize Int+ | TextureFloat [Float] Filter Filter GLSize GLSize Int++data Filter = Linear -- ^ Average of the four nearest pixels.+ | Nearest -- ^ Nearest pixel.+ deriving Eq++data LoadedTexture = LoadedTexture GLSize GLSize GL.Texture++instance Hashable TextureImage where+ hashWithSalt salt tex = hashWithSalt salt $ textureHash tex++instance Eq TextureImage where+ (TexturePixels _ _ _ _ _ h) == (TexturePixels _ _ _ _ _ h') = h == h'+ (TextureRaw _ _ _ _ _ h) == (TextureRaw _ _ _ _ _ h') = h == h'+ (TextureFloat _ _ _ _ _ h) == (TextureFloat _ _ _ _ _ h') = h == h'+ _ == _ = False++instance GLES => Eq LoadedTexture where+ LoadedTexture _ _ t == LoadedTexture _ _ t' = t == t'++textureHash :: TextureImage -> Int+textureHash (TexturePixels _ _ _ _ _ h) = h+textureHash (TextureRaw _ _ _ _ _ h) = h+textureHash (TextureFloat _ _ _ _ _ h) = h++instance GLES => Resource TextureImage LoadedTexture GL where+ loadResource i = Right <$> loadTextureImage i+ unloadResource _ (LoadedTexture _ _ t) = deleteTexture t++loadTextureImage :: GLES => TextureImage -> GL LoadedTexture+loadTextureImage (TexturePixels ps min mag w h hash) =+ do arr <- liftIO . encodeUInt8s . take (fromIntegral $ w * h * 4) $+ ps >>= \(Color r g b a) -> [r, g, b, a]+ loadTextureImage $ TextureRaw arr min mag w h hash+loadTextureImage (TextureRaw arr min mag w h _) =+ do t <- emptyTexture min mag+ texImage2DUInt gl_TEXTURE_2D 0+ (fromIntegral gl_RGBA)+ w h 0+ gl_RGBA+ gl_UNSIGNED_BYTE+ arr+ return $ LoadedTexture (fromIntegral w)+ (fromIntegral h)+ t+loadTextureImage (TextureFloat ps min mag w h hash) =+ do arr <- liftIO . encodeFloats . take (fromIntegral $ w * h * 4) $ ps+ t <- emptyTexture min mag+ texImage2DFloat gl_TEXTURE_2D 0+ (fromIntegral gl_RGBA32F)+ w h 0+ gl_RGBA+ gl_FLOAT+ arr+ return $ LoadedTexture (fromIntegral w)+ (fromIntegral h)+ t++emptyTexture :: GLES => Filter -> Filter -> GL GL.Texture+emptyTexture minf magf = do t <- createTexture+ bindTexture gl_TEXTURE_2D t+ param gl_TEXTURE_MIN_FILTER $ f minf+ param gl_TEXTURE_MAG_FILTER $ f magf+ param gl_TEXTURE_WRAP_S gl_REPEAT+ param gl_TEXTURE_WRAP_T gl_REPEAT+ return t+ where f Linear = gl_LINEAR+ f Nearest = gl_NEAREST++ param :: GLES => GLEnum -> GLEnum -> GL ()+ param p v = texParameteri gl_TEXTURE_2D p $ fromIntegral v
− Graphics/Rendering/Ombra/Types.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators, FlexibleContexts,- ExistentialQuantification, GeneralizedNewtypeDeriving #-}--module Graphics.Rendering.Ombra.Types (- Draw(..),- DrawState(..),- UniformLocation(..),- Texture(..),- TextureImage(..),- Filter(..),- LoadedTexture(..),- Geometry(..),- Group(..),- Object(..),- Global(..),- Layer(..),- Buffer(..),- RenderLayer(..),- LayerType(..),- CullFace(..)-) where--import Control.Applicative-import Control.Monad.IO.Class-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State-import Data.Hashable-import Data.Proxy (Proxy)-import Data.Vect.Float hiding (Vector)-import Data.Vector (Vector)-import Data.Typeable-import Data.Word (Word8)-import qualified Graphics.Rendering.Ombra.Blend as Blend-import qualified Graphics.Rendering.Ombra.Stencil as Stencil-import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Internal.GL hiding (Program, Texture,- UniformLocation, Buffer)-import qualified Graphics.Rendering.Ombra.Internal.GL as GL-import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Internal.Resource-import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Shader.ShaderVar--newtype UniformLocation = UniformLocation GL.UniformLocation---- | The state of the 'Draw' monad.-data DrawState = DrawState {- currentProgram :: Maybe (Program '[] '[]),- loadedProgram :: Maybe LoadedProgram,- programs :: ResMap (Program '[] '[]) LoadedProgram,- uniforms :: ResMap (LoadedProgram, String) UniformLocation,- gpuBuffers :: ResMap (Geometry '[]) GPUBufferGeometry,- gpuVAOs :: ResMap (Geometry '[]) GPUVAOGeometry,- textureImages :: ResMap TextureImage LoadedTexture,- activeTextures :: Vector (Maybe Texture),- viewportSize :: (Int, Int),- blendMode :: Maybe Blend.Mode,- stencilMode :: Maybe Stencil.Mode,- cullFace :: Maybe CullFace,- depthTest :: Bool,- depthMask :: Bool,- colorMask :: (Bool, Bool, Bool, Bool)-}---- | A state monad on top of 'GL'.-newtype Draw a = Draw { unDraw :: StateT DrawState GL a }- deriving (Functor, Applicative, Monad, MonadIO)--instance EmbedIO Draw where- embedIO f (Draw a) = Draw get >>= Draw . lift . embedIO f . evalStateT a---- | A texture.-data Texture = TextureImage TextureImage- | TextureLoaded LoadedTexture- deriving Eq- -data TextureImage = TexturePixels [Color] Filter Filter GLSize GLSize Int- | TextureRaw UInt8Array Filter Filter GLSize GLSize Int- | TextureFloat [Float] Filter Filter GLSize GLSize Int--data Filter = Linear -- ^ Average of the four nearest pixels.- | Nearest -- ^ Nearest pixel.- deriving Eq--data LoadedTexture = LoadedTexture GLSize GLSize GL.Texture---- | A group of 'Object's.-data Group (gs :: [*]) (is :: [*]) where- Empty :: Group gs is- Object :: Object gs is -> Group gs is- Global :: Global g -> Group gs is -> Group (g ': gs) is- Append :: Group gs is -> Group gs' is' -> Group gs'' is''- Blend :: Maybe Blend.Mode -> Group gs is -> Group gs is- Stencil :: Maybe Stencil.Mode -> Group gs is -> Group gs is- Cull :: Maybe CullFace -> Group gs is -> Group gs is- DepthTest :: Bool -> Group gs is -> Group gs is- DepthMask :: Bool -> Group gs is -> Group gs is- ColorMask :: (Bool, Bool, Bool, Bool) -> Group gs is -> Group gs is---- | A geometry associated with some uniforms.-data Object (gs :: [*]) (is :: [*]) where- (:~>) :: Global g -> Object gs is -> Object (g ': gs) is- Mesh :: Geometry is -> Object '[] is- NoMesh :: Object '[] '[]--infixr 2 :~>---- | The value of a GPU uniform.-data Global g where- (:=) :: (ShaderVar g, Uniform 'S g)- => (a -> g) -> Draw (CPU 'S g) -> Global g- Mirror :: (ShaderVar g, Uniform 'M g)- => Proxy g -> Draw (CPU 'M g) -> Global g--infix 3 :=---- | A 'Group' associated with a program.-data Layer = forall oi pi og pg. (Subset pi oi, Subset pg og)- => Layer (Program pg pi) (Group og oi)- | SubLayer (RenderLayer Layer)- | OverLayer Layer Layer- | ClearLayer [Buffer] Layer--data Buffer = ColorBuffer | DepthBuffer | StencilBuffer---- | 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--data LayerType = ColorLayer- | DepthLayer- | DepthStencilLayer- | BufferLayer Int deriving Eq---- Side(s) to be culled.-data CullFace = CullFront | CullBack | CullFrontBack deriving Eq--instance Hashable TextureImage where- hashWithSalt salt tex = hashWithSalt salt $ textureHash tex--instance Eq TextureImage where- (TexturePixels _ _ _ _ _ h) == (TexturePixels _ _ _ _ _ h') = h == h'- (TextureRaw _ _ _ _ _ h) == (TextureRaw _ _ _ _ _ h') = h == h'- (TextureFloat _ _ _ _ _ h) == (TextureFloat _ _ _ _ _ h') = h == h'- _ == _ = False--instance GLES => Eq LoadedTexture where- LoadedTexture _ _ t == LoadedTexture _ _ t' = t == t'--textureHash :: TextureImage -> Int-textureHash (TexturePixels _ _ _ _ _ h) = h-textureHash (TextureRaw _ _ _ _ _ h) = h-textureHash (TextureFloat _ _ _ _ _ h) = h
ombra.cabal view
@@ -1,21 +1,7 @@ name: ombra-version: 0.1.1.0+version: 0.2.0.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.- .- .- The modules you generally need to use are:- .- "Graphics.Rendering.Ombra.D3": 3D graphics- .- "Graphics.Rendering.Ombra.D2": 2D graphics- .- "Graphics.Rendering.Ombra.Generic": although both D3 and D2 export it, you may want to read the documentation- .- "Graphics.Rendering.Ombra.Shader": for creating shaders- .- "Graphics.Rendering.Ombra.Draw": this lets you render the pure objects you create with D2 and D3- . homepage: https://github.com/ziocroc/Ombra bug-reports: https://github.com/ziocroc/Ombra/issues license: BSD3@@ -37,27 +23,28 @@ description: Enable the OpenGL backend. Main module: Graphics.Rendering.Ombra.Backend.OpenGL flag webgl- description: Enable the GHCJS/WebGL backend, if compiled with GHCJS. Main module: Graphics.Rendering.Ombra.Backend.WebGL+ description: Enable the GHCJS/WebGL backend, if compiled with GHCJS. This automatically disables the OpenGL backend. Main module: Graphics.Rendering.Ombra.Backend.WebGL+ default: False library- exposed-modules: Graphics.Rendering.Ombra.Generic, Graphics.Rendering.Ombra.Blend, Graphics.Rendering.Ombra.Stencil, Graphics.Rendering.Ombra.Shader, Graphics.Rendering.Ombra.Transformation, Graphics.Rendering.Ombra.Draw, Graphics.Rendering.Ombra.Draw.Internal, Graphics.Rendering.Ombra.D2, Graphics.Rendering.Ombra.Geometry, Graphics.Rendering.Ombra.D3, Graphics.Rendering.Ombra.Types, Graphics.Rendering.Ombra.Texture, Graphics.Rendering.Ombra.Color, Graphics.Rendering.Ombra.Backend, Graphics.Rendering.Ombra.Shapes, Graphics.Rendering.Ombra.Internal.GL, 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.Default3D, Graphics.Rendering.Ombra.Shader.Default2D, Graphics.Rendering.Ombra.Shader.Language.Types, Graphics.Rendering.Ombra.Shader.Language.Functions- other-modules: Graphics.Rendering.Ombra.Internal.Resource, Graphics.Rendering.Ombra.Internal.TList+ 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 - if flag(webgl) && impl(ghcjs)+ if flag(webgl) exposed-modules: Graphics.Rendering.Ombra.Backend.WebGL other-modules: Graphics.Rendering.Ombra.Backend.WebGL.Raw, Graphics.Rendering.Ombra.Backend.WebGL.Types, Graphics.Rendering.Ombra.Backend.WebGL.Const - if flag(opengl) && !impl(ghcjs)+ if flag(opengl) && !flag(webgl) exposed-modules: Graphics.Rendering.Ombra.Backend.OpenGL other-extensions: TypeOperators, DataKinds, ConstraintKinds, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, RankNTypes, GADTs, TypeSynonymInstances, KindSignatures, UndecidableInstances, ExistentialQuantification, GeneralizedNewtypeDeriving, NullaryTypeClasses, PolyKinds, ScopedTypeVariables, FunctionalDependencies, DeriveDataTypeable, ImpredicativeTypes, RebindableSyntax - build-depends: base <5.0, vect <0.5, hashable <1.3, unordered-containers <0.3, vector <0.12, transformers <0.6, hashtables <1.4+ build-depends: base <5.0, vect <0.5, hashable <1.3, unordered-containers <0.3, transformers <0.6, hashtables <1.4 - if flag(opengl) && !impl(ghcjs)+ if flag(opengl) && !flag(webgl) build-depends: gl <0.8 - if flag(webgl) && impl(ghcjs)+ if flag(webgl) build-depends: ghcjs-base default-language: Haskell2010