ombra 0.3.0.0 → 0.3.1.0

raw patch · 36 files changed

+1371/−840 lines, 36 filesdep ~glPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: gl

API changes (from Hackage documentation)

Files

• CHANGES.md +8/−0
• Graphics/Rendering/Ombra/Backend.hs +21/−2
• Graphics/Rendering/Ombra/Backend/OpenGL.hs +15/−2
• Graphics/Rendering/Ombra/Backend/WebGL.hs +51/−34
• Graphics/Rendering/Ombra/Backend/WebGL/Raw.hs +1/−1
• Graphics/Rendering/Ombra/D2.hs +1/−1
• Graphics/Rendering/Ombra/D3.hs +35/−19
• Graphics/Rendering/Ombra/Draw.hs +17/−4
• Graphics/Rendering/Ombra/Draw/Internal.hs +103/−299
• Graphics/Rendering/Ombra/Geometry.hs +46/−136
• Graphics/Rendering/Ombra/Geometry/Internal.hs +232/−102
• Graphics/Rendering/Ombra/Geometry/Types.hs +165/−0
• Graphics/Rendering/Ombra/Internal/GL.hs +10/−2
• Graphics/Rendering/Ombra/Internal/Resource.hs +14/−3
• Graphics/Rendering/Ombra/Layer.hs +1/−0
• Graphics/Rendering/Ombra/Layer/Internal.hs +173/−58
• Graphics/Rendering/Ombra/Layer/Types.hs +70/−0
• Graphics/Rendering/Ombra/Object.hs +11/−9
• Graphics/Rendering/Ombra/Object/Internal.hs +59/−45
• Graphics/Rendering/Ombra/Object/Types.hs +53/−0
• Graphics/Rendering/Ombra/Screen.hs +13/−0
• Graphics/Rendering/Ombra/Shader.hs +4/−0
• Graphics/Rendering/Ombra/Shader/Default2D.hs +6/−3
• Graphics/Rendering/Ombra/Shader/Default3D.hs +22/−11
• Graphics/Rendering/Ombra/Shader/GLSL.hs +12/−3
• Graphics/Rendering/Ombra/Shader/Language.hs +3/−0
• Graphics/Rendering/Ombra/Shader/Language/Functions.hs +12/−0
• Graphics/Rendering/Ombra/Shader/Program.hs +65/−17
• Graphics/Rendering/Ombra/Shapes.hs +43/−46
• Graphics/Rendering/Ombra/Texture.hs +1/−0
• Graphics/Rendering/Ombra/Texture/Internal.hs +46/−37
• Graphics/Rendering/Ombra/Texture/Types.hs +43/−0
• Graphics/Rendering/Ombra/Vector.hs +2/−2
• LICENSE +1/−1
• README.md +4/−0
• ombra.cabal +8/−3

@@ -0,0 +1,8 @@+## 0.3.1++  * Split view and projection matrix in the default 3D shader+  * *~> and removeAttribute now have precise return types+  * Replaced mkGeometryInd with the GeometryBuilder monad functions+  * Added decompose and mapVertices Geometry functions+  * Added dFdx, dFdy, fwidth shader functions+  * Added extension checking functions

@@ -4,6 +4,7 @@  import Control.Concurrent (ThreadId) import Data.Bits (Bits)+import Data.Hashable (Hashable) import Data.Int import Data.Word import Foreign.Storable@@ -28,7 +29,9 @@       , Eq GLInt       , Eq GLPtrDiff       , Eq GLSize-      , Eq Texture) => GLES where+      , Eq Texture+      , Eq Program+      , Hashable Program) => GLES where         type Ctx         type GLEnum         type GLUInt@@ -56,9 +59,11 @@          true :: GLBool         false :: GLBool+        isTrue :: GLBool -> Bool         nullGLPtr :: GLPtr         -- arrayGLPtr :: Array -> (GLPtr -> IO a) -> IO a         toGLString :: String -> GLString+        fromGLString :: GLString -> String         noBuffer :: Buffer         noTexture :: Texture         noVAO :: VertexArrayObject@@ -85,6 +90,20 @@         fromUInt16Array :: UInt16Array -> AnyArray         decodeBytes :: UInt8Array -> IO [Word8] +        -- | This extension is fundamental and Ombra won't work without it.+        hasVertexArrayObjects :: Ctx -> IO Bool++        -- | Required for the buffers* layer functions. May not be supported+        -- on older hardware.+        hasFloatTextures :: Ctx -> IO Bool++        -- | Required for the buffers* layer functions. May not be supported+        -- on older hardware.+        hasDrawBuffers :: Ctx -> IO Bool++        -- | Required for the dFdx, dFdy and fwidth shader functions.+        hasStandardDerivatives :: Ctx -> IO Bool+         glActiveTexture :: Ctx -> GLEnum -> IO ()         glAttachShader :: Ctx -> Program -> Shader -> IO ()         glBindAttribLocation :: Ctx -> Program -> GLUInt -> GLString -> IO ()@@ -152,7 +171,7 @@         -- glGetFramebufferAttachmentParameter :: Ctx -> GLEnum -> GLEnum -> IO Word         glGetProgramInfoLog :: Ctx -> Program -> IO GLString         -- glGetRenderbufferParameter :: Ctx -> Word -> Word -> IO (JSRef a)-        -- glGetShaderParameter :: Ctx -> Shader -> Word -> IO (JSRef a)+        glGetShaderParameterBool :: Ctx -> Shader -> GLEnum -> IO GLBool         -- glGetShaderPrecisionFormat :: Ctx -> GLEnum -> GLEnum -> IO ShaderPrecisionFormat         glGetShaderInfoLog :: Ctx -> Shader -> IO GLString         glGetShaderSource :: Ctx -> Shader -> IO GLString

@@ -15,7 +15,8 @@ import Graphics.GL.Types as GL  makeContext :: IO Ctx-makeContext = return ()+makeContext =+        words <$> (GL.glGetString GL.GL_EXTENSIONS >>= peekCString . castPtr)  genToCreate :: Storable a => (GLsizei -> Ptr a -> IO ()) -> ctx -> IO a genToCreate gen _ = do ptr <- malloc@@ -66,7 +67,7 @@               size = len * sizeOf (head xs)  instance GLES where-        type Ctx = ()+        type Ctx = [String]         type GLEnum = GLenum         type GLUInt = GLuint         type GLInt = GLint@@ -92,8 +93,10 @@          true = 1         false = 0+        isTrue = (== 1)         nullGLPtr = nullPtr         toGLString = id+        fromGLString = id         noBuffer = 0         noTexture = 0         noVAO = 0@@ -134,6 +137,11 @@         fromUInt8Array (size, fptr) = (size, castForeignPtr fptr)         decodeBytes (s, f) = arrayToList (s, castForeignPtr f) +        hasVertexArrayObjects = return . elem "GL_ARB_vertex_array_object"+        hasFloatTextures = return . elem "GL_ARB_texture_float"+        hasDrawBuffers = return . const True+        hasStandardDerivatives = return . elem "GL_OES_standard_derivatives"+         glActiveTexture = const GL.glActiveTexture         glAttachShader = const GL.glAttachShader         glBindAttribLocation _ a b c = withCString c $ GL.glBindAttribLocation a b@@ -202,6 +210,11 @@         glGetProgramInfoLog = getString GL.glGetProgramInfoLog         glGetShaderInfoLog = getString GL.glGetShaderInfoLog         glGetShaderSource = getString GL.glGetShaderSource+        glGetShaderParameterBool _ a b = do ptr <- malloc+                                            GL.glGetShaderiv a b ptr+                                            value <- peek ptr+                                            free ptr+                                            return $ fromIntegral value         glGetUniformLocation _ a b = withCString b $ GL.glGetUniformLocation a         glHint = const GL.glHint         glIsBuffer = const GL.glIsBuffer

@@ -10,11 +10,12 @@ import Control.Concurrent import Data.Coerce import Data.Maybe+import Data.Hashable import qualified Data.HashMap.Strict as H import Data.Int (Int32) import Data.IORef import Data.List (unfoldr)-import Data.JSString (JSString, pack)+import Data.JSString (JSString, pack, unpack) import Data.Word import Graphics.Rendering.Ombra.Backend import qualified Graphics.Rendering.Ombra.Backend.WebGL.Const as JS@@ -61,32 +62,35 @@                      -> IO Float32Array  -data TagTex = TagTex Int JS.Texture+data TagTexture = TagTexture Int JS.Texture+data TagProgram = TagProgram Int JS.Program -instance Eq TagTex where-        TagTex t _ == TagTex t' _ = t == t'+instance Eq TagTexture where+        TagTexture t _ == TagTexture t' _ = t == t' +instance Eq TagProgram where+        TagProgram t _ == TagProgram t' _ = t == t'+        +instance Hashable TagProgram where+        hashWithSalt salt (TagProgram t _) = hashWithSalt salt t+ makeContext :: JSVal -- ^ Canvas element.             -> IO Ctx makeContext element = do ctx <- JS.getCtx element                          counter <- newIORef 0                          JS.getExtension ctx "WEBGL_depth_texture"-                         JS.getExtension ctx "OES_texture_float"-                         floatTexExt <--                                 JS.getExtension ctx "WEBGL_color_buffer_float"+                         JS.getExtension ctx "WEBGL_color_buffer_float"+                         floatTexExt <- JS.getExtension ctx "OES_texture_float"                          vaoExt <- JS.getExtension ctx "OES_vertex_array_object"                          drawBufsExt <- JS.getExtension ctx "WEBGL_draw_buffers"+                         derivativesExt <- JS.getExtension ctx+                                                "OES_standard_derivatives"                          setProp "floatTexExt" floatTexExt $ Object ctx                          setProp "vaoExt" vaoExt $ Object ctx                          setProp "drawBufs" drawBufsExt $ Object ctx+                         setProp "derivatives" derivativesExt $ Object ctx                          return (counter, ctx) -hasFloatTextures :: Ctx -> IO Bool-hasFloatTextures = (not . isNull <$>) .  getProp "floatTexExt" . Object . snd--hasDrawBuffers :: Ctx -> IO Bool-hasDrawBuffers = (not . isNull <$>) .  getProp "drawBufs" . Object . snd- toJSArray :: ToJSVal a => (v -> Maybe (a, v)) -> v -> IO JSArray.JSArray toJSArray next iv = JSArray.fromList <$> mapM toJSVal list         where list = unfoldr next iv@@ -111,9 +115,9 @@         type GLBool = Bool         type Buffer = JS.Buffer         type UniformLocation = JS.UniformLocation-        type Texture = TagTex+        type Texture = TagTexture         type Shader = JS.Shader-        type Program = JS.Program+        type Program = TagProgram         type FrameBuffer = JS.FrameBuffer         type RenderBuffer = JS.RenderBuffer         type VertexArrayObject = JS.VertexArrayObject@@ -127,10 +131,12 @@          true = True         false = False+        isTrue = id         nullGLPtr = 0         toGLString = pack+        fromGLString = unpack         noBuffer = JS.noBuffer-        noTexture = TagTex (-1) JS.noTexture+        noTexture = TagTexture (-1) JS.noTexture         noUInt8Array = nullUInt8Array         noFloat32Array = nullFloat32Array         noVAO = JS.noVAO@@ -224,13 +230,22 @@                          in return $ map (flip JSDataView.getUint8 dw)                                          [0 .. JS.length ar - 1] +        hasVertexArrayObjects =+                (not . isNull <$>) .  getProp "vaoExt" . Object . snd+        hasFloatTextures =+                (not . isNull <$>) .  getProp "floatTexExt" . Object . snd+        hasDrawBuffers =+                (not . isNull <$>) .  getProp "drawBufs" . Object . snd+        hasStandardDerivatives =+                (not . isNull <$>) .  getProp "derivatives" . Object . snd+         glActiveTexture = JS.glActiveTexture . snd-        glAttachShader = JS.glAttachShader . snd-        glBindAttribLocation = JS.glBindAttribLocation . snd+        glAttachShader (_, c) (TagProgram _ p) s = JS.glAttachShader c p s+        glBindAttribLocation (_, c) (TagProgram _ p) = JS.glBindAttribLocation c p         glBindBuffer = JS.glBindBuffer . snd         glBindFramebuffer = JS.glBindFramebuffer . snd         glBindRenderbuffer = JS.glBindRenderbuffer . snd-        glBindTexture (_, c) e (TagTex _ t) = JS.glBindTexture c e t+        glBindTexture (_, c) e (TagTexture _ t) = JS.glBindTexture c e t         glBindVertexArray = JS.glBindVertexArrayOES . snd         glBlendColor = JS.glBlendColor . snd         glBlendEquation = JS.glBlendEquation . snd@@ -252,25 +267,27 @@         glCopyTexSubImage2D = JS.glCopyTexSubImage2D . snd         glCreateBuffer = JS.glCreateBuffer . snd         glCreateFramebuffer = JS.glCreateFramebuffer . snd-        glCreateProgram = JS.glCreateProgram . snd+        glCreateProgram (r, c) = do p <- JS.glCreateProgram c+                                    n <- atomicModifyIORef' r $ \n -> (n + 1, n)+                                    return $ TagProgram n p         glCreateRenderbuffer = JS.glCreateRenderbuffer . snd         glCreateShader = JS.glCreateShader . snd         glCreateTexture (r, c) = do t <- JS.glCreateTexture c                                     n <- atomicModifyIORef' r $ \n -> (n + 1, n)-                                    return $ TagTex n t+                                    return $ TagTexture n t         glCreateVertexArray = JS.glCreateVertexArrayOES . snd         glCullFace = JS.glCullFace . snd         glDeleteBuffer = JS.glDeleteBuffer . snd         glDeleteFramebuffer = JS.glDeleteFramebuffer . snd-        glDeleteProgram = JS.glDeleteProgram . snd+        glDeleteProgram (_, c) (TagProgram _ p) = JS.glDeleteProgram c p         glDeleteRenderbuffer = JS.glDeleteRenderbuffer . snd         glDeleteShader = JS.glDeleteShader . snd-        glDeleteTexture (_, c) (TagTex _ t) = JS.glDeleteTexture c t+        glDeleteTexture (_, c) (TagTexture _ t) = JS.glDeleteTexture c t         glDeleteVertexArray = JS.glDeleteVertexArrayOES . snd         glDepthFunc = JS.glDepthFunc . snd         glDepthMask = JS.glDepthMask . snd         glDepthRange = JS.glDepthRange . snd-        glDetachShader = JS.glDetachShader . snd+        glDetachShader (_, c) (TagProgram _ p) = JS.glDetachShader c p         glDisable = JS.glDisable . snd         glDisableVertexAttribArray = JS.glDisableVertexAttribArray . snd         glDrawArrays = JS.glDrawArrays . snd@@ -281,39 +298,39 @@         glFinish = JS.glFinish . snd         glFlush = JS.glFlush . snd         glFramebufferRenderbuffer = JS.glFramebufferRenderbuffer . snd-        glFramebufferTexture2D (_, ctx) a b c (TagTex _ t) d =+        glFramebufferTexture2D (_, ctx) a b c (TagTexture _ t) d =                 JS.glFramebufferTexture2D ctx a b c t d         glFrontFace = JS.glFrontFace . snd         glGenerateMipmap = JS.glGenerateMipmap . snd         -- glGetActiveAttrib = JS.glGetActiveAttrib . snd         -- glGetActiveUniform = JS.glGetActiveUniform . snd-        glGetAttribLocation = JS.glGetAttribLocation . snd+        glGetAttribLocation (_, c) (TagProgram _ p) = JS.glGetAttribLocation c p         -- glGetBufferParameter = JS.glGetBufferParameter . snd         -- glGetParameter = JS.glGetParameter . snd         glGetError = JS.glGetError . snd         -- glGetFramebufferAttachmentParameter = JS.glGetFramebufferAttachmentParameter . snd-        glGetProgramInfoLog = JS.glGetProgramInfoLog . snd+        glGetProgramInfoLog (_, c) (TagProgram _ p) = JS.glGetProgramInfoLog c p         -- glGetRenderbufferParameter = JS.glGetRenderbufferParameter . snd-        -- glGetShaderParameter = JS.glGetShaderParameter . snd+        glGetShaderParameterBool = JS.glGetShaderParameterBool . snd         -- glGetShaderPrecisionFormat = JS.glGetShaderPrecisionFormat . snd         glGetShaderInfoLog = JS.glGetShaderInfoLog . snd         glGetShaderSource = JS.glGetShaderSource . snd         -- glGetTexParameter = JS.glGetTexParameter . snd         -- glGetUniform = JS.glGetUniform . snd-        glGetUniformLocation = JS.glGetUniformLocation . snd+        glGetUniformLocation (_, c) (TagProgram _ p) = JS.glGetUniformLocation c p         -- glGetVertexAttrib = JS.glGetVertexAttrib . snd         -- glGetVertexAttribOffset = JS.glGetVertexAttribOffset . snd         glHint = JS.glHint . snd         glIsBuffer = JS.glIsBuffer . snd         glIsEnabled = JS.glIsEnabled . snd         glIsFramebuffer = JS.glIsFramebuffer . snd-        glIsProgram = JS.glIsProgram . snd+        glIsProgram (_, c) (TagProgram _ p) = JS.glIsProgram c p         glIsRenderbuffer = JS.glIsRenderbuffer . snd         glIsShader = JS.glIsShader . snd-        glIsTexture (_, c) (TagTex _ t) = JS.glIsTexture c t+        glIsTexture (_, c) (TagTexture _ t) = JS.glIsTexture c t         glIsVertexArray = JS.glIsVertexArrayOES . snd         glLineWidth = JS.glLineWidth . snd-        glLinkProgram = JS.glLinkProgram . snd+        glLinkProgram (_, c) (TagProgram _ p) = JS.glLinkProgram c p         glPixelStorei = JS.glPixelStorei . snd         glPolygonOffset = JS.glPolygonOffset . snd         glReadPixels = JS.glReadPixels . snd@@ -352,8 +369,8 @@         glUniformMatrix2fv (_, c) loc _ arr = JS.glUniformMatrix2fv c loc False arr         glUniformMatrix3fv (_, c) loc _ arr = JS.glUniformMatrix3fv c loc False arr         glUniformMatrix4fv (_, c) loc _ arr = JS.glUniformMatrix4fv c loc False arr-        glUseProgram = JS.glUseProgram . snd-        glValidateProgram = JS.glValidateProgram . snd+        glUseProgram (_, c) (TagProgram _ p) = JS.glUseProgram c p+        glValidateProgram (_, c) (TagProgram _ p) = JS.glValidateProgram c p         glVertexAttrib1f = JS.glVertexAttrib1f . snd         glVertexAttrib1fv = JS.glVertexAttrib1fv . snd         glVertexAttrib2f = JS.glVertexAttrib2f . snd

@@ -204,7 +204,7 @@         glGetRenderbufferParameter :: Ctx -> Word -> Word -> IO JSVal  foreign import javascript unsafe "$1.getShaderParameter($2, $3)"-        glGetShaderParameter :: Ctx -> Shader -> Word -> IO JSVal+        glGetShaderParameterBool :: Ctx -> Shader -> Word -> IO Bool  foreign import javascript unsafe "$1.getShaderPrecisionFormat($2, $3)"         glGetShaderPrecisionFormat :: Ctx -> Word -> Word -> IO ShaderPrecisionFormat

@@ -64,7 +64,7 @@ rect = flip poly rectGeometry  -- | A 2D object with a specified 'Geometry'.-poly :: GLES => Texture -> Geometry is -> Object Uniforms2D is+poly :: GLES => Texture -> Geometry (i ': is) -> Object Uniforms2D (i ': is) poly t g = withTexture t (Image -=) :~>            Depth -= 0 :~>            Transform2 -= idmtx :~>

@@ -20,9 +20,10 @@         transform,         -- * Layers         view,+        proj,         viewPersp,         viewOrtho,-        viewVP,+        viewProj,         layerS,         -- * Matrices         -- ** View matrices@@ -43,6 +44,7 @@         Texture2(..),         Transform3(..),         View3(..),+        Project3(..) ) where  import Graphics.Rendering.Ombra.Backend hiding (Texture, Program)@@ -54,33 +56,43 @@ import Graphics.Rendering.Ombra.Shapes import Graphics.Rendering.Ombra.Vector import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Shader.Default3D (Texture2(..), Transform3(..), View3(..))+import Graphics.Rendering.Ombra.Shader.Default3D+        (Texture2(..), Transform3(..), View3(..), Project3(..)) 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, without the 'View3' matrix.+-- | A standard 3D object, without the 'View3' and 'Project3' matrix. type Object3D = Object Uniforms3D Geometry3D  -- | 3D objects compatible with the standard 3D shader program.-type IsObject3D gs is = ( Subset Geometry3D is, Subset (View3 ': Uniforms3D) gs-                        , ShaderVars is, ShaderVars gs )+type IsObject3D gs is = ( Subset Geometry3D is+                        , Subset (Project3 ': View3 ': Uniforms3D) gs+                        , ShaderVars is+                        , ShaderVars gs )  -- | A cube with a specified 'Texture'. cube :: GLES => Texture -> Object3D cube = flip mesh cubeGeometry  -- | A 3D object with a specified 'Geometry'.-mesh :: GLES => Texture -> Geometry is -> Object Uniforms3D is+mesh :: GLES => Texture -> Geometry (i ': is) -> Object Uniforms3D (i ': is) mesh t g = Transform3 -= idmtx :~> withTexture t (Texture2 -=) :~> geom g --- | Create a group of objects with a view matrix.+-- | Create a group of objects with a view matrix and use the identity matrix as+-- a projection matrix. view :: (GLES, ShaderVars gs, ShaderVars is)-     => Mat4 -> [Object gs is] -> Object (View3 ': gs) is-view m = viewVP $ const m+     => Mat4 -> [Object gs is] -> Object (Project3 ': View3 ': gs) is+view m = viewProj (const m) (const idmtx) +-- | Create a group of objects with a projection matrix and use the identity+-- matrix as a view matrix.+proj :: (GLES, ShaderVars gs, ShaderVars is)+     => Mat4 -> [Object gs is] -> Object (Project3 ': View3 ': gs) is+proj m = viewProj (const idmtx) (const m)+ -- | Create a group of objects with a view matrix and perspective projection. viewPersp :: (GLES, ShaderVars gs, ShaderVars is)           => Float      -- ^ Near@@ -88,8 +100,8 @@           -> Float      -- ^ FOV           -> Mat4       -- ^ View matrix           -> [Object gs is]-          -> Object (View3 ': gs) is-viewPersp n f fov m = viewVP $ \s -> m .*. perspectiveMat4Size n f fov s+          -> Object (Project3 ': View3 ': gs) is+viewPersp n f fov m = viewProj (const m) (perspectiveMat4Size n f fov)  -- | Create a group of objects with a view matrix and orthographic projection. viewOrtho :: (GLES, ShaderVars gs, ShaderVars is)@@ -101,15 +113,19 @@           -> Float      -- ^ Top           -> Mat4       -- ^ View matrix           -> [Object gs is]-          -> Object (View3 ': gs) is-viewOrtho n f l r b t m = view $ m .*. orthoMat4 n f l r b t+          -> Object (Project3 ': View3 ': gs) is+viewOrtho n f l r b t m = viewProj (const m) (const $ 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] -> Object (View3 ': gs) is-viewVP mf o = withFramebufferSize (\s -> View3 -= mf (tupleToVec s))-              :~> mconcat o+-- | Create a group of objects with a view matrix and a projection matrix,+-- depending on the size of the framebuffer.+viewProj :: (GLES, ShaderVars gs, ShaderVars is)+         => (Vec2 -> Mat4)      -- ^ View matrix+         -> (Vec2 -> Mat4)      -- ^ Projection matrix+         -> [Object gs is]+         -> Object (Project3 ': View3 ': gs) is+viewProj v p o =     withFramebufferSize (\s -> Project3 -= p (tupleToVec s))+                 :~> withFramebufferSize (\s -> View3 -= v (tupleToVec s))+                 :~> mconcat o         where tupleToVec (w, h) = Vec2 (fromIntegral w) (fromIntegral h)  -- | A 'Layer' with the standard 3D program.

@@ -9,26 +9,37 @@         evalDrawCtx,         drawState,         -- * Draw actions+        MonadGL(gl),+        MonadScreen(resizeViewport),+        MonadObject,         drawInit,         clearBuffers,         drawLayer,-        resizeViewport,         -- ** Resources         -- $resources+        ResStatus(..),         preloadGeometry,         preloadTexture,         preloadProgram,         removeGeometry,         removeTexture,         removeProgram,-        -- *-        gl+        checkGeometry,+        checkTexture,+        checkProgram,+        -- * Extensions+        hasVertexArrayObjects,+        hasFloatTextures,+        hasDrawBuffers,+        hasStandardDerivatives, ) where  import Data.IORef import Graphics.Rendering.Ombra.Draw.Internal+import Graphics.Rendering.Ombra.Object.Internal import Graphics.Rendering.Ombra.Internal.GL hiding (Buffer) import Graphics.Rendering.Ombra.Layer+import Graphics.Rendering.Ombra.Screen  -- | Run a Draw action using an IORef and a context. refDrawCtx :: GLES => Ctx -> Draw a -> IORef DrawState -> IO a@@ -57,4 +68,6 @@ -- alive by their corresponding CPU resources. Specifically, these resources are -- Geometries, Textures and Programs. This means that, when a CPU resource is -- garbage collected, the GPU resource is also removed. The functions below let--- you manage allocation and deallocation manually.+-- you manage allocation and deallocation manually. Note that if you try to use+-- a resource that was deallocated with the remove* functions it will be+-- allocated again.

@@ -1,10 +1,11 @@ {-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances,              FlexibleInstances, MultiParamTypeClasses, KindSignatures,-             GeneralizedNewtypeDeriving, PolyKinds #-}+             GeneralizedNewtypeDeriving, PolyKinds, TypeOperators #-}  module Graphics.Rendering.Ombra.Draw.Internal (         Draw,         DrawState,+        ResStatus(..),         drawState,         drawInit,         clearBuffers,@@ -16,6 +17,9 @@         removeGeometry,         removeTexture,         removeProgram,+        checkGeometry,+        checkTexture,+        checkProgram,         textureSize,         setProgram,         resizeViewport,@@ -26,13 +30,16 @@         drawGet ) where -import Data.Proxy 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 hiding (clear)+import Graphics.Rendering.Ombra.Geometry.Types+import Graphics.Rendering.Ombra.Layer.Internal+import Graphics.Rendering.Ombra.Layer.Types import Graphics.Rendering.Ombra.Object.Internal+import Graphics.Rendering.Ombra.Object.Types import Graphics.Rendering.Ombra.Texture.Internal+import Graphics.Rendering.Ombra.Texture.Types import Graphics.Rendering.Ombra.Backend (GLES) import qualified Graphics.Rendering.Ombra.Backend as GL import Graphics.Rendering.Ombra.Internal.GL hiding (Texture, Program, Buffer,@@ -40,19 +47,15 @@                                                     depthMask, colorMask) import qualified Graphics.Rendering.Ombra.Internal.GL as GL import Graphics.Rendering.Ombra.Internal.Resource-import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.GLSL+import Graphics.Rendering.Ombra.Screen import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Shader.ShaderVar import qualified Graphics.Rendering.Ombra.Stencil.Internal as Stencil import Graphics.Rendering.Ombra.Vector  import Data.Hashable (Hashable)-import Data.Word (Word8) import Control.Monad (when) import Control.Monad.IO.Class import Control.Monad.Trans.Class-import Control.Monad.Trans.Except import Control.Monad.Trans.State  -- | The state of the 'Draw' monad.@@ -75,8 +78,6 @@         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)@@ -84,6 +85,62 @@ instance EmbedIO Draw where         embedIO f (Draw a) = Draw get >>= Draw . lift . embedIO f . evalStateT a +instance GLES => MonadScreen Draw where+        currentViewport = viewportSize <$> Draw get+        resizeViewport w h = do setViewport w h+                                Draw . modify $ \s ->+                                        s { viewportSize = (w, h) }++instance GLES => MonadProgram Draw where+        withProgram p act =+                do current <- currentProgram <$> Draw get+                   when (current /= Just (programIndex p)) $+                           getProgram p >>= \elp ->+                                case elp of+                                     Right lp -> do Draw . modify $ \s ->+                                                     s { currentProgram = Just $+                                                             programIndex p+                                                       , loadedProgram = Just lp+                                                       , activeTextures = 0+                                                       }+                                                    act lp+                                     Left _ -> return ()+        getUniform name = do mprg <- loadedProgram <$> Draw get+                             case mprg of+                                  Just prg -> do map <- uniforms <$> Draw get+                                                 gl $ getResource' prg+                                                                   (prg, name)+                                                                   map+                                  Nothing -> return $ Left "No loaded program."++instance GLES => MonadDrawingMode Draw where+        withBlendMode m a = stateReset blendMode setBlendMode m a+        withStencilMode m a = stateReset stencilMode setStencilMode m a+        withDepthTest d a = stateReset depthTest setDepthTest d a+        withDepthMask m a = stateReset depthMask setDepthMask m a+        withColorMask m a = stateReset colorMask setColorMask m a+        withCulling face a = stateReset cullFace setCullFace face a++        -- where tupleToVec (x, y) = Vec2 (fromIntegral x) (fromIntegral y)++instance GLES => MonadTexture Draw where+        getTexture (TextureLoaded l) = return $ Right l+        getTexture (TextureImage t) = getTextureImage t+        getActiveTexturesCount = activeTextures <$> Draw get+        setActiveTexturesCount n = Draw . modify  $ \s ->+                                        s { activeTextures = n }+        newTexture w h fm fM = gl $ LoadedTexture w' h' <$> emptyTexture fm fM+                where (w', h') = (fromIntegral w, fromIntegral h)+        unusedTexture = removeTexture . TextureLoaded++instance GLES => MonadGeometry Draw where+        getAttribute = getDrawResource gl attributes+        getElementBuffer = getDrawResource gl elemBuffers+        getGeometry = getDrawResource id geometries++instance MonadGL Draw where+        gl = Draw . lift+ -- | Create a 'DrawState'. drawState :: GLES           => Int         -- ^ Viewport width@@ -151,34 +208,25 @@          -> GL a evalDraw (Draw a) = evalStateT a --- | Viewport.-resizeViewport :: GLES-               => Int   -- ^ Width.-               -> Int   -- ^ Height.-               -> Draw ()-resizeViewport w h = do gl $ viewport 0 0 (fromIntegral w) (fromIntegral h)-                        Draw . modify $ \s -> s { viewportSize = (w, h) }--clearBuffers :: GLES => [Buffer] -> Draw ()-clearBuffers = mapM_ $ gl . clear . buffer-        where buffer ColorBuffer = gl_COLOR_BUFFER_BIT-              buffer DepthBuffer = gl_DEPTH_BUFFER_BIT-              buffer StencilBuffer = gl_STENCIL_BUFFER_BIT+left :: Either String a -> Maybe String+left (Left x) = Just x+left _ = Nothing --- | Manually allocate a 'Geometry' in the GPU.-preloadGeometry :: GLES => Geometry is -> Draw ()-preloadGeometry g = () <$ getGeometry g+-- | Manually allocate a 'Geometry' in the GPU. Eventually returns an error+-- string.+preloadGeometry :: GLES => Geometry (i ': is) -> Draw (Maybe String)+preloadGeometry g = left <$> getGeometry g  -- | Manually allocate a 'Texture' in the GPU.-preloadTexture :: GLES => Texture -> Draw ()-preloadTexture t = () <$ getTexture t+preloadTexture :: GLES => Texture -> Draw (Maybe String)+preloadTexture t = left <$> getTexture t  -- | Manually allocate a 'Program' in the GPU.-preloadProgram :: GLES => Program gs is -> Draw ()-preloadProgram p = () <$ getProgram p+preloadProgram :: GLES => Program gs is -> Draw (Maybe String)+preloadProgram p = left <$> getProgram p --- | Manually delete a 'Geometry' from the GPU. Note that if you try to draw it, it will be allocated again.-removeGeometry :: GLES => Geometry is -> Draw ()+-- | Manually delete a 'Geometry' from the GPU.+removeGeometry :: GLES => Geometry (i ': is) -> Draw () removeGeometry g = removeDrawResource id geometries g  -- | Manually delete a 'Texture' from the GPU.@@ -191,65 +239,23 @@ removeProgram :: GLES => Program gs is -> Draw () removeProgram = removeDrawResource gl programs --- | Draw a 'Layer'.-drawLayer :: GLES => Layer' Drawable t a -> Draw a-drawLayer = fmap fst . flip drawLayer' []+-- | Check if a 'Geometry' failed to load.+checkGeometry :: GLES => Geometry (i ': is) -> Draw (ResStatus ())+checkGeometry g = fmap (const ()) <$> checkDrawResource id geometries g -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)+-- | Check if a 'Texture' failed to load. Eventually returns the texture width+-- and height.+checkTexture :: (GLES, Num a) => Texture -> Draw (ResStatus (a, a))+checkTexture (TextureImage i) =+        fmap loadedTextureSize <$> checkDrawResource gl textureImages i+checkTexture (TextureLoaded l) = return $ Loaded (loadedTextureSize l) --- | Draw an 'Object'.-drawObject :: GLES => Object gs is -> Draw ()-drawObject (g :~> o) = withGlobal g $ drawObject o-drawObject (Mesh g) = withRes_ (getGeometry g) drawGeometry-drawObject NoMesh = return ()-drawObject (Prop p o) = withObjProp p $ drawObject o-drawObject (Append o o') = drawObject o >> drawObject o'+loadedTextureSize :: (GLES, Num a) => LoadedTexture -> (a, a)+loadedTextureSize (LoadedTexture w h _) = (fromIntegral w, fromIntegral h) -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+-- | Check if a 'Program' failed to load.+checkProgram :: GLES => Program gs is -> Draw (ResStatus ())+checkProgram p = fmap (const ()) <$> checkDrawResource gl programs p  stateReset :: (DrawState -> a) -> (a -> Draw ()) -> a -> Draw b -> Draw b stateReset getOld set new act = do old <- getOld <$> Draw get@@ -258,80 +264,6 @@                                    set old                                    return b -withGlobal :: GLES => Global g -> Draw () -> Draw ()-withGlobal (Single g c) a = uniform (Proxy :: Proxy 'S)  (g undefined) c >> a-withGlobal (Mirror g c) a = uniform (Proxy :: Proxy 'M)-                                    (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 $-                        \n ug uc -> withRes_ (getUniform $ uniformName g n) $-                                \(UniformLocation l) -> gl $ setUniform l ug uc-                                                                --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))-                          $ \(LoadedTexture w h _) -> return ( fromIntegral w-                                                             , fromIntegral h)---- | Set the program.-setProgram :: GLES => Program g i -> Draw ()-setProgram p = do current <- currentProgram <$> Draw get-                  when (current /= Just (programIndex p)) $-                        withRes_ (getProgram p) $-                                \lp@(LoadedProgram glp _ _) -> do-                                   Draw . modify $ \s -> s {-                                           currentProgram =-                                                   Just $ programIndex p,-                                           loadedProgram = Just lp,-                                           activeTextures = 0-                                   }-                                   gl $ useProgram glp--withRes_ :: Draw (Either String a) -> (a -> Draw ()) -> Draw ()-withRes_ drs = withRes drs $ return ()--withRes :: Draw (Either String a) -> Draw b -> (a -> Draw b) -> Draw b-withRes drs u l = drs >>= \rs -> case rs of-                                      Right r -> l r-                                      _ -> u--getUniform :: GLES => String -> Draw (Either String UniformLocation)-getUniform name = do mprg <- loadedProgram <$> Draw get-                     case mprg of-                          Just prg -> getDrawResource gl uniforms (prg, name)-                          Nothing -> return $ Left "No loaded program."--getGeometry :: GLES => Geometry is -> Draw (Either String LoadedGeometry)-getGeometry = getDrawResource id geometries--getTexture :: GLES => Texture -> Draw (Either String LoadedTexture)-getTexture (TextureLoaded l) = return $ Right l-getTexture (TextureImage t) = getTextureImage t- getTextureImage :: GLES => TextureImage                 -> Draw (Either String LoadedTexture) getTextureImage = getDrawResource gl textureImages@@ -339,115 +271,6 @@ getProgram :: GLES => Program gs is -> Draw (Either String LoadedProgram) getProgram = getDrawResource gl programs --- | Draw a 'Layer' on some textures.-layerToTexture :: (GLES, Integral a)-               => Bool                                  -- ^ Draw buffers-               -> [LayerType]                           -- ^ Textures contents-               -> a                                     -- ^ Width-               -> a                                     -- ^ Height-               -> Layer' s t x                          -- ^ Layer to draw-               -> Either b ( [Color] -> Draw b-                           , Int, Int, Int, Int)        -- ^ Color inspecting-                                                        -- function, start x,-                                                        -- start y, width,-                                                        -- height-               -> Either c ( [Word8] -> Draw c-                           , Int, Int, Int, Int)        -- ^ Depth inspecting,-                                                        -- function, etc.-               -> [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 (x, tts', colRes, depthRes)--        return (x, tts', ts, colRes, depthRes)--        where (w, h) = (fromIntegral wp, fromIntegral hp)-              arguments stype =-                        case stype of-                              ColorLayer -> ( fromIntegral gl_RGBA-                                            , gl_RGBA-                                            , gl_UNSIGNED_BYTE-                                            , gl_COLOR_ATTACHMENT0-                                            , [ColorBuffer] )-                              DepthLayer -> ( fromIntegral gl_DEPTH_COMPONENT-                                            , gl_DEPTH_COMPONENT-                                            , gl_UNSIGNED_SHORT-                                            , gl_DEPTH_ATTACHMENT-                                            , [DepthBuffer] )-                              DepthStencilLayer -> ( fromIntegral-                                                        gl_DEPTH_STENCIL-                                                   , gl_DEPTH_STENCIL-                                                   , gl_UNSIGNED_INT_24_8-                                                   , gl_DEPTH_STENCIL_ATTACHMENT-                                                   , [ DepthBuffer-                                                     , StencilBuffer]-                                                   )-                              BufferLayer n -> ( fromIntegral gl_RGBA32F-                                               , gl_RGBA-                                               , gl_FLOAT-                                               , gl_COLOR_ATTACHMENT0 + -                                                 fromIntegral n-                                               , [] )--              inspect :: Either c (a -> Draw c, Int, Int, Int, Int) -> GLEnum-                      -> ([Word8] -> a) -> Int -> Draw c-              inspect (Left r) _ _ _ = return r-              inspect (Right (insp, x, y, rw, rh)) format trans s =-                        do arr <- liftIO . newByteArray $-                                        fromIntegral rw * fromIntegral rh * s-                           gl $ readPixels (fromIntegral x)-                                           (fromIntegral y)-                                           (fromIntegral rw)-                                           (fromIntegral rh)-                                           format gl_UNSIGNED_BYTE arr-                           liftIO (decodeBytes arr) >>= insp . trans-              wordsToColors (r : g : b : a : xs) = Color r g b a :-                                                   wordsToColors xs-              wordsToColors _ = []--renderToTexture :: GLES-                => Bool -> [(GLInt, GLEnum, GLEnum, GLEnum, [Buffer])]-                -> GLSize -> GLSize -> Draw a -> Draw ([GL.Texture], a)-renderToTexture drawBufs infos w h act = do-        fb <- gl createFramebuffer -        gl $ bindFramebuffer gl_FRAMEBUFFER fb--        (ts, attchs, buffersToClear) <- fmap unzip3 . gl . flip mapM infos $-                \(internalFormat, format, pixelType, attachment, buffer) ->-                        do t <- emptyTexture (Linear, Nothing) Linear-                           bindTexture gl_TEXTURE_2D t-                           if pixelType == gl_FLOAT-                           then liftIO noFloat32Array >>=-                                            texImage2DFloat gl_TEXTURE_2D 0-                                                            internalFormat w h-                                                            0 format pixelType-                           else liftIO noUInt8Array >>=-                                     texImage2DUInt gl_TEXTURE_2D 0-                                                    internalFormat w h-                                                    0 format pixelType-                           framebufferTexture2D gl_FRAMEBUFFER attachment-                                                gl_TEXTURE_2D t 0-                           return (t, fromIntegral attachment, buffer)--        let buffersToDraw = filter (/= fromIntegral gl_DEPTH_ATTACHMENT) attchs-        when drawBufs $ liftIO (encodeInts buffersToDraw) >>= gl . drawBuffers--        (sw, sh) <- viewportSize <$> Draw get-        resizeViewport (fromIntegral w) (fromIntegral h)--        clearBuffers $ concat buffersToClear-        ret <- act--        resizeViewport sw sh-        gl $ deleteFramebuffer fb--        return (ts, ret)- setBlendMode :: GLES => Maybe Blend.Mode -> Draw () setBlendMode Nothing = do m <- blendMode <$> Draw get                           case m of@@ -559,6 +382,15 @@         map <- mg <$> Draw get         lft $ getResource i map +checkDrawResource :: Resource i r m+                  => (m (ResStatus r) -> Draw (ResStatus r))+                  -> (DrawState -> ResMap r)+                  -> i+                  -> Draw (ResStatus r)+checkDrawResource lft mg i = do+        map <- mg <$> Draw get+        lft $ checkResource i map+ removeDrawResource :: (Resource i r m, Hashable i)                    => (m () -> Draw ())                    -> (DrawState -> ResMap r)@@ -567,34 +399,6 @@ removeDrawResource lft mg i = do         s <- mg <$> Draw get         lft $ removeResource i s--drawGeometry :: GLES => LoadedGeometry -> Draw ()-drawGeometry (LoadedGeometry ec vao) = currentProgram <$> Draw get >>=-        \mcp -> case mcp of-                     Just _ -> gl $ do bindVertexArray vao-                                       drawElements gl_TRIANGLES-                                                    (fromIntegral ec)-                                                    gl_UNSIGNED_SHORT-                                                    nullGLPtr-                                       bindVertexArray noVAO-                     Nothing -> return ()--instance GLES => Resource (LoadedProgram, String) UniformLocation GL where-        loadResource (LoadedProgram prg _ _, g) =-                do loc <- getUniformLocation prg $ toGLString g-                   return . Right $ UniformLocation loc-        unloadResource _ _ = return ()--instance GLES => Resource (Geometry is) LoadedGeometry Draw where-        loadResource = runExceptT .-                       loadGeometry (ExceptT . getDrawResource gl attributes)-                                    (ExceptT . getDrawResource gl elemBuffers)-                                    (lift . gl)-        unloadResource _ = gl . deleteGeometry---- | Perform a 'GL' action in the 'Draw' monad.-gl :: GL a -> Draw a-gl = Draw . lift  -- | Get the 'DrawState'. drawGet :: Draw DrawState

@@ -6,20 +6,27 @@         Vertex(..),         Triangle(..),         mkGeometry,-        mkGeometryInd,+        mapVertices,         removeAttribute,+        decompose,+        -- * Geometry builder+        Attributes,+        AttrVertex,+        GeometryBuilder,+        GeometryBuilderT,+        vertex,+        triangle,+        buildGeometry,+        buildGeometryT,         -- * 2D and 3D geometries-        Geometry2D,-        Geometry3D,-        positionOnly,+        D2.Geometry2D,+        D3.Geometry3D,         mkGeometry2D,         mkGeometry3D,         mkGeometry2D',         mkGeometry3D',-        mkGeometry2DInd,-        mkGeometry3DInd,-        mkGeometry2DInd',-        mkGeometry3DInd',+        vertex2D,+        vertex3D ) where  import Control.Monad@@ -32,6 +39,7 @@ import Graphics.Rendering.Ombra.Backend (GLES) import Graphics.Rendering.Ombra.Internal.TList (Append) import Graphics.Rendering.Ombra.Geometry.Internal+import Graphics.Rendering.Ombra.Geometry.Types import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Shader.Default2D (Position2) import Graphics.Rendering.Ombra.Shader.Default3D (Position3, Normal3)@@ -39,151 +47,53 @@ import qualified Graphics.Rendering.Ombra.Shader.Default3D as D3 import Graphics.Rendering.Ombra.Vector -data Triangle a = Triangle a a a---- | A list of the attributes of a vertex.------ For instance: @Attr Position3 p :~ Attr UV u :~ Attr Normal3 n@-data Vertex (is :: [*]) where-        Attr :: (Hashable (CPU S i), Attribute S i)-             => (a -> i)-             -> CPU S i-             -> Vertex '[i]-        (:~) :: Vertex '[i] -> Vertex is -> Vertex (i ': is)--infixr 5 :~---- | A 3D geometry.-type Geometry3D = '[Position3, D3.UV, D3.Normal3]---- | A 2D geometry.-type Geometry2D = '[Position2, D2.UV]---- | Create a generic 'Geometry'.-mkGeometry :: (GLES, Attributes is)-           => [Triangle (Vertex is)]-           -> Geometry is-mkGeometry (ts :: [Triangle (Vertex is)]) =-        geometry attrList (ElemData (map (lastElem -) elemList) (hash elemList))-        where (attrList, elemList, lastElem) =-                runST (H.new >>= \table ->-                        foldrM (\(Triangle x y z) -> addVertex table x <=<-                                                     addVertex table y <=<-                                                     addVertex table z)-                               (emptyAttrList (Proxy :: Proxy is), [], 0)-                               ts)--              addVertex :: H.HashTable s Int Word16-                        -> Vertex is-                        -> (AttrList is, [Word16], Word16)-                        -> ST s (AttrList is, [Word16], Word16)-              addVertex t v (attrList, elemList, lastElem) =-                      do melem <- H.lookup t $ hash v-                         (newElem, attrList') <--                                case melem of-                                     Just elem -> return (elem, attrList)-                                     Nothing -> do H.insert t (hash v)-                                                              (lastElem + 1)-                                                   return ( lastElem + 1-                                                          , addAttrList v-                                                                attrList-                                                          )-                         let lastElem' = max lastElem newElem-                         return (attrList', newElem : elemList, lastElem')---- | Create a 'Geometry' using a list of indices to a list of vertices. This--- is faster than 'mkGeometry'.-mkGeometryInd :: (GLES, Attributes is)-              => [Vertex is]-              -> [Triangle Word16]-              -> Geometry is-mkGeometryInd (vs :: [Vertex is]) ts = -        geometry attrList $ ElemData elemList (hash elemList)-        where elemList = foldr (\(Triangle x y z) l -> x : y : z : l) [] ts-              attrList = foldr addAttrList-                               (emptyAttrList (Proxy :: Proxy is))-                               vs-        -addAttrList :: Vertex is -> AttrList is -> AttrList is-addAttrList (Attr _ x) (AttrListCons (AttrData xs h) rest) =-        --- XXX: ???-        AttrListCons (AttrData (x : xs) $ hashWithSalt (hash x + h) h) rest-addAttrList (Attr _ x :~ v') (AttrListCons (AttrData xs h) rest) =-        AttrListCons (AttrData (x : xs) $ hashWithSalt (hash x + h) h) $-                addAttrList v' rest- -- | Create a 3D 'Geometry'. mkGeometry3D :: GLES              => [Triangle (Vec3, Vec2, Vec3)] -- ^ (Position, UV, Normal)-             -> Geometry Geometry3D-mkGeometry3D = mkGeometry . map (fmap $ \(v, u, n) -> vertex3D v u n)+             -> Geometry D3.Geometry3D+mkGeometry3D = mkGeometry . map (fmap $ \(v, u, n) -> mkVertex3D v u n)  -- | Create an extended 3D 'Geometry'.-mkGeometry3D' :: (GLES, Attributes (Append is Geometry3D))-              => [Triangle (Vertex is, Vec3, Vec2, Vec3)]-              -> Geometry (Append is Geometry3D)+mkGeometry3D' :: (GLES, Attributes (Append (i ': is) D3.Geometry3D))+              => [Triangle (Vertex (i ': is), Vec3, Vec2, Vec3)]+              -> Geometry (Append (i ': is) D3.Geometry3D) mkGeometry3D' = mkGeometry .-                map (fmap $ \(e, v, u, n) -> extend e $ vertex3D v u n)+                map (fmap $ \(e, v, u, n) -> extend e $ mkVertex3D v u n)  -- | Create a 2D 'Geometry'. mkGeometry2D :: GLES              => [Triangle (Vec2, Vec2)] -- ^ (Position, Texture UV coordinates)-             -> Geometry Geometry2D-mkGeometry2D = mkGeometry . map (fmap $ \(v, u) -> vertex2D v u)+             -> Geometry D2.Geometry2D+mkGeometry2D = mkGeometry . map (fmap $ \(v, u) -> mkVertex2D v u)  -- | Create an extended 2D 'Geometry'.-mkGeometry2D' :: (GLES, Attributes (Append is Geometry2D))-              => [Triangle (Vertex is, Vec2, Vec2)]-              -> Geometry (Append is Geometry2D)-mkGeometry2D' = mkGeometry . map (fmap $ \(e, v, u) -> extend e $ vertex2D v u)---- | Create a 3D 'Geometry' using a list of indices.-mkGeometry3DInd :: GLES-                => [(Vec3, Vec2, Vec3)]-                -> [Triangle Word16]-                -> Geometry Geometry3D-mkGeometry3DInd = mkGeometryInd . map (\(v, u, n) -> vertex3D v u n)---- | Create an extended 3D 'Geometry' using a list of indices.-mkGeometry3DInd' :: (GLES, Attributes (Append is Geometry3D))-                 => [(Vertex is, Vec3, Vec2, Vec3)]-                 -> [Triangle Word16]-                 -> Geometry (Append is Geometry3D)-mkGeometry3DInd' = mkGeometryInd .-                   map (\(e, v, u, n) -> extend e $ vertex3D v u n)+mkGeometry2D' :: (GLES, Attributes (Append (i ': is) D2.Geometry2D))+              => [Triangle (Vertex (i ': is), Vec2, Vec2)]+              -> Geometry (Append (i ': is) D2.Geometry2D)+mkGeometry2D' = mkGeometry .+                map (fmap $ \(e, v, u) -> extend e $ mkVertex2D v u) --- | Create a 2D 'Geometry' using a list of indices.-mkGeometry2DInd :: GLES-                => [(Vec2, Vec2)]-                -> [Triangle Word16]-                -> Geometry Geometry2D-mkGeometry2DInd = mkGeometryInd . map (\(v, u) -> vertex2D v u)+-- | Create a new 2D vertex.+vertex2D :: (GLES, Monad m)+         => Vec2+         -> Vec2+         -> GeometryBuilderT D2.Geometry2D m (AttrVertex D2.Geometry2D)+vertex2D p u = vertex $ mkVertex2D p u --- | Create an extended 2D 'Geometry' using a list of indices.-mkGeometry2DInd' :: (GLES, Attributes (Append is Geometry2D))-                 => [(Vertex is, Vec2, Vec2)]-                 -> [Triangle Word16]-                 -> Geometry (Append is Geometry2D)-mkGeometry2DInd' = mkGeometryInd .  map (\(e, v, u) -> extend e $ vertex2D v u)+-- | Create a new 3D vertex.+vertex3D :: (GLES, Monad m)+         => Vec3+         -> Vec2+         -> Vec3+         -> GeometryBuilderT D3.Geometry3D m (AttrVertex D3.Geometry3D)+vertex3D p u n = vertex $ mkVertex3D p u n -vertex3D :: GLES => Vec3 -> Vec2 -> Vec3 -> Vertex Geometry3D-vertex3D p u n = Attr D3.Position3 p :~ Attr D3.UV u :~ Attr D3.Normal3 n+mkVertex3D :: GLES => Vec3 -> Vec2 -> Vec3 -> Vertex D3.Geometry3D+mkVertex3D p u n = Attr D3.Position3 p :~ Attr D3.UV u :~ Attr D3.Normal3 n -vertex2D :: GLES => Vec2 -> Vec2 -> Vertex Geometry2D-vertex2D p u = Attr D2.Position2 p :~ Attr D2.UV u+mkVertex2D :: GLES => Vec2 -> Vec2 -> Vertex D2.Geometry2D+mkVertex2D p u = Attr D2.Position2 p :~ Attr D2.UV u  extend :: Vertex is -> Vertex is' -> Vertex (Append is is') extend (Attr c x) v = Attr c x :~ v extend (Attr c x :~ v') v = Attr c x :~ extend v' v---- | Remove the 'UV' and 'Normal3' attributes from a 3D Geometry.-positionOnly :: Geometry Geometry3D -> Geometry '[Position3]-positionOnly (Geometry (AttrListCons pd _) es _) =-        geometry (AttrListCons pd AttrListNil) es--instance Hashable (Vertex is) where-        hashWithSalt s (Attr _ a) = hashWithSalt s a-        hashWithSalt s (x :~ y) = hashWithSalt (hashWithSalt s x) y--instance Functor Triangle where-        fmap f (Triangle x y z) = Triangle (f x) (f y) (f z)

@@ -1,121 +1,229 @@ {-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,              MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables,-             PolyKinds, UndecidableInstances, RankNTypes #-}+             PolyKinds, TypeFamilies, RankNTypes, ConstraintKinds,+             UndecidableInstances #-}  module Graphics.Rendering.Ombra.Geometry.Internal (-        AttrList(..),-        AttrData(..),-        Geometry(..),-        ElemData(..),+        MonadGeometry(..),         LoadedBuffer,         LoadedAttribute,         LoadedGeometry(..),-        Attributes(..),-        geometry,+        vertex,+        triangle,+        mkGeometry,+        buildGeometry,+        buildGeometryT,+        decompose,+        mapVertices,         removeAttribute,-        loadGeometry,-        deleteGeometry+        drawGeometry ) where -import Control.Monad.Trans.Class+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except import Control.Monad.Trans.State+import Data.Foldable (foldlM) import qualified Data.Hashable as H-import Data.Typeable+import qualified Data.HashMap.Lazy as H+import Data.List (foldl')+import Data.Proxy import Data.Word (Word16)-import Unsafe.Coerce +import Graphics.Rendering.Ombra.Geometry.Types import Graphics.Rendering.Ombra.Internal.GL import Graphics.Rendering.Ombra.Internal.Resource+import Graphics.Rendering.Ombra.Internal.TList (Remove, Append) 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)) import Graphics.Rendering.Ombra.Vector --- | A heterogeneous list of attributes.-data AttrList (is :: [*]) where-        AttrListNil :: AttrList '[]-        AttrListCons :: (H.Hashable (CPU S i), Attribute S i)-                     => AttrData i-                     -> AttrList is-                     -> AttrList (i ': is)+class (GLES, MonadGL m) => MonadGeometry m where+        getAttribute :: Attribute 'S i+                     => AttrCol (i ': is)+                     -> m (Either String LoadedAttribute)+        getElementBuffer :: Elements is -> m (Either String LoadedBuffer)+        getGeometry :: Geometry (i ': is) -> m (Either String LoadedGeometry) -data AttrData i = AttrData [CPU S i] Int --- | A set of attributes and indices.-data Geometry (is :: [*]) = Geometry (AttrList is) ElemData Int- data LoadedGeometry = LoadedGeometry {+        -- elementType :: GLEnum,         elementCount :: Int,         vao :: VertexArrayObject }  newtype LoadedBuffer = LoadedBuffer Buffer -data ElemData = ElemData [Word16] Int- data LoadedAttribute = LoadedAttribute GLUInt [(Buffer, GLUInt -> GL ())] -instance Eq (Geometry is) where-        (Geometry _ _ h) == (Geometry _ _ h') = h == h'+rehashGeometry :: Geometry is -> Geometry is+rehashGeometry g = let Triangles elemsHash _ = elements g+                   in g { geometryHash = H.hashWithSalt (topHash g) elemsHash } -instance H.Hashable (Geometry is) where-        hashWithSalt salt (Geometry _ _ h) = H.hashWithSalt salt h+emptyGeometry :: Attributes is => Geometry is+emptyGeometry = rehashGeometry $ Geometry 0 0 emptyAttrCol (Triangles 0 []) (-1) -instance H.Hashable ElemData where-        hashWithSalt salt (ElemData _ h) = H.hashWithSalt salt h+downList :: NotTop p => AttrTable p (i ': is) -> [CPU 'S i] -> [CPU 'S i]+downList AttrEnd xs = xs+downList (AttrCell x _ down) xs = downList down $ x : xs -instance Eq ElemData where-        (ElemData _ h) == (ElemData _ h') = h == h'+foldVertices :: NotTop p+             => (AttrVertex is -> b -> b)+             -> b+             -> AttrTable p is+             -> (Int, b)+foldVertices f acc AttrEnd = (-1, acc)+foldVertices f acc cell@(AttrCell _ _ down) =+        let (didx, acc') = foldVertices f acc down+            idx = didx + 1+            widx = fromIntegral idx+        in (idx, f (AttrVertex widx cell) acc') -instance H.Hashable (AttrData i) where-        hashWithSalt salt (AttrData _ h) = H.hashWithSalt salt h+addVertex :: Attributes is+          => Vertex is+          -> Geometry is+          -> (AttrVertex is, Geometry is)+addVertex v g =+        let top' = addTop v $ top g+            topHash = H.hash top'+            idx = lastIndex g + 1+            av = case top' of+                      AttrTop _ _ c -> AttrVertex (fromIntegral idx) c+        in ( av+           , rehashGeometry $ g { topHash = topHash+                                , top = top'+                                , lastIndex = idx+                                }+           ) -instance Eq (AttrData i) where-        (AttrData _ h) == (AttrData _ h') = h == h'+addTriangle :: Attributes is+            => Triangle (AttrVertex is)+            -> Geometry is+            -> Geometry is+addTriangle t g = let Triangles h ts = elements g+                      elements' = Triangles (H.hashWithSalt (H.hash t) h)+                                            (t : ts)+                  in rehashGeometry $ g { elements = elements' } -instance H.Hashable (AttrList is) where-        hashWithSalt salt AttrListNil = salt-        hashWithSalt salt (AttrListCons (AttrData _ h) al) =-                H.hashWithSalt (H.hashWithSalt salt h) al+-- | Create a new vertex that can be used in 'addTriangle'.+vertex :: (Monad m, Attributes is)+       => Vertex is+       -> GeometryBuilderT is m (AttrVertex is)+vertex = GeometryBuilderT . state . addVertex -class Attributes (is :: [*]) where-        emptyAttrList :: Proxy (is :: [*]) -> AttrList is-        -instance Attributes '[] where-        emptyAttrList _ = AttrListNil+-- | Add a triangle to the current geometry.+triangle :: (Monad m, Attributes is)+         => AttrVertex is+         -> AttrVertex is+         -> AttrVertex is+         -> GeometryBuilderT is m ()+triangle x y z = GeometryBuilderT . state $ \g -> ((), addTriangle t g)+        where t = Triangle x y z -instance (H.Hashable (CPU S i), Attribute S i, Attributes is) =>-        Attributes (i ': is) where-        emptyAttrList (_ :: Proxy (i ': is)) =-                AttrListCons (AttrData [] (H.hash (0 :: Int)) :: AttrData i) $-                        emptyAttrList (Proxy :: Proxy is)+-- | Create a 'Geometry' using the 'GeometryBuilder' monad. This is more+-- efficient than 'mkGeometry'.+buildGeometry :: Attributes (i ': is)+              => GeometryBuilder (i ': is) ()+              -> Geometry (i ': is)+buildGeometry (GeometryBuilderT m) = execState m emptyGeometry -geometry :: AttrList is -> ElemData -> Geometry is-geometry al es = Geometry al es $ H.hashWithSalt (H.hash al) es+buildGeometryT :: (Monad m, Attributes (i ': is))+               => GeometryBuilderT (i ': is) m ()+               -> m (Geometry (i ': is))+buildGeometryT (GeometryBuilderT m) = execStateT m emptyGeometry +-- | Create a 'Geometry' using a list of triangles.+mkGeometry :: (GLES, Attributes (i ': is))+           => [Triangle (Vertex (i ': is))]+           -> Geometry (i ': is)+mkGeometry t = buildGeometry (foldlM add H.empty t >> return ())+        where add vertices (Triangle v1 v2 v3) =+                do (vertices1, av1) <- mvertex vertices v1+                   (vertices2, av2) <- mvertex vertices1 v2+                   (vertices3, av3) <- mvertex vertices2 v3+                   triangle av1 av2 av3+                   return vertices3+              mvertex vertices v =+                case H.lookup v vertices of+                     Just av -> return (vertices, av)+                     Nothing -> do av <- vertex v+                                   return (H.insert v av vertices, av)++attrVertexToVertex :: Attributes is => AttrVertex is -> Vertex is+attrVertexToVertex (AttrVertex _ tab) = rowToVertex tab++-- | Convert a 'Geometry' back to a list of triangles.+decompose :: Geometry (i ': is) -> [Triangle (Vertex (i ': is))] +decompose g@(Geometry _ _ _ (Triangles _ triangles) _) =+        flip map triangles $ fmap attrVertexToVertex++type AttrVertexMap is v = H.HashMap (AttrVertex is) v++-- | Transform each vertex of a geometry. You can create a value for each+-- triangle so that the transforming function will receive a list of the values+-- of the triangles the vertex belongs to.+mapVertices :: (Attributes is, Attributes is', GLES)+            => (Triangle (Vertex is) -> a)+            -> ([a] -> Vertex is -> Vertex is')+            -> Geometry is+            -> Geometry is'+mapVertices getValue (transVert :: [a] -> Vertex is -> Vertex is')+            (Geometry _ _ (AttrTop _ _ row0) (Triangles thash triangles) _) =+        let accTriangle vertMap tri@(Triangle v1 v2 v3) (values, triangles) =+                    let value = getValue $ fmap attrVertexToVertex tri+                        values' = foldr (flip (H.insertWith (++)) [value])+                                        values+                                        [v1, v2, v3]+                        tri' = fmap (vertMap H.!) tri+                    in (values', tri' : triangles)++            accVertex valueMap avert (vertMap, geom) =+                    let value = valueMap H.! avert+                        vert = attrVertexToVertex avert+                        vert' = transVert value vert+                        (avert', geom') = addVertex vert' geom+                        vertMap' = H.insert avert avert' vertMap+                    in (vertMap', geom')++            (valueMap, triangles') = foldr (accTriangle vertMap)+                                           (H.empty, [])+                                           triangles+            (_, (vertMap, Geometry tophash' _ top' _ lidx)) =+                    foldVertices (accVertex valueMap)+                                 (H.empty, emptyGeometry)+                                 row0+            geom' = Geometry tophash' 0 top' (Triangles thash triangles') lidx+        in rehashGeometry geom'+ -- | Remove an attribute from a geometry.-removeAttribute :: (RemoveAttr i is is', GLES)+removeAttribute :: ( RemoveAttr i is+                   , Attributes is+                   , Attributes (Remove i is)+                   , GLES+                   )                 => (a -> i)      -- ^ Attribute constructor (or any other                                  -- function with that type).-                -> Geometry is -> Geometry is'-removeAttribute g (Geometry al es _) = geometry (removeAttr g al) es+                -> Geometry is+                -> Geometry (Remove i is)+removeAttribute g = mapVertices (const ()) (const $ removeAttr g) -class RemoveAttr i is is' where-        removeAttr :: (a -> i) -> AttrList is -> AttrList is'+class RemoveAttr i is where+        removeAttr :: (a -> i) -> Vertex is -> Vertex (Remove i is) -instance RemoveAttr i (i ': is) is where-        removeAttr _ (AttrListCons _ al) = al+instance {-# OVERLAPPING #-} (Remove i '[i', i] ~ '[i']) =>+        RemoveAttr i '[i', i] where+        removeAttr g (Attr g' x :~ _) = Attr g' x -instance RemoveAttr i is is' =>-         RemoveAttr i (i1 ': is) (i1 ': is') where-        removeAttr g (AttrListCons c al) =-                AttrListCons c $ removeAttr g al+instance {-# OVERLAPPING #-} RemoveAttr i is' => RemoveAttr i (i ': is') where+        removeAttr g (Attr _ _ :~ v) = removeAttr g v -instance (GLES, Attribute 'S i) => Resource (AttrData i) LoadedAttribute GL where-        loadResource (AttrData vs _ :: AttrData i) =+instance {-# OVERLAPPABLE #-} ( RemoveAttr i is'+                              , Remove i (i' ': is') ~ (i' ': Remove i is')+                              ) => RemoveAttr i (i' ': is') where+        removeAttr g (Attr g' x) = Attr g' x+        removeAttr g (Attr g' x :~ v) = Attr g' x :~ removeAttr g v++instance GLES => Resource (AttrCol (i ': is)) LoadedAttribute GL where+        loadResource (AttrTop _ _ down :: AttrCol (i ': is)) =                 fmap (Right . uncurry LoadedAttribute) .                 flip execStateT (0, []) $                         withAttributes (Proxy :: Proxy 'S) (undefined :: i) vs $@@ -129,52 +237,62 @@                                                         (undefined :: g)                                                set = setAttribute g . (+ i)                                            put (i + sz, (buf, set) : as)+                where vs = downList down []         unloadResource _ (LoadedAttribute _ as) =                 mapM_ (\(buf, _) -> deleteBuffer buf) as -instance GLES => Resource ElemData LoadedBuffer GL where-        loadResource (ElemData elems _) =+instance GLES => Resource (Elements is) LoadedBuffer GL where+        loadResource (Triangles _ ts) =                 liftIO (encodeUShorts elems) >>=                         fmap (Right . LoadedBuffer) .                         loadBuffer gl_ELEMENT_ARRAY_BUFFER                         . fromUInt16Array+                where elems = ts >>= ids+                      ids (Triangle (AttrVertex x _)+                                    (AttrVertex y _)+                                    (AttrVertex z _)) = [x, y, z]         unloadResource _ (LoadedBuffer buf) = deleteBuffer buf -loadGeometry :: (GLES, Monad m)-             => (forall i. Attribute 'S i => AttrData i -> m LoadedAttribute)-             -> (ElemData -> m LoadedBuffer)-             -> (forall a. GL a -> m a)-             -> Geometry is-             -> m LoadedGeometry-loadGeometry getAttr getElems gl (Geometry attrList elems@(ElemData es _) _) =-        do vao <- gl createVertexArray-           gl $ bindVertexArray vao+instance (GLES, MonadGeometry m, EmbedIO m) =>+        Resource (Geometry (i ': is)) LoadedGeometry m where+        loadResource = loadGeometry+        unloadResource _ = gl . deleteGeometry -           setAttrList getAttr gl (0 :: GLUInt) attrList-           LoadedBuffer eb <- getElems elems+loadGeometry :: (GLES, MonadGeometry m)+             => Geometry (i ': is)+             -> m (Either String LoadedGeometry)+loadGeometry geometry@(Geometry _ _ _ _ _) = runExceptT $+        do vao <- lift $ gl createVertexArray+           lift . gl $ bindVertexArray vao -           gl $ do bindBuffer gl_ELEMENT_ARRAY_BUFFER eb-                   bindVertexArray noVAO-                   bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer-                   bindBuffer gl_ARRAY_BUFFER noBuffer+           ExceptT . setAttrTop (0 :: GLUInt) $ top geometry+           LoadedBuffer eb <- ExceptT . getElementBuffer $ elements geometry -           return $ LoadedGeometry (length es) vao+           lift . gl $ do bindBuffer gl_ELEMENT_ARRAY_BUFFER eb+                          bindVertexArray noVAO+                          bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer+                          bindBuffer gl_ARRAY_BUFFER noBuffer -setAttrList :: (GLES, Monad m)-            => (forall i. Attribute 'S i => AttrData i -> m LoadedAttribute)-            -> (forall a. GL a -> m a)-            -> GLUInt-            -> AttrList is-            -> m ()-setAttrList getAttr gl i (AttrListCons attrData rest) =-        do (LoadedAttribute sz as) <- getAttr attrData-           gl $ mapM_ (\(buf, set) -> do bindBuffer gl_ARRAY_BUFFER buf-                                         enableVertexAttribArray i-                                         set i-                      ) as-           setAttrList getAttr gl (i + sz) rest-setAttrList _ _ _ AttrListNil = return ()+           return $ LoadedGeometry (elementCount $ elements geometry) vao+        where elementCount (Triangles _ ts) = 3 * length ts +setAttrTop :: (GLES, MonadGeometry m, Attributes (i ': is))+           => GLUInt+           -> AttrCol (i ': is)+           -> m (Either String ())+setAttrTop i0 col0 = runExceptT . (>> return ()) $+        foldTop (\geti col@(AttrTop _ _ _) ->+                        do i <- geti+                           LoadedAttribute sz as <- ExceptT $ getAttribute col+                           lift . gl $+                                mapM_ (\(buf, set) ->+                                        do bindBuffer gl_ARRAY_BUFFER buf+                                           enableVertexAttribArray i+                                           set i+                                      ) as+                           return $ i + sz+                ) (return i0) col0+ deleteGeometry :: GLES => LoadedGeometry -> GL () deleteGeometry (LoadedGeometry _ vao) = deleteVertexArray vao @@ -185,3 +303,15 @@            bufferData ty bufData gl_STATIC_DRAW            bindBuffer ty noBuffer            return buffer++drawGeometry :: MonadGeometry m => Geometry (i ': is) -> m ()+drawGeometry g = getGeometry g >>= \eg ->+        case eg of+             Left _ -> return ()+             Right (LoadedGeometry ec vao) ->+                     gl $ do bindVertexArray vao+                             drawElements gl_TRIANGLES+                                          (fromIntegral ec)+                                          gl_UNSIGNED_SHORT+                                          nullGLPtr+                             bindVertexArray noVAO

@@ -0,0 +1,165 @@+{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,+             FlexibleInstances, UndecidableInstances, TypeFamilies, RankNTypes,+             GeneralizedNewtypeDeriving, ConstraintKinds #-}++module Graphics.Rendering.Ombra.Geometry.Types (+        Vertex(..),+        Triangle(..),+        AttrTable(..),+        AttrCol,+        AttrVertex(..),+        AttrPosition(..),+        Geometry(..),+        GeometryBuilder,+        GeometryBuilderT(..),+        Elements(..),+        NotTop,+        Previous,+        Attributes(..)+) where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import GHC.Exts (Constraint)+import qualified Data.Hashable as H+import Data.Functor.Identity (Identity)+import Data.Word (Word16)++import Graphics.Rendering.Ombra.Shader.CPU++data Triangle a = Triangle a a a++-- | A list of the attributes of a vertex.+--+-- For instance: @Attr Position3 p :~ Attr UV u :~ Attr Normal3 n@+data Vertex (is :: [*]) where+        Attr :: (Eq (CPU S i), H.Hashable (CPU S i), Attribute S i)+             => (a -> i)+             -> CPU S i+             -> Vertex '[i]+        (:~) :: Vertex '[i] -> Vertex is -> Vertex (i ': is)++infixr 5 :~++data Elements is = Triangles Int [Triangle (AttrVertex is)]++-- | A set of triangles.+data Geometry (is :: [*]) where+        Geometry :: Attributes is+                 => { topHash :: Int            -- TODO: ?+                    , geometryHash :: Int       -- TODO: ?+                    , top :: AttrCol is+                    , elements :: Elements is+                    , lastIndex :: Int+                    }+                 -> Geometry is++newtype GeometryBuilderT is m a = GeometryBuilderT (StateT (Geometry is) m a)+        deriving (Functor, Applicative, Monad, MonadTrans)++type GeometryBuilder is = GeometryBuilderT is Identity++-- | A vertex in a 'Geometry'.+data AttrVertex (is :: [*]) where+        AttrVertex :: NotTop p => Word16 -> AttrTable p is -> AttrVertex is++data AttrPosition = Top | Middle | Bottom | End++type family Previous (p :: AttrPosition) :: AttrPosition where+        Previous Middle = Middle+        Previous Bottom = Middle+        Previous End = Bottom++-- | A table where rows are vertices and columns are the values of a certain+-- attribute. The top row contains the hash of the values in the row instead of+-- actual attribute data.+data AttrTable (b :: AttrPosition) (is :: [*]) where+        AttrNil :: AttrTable b '[]+        AttrEnd :: AttrTable End is+        AttrTop :: (NotTop p, Attribute 'S i)+                => Int+                -> AttrTable Top is+                -> AttrTable p (i ': is)+                -> AttrTable Top (i ': is)+        AttrCell :: (H.Hashable (CPU S i), Attribute 'S i)+                 => CPU 'S i+                 -> AttrTable (Previous p) is+                 -> AttrTable p (i ': is)+                 -> AttrTable (Previous p) (i ': is)++type AttrCol = AttrTable Top+type NotTop p = Previous p ~ Previous p++class Attributes is where+        emptyAttrCol :: AttrCol is+        cell :: Vertex is -> AttrTable p is -> AttrTable (Previous p) is+        addTop :: Vertex is -> AttrCol is -> AttrCol is+        foldTop :: (forall i is. b -> AttrCol (i ': is) -> b)+                -> b+                -> AttrCol is+                -> b+        rowToVertex :: NotTop p => AttrTable p is -> Vertex is++instance (Attribute 'S i, Eq (CPU 'S i)) => Attributes '[i] where+        emptyAttrCol = AttrTop (H.hash (0 :: Int)) AttrNil AttrEnd+        cell (Attr _ x) down = AttrCell x AttrNil down+        addTop v@(Attr _ x) (AttrTop thash next down) =+                AttrTop (H.hashWithSalt (H.hash x + thash) thash)+                        next+                        (cell v down)+        foldTop f acc top = f acc top+        rowToVertex (AttrCell x _ _) = Attr (const undefined) x++instance (Attribute 'S i1, Eq (CPU 'S i1), Attributes (i2 ': is)) =>+        Attributes (i1 ': (i2 ': is)) where+        emptyAttrCol = AttrTop (H.hash (0 :: Int)) emptyAttrCol AttrEnd+        cell (Attr _ x :~ v) down1@(AttrCell _ down2 _) =+                AttrCell x (cell v down2) down1+        cell (Attr _ x :~ v) AttrEnd = AttrCell x (cell v AttrEnd) AttrEnd+        addTop v1@(Attr _ x :~ v2) (AttrTop thash next down) =+                AttrTop (H.hashWithSalt (H.hash x + thash) thash)+                        (addTop v2 next)+                        (cell v1 down)+        foldTop f acc top@(AttrTop _ next _) = foldTop f (f acc top) next+        rowToVertex (AttrCell x next _) =+                Attr (const undefined) x :~ rowToVertex next++instance Functor Triangle where+        fmap f (Triangle x y z) = Triangle (f x) (f y) (f z)++instance H.Hashable (Vertex is) where+        hashWithSalt s (Attr _ a) = H.hashWithSalt s a+        hashWithSalt s (x :~ y) = H.hashWithSalt (H.hashWithSalt s x) y++instance Eq (Vertex is) where+        (Attr _ x) == (Attr _ x') = x == x'+        (Attr _ x :~ v) == (Attr _ x' :~ v') = x == x' && v == v'++instance H.Hashable a => H.Hashable (Triangle a) where+        hashWithSalt salt (Triangle x y z) = H.hashWithSalt salt (x, y, z)++instance Eq (Geometry is) where+        g == g' = geometryHash g == geometryHash g'++instance H.Hashable (Geometry is) where+        hashWithSalt salt = H.hashWithSalt salt . geometryHash++instance H.Hashable (Elements is) where+        hashWithSalt salt (Triangles h _) = H.hashWithSalt salt h++instance Eq (Elements is) where+        (Triangles h _) == (Triangles h' _) = h == h'++instance H.Hashable (AttrVertex is) where+        hashWithSalt salt (AttrVertex i _) = H.hashWithSalt salt i++instance Eq (AttrVertex is) where+        (AttrVertex i _) == (AttrVertex i' _) = i == i'++instance H.Hashable (AttrCol is) where+        hashWithSalt salt AttrNil = salt+        hashWithSalt salt (AttrTop thash next _) =+                H.hashWithSalt (H.hashWithSalt salt thash) next++instance Eq (AttrCol (i ': is)) where+        (AttrTop h _ _) == (AttrTop h' _ _) = h == h'

@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Graphics.Rendering.Ombra.Internal.GL (+        MonadGL(..),         GL,         ActiveTexture(..),         module Graphics.Rendering.Ombra.Backend,@@ -69,6 +70,7 @@         getError,         getProgramInfoLog,         -- getShaderPrecisionFormat,+        getShaderParameterBool,         getShaderInfoLog,         getShaderSource,         getUniformLocation,@@ -144,6 +146,12 @@ newtype GL a = GL (ReaderT Ctx IO a)         deriving (Functor, Applicative, Monad, MonadIO) +class MonadIO m => MonadGL m where+        gl :: GL a -> m a++instance MonadGL GL where+        gl = id+ -- | A Texture ready to be passed as an uniform. newtype ActiveTexture = ActiveTexture Word @@ -357,8 +365,8 @@ -- glGetRenderbufferParameter :: GLES => Word -> Word -> GL (JSRef a) -- getRenderbufferParameter a b = getCtx >>= \ctx -> liftIO $ glGetRenderbufferParameter ctx a b --- glGetShaderParameter :: GLES => Shader -> Word -> GL (JSRef a)--- getShaderParameter a b = getCtx >>= \ctx -> liftIO $ glGetShaderParameter ctx a b+getShaderParameterBool :: GLES => Shader -> GLEnum -> GL GLBool+getShaderParameterBool a b = getCtx >>= \ctx -> liftIO $ glGetShaderParameterBool ctx a b  -- getShaderPrecisionFormat :: GLES => GLEnum -> GLEnum -> GL ShaderPrecisionFormat -- getShaderPrecisionFormat a b = getCtx >>= \ctx -> liftIO $ glGetShaderPrecisionFormat ctx a b

@@ -9,6 +9,8 @@         newResMap,         addResource,         getResource,+        getResource',+        checkResource,         removeResource,         unloader ) where@@ -25,7 +27,7 @@                  | Error String  class (Eq i, Applicative m, EmbedIO m, Hashable i) =>-        Resource i r m | r -> m where+        Resource i r m where         loadResource :: i -> m (Either String r)         unloadResource :: Maybe i -> r -> m () @@ -55,8 +57,12 @@                                                    Just (Left e) -> Error e                                                    Nothing -> Unloaded + getResource :: Resource i r m => i -> ResMap r -> m (Either String r)-getResource (i :: i) rmap@(ResMap map) =+getResource i = getResource' i i++getResource' :: Resource i r m => k -> i -> ResMap r -> m (Either String r)+getResource' k (i :: i) rmap@(ResMap map) =         do status <- checkResource i rmap            case status of                    Unloaded ->@@ -66,7 +72,7 @@                                          Left s -> H.insert map ihash $ Left s                                          Right r -> H.insert map ihash $ Right r -                           embedIO (addFinalizer i) $+                           embedIO (addFinalizer k) $                                    removeResource' (Nothing :: Maybe i)                                                    ihash rmap                            meRes <- liftIO . H.lookup map $ ihash@@ -92,3 +98,8 @@  unloader :: (Resource i r m, EmbedIO m) => k -> Maybe i -> r -> m () unloader k i r = embedIO (addFinalizer k) $ unloadResource i r++instance Functor ResStatus where+        fmap f (Loaded r) = Loaded (f r)+        fmap _ Unloaded = Unloaded+        fmap _ (Error s) = Error s

@@ -48,6 +48,7 @@ import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Layer.Internal+import Graphics.Rendering.Ombra.Layer.Types import Graphics.Rendering.Ombra.Object import Graphics.Rendering.Ombra.Shader.Program import Graphics.Rendering.Ombra.Texture

@@ -3,69 +3,19 @@ module Graphics.Rendering.Ombra.Layer.Internal where  import Data.Word (Word8)+import Control.Monad (when) import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.GL hiding (Buffer, Texture)+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.Layer.Types import Graphics.Rendering.Ombra.Object.Internal+import Graphics.Rendering.Ombra.Object.Types+import Graphics.Rendering.Ombra.Screen import Graphics.Rendering.Ombra.Shader.Program import Graphics.Rendering.Ombra.Texture.Internal---- | An 'Object' associated with a program.-type Layer = Layer' Drawable () ()---- | 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---- | 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+import Graphics.Rendering.Ombra.Texture.Types  -- TODO: document buffers. -- | Layer that clear some buffers. For instance, @clear ['ColorBuffer']@ fills@@ -216,3 +166,168 @@                 TextureLayer True                              (DepthStencilLayer : map BufferLayer [0 .. n - 1])                              (w, h) (0, 0, 0, 0) False False l++clearBuffers :: (GLES, MonadGL m) => [Buffer] -> m ()+clearBuffers = mapM_ $ gl . GL.clear . buffer+        where buffer ColorBuffer = gl_COLOR_BUFFER_BIT+              buffer DepthBuffer = gl_DEPTH_BUFFER_BIT+              buffer StencilBuffer = gl_STENCIL_BUFFER_BIT++-- | Draw a 'Layer'.+drawLayer :: MonadObject m => Layer' Drawable t a -> m a+drawLayer = fmap fst . flip drawLayer' []++drawLayer' :: MonadObject m+           => Layer' s t a+           -> [TTexture t]+           -> m (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 :: Monad m+                         => Bool+                         -> Either (Maybe [r])+                                   ([r] -> m (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) -> unusedTexture 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 a 'Layer' on some textures.+layerToTexture :: (GLES, Integral a, MonadObject m)+               => Bool                                  -- ^ Draw buffers+               -> [LayerType]                           -- ^ Textures contents+               -> a                                     -- ^ Width+               -> a                                     -- ^ Height+               -> Layer' s t x                          -- ^ Layer to draw+               -> Either b ( [Color] -> m b+                           , Int, Int, Int, Int)        -- ^ Color inspecting+                                                        -- function, start x,+                                                        -- start y, width,+                                                        -- height+               -> Either c ( [Word8] -> m c+                           , Int, Int, Int, Int)        -- ^ Depth inspecting,+                                                        -- function, etc.+               -> [TTexture t]+               -> m (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 (x, tts', colRes, depthRes)++        return (x, tts', ts, colRes, depthRes)++        where (w, h) = (fromIntegral wp, fromIntegral hp)+              arguments stype =+                        case stype of+                              ColorLayer -> ( fromIntegral gl_RGBA+                                            , gl_RGBA+                                            , gl_UNSIGNED_BYTE+                                            , gl_COLOR_ATTACHMENT0+                                            , [ColorBuffer] )+                              DepthLayer -> ( fromIntegral gl_DEPTH_COMPONENT+                                            , gl_DEPTH_COMPONENT+                                            , gl_UNSIGNED_SHORT+                                            , gl_DEPTH_ATTACHMENT+                                            , [DepthBuffer] )+                              DepthStencilLayer -> ( fromIntegral+                                                        gl_DEPTH_STENCIL+                                                   , gl_DEPTH_STENCIL+                                                   , gl_UNSIGNED_INT_24_8+                                                   , gl_DEPTH_STENCIL_ATTACHMENT+                                                   , [ DepthBuffer+                                                     , StencilBuffer]+                                                   )+                              BufferLayer n -> ( fromIntegral gl_RGBA32F+                                               , gl_RGBA+                                               , gl_FLOAT+                                               , gl_COLOR_ATTACHMENT0 + +                                                 fromIntegral n+                                               , [] )++              inspect (Left r) _ _ _ = return r+              inspect (Right (insp, x, y, rw, rh)) format trans s =+                        do arr <- liftIO . newByteArray $+                                        fromIntegral rw * fromIntegral rh * s+                           gl $ readPixels (fromIntegral x)+                                           (fromIntegral y)+                                           (fromIntegral rw)+                                           (fromIntegral rh)+                                           format gl_UNSIGNED_BYTE arr+                           liftIO (decodeBytes arr) >>= insp . trans+              wordsToColors (r : g : b : a : xs) = Color r g b a :+                                                   wordsToColors xs+              wordsToColors _ = []++renderToTexture :: (GLES, MonadObject m)+                => Bool+                -> [(GLInt, GLEnum, GLEnum, GLEnum, [Buffer])]+                -> GLSize+                -> GLSize+                -> m a+                -> m ([GL.Texture], a)+renderToTexture drawBufs infos w h act = do+        fb <- gl createFramebuffer +        gl $ bindFramebuffer gl_FRAMEBUFFER fb++        (ts, attchs, buffersToClear) <- fmap unzip3 . flip mapM infos $+                \(internalFormat, format, pixelType, attachment, buffer) ->+                        do LoadedTexture _ _ t <- newTexture (fromIntegral w)+                                                             (fromIntegral h)+                                                             (Nearest, Nothing)+                                                             Nearest+                           gl $ bindTexture gl_TEXTURE_2D t+                           if pixelType == gl_FLOAT+                           then liftIO noFloat32Array >>=+                                        gl . texImage2DFloat gl_TEXTURE_2D 0+                                                             internalFormat w h+                                                             0 format pixelType+                           else liftIO noUInt8Array >>=+                                        gl . texImage2DUInt gl_TEXTURE_2D 0+                                                            internalFormat w h+                                                            0 format pixelType+                           gl $ framebufferTexture2D gl_FRAMEBUFFER attachment+                                                     gl_TEXTURE_2D t 0+                           return (t, fromIntegral attachment, buffer)++        let buffersToDraw = filter (/= fromIntegral gl_DEPTH_ATTACHMENT) attchs+        when drawBufs $ liftIO (encodeInts buffersToDraw) >>= gl . drawBuffers++        (sw, sh) <- currentViewport+        resizeViewport (fromIntegral w) (fromIntegral h)++        clearBuffers $ concat buffersToClear+        ret <- act++        resizeViewport sw sh+        gl $ deleteFramebuffer fb++        return (ts, ret)

@@ -0,0 +1,70 @@+{-# LANGUAGE GADTs, RankNTypes, DataKinds, KindSignatures #-}++module Graphics.Rendering.Ombra.Layer.Types where++import Data.Word (Word8)+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Object.Types+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Texture.Types+import Graphics.Rendering.Ombra.Texture.Internal++-- | An 'Object' associated with a program.+type Layer = Layer' Drawable () ()++-- | 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++-- | 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+

@@ -51,7 +51,7 @@ 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.Object.Types import Graphics.Rendering.Ombra.Internal.GL (ActiveTexture) import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Shader.CPU hiding (mirror)@@ -102,7 +102,7 @@ nothing = NoMesh  -- | An object with a specified 'Geometry'.-geom :: Geometry i -> Object '[] i+geom :: Geometry (i ': is) -> Object '[] (i ': is) geom = Mesh  -- TODO: Either (CPU 'S g) (CPU 'M g) ???@@ -139,18 +139,20 @@  infixr 2 ~~> -class RemoveGlobal g gs gs' where+class RemoveGlobal g gs' where         -- | Remove a global from an 'Object'.-        (*~>) :: (a -> g) -> Object gs is -> Object gs' is+        (*~>) :: (a -> g) -> Object gs' is -> Object (Remove g gs') is -instance {-# OVERLAPPING #-} RemoveGlobal g (g ': gs) gs where+instance {-# OVERLAPPING #-} Remove g (g : gs') ~ gs' =>+        RemoveGlobal g (g ': gs') where         _ *~> (_ :~> o) = o         r *~> (Prop p o) = Prop p $ r *~> o         r *~> (Append o o') = Append (r *~> o) (r *~> o')         r *~> NoMesh = NoMesh -instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, RemoveGlobal g gs gs') =>-         RemoveGlobal g (g1 ': gs) (g1 ': gs') where+instance {-# OVERLAPPABLE #-} ( Remove g (g' ': gs') ~ (g' ': Remove g gs')+                              , RemoveGlobal g gs'+                              ) => RemoveGlobal g (g' ': 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')@@ -159,8 +161,8 @@ infixr 2 *~>  -- | Modify the geometry of an 'Object'.-modifyGeometry :: (Geometry (i ': is) -> Geometry is')-               -> Object gs (i ': is) -> Object gs is'+modifyGeometry :: (Geometry (i ': is) -> Geometry (i' : is'))+               -> Object gs (i ': is) -> Object gs (i' : 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

@@ -1,53 +1,67 @@-{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators,-             FlexibleContexts #-}+{-# LANGUAGE GADTs, DataKinds, PolyKinds, ConstraintKinds #-} -module Graphics.Rendering.Ombra.Object.Internal where+module Graphics.Rendering.Ombra.Object.Internal (+        MonadObject,+        MonadDrawingMode(..),+        drawObject+) where -import Data.Proxy (Proxy)-import Data.Monoid-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 Data.Proxy (Proxy(..))+import Graphics.Rendering.Ombra.Blend as Blend+import Graphics.Rendering.Ombra.Geometry.Internal+import Graphics.Rendering.Ombra.Internal.GL+import Graphics.Rendering.Ombra.Object.Types+import Graphics.Rendering.Ombra.Screen 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)+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Shader.ShaderVar (varBuild)+import Graphics.Rendering.Ombra.Stencil as Stencil+import Graphics.Rendering.Ombra.Texture.Internal -infixr 2 :~>+type MonadObject m = ( MonadProgram m+                     , MonadTexture m+                     , MonadScreen m+                     , MonadGeometry m+                     , MonadDrawingMode m+                     ) --- | 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+class MonadDrawingMode m where+        withBlendMode :: Maybe Blend.Mode -> m a -> m a+        withStencilMode :: Maybe Stencil.Mode -> m a -> m a+        withDepthTest :: Bool -> m a -> m a+        withDepthMask :: Bool -> m a -> m a+        withColorMask :: (Bool, Bool, Bool, Bool) -> m a -> m a+        withCulling :: Maybe CullFace -> m a -> m a +withGlobal :: (MonadProgram m, MonadTexture m, MonadScreen m)+           => Global g+           -> m ()+           -> m ()+withGlobal (Single g c) act =+        setUniformValue (Proxy :: Proxy 'S)  (g undefined) c >> act+withGlobal (Mirror g c) act =+           setUniformValue (Proxy :: Proxy 'M) (varBuild (const undefined) g) c+        >> act+withGlobal (WithTexture t gf) act =+        withActiveTexture t () $ flip withGlobal act . gf+withGlobal (WithTextureSize t gf) act =+        textureSize t >>= flip withGlobal act . gf+withGlobal (WithFramebufferSize gf) act =+        currentViewport >>= flip withGlobal act . gf --- Side(s) to be culled.-data CullFace = CullFront | CullBack | CullFrontBack deriving Eq+withObjProp :: MonadDrawingMode m => ObjProp -> m a -> m a+withObjProp (Blend m) a = withBlendMode m a+withObjProp (Stencil m) a = withStencilMode m a+withObjProp (DepthTest d) a = withDepthTest d a+withObjProp (DepthMask m) a = withDepthMask m a+withObjProp (ColorMask m) a = withColorMask m a+withObjProp (Cull face) a = withCulling face a --- TODO: should be Semigroup, mempty is unsafe-instance (ShaderVars gs, ShaderVars is) => Monoid (Object gs is) where-        mempty = NoMesh-        mappend = Append+drawObject :: MonadObject m+           => Object gs is+           -> m ()+drawObject (g :~> o) = withGlobal g $ drawObject o+drawObject (Mesh g) = drawGeometry g+drawObject NoMesh = return ()+drawObject (Prop p o) = withObjProp p $ drawObject o+drawObject (Append o o') = drawObject o >> drawObject o'

@@ -0,0 +1,53 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators,+             FlexibleContexts #-}++module Graphics.Rendering.Ombra.Object.Types where++import Data.Proxy (Proxy)+import Data.Monoid+import qualified Graphics.Rendering.Ombra.Blend as Blend+import qualified Graphics.Rendering.Ombra.Stencil as Stencil+import Graphics.Rendering.Ombra.Geometry.Types+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.Types++-- | 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 :: ((i : is') ~ is) => Geometry (i : 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

@@ -0,0 +1,13 @@+module Graphics.Rendering.Ombra.Screen (+        MonadScreen(..),+        setViewport+) where++import Graphics.Rendering.Ombra.Internal.GL++class GLES => MonadScreen m where+        currentViewport :: m (Int, Int)+        resizeViewport :: Int -> Int -> m ()++setViewport :: (GLES, MonadGL m) => Int -> Int -> m ()+setViewport w h = gl $ viewport 0 0 (fromIntegral w) (fromIntegral h)

@@ -36,6 +36,7 @@ module Graphics.Rendering.Ombra.Shader (         module Data.Boolean,         module Data.VectorSpace,+        module Data.Cross,         -- * Types         Shader.Shader,         Shader.VertexShader,@@ -105,6 +106,9 @@         Shader.reflect,         Shader.refract,         Shader.matrixCompMult,+        Shader.dFdx,+        Shader.dFdy,+        Shader.fwidth,         -- *** Vector relational functions         Shader.VecOrd,         Shader.VecEq,

@@ -2,7 +2,7 @@  module Graphics.Rendering.Ombra.Shader.Default2D (         Uniforms,-        Attributes,+        Geometry2D,         Image(..),         Depth(..),         Transform2(..),@@ -16,8 +16,10 @@ import Graphics.Rendering.Ombra.Shader  type Uniforms = '[View2, Image, Depth, Transform2]-type Attributes = '[Position2, UV] +-- | A 2D geometry.+type Geometry2D = '[Position2, UV]+ -- | An uniform that represents the texture used in the default 2D shader. data Image = Image GSampler2D deriving Generic @@ -33,7 +35,8 @@ data Position2 = Position2 GVec2 deriving Generic  vertexShader :: VertexShader '[Transform2, View2, Depth]-                             '[Position2, UV] '[UV]+                             '[Position2, UV]+                             '[UV] vertexShader (Transform2 trans :- View2 view :- Depth z :- N)              (Position2 pos :- uv@(UV _) :- N) =                 let GVec3 x' y' _ = view .*. trans .* (pos ^| 1)

@@ -2,10 +2,11 @@  module Graphics.Rendering.Ombra.Shader.Default3D (         Uniforms,-        Attributes,+        Geometry3D,         Texture2(..),         Transform3(..),         View3(..),+        Project3(..),         Position3(..),         UV(..),         Normal3(..),@@ -15,29 +16,39 @@  import Graphics.Rendering.Ombra.Shader -type Uniforms = '[View3, Transform3, Texture2]-type Attributes = '[Position3, UV, Normal3]+type Uniforms = '[Project3, View3, Transform3, Texture2] +-- | A 3D geometry.+type Geometry3D = '[Position3, UV, Normal3]+ data Texture2 = Texture2 GSampler2D deriving Generic  data Transform3 = Transform3 GMat4 deriving Generic  data View3 = View3 GMat4 deriving Generic +data Project3 = Project3 GMat4 deriving Generic+ data Position3 = Position3 GVec3 deriving Generic  data Normal3 = Normal3 GVec3 deriving Generic -vertexShader :: VertexShader '[ Transform3, View3 ]-                             '[ Position3, UV, Normal3 ]+-- | The output position and normal are in view space.+vertexShader :: VertexShader '[ Project3, View3, Transform3 ]+                             Geometry3D                              '[ Position3, UV, Normal3 ]-vertexShader (Transform3 modelGMatrix :- View3 viewGMatrix :- N)+vertexShader (  Project3 projMatrix+             :- View3 viewMatrix+             :- Transform3 modelMatrix+             :- N)              (Position3 pos :- uv :- Normal3 norm :- N) =-             let worldPos = store $ modelGMatrix .* (pos ^| 1.0)-                 viewPos = viewGMatrix .* worldPos-                 worldNorm = extract $ modelGMatrix .* (norm ^| 0)-             in Vertex viewPos :- Position3 (extract worldPos) :--                uv :- Normal3 worldNorm :- N+             let worldPos = modelMatrix .* (pos ^| 1.0)+                 viewPos = store $ viewMatrix .* worldPos+                 projPos = projMatrix .* viewPos+                 worldNorm = modelMatrix .* (norm ^| 0)+                 viewNorm = viewMatrix .* worldNorm+             in Vertex projPos :- Position3 (extract viewPos) :-+                uv :- Normal3 (extract viewNorm) :- N  fragmentShader :: FragmentShader '[ Texture2 ] [ Position3, UV, Normal3 ] fragmentShader (Texture2 sampler :- N) (_ :- UV (GVec2 s t) :- _ :- N) =

@@ -9,6 +9,7 @@         uniformName ) where +import Data.List (find) import Data.Hashable (hash) -- TODO: use ST hashtables import qualified Data.HashMap.Strict as H import Data.Typeable@@ -41,9 +42,15 @@  fragmentToGLSL :: (ShaderVars g, ShaderVars i) => FragmentShader g i -> String fragmentToGLSL v =-        shaderToGLSL "#version 100\nprecision mediump float;"-                     "varying" "" (vars True v)-                      [ ("hvFragmentShaderOutput0", "gl_FragData[0]")+        let r@(SV _ _ os) = vars True v+            header | Just _ <- find (\(_, n, _) -> requiresMRT n) os = +                    "#extension GL_EXT_draw_buffers : require\n"+                   | otherwise = ""+        in shaderToGLSL ("#version 100\n" ++ header +++                         "#extension GL_OES_standard_derivatives : enable\n" +++                         "precision mediump float;")+                        "varying" "" (vars True v) subst+        where subst = [ ("hvFragmentShaderOutput0", "gl_FragData[0]")                       , ("hvFragmentShaderOutput1", "gl_FragData[1]")                       , ("hvFragmentShaderOutput2", "gl_FragData[2]")                       , ("hvFragmentShaderOutput3", "gl_FragData[3]")@@ -59,6 +66,8 @@                       , ("hvFragmentShaderOutput13", "gl_FragData[13]")                       , ("hvFragmentShaderOutput14", "gl_FragData[14]")                       , ("hvFragmentShaderOutput15", "gl_FragData[15]") ]+              requiresMRT "hvFragmentShaderOutput0" = False+              requiresMRT _ = True  shaderToGLSL :: String -> String -> String -> SV -> [(String, String)] -> String shaderToGLSL header ins outs (SV gs is os) predec = concat

@@ -88,6 +88,9 @@         reflect,         refract,         matrixCompMult,+        dFdx,+        dFdy,+        fwidth,         -- *** Vector relational functions         VecOrd,         VecEq,

@@ -422,6 +422,18 @@ textureCubeLod :: GSamplerCube -> GVec3 -> GFloat -> GVec4 textureCubeLod = fun3 "textureCubeLod" +-- | Partial derivative of the argument with respect to the window X coordinate.+dFdx :: GenType a => a -> a+dFdx = fun1 "dFdx"++-- | Partial derivative of the argument with respect to the window Y coordinate.+dFdy :: GenType a => a -> a+dFdy = fun1 "dFdy"++-- | Sum of the absolute values of 'dFdx' and 'dFdy'.+fwidth :: GenType a => a -> a+fwidth = fun1 "fwidth"+ -- | The position of the vertex (only works in the vertex shader). position :: GVec4 position = fromExpr $ Read "gl_Position"

@@ -4,12 +4,15 @@              TypeSynonymInstances, FlexibleContexts #-}  module Graphics.Rendering.Ombra.Shader.Program (+        MonadProgram(..),         LoadedProgram(..),         Compatible,         Program,         ProgramIndex,         program,-        loadProgram,+        setProgram,+        UniformLocation(..),+        setUniformValue,         DefaultUniforms2D,         DefaultAttributes2D,         DefaultUniforms3D,@@ -23,10 +26,11 @@ import qualified Data.HashMap.Strict as H import qualified Graphics.Rendering.Ombra.Shader.Default2D as Default2D import qualified Graphics.Rendering.Ombra.Shader.Default3D as Default3D+import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Shader.GLSL-import Graphics.Rendering.Ombra.Shader.ShaderVar (ShaderVars)+import Graphics.Rendering.Ombra.Shader.ShaderVar (ShaderVar, ShaderVars) import Graphics.Rendering.Ombra.Shader.Stages-import Graphics.Rendering.Ombra.Internal.GL hiding (Program)+import Graphics.Rendering.Ombra.Internal.GL hiding (Program, UniformLocation) import qualified Graphics.Rendering.Ombra.Internal.GL as GL import Graphics.Rendering.Ombra.Internal.Resource import Graphics.Rendering.Ombra.Internal.TList@@ -40,17 +44,19 @@  newtype ProgramIndex = ProgramIndex Int deriving Eq +newtype UniformLocation = UniformLocation GL.UniformLocation+ -- | The uniforms used in the default 3D program. type DefaultUniforms3D = Default3D.Uniforms  -- | The attributes used in the default 3D program.-type DefaultAttributes3D = Default3D.Attributes+type DefaultAttributes3D = Default3D.Geometry3D  -- | The uniforms used in the default 2D program. type DefaultUniforms2D = Default2D.Uniforms  -- | The attributes used in the default 2D program.-type DefaultAttributes2D = Default2D.Attributes+type DefaultAttributes2D = Default2D.Geometry2D  instance Hashable (Program gs is) where         hashWithSalt salt (Program _ _ h) = hashWithSalt salt h@@ -66,9 +72,15 @@  instance GLES => Resource (Program g i) LoadedProgram GL where         -- TODO: err check!-        loadResource i = Right <$> loadProgram i+        loadResource i = loadProgram i         unloadResource _ (LoadedProgram p _ _) = deleteProgram p +instance GLES => Resource (LoadedProgram, String) UniformLocation GL where+        loadResource (LoadedProgram prg _ _, g) =+                do loc <- getUniformLocation prg $ toGLString g+                   return . Right $ UniformLocation loc+        unloadResource _ _ = return ()+ -- | Compatible shaders. type Compatible pgs vgs fgs =         EqualOrErr pgs (Union vgs fgs)@@ -100,30 +112,66 @@ defaultProgram2D :: Program DefaultUniforms2D DefaultAttributes2D defaultProgram2D = program Default2D.vertexShader Default2D.fragmentShader -loadProgram :: GLES => Program g i -> GL LoadedProgram+class (GLES, MonadGL m) => MonadProgram m where+        withProgram :: Program gs is -> (LoadedProgram -> m ()) -> m ()+        getUniform :: String -> m (Either String UniformLocation)++setUniformValue :: (MonadProgram m, ShaderVar g, Uniform s g)+                => proxy (s :: CPUSetterType *)+                -> g+                -> CPU s g+                -> m ()+setUniformValue p g c = withUniforms p g c $ \n ug uc ->+        getUniform (uniformName g n) >>= \eu ->+                case eu of+                     Right (UniformLocation l) -> gl $ setUniform l ug uc+                     Left _ -> return ()++setProgram :: MonadProgram m => Program gs is -> m ()+setProgram p = withProgram p $ \(LoadedProgram glp _ _) -> gl $ useProgram glp++loadProgram :: GLES => Program g i -> GL (Either String LoadedProgram) loadProgram (Program (vss, attrs) fss h) =         do glp <- createProgram               vs <- loadSource gl_VERTEX_SHADER vss            fs <- loadSource gl_FRAGMENT_SHADER fss-           attachShader glp vs-           attachShader glp fs++           vsStatus <- getShaderParameterBool vs gl_COMPILE_STATUS+           fsStatus <- getShaderParameterBool fs gl_COMPILE_STATUS++           if isTrue vsStatus && isTrue fsStatus+           then do attachShader glp vs+                   attachShader glp fs   -           locs <- bindAttribs glp 0 attrs []-           linkProgram glp+                   locs <- bindAttribs glp 0 attrs []+                   linkProgram glp++                   -- TODO: error check   -           -- TODO: ??-           {--           detachShader glp vs-           detachShader glp fs-           -}+                   -- TODO: ??+                   {-+                   detachShader glp vs+                   detachShader glp fs+                   -}   -           return $ LoadedProgram glp (H.fromList locs) h+                   return . Right $ LoadedProgram glp+                                                  (H.fromList locs)+                                                  (hash glp)+           else do vsError <- shaderError vs vsStatus "Vertex shader"+                   fsError <- shaderError fs fsStatus "Fragment shader" +                   return . Left $ vsError ++ fsError+         where bindAttribs _ _ [] r = return r               bindAttribs glp i ((nm, sz) : xs) r =                         bindAttribLocation glp (fromIntegral i) (toGLString nm)                         >> bindAttribs glp (i + sz) xs ((nm, i) : r)++              shaderError :: GLES => Shader -> GLBool -> String -> GL String+              shaderError _ b _ | isTrue b = return ""+              shaderError s _ name = getShaderInfoLog s >>= \err ->+                        return $ name ++ " error:" ++ fromGLString err ++ "\n"  loadSource :: GLES => GLEnum -> String -> GL Shader loadSource ty src =

@@ -5,51 +5,48 @@ import Graphics.Rendering.Ombra.Vector  rectGeometry :: GLES => Geometry Geometry2D-rectGeometry = mkGeometry2DInd [ (Vec2 (-0.5) (-0.5), Vec2 0 0)-                               , (Vec2 0.5    (-0.5), Vec2 1 0)-                               , (Vec2 0.5    0.5   , Vec2 1 1)-                               , (Vec2 (-0.5) 0.5   , Vec2 0 1)-                               ]-                               [ Triangle 0 1 2-                               , Triangle 0 3 2-                               ]+rectGeometry = buildGeometry $ do lb <- vertex2D (Vec2 (-0.5) (-0.5)) (Vec2 0 0)+                                  rb <- vertex2D (Vec2 0.5    (-0.5)) (Vec2 1 0)+                                  rt <- vertex2D (Vec2 0.5    0.5   ) (Vec2 1 1)+                                  lt <- vertex2D (Vec2 (-0.5) 0.5   ) (Vec2 0 1)+                                  triangle lb rb rt+                                  triangle lb lt rt  cubeGeometry :: GLES => Geometry Geometry3D-cubeGeometry = mkGeometry3DInd [ (Vec3 1 1 (-1), Vec2 1 0, Vec3 0 0 (-1))-                               , (Vec3 1 (-1) (-1), Vec2 1 1, Vec3 0 0 (-1))-                               , (Vec3 (-1) 1 (-1), Vec2 0 0, Vec3 0 0 (-1))-                               , (Vec3 (-1) (-1) 1, Vec2 0 1, Vec3 (-1) 0 0)-                               , (Vec3 (-1) 1 1, Vec2 0 0, Vec3 (-1) 0 0)-                               , (Vec3 (-1) (-1) (-1), Vec2 1 1, Vec3 (-1) 0 0)-                               , (Vec3 (-1) (-1) 1, Vec2 0 0, Vec3 0 0 1)-                               , (Vec3 1 (-1) 1, Vec2 1 0, Vec3 0 0 1)-                               , (Vec3 (-1) 1 1, Vec2 0 1, Vec3 0 0 1)-                               , (Vec3 1 (-1) 1, Vec2 0 0, Vec3 1 0 0)-                               , (Vec3 1 (-1) (-1), Vec2 1 0, Vec3 1 0 0)-                               , (Vec3 1 1 1, Vec2 0 1, Vec3 1 0 0)-                               , (Vec3 1 1 (-1), Vec2 1 1, Vec3 0 1 0)-                               , (Vec3 (-1) 1 (-1), Vec2 0 1, Vec3 0 1 0)-                               , (Vec3 1 1 1, Vec2 1 0, Vec3 0 1 0)-                               , (Vec3 1 (-1) (-1), Vec2 1 1, Vec3 0 (-1) 0)-                               , (Vec3 1 (-1) 1, Vec2 0 1, Vec3 0 (-1) 0)-                               , (Vec3 (-1) (-1) (-1), Vec2 1 0, Vec3 0 (-1) 0)-                               , (Vec3 (-1) (-1) (-1), Vec2 0 1, Vec3 0 0 (-1))-                               , (Vec3 (-1) 1 (-1), Vec2 1 0, Vec3 (-1) 0 0)-                               , (Vec3 1 1 1, Vec2 1 1, Vec3 0 0 1)-                               , (Vec3 1 1 (-1), Vec2 1 1, Vec3 1 0 0)-                               , (Vec3 (-1) 1 1, Vec2 0 0, Vec3 0 1 0)-                               , (Vec3 (-1) (-1) 1, Vec2 0 0, Vec3 0 (-1) 0)-                               ]-                               [ Triangle 0 1 2-                               , Triangle 3 4 5-                               , Triangle 6 7 8-                               , Triangle 9 10 11-                               , Triangle 12 13 14-                               , Triangle 15 16 17-                               , Triangle 1 18 2-                               , Triangle 4 19 5-                               , Triangle 7 20 8-                               , Triangle 10 21 11-                               , Triangle 13 22 14-                               , Triangle 16 23 17-                               ]+cubeGeometry = buildGeometry $+        do v0 <- vertex3D (Vec3 1 1 (-1)) (Vec2 1 0) (Vec3 0 0 (-1))+           v1 <- vertex3D (Vec3 1 (-1) (-1)) (Vec2 1 1) (Vec3 0 0 (-1))+           v2 <- vertex3D (Vec3 (-1) 1 (-1)) (Vec2 0 0) (Vec3 0 0 (-1))+           v3 <- vertex3D (Vec3 (-1) (-1) 1) (Vec2 0 1) (Vec3 (-1) 0 0)+           v4 <- vertex3D (Vec3 (-1) 1 1) (Vec2 0 0) (Vec3 (-1) 0 0)+           v5 <- vertex3D (Vec3 (-1) (-1) (-1)) (Vec2 1 1) (Vec3 (-1) 0 0)+           v6 <- vertex3D (Vec3 (-1) (-1) 1) (Vec2 0 0) (Vec3 0 0 1)+           v7 <- vertex3D (Vec3 1 (-1) 1) (Vec2 1 0) (Vec3 0 0 1)+           v8 <- vertex3D (Vec3 (-1) 1 1) (Vec2 0 1) (Vec3 0 0 1)+           v9 <- vertex3D (Vec3 1 (-1) 1) (Vec2 0 0) (Vec3 1 0 0)+           v10 <- vertex3D (Vec3 1 (-1) (-1)) (Vec2 1 0) (Vec3 1 0 0)+           v11 <- vertex3D (Vec3 1 1 1) (Vec2 0 1) (Vec3 1 0 0)+           v12 <- vertex3D (Vec3 1 1 (-1)) (Vec2 1 1) (Vec3 0 1 0)+           v13 <- vertex3D (Vec3 (-1) 1 (-1)) (Vec2 0 1) (Vec3 0 1 0)+           v14 <- vertex3D (Vec3 1 1 1) (Vec2 1 0) (Vec3 0 1 0)+           v15 <- vertex3D (Vec3 1 (-1) (-1)) (Vec2 1 1) (Vec3 0 (-1) 0)+           v16 <- vertex3D (Vec3 1 (-1) 1) (Vec2 0 1) (Vec3 0 (-1) 0)+           v17 <- vertex3D (Vec3 (-1) (-1) (-1)) (Vec2 1 0) (Vec3 0 (-1) 0)+           v18 <- vertex3D (Vec3 (-1) (-1) (-1)) (Vec2 0 1) (Vec3 0 0 (-1))+           v19 <- vertex3D (Vec3 (-1) 1 (-1)) (Vec2 1 0) (Vec3 (-1) 0 0)+           v20 <- vertex3D (Vec3 1 1 1) (Vec2 1 1) (Vec3 0 0 1)+           v21 <- vertex3D (Vec3 1 1 (-1)) (Vec2 1 1) (Vec3 1 0 0)+           v22 <- vertex3D (Vec3 (-1) 1 1) (Vec2 0 0) (Vec3 0 1 0)+           v23 <- vertex3D (Vec3 (-1) (-1) 1) (Vec2 0 0) (Vec3 0 (-1) 0)+           triangle v0 v1 v2+           triangle v3 v4 v5+           triangle v6 v7 v8+           triangle v9 v10 v11+           triangle v12 v13 v14+           triangle v15 v16 v17+           triangle v1 v18 v2+           triangle v4 v19 v5+           triangle v7 v20 v8+           triangle v10 v21 v11+           triangle v13 v22 v14+           triangle v16 v23 v17

@@ -13,6 +13,7 @@ import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Internal.GL hiding (Texture) import Graphics.Rendering.Ombra.Texture.Internal+import Graphics.Rendering.Ombra.Texture.Types import Graphics.Rendering.Ombra.Vector  -- | Creates a 'Texture' from a list of pixels.

@@ -1,54 +1,63 @@ {-# LANGUAGE MultiParamTypeClasses #-} -module Graphics.Rendering.Ombra.Texture.Internal where+module Graphics.Rendering.Ombra.Texture.Internal (+        MonadTexture(..),+        withActiveTexture,+        textureSize,+        emptyTexture+) where  import Control.Monad (when) 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.GL hiding (Texture) import Graphics.Rendering.Ombra.Internal.Resource---- | A texture.-data Texture = TextureImage TextureImage-             | TextureLoaded LoadedTexture-             deriving Eq-             -data TextureImage = TexturePixels Bool [[Color]] (Filter, Maybe Filter) Filter-                                  GLSize GLSize Int-                  | TextureRaw Bool [UInt8Array] (Filter, Maybe Filter) Filter-                               GLSize GLSize Int-                  | TextureFloat [Float] (Filter, Maybe 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'+import Graphics.Rendering.Ombra.Texture.Types -textureHash :: TextureImage -> Int-textureHash (TexturePixels _ _ _ _ _ _ h) = h-textureHash (TextureRaw _ _ _ _ _ _ h) = h-textureHash (TextureFloat _ _ _ _ _ h) = h+class (MonadGL m, GLES) => MonadTexture m where+        getTexture :: Texture -> m (Either String LoadedTexture)+        getActiveTexturesCount :: m Int+        setActiveTexturesCount :: Int -> m ()+        newTexture :: Int+                   -> Int+                   -> (Filter, Maybe Filter)+                   -> Filter+                   -> m LoadedTexture+        unusedTexture :: LoadedTexture -> m ()  instance GLES => Resource TextureImage LoadedTexture GL where         loadResource i = Right <$> loadTextureImage i         unloadResource _ (LoadedTexture _ _ t) = deleteTexture t++makeActive :: MonadTexture m => (ActiveTexture -> m a) -> m a+makeActive f = do atn <- getActiveTexturesCount+                  setActiveTexturesCount $ atn + 1+                  gl . activeTexture $ gl_TEXTURE0 + fromIntegral atn+                  ret <- f . ActiveTexture . fromIntegral $ atn+                  setActiveTexturesCount $ atn+                  return ret++withActiveTexture :: MonadTexture m+                  => Texture+                  -> a+                  -> (ActiveTexture -> m a)+                  -> m a+withActiveTexture tex fail f = getTexture tex >>= \etex ->+        case etex of+             Left _ -> return fail+             Right (LoadedTexture _ _ wtex) -> makeActive $+                        \at -> do gl $ bindTexture gl_TEXTURE_2D wtex+                                  f at++-- | Get the dimensions of a 'Texture'.+textureSize :: (MonadTexture m, Num a) => Texture -> m (a, a)+textureSize tex = do etex <- getTexture tex+                     case etex of+                          Left _ -> return (0, 0)+                          Right (LoadedTexture w h _) ->+                                  return (fromIntegral w, fromIntegral h)  loadTextureImage :: GLES => TextureImage -> GL LoadedTexture loadTextureImage (TexturePixels g pss min mag w h hash) =

@@ -0,0 +1,43 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Graphics.Rendering.Ombra.Texture.Types where++import Data.Hashable+import Graphics.Rendering.Ombra.Backend hiding (Texture)+import qualified Graphics.Rendering.Ombra.Backend as GL+import Graphics.Rendering.Ombra.Color++-- | A texture.+data Texture = TextureImage TextureImage+             | TextureLoaded LoadedTexture+             deriving Eq+             +data TextureImage = TexturePixels Bool [[Color]] (Filter, Maybe Filter) Filter+                                  GLSize GLSize Int+                  | TextureRaw Bool [UInt8Array] (Filter, Maybe Filter) Filter+                               GLSize GLSize Int+                  | TextureFloat [Float] (Filter, Maybe 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

@@ -54,8 +54,8 @@                    {-# UNPACK #-} !Int32                    deriving (Generic, Show, Eq) -infixr 5 ^|-infixr 5 ^|^+infixl 5 ^|+infixl 5 ^|^ class VectorSpace v => Ext v where         type Extended v = w | w -> v         -- | Extend the vector with a specified scalar.

@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Luca Prezzavento+Copyright (c) 2014-2017, Luca Prezzavento  All rights reserved. 

@@ -12,3 +12,7 @@   * Written in **Haskell**  Running examples: [01](http://ziocroc.github.io/Ombra/01/) [02](http://ziocroc.github.io/Ombra/02/) [03](http://ziocroc.github.io/Ombra/03/) [04](http://ziocroc.github.io/Ombra/04/) [05](http://ziocroc.github.io/Ombra/05/) [06](http://ziocroc.github.io/Ombra/06/) ++[Installation](https://github.com/ziocroc/Ombra/wiki/Installation) (important)++[Documentation](https://hackage.haskell.org/package/ombra/docs/Graphics-Rendering-Ombra.html)

@@ -1,5 +1,5 @@ name:                ombra-version:             0.3.0.0+version:             0.3.1.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@@ -12,7 +12,7 @@ copyright:           Copyright © 2014-2017 Luca Prezzavento category:            Graphics build-type:          Simple-extra-source-files:  README.md+extra-source-files:  README.md, CHANGES.md cabal-version:       >=1.10  source-repository head@@ -49,6 +49,7 @@    other-modules:       Graphics.Rendering.Ombra.Internal.Resource,                        Graphics.Rendering.Ombra.Internal.TList,+                       Graphics.Rendering.Ombra.Screen,                        Graphics.Rendering.Ombra.Shader.ShaderVar,                        Graphics.Rendering.Ombra.Shader.GLSL,                        Graphics.Rendering.Ombra.Shader.Stages,@@ -59,9 +60,13 @@                        Graphics.Rendering.Ombra.Shader.Language.Functions,                        Graphics.Rendering.Ombra.Draw.Internal,                        Graphics.Rendering.Ombra.Layer.Internal,+                       Graphics.Rendering.Ombra.Layer.Types,                        Graphics.Rendering.Ombra.Object.Internal,+                       Graphics.Rendering.Ombra.Object.Types,                        Graphics.Rendering.Ombra.Geometry.Internal,+                       Graphics.Rendering.Ombra.Geometry.Types,                        Graphics.Rendering.Ombra.Texture.Internal,+                       Graphics.Rendering.Ombra.Texture.Types,                        Graphics.Rendering.Ombra.Blend.Internal,                        Graphics.Rendering.Ombra.Stencil.Internal @@ -98,7 +103,7 @@   build-depends:       base <5.0, Boolean <0.3, vector-space <0.11, hashable <1.3, unordered-containers <0.3, transformers <0.6, hashtables <1.4    if flag(opengl) && !flag(webgl)-    build-depends:     gl <0.8+    build-depends:     gl >=0.8 && <0.9    if flag(webgl)     build-depends:     ghcjs-base