ombra 0.3.1.0 → 1.0.0.0

raw patch · 62 files changed

+4274/−4421 lines, 62 filesdep +MemoTriedep +monad-controldep +transformers-basedep ~basedep ~vector-spacePVP ok

version bump matches the API change (PVP)

Dependencies added: MemoTrie, monad-control, transformers-base

Dependency ranges changed: base, vector-space

API changes (from Hackage documentation)

Files

• CHANGES.md +0/−8
• Graphics/Rendering/Ombra.hs +12/−23
• Graphics/Rendering/Ombra/Backend.hs +49/−30
• Graphics/Rendering/Ombra/Backend/OpenGL.hs +47/−25
• Graphics/Rendering/Ombra/Backend/WebGL.hs +66/−68
• Graphics/Rendering/Ombra/Backend/WebGL/Raw.hs +7/−1
• Graphics/Rendering/Ombra/Backend/WebGL/Types.hs +4/−0
• Graphics/Rendering/Ombra/Blend.hs +23/−2
• Graphics/Rendering/Ombra/Blend/Draw.hs +46/−0
• Graphics/Rendering/Ombra/Blend/Internal.hs +0/−65
• Graphics/Rendering/Ombra/Blend/Types.hs +29/−0
• Graphics/Rendering/Ombra/Color.hs +8/−1
• Graphics/Rendering/Ombra/Culling/Draw.hs +9/−0
• Graphics/Rendering/Ombra/Culling/Types.hs +6/−0
• Graphics/Rendering/Ombra/D2.hs +0/−163
• Graphics/Rendering/Ombra/D3.hs +0/−183
• Graphics/Rendering/Ombra/Draw.hs +35/−46
• Graphics/Rendering/Ombra/Draw/Class.hs +76/−0
• Graphics/Rendering/Ombra/Draw/Internal.hs +0/−405
• Graphics/Rendering/Ombra/Draw/Monad.hs +752/−0
• Graphics/Rendering/Ombra/Geometry.hs +156/−66
• Graphics/Rendering/Ombra/Geometry/Draw.hs +137/−0
• Graphics/Rendering/Ombra/Geometry/Internal.hs +0/−317
• Graphics/Rendering/Ombra/Geometry/Types.hs +264/−44
• Graphics/Rendering/Ombra/Image.hs +74/−0
• Graphics/Rendering/Ombra/Image/Types.hs +35/−0
• Graphics/Rendering/Ombra/Internal/GL.hs +44/−12
• Graphics/Rendering/Ombra/Internal/Resource.hs +23/−22
• Graphics/Rendering/Ombra/Layer.hs +0/−214
• Graphics/Rendering/Ombra/Layer/Internal.hs +0/−333
• Graphics/Rendering/Ombra/Layer/Types.hs +0/−70
• Graphics/Rendering/Ombra/Object.hs +0/−221
• Graphics/Rendering/Ombra/Object/Internal.hs +0/−67
• Graphics/Rendering/Ombra/Object/Types.hs +0/−53
• Graphics/Rendering/Ombra/OutBuffer.hs +52/−0
• Graphics/Rendering/Ombra/OutBuffer/Types.hs +100/−0
• Graphics/Rendering/Ombra/Screen.hs +2/−1
• Graphics/Rendering/Ombra/Shader.hs +202/−433
• Graphics/Rendering/Ombra/Shader/CPU.hs +77/−192
• Graphics/Rendering/Ombra/Shader/Default2D.hs +0/−47
• Graphics/Rendering/Ombra/Shader/Default3D.hs +0/−55
• Graphics/Rendering/Ombra/Shader/GLSL.hs +224/−175
• Graphics/Rendering/Ombra/Shader/Language.hs +418/−180
• Graphics/Rendering/Ombra/Shader/Language/Functions.hs +82/−45
• Graphics/Rendering/Ombra/Shader/Language/Types.hs +164/−62
• Graphics/Rendering/Ombra/Shader/Program.hs +23/−64
• Graphics/Rendering/Ombra/Shader/ShaderVar.hs +0/−131
• Graphics/Rendering/Ombra/Shader/Stages.hs +0/−108
• Graphics/Rendering/Ombra/Shader/Types.hs +661/−0
• Graphics/Rendering/Ombra/Shapes.hs +0/−52
• Graphics/Rendering/Ombra/Stencil.hs +14/−2
• Graphics/Rendering/Ombra/Stencil/Draw.hs +35/−0
• Graphics/Rendering/Ombra/Stencil/Internal.hs +0/−68
• Graphics/Rendering/Ombra/Stencil/Types.hs +42/−0
• Graphics/Rendering/Ombra/Texture.hs +70/−43
• Graphics/Rendering/Ombra/Texture/Draw.hs +130/−0
• Graphics/Rendering/Ombra/Texture/Internal.hs +0/−113
• Graphics/Rendering/Ombra/Texture/Types.hs +35/−14
• Graphics/Rendering/Ombra/Transformation.hs +0/−154
• Graphics/Rendering/Ombra/Vector.hs +7/−0
• README.md +1/−13
• ombra.cabal +33/−30

@@ -1,8 +0,0 @@-## 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

@@ -1,34 +1,23 @@-{-|-This module re-exports all the modules used to build scenes with Ombra.----You may also want to import:--"Graphics.Rendering.Ombra.D3": 3D graphics--"Graphics.Rendering.Ombra.D2": 2D graphics--"Graphics.Rendering.Ombra.Vector": vectors and matrices--"Graphics.Rendering.Ombra.Shader": to write shaders--"Graphics.Rendering.Ombra.Draw": to render the layers--} module Graphics.Rendering.Ombra (         module Graphics.Rendering.Ombra.Color,+        module Graphics.Rendering.Ombra.Draw,         module Graphics.Rendering.Ombra.Geometry,-        module Graphics.Rendering.Ombra.Layer,-        module Graphics.Rendering.Ombra.Object,+        module Graphics.Rendering.Ombra.Shader,+        module Graphics.Rendering.Ombra.Image,         module Graphics.Rendering.Ombra.Texture, -        -- * Backend constraint-        GLES+        -- * Backend+        GLES( hasVertexArrayObjects+            , hasFloatTextures+            , hasDrawBuffers+            , hasStandardDerivatives+            ) ) where  import Graphics.Rendering.Ombra.Backend import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Draw import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Layer-import Graphics.Rendering.Ombra.Object+import Graphics.Rendering.Ombra.Shader+import Graphics.Rendering.Ombra.Image import Graphics.Rendering.Ombra.Texture

@@ -1,7 +1,15 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses,+             FlexibleContexts, ConstraintKinds #-} -module Graphics.Rendering.Ombra.Backend where+-- |+-- Module:      Graphics.Rendering.Ombra.Backend+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only +module Graphics.Rendering.Ombra.Backend (GLES(..)) where+ import Control.Concurrent (ThreadId) import Data.Bits (Bits) import Data.Hashable (Hashable)@@ -12,26 +20,31 @@ import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.Vector --- Mixed OpenGL ES 2.0/WebGL 1.0/OpenGL 2.0 API, with VAOs and FBOs.--- | Backend API.-class ( Integral GLEnum-      , Integral GLUInt-      , Integral GLInt-      , Integral GLSize-      , Bits GLEnum-      , Num GLEnum-      , Num GLUInt-      , Num GLInt-      , Num GLPtrDiff-      , Num GLSize-      , Eq GLEnum-      , Eq GLUInt-      , Eq GLInt-      , Eq GLPtrDiff-      , Eq GLSize-      , Eq Texture-      , Eq Program-      , Hashable Program) => GLES where+type GLTypes enum uint int size ptrdiff texture program =+      ( Integral enum+      , Integral uint+      , Integral int+      , Integral size+      , Bits enum+      , Num enum+      , Num uint+      , Num int+      , Num ptrdiff+      , Num size+      , Eq enum+      , Eq uint+      , Eq int+      , Eq ptrdiff+      , Eq size+      , Eq texture+      , Eq program+      , Hashable program+      )++-- | Instances of this class are implementations of the OpenGL API.+class GLTypes GLEnum GLUInt GLInt GLSize+              GLPtrDiff Texture Program+      => GLES where         type Ctx         type GLEnum         type GLUInt@@ -65,6 +78,7 @@         toGLString :: String -> GLString         fromGLString :: GLString -> String         noBuffer :: Buffer+        noFramebuffer :: FrameBuffer         noTexture :: Texture         noVAO :: VertexArrayObject         noUInt8Array :: IO UInt8Array@@ -80,25 +94,27 @@         encodeIVec2s :: [IVec2] -> IO Int32Array         encodeIVec3s :: [IVec3] -> IO Int32Array         encodeIVec4s :: [IVec4] -> IO Int32Array-        encodeUShorts :: [Word16] -> IO UInt16Array+        encodeUInt16s :: [Word16] -> IO UInt16Array         encodeUInt8s :: [Word8] -> IO UInt8Array -        newByteArray :: Int -> IO UInt8Array+        newUInt8Array :: Int -> IO UInt8Array+        newUInt16Array :: Int -> IO UInt16Array+        newFloat32Array :: Int -> IO Float32Array         fromFloat32Array :: Float32Array -> AnyArray         fromInt32Array :: Int32Array -> AnyArray         fromUInt8Array :: UInt8Array -> AnyArray         fromUInt16Array :: UInt16Array -> AnyArray-        decodeBytes :: UInt8Array -> IO [Word8]+        decodeUInt8s :: UInt8Array -> IO [Word8]+        decodeUInt16s :: UInt16Array -> IO [Word16]+        decodeFloat32s :: Float32Array -> IO [Float]          -- | 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.+        -- | Required for using float textures and GBuffers.         hasFloatTextures :: Ctx -> IO Bool -        -- | Required for the buffers* layer functions. May not be supported-        -- on older hardware.+        -- | Required for using GBuffers with more than 4 GFloats.         hasDrawBuffers :: Ctx -> IO Bool          -- | Required for the dFdx, dFdy and fwidth shader functions.@@ -193,7 +209,9 @@         glLinkProgram :: Ctx -> Program -> IO ()         glPixelStorei :: Ctx -> GLEnum -> GLInt -> IO ()         glPolygonOffset :: Ctx -> Float -> Float -> IO ()-        glReadPixels :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt8Array -> IO ()+        glReadPixelsUInt8 :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt8Array -> IO ()+        glReadPixelsUInt16 :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt16Array -> IO ()+        glReadPixelsFloat :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Float32Array -> IO ()         glRenderbufferStorage :: Ctx -> GLEnum -> GLEnum -> GLSize -> GLSize -> IO ()         glSampleCoverage :: Ctx -> Float -> GLBool -> IO ()         glScissor :: Ctx -> GLInt -> GLInt -> GLSize -> GLSize -> IO ()@@ -504,6 +522,7 @@         gl_RGB5_A1 :: GLEnum         gl_RGB565 :: GLEnum         gl_DEPTH_COMPONENT16 :: GLEnum+        gl_STENCIL_INDEX :: GLEnum         gl_STENCIL_INDEX8 :: GLEnum         gl_RENDERBUFFER_WIDTH :: GLEnum         gl_RENDERBUFFER_HEIGHT :: GLEnum

@@ -1,5 +1,12 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} +-- |+-- Module:      Graphics.Rendering.Ombra.Backend.OpenGL+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only+ module Graphics.Rendering.Ombra.Backend.OpenGL (makeContext) where          import Data.Word@@ -37,9 +44,12 @@                      return str         where len = 4096 -uniform :: (a -> GLsizei -> Ptr b -> IO ())+uniform :: forall a b ctx. Storable b+        => GLsizei+        -> (a -> GLsizei -> Ptr b -> IO ())         -> ctx -> a -> (GLsizei, ForeignPtr b) -> IO ()-uniform f _ a (len, fp) = withForeignPtr fp $ f a (quot len 4)+uniform mul f _ a (len, fp) = withForeignPtr fp $ f a (quot len sz)+        where sz = mul * fromIntegral (sizeOf (undefined :: b))  uniformMatrix :: (a -> GLsizei -> GLboolean -> Ptr b -> IO ()) -> GLsizei               -> ctx -> a -> GLboolean -> (GLsizei, ForeignPtr b) -> IO ()@@ -59,12 +69,12 @@ arrayToList (sz, fptr) = withForeignPtr (castForeignPtr fptr) $ \ptr ->                                 peekArray (fromIntegral sz) ptr -mkArray :: Storable a => [a] -> IO (GLsizei, ForeignPtr b)+mkArray :: forall a b. Storable a => [a] -> IO (GLsizei, ForeignPtr b) mkArray xs = do arr <- mallocForeignPtrArray len                 withForeignPtr arr $ flip pokeArray xs                 return (fromIntegral size, castForeignPtr arr)         where len = length xs-              size = len * sizeOf (head xs)+              size = len * sizeOf (undefined :: a)  instance GLES where         type Ctx = [String]@@ -98,26 +108,29 @@         toGLString = id         fromGLString = id         noBuffer = 0+        noFramebuffer = 0         noTexture = 0         noVAO = 0         noUInt8Array = fmap ((,) 0) $ newForeignPtr_ nullPtr         noFloat32Array = fmap ((,) 0) $ newForeignPtr_ nullPtr          encodeMat2 (Mat2 (Vec2 a1 a2) (Vec2 b1 b2)) =-                mkArray [ a1, a2, b1, b2 ]+                mkArray [ a1, b1, a2, b2 ]          encodeMat3 (Mat3 (Vec3 a1 a2 a3)                          (Vec3 b1 b2 b3)-                         (Vec3 c1 c2 c3)) = mkArray [ a1, a2, a3-                                                    , b1, b2, b3-                                                    , c1, c2, c3 ]+                         (Vec3 c1 c2 c3)) = mkArray [ a1, b1, c1+                                                    , a2, b2, c2+                                                    , a3, b3, c3+                                                    ]         encodeMat4 (Mat4 (Vec4 a1 a2 a3 a4)                          (Vec4 b1 b2 b3 b4)                          (Vec4 c1 c2 c3 c4)-                         (Vec4 d1 d2 d3 d4) ) = mkArray [ a1, a2, a3, a4-                                                        , b1, b2, b3, b4-                                                        , c1, c2, c3, c4-                                                        , d1, d2, d3, d4 ]+                         (Vec4 d1 d2 d3 d4) ) = mkArray [ a1, b1, c1, d1+                                                        , a2, b2, c2, d2+                                                        , a3, b3, c3, d3+                                                        , a4, b4, c4, d4+                                                        ]          encodeFloats = mkArray         encodeVec2s = mkArray@@ -127,15 +140,19 @@         encodeIVec2s = mkArray         encodeIVec3s = mkArray         encodeIVec4s = mkArray-        encodeUShorts = mkArray         encodeUInt8s = mkArray+        encodeUInt16s = mkArray -        newByteArray = mkArrayLen+        newUInt8Array = mkArrayLen+        newUInt16Array = mkArrayLen+        newFloat32Array = mkArrayLen         fromFloat32Array (size, fptr) = (size, castForeignPtr fptr)         fromInt32Array (size, fptr) = (size, castForeignPtr fptr)         fromUInt16Array (size, fptr) = (size, castForeignPtr fptr)         fromUInt8Array (size, fptr) = (size, castForeignPtr fptr)-        decodeBytes (s, f) = arrayToList (s, castForeignPtr f)+        decodeUInt8s (s, f) = arrayToList (s, castForeignPtr f)+        decodeUInt16s (s, f) = arrayToList (s, castForeignPtr f)+        decodeFloat32s (s, f) = arrayToList (s, castForeignPtr f)          hasVertexArrayObjects = return . elem "GL_ARB_vertex_array_object"         hasFloatTextures = return . elem "GL_ARB_texture_float"@@ -229,8 +246,12 @@         glLinkProgram = const GL.glLinkProgram         glPixelStorei = const GL.glPixelStorei         glPolygonOffset = const GL.glPolygonOffset-        glReadPixels _ a b c d e f (_, fp)  = withForeignPtr fp $+        glReadPixelsUInt8 _ a b c d e f (_, fp)  = withForeignPtr fp $                 GL.glReadPixels a b c d e f . castPtr+        glReadPixelsUInt16 _ a b c d e f (_, fp)  = withForeignPtr fp $+                GL.glReadPixels a b c d e f . castPtr+        glReadPixelsFloat _ a b c d e f (_, fp)  = withForeignPtr fp $+                GL.glReadPixels a b c d e f . castPtr         glRenderbufferStorage = const GL.glRenderbufferStorage         glSampleCoverage = const GL.glSampleCoverage         glScissor = const GL.glScissor@@ -254,21 +275,21 @@         glTexSubImage2D _ a b c d e f g h (_, fp) = withForeignPtr fp $                 GL.glTexSubImage2D a b c d e f g h . castPtr         glUniform1f = const GL.glUniform1f-        glUniform1fv = uniform GL.glUniform1fv+        glUniform1fv = uniform 1 GL.glUniform1fv         glUniform1i = const GL.glUniform1i-        glUniform1iv = uniform GL.glUniform1iv+        glUniform1iv = uniform 1 GL.glUniform1iv         glUniform2f = const GL.glUniform2f-        glUniform2fv = uniform GL.glUniform2fv+        glUniform2fv = uniform 2 GL.glUniform2fv         glUniform2i = const GL.glUniform2i-        glUniform2iv = uniform GL.glUniform2iv+        glUniform2iv = uniform 2 GL.glUniform2iv         glUniform3f = const GL.glUniform3f-        glUniform3fv = uniform GL.glUniform3fv+        glUniform3fv = uniform 3 GL.glUniform3fv         glUniform3i = const GL.glUniform3i-        glUniform3iv = uniform GL.glUniform3iv+        glUniform3iv = uniform 3 GL.glUniform3iv         glUniform4f = const GL.glUniform4f-        glUniform4fv = uniform GL.glUniform4fv+        glUniform4fv = uniform 4 GL.glUniform4fv         glUniform4i = const GL.glUniform4i-        glUniform4iv = uniform GL.glUniform4iv+        glUniform4iv = uniform 4 GL.glUniform4iv         glUniformMatrix2fv = uniformMatrix GL.glUniformMatrix2fv 4         glUniformMatrix3fv = uniformMatrix GL.glUniformMatrix3fv 9         glUniformMatrix4fv = uniformMatrix GL.glUniformMatrix4fv 16@@ -548,6 +569,7 @@         gl_RGB5_A1 = GL.GL_RGB5_A1         gl_RGB565 = error "GL_RGB565: not present in OpenGL 2.1"         gl_DEPTH_COMPONENT16 = GL.GL_DEPTH_COMPONENT16+        gl_STENCIL_INDEX = GL.GL_STENCIL_INDEX         gl_STENCIL_INDEX8 = GL.GL_STENCIL_INDEX8         gl_RENDERBUFFER_WIDTH = GL.GL_RENDERBUFFER_WIDTH         gl_RENDERBUFFER_HEIGHT = GL.GL_RENDERBUFFER_HEIGHT

@@ -1,7 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses, TypeFamilies,              UndecidableInstances, OverloadedStrings #-} -{-| The GHCJS/WebGL backend. This just exports the instance for 'GLES'. -}+-- |+-- Module:      Graphics.Rendering.Ombra.Backend.WebGL+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only+ module Graphics.Rendering.Ombra.Backend.WebGL (         makeContext ) where@@ -81,6 +87,8 @@                          JS.getExtension ctx "WEBGL_depth_texture"                          JS.getExtension ctx "WEBGL_color_buffer_float"                          floatTexExt <- JS.getExtension ctx "OES_texture_float"+                         -- TODO: add hasTextureFloatLinear+                         JS.getExtension ctx "OES_texture_float_linear"                          vaoExt <- JS.getExtension ctx "OES_vertex_array_object"                          drawBufsExt <- JS.getExtension ctx "WEBGL_draw_buffers"                          derivativesExt <- JS.getExtension ctx@@ -91,17 +99,8 @@                          setProp "derivatives" derivativesExt $ Object ctx                          return (counter, ctx) -toJSArray :: ToJSVal a => (v -> Maybe (a, v)) -> v -> IO JSArray.JSArray-toJSArray next iv = JSArray.fromList <$> mapM toJSVal list-        where list = unfoldr next iv-        {- -        JSArray.create >>= iterPush iv-        where iterPush v arr = case next v of-                                        Just (x, v') -> do xRef <- toJSVal x-                                                           JSArray.push xRef arr-                                                           iterPush v' arr-                                        Nothing -> return arr-        -}+toJSArray :: ToJSVal a => [a] -> IO JSArray.JSArray+toJSArray list = JSArray.fromList <$> mapM toJSVal list  instance GLES where         type Ctx = (IORef Int, JS.Ctx)@@ -136,76 +135,55 @@         toGLString = pack         fromGLString = unpack         noBuffer = JS.noBuffer+        noFramebuffer = JS.noFramebuffer         noTexture = TagTexture (-1) JS.noTexture         noUInt8Array = nullUInt8Array         noFloat32Array = nullFloat32Array         noVAO = JS.noVAO          encodeMat2 (Mat2 (Vec2 a1 a2) (Vec2 b1 b2)) =-                        encodeMat2JS a1 a2-                                     b1 b2+                        encodeMat2JS a1 b1+                                     a2 b2          encodeMat3 (Mat3 (Vec3 a1 a2 a3)                          (Vec3 b1 b2 b3)                          (Vec3 c1 c2 c3)) =-                        encodeMat3JS a1 a2 a3-                                     b1 b2 b3-                                     c1 c2 c3+                        encodeMat3JS a1 b1 c1+                                     a2 b2 c2+                                     a3 b3 c3         encodeMat4 (Mat4 (Vec4 a1 a2 a3 a4)                          (Vec4 b1 b2 b3 b4)                          (Vec4 c1 c2 c3 c4)                          (Vec4 d1 d2 d3 d4) ) =-                        encodeMat4JS a1 a2 a3 a4-                                     b1 b2 b3 b4-                                     c1 c2 c3 c4-                                     d1 d2 d3 d4-        encodeFloats v = JSArray.fromList <$> mapM toJSVal v-                         >>= JS.float32ArrayFrom-        encodeInts v = JSArray.fromList <$> mapM toJSVal v-                       >>= JS.int32ArrayFrom+                        encodeMat4JS a1 b1 c1 d1+                                     a2 b2 c2 d2+                                     a3 b3 c3 d3+                                     a4 b4 c4 d4+        encodeFloats v = toJSArray v >>= JS.float32ArrayFrom+        encodeInts v = toJSArray v >>= JS.int32ArrayFrom          -- TODO: faster implementation-        encodeVec2s v = toJSArray next (False, v) >>= JS.float32ArrayFrom-                where next (False, xs@(Vec2 x _ : _)) = Just (x, (True, xs))-                      next (True, Vec2 _ y : xs) = Just (y, (False, xs))-                      next (_, []) = Nothing+        encodeVec2s v = toJSArray fv >>= JS.float32ArrayFrom+                where fv = concatMap (\(Vec2 x y) -> [x, y]) v -        encodeVec3s v = toJSArray next (0, v) >>= JS.float32ArrayFrom-                where next (0, xs@(Vec3 x _ _ : _)) = Just (x, (1, xs))-                      next (1, xs@(Vec3 _ y _ : _)) = Just (y, (2, xs))-                      next (2, Vec3 _ _ z : xs) = Just (z, (0, xs))-                      next (_, []) = Nothing+        encodeVec3s v = toJSArray fv >>= JS.float32ArrayFrom+                where fv = concatMap (\(Vec3 x y z) -> [x, y, z]) v -        encodeVec4s v = toJSArray next (0, v) >>= JS.float32ArrayFrom-                where next (0, xs@(Vec4 x _ _ _ : _)) = Just (x, (1, xs))-                      next (1, xs@(Vec4 _ y _ _ : _)) = Just (y, (2, xs))-                      next (2, xs@(Vec4 _ _ z _ : _)) = Just (z, (3, xs))-                      next (3, Vec4 _ _ _ w : xs) = Just (w, (0, xs))-                      next (_, []) = Nothing+        encodeVec4s v = toJSArray fv >>= JS.float32ArrayFrom+                where fv = concatMap (\(Vec4 x y z w) -> [x, y, z, w]) v -        encodeIVec2s v = toJSArray next (False, v) >>= JS.int32ArrayFrom-                where next (False, xs@(IVec2 x _ : _)) = Just (x, (True, xs))-                      next (True, IVec2 _ y : xs) = Just (y, (False, xs))-                      next (_, []) = Nothing+        encodeIVec2s v = toJSArray iv >>= JS.int32ArrayFrom+                where iv = concatMap (\(IVec2 x y) -> [x, y]) v -        encodeIVec3s v = toJSArray next (0, v) >>= JS.int32ArrayFrom-                where next (0, xs@(IVec3 x _ _ : _)) = Just (x, (1, xs))-                      next (1, xs@(IVec3 _ y _ : _)) = Just (y, (2, xs))-                      next (2, IVec3 _ _ z : xs) = Just (z, (0, xs))-                      next (_, []) = Nothing+        encodeIVec3s v = toJSArray iv >>= JS.int32ArrayFrom+                where iv = concatMap (\(IVec3 x y z) -> [x, y, z]) v -        encodeIVec4s v = toJSArray next (0, v) >>= JS.int32ArrayFrom-                where next (0, xs@(IVec4 x _ _ _ : _)) = Just (x, (1, xs))-                      next (1, xs@(IVec4 _ y _ _ : _)) = Just (y, (2, xs))-                      next (2, xs@(IVec4 _ _ z _ : _)) = Just (z, (3, xs))-                      next (3, IVec4 _ _ _ w : xs) = Just (w, (0, xs))-                      next (_, []) = Nothing+        encodeIVec4s v = toJSArray iv >>= JS.int32ArrayFrom+                where iv = concatMap (\(IVec4 x y z w) -> [x, y, z, w]) v -        encodeUShorts v = JSArray.fromList <$> mapM toJSVal v-                          >>= JS.uint16ArrayFrom+        encodeUInt16s v = toJSArray v >>= JS.uint16ArrayFrom -        encodeUInt8s v = JSArray.fromList <$> mapM toJSVal v-                         >>= JS.uint8ArrayFrom+        encodeUInt8s v = toJSArray v >>= JS.uint8ArrayFrom  {-         encodeColors v = toJSArray next (0, v) >>= JS.uint8ArrayFrom@@ -217,18 +195,35 @@ -}          -- !-        newByteArray l = do arr <- JSArray.create-                            _ <- sequence . replicate l $-                                    toJSVal (0 :: Word) >>=-                                    flip JSArray.push arr-                            JSArray.unsafeFreeze arr >>= JS.uint8ArrayFrom+        newUInt8Array l = do arr <- JSArray.create+                             _ <- sequence . replicate l $+                                     toJSVal (0 :: Word8) >>=+                                     flip JSArray.push arr+                             JSArray.unsafeFreeze arr >>= JS.uint8ArrayFrom+        newUInt16Array l = do arr <- JSArray.create+                              _ <- sequence . replicate l $+                                      toJSVal (0 :: Word16) >>=+                                      flip JSArray.push arr+                              JSArray.unsafeFreeze arr >>= JS.uint16ArrayFrom+        newFloat32Array l = do arr <- JSArray.create+                               _ <- sequence . replicate l $+                                       toJSVal (0 :: Float) >>=+                                       flip JSArray.push arr+                               JSArray.unsafeFreeze arr >>= JS.float32ArrayFrom         fromFloat32Array = JS.buffer         fromInt32Array = JS.buffer         fromUInt8Array = JS.buffer         fromUInt16Array = JS.buffer-        decodeBytes ar = let dw = JSDataView.dataView $ JS.buffer ar-                         in return $ map (flip JSDataView.getUint8 dw)-                                         [0 .. JS.length ar - 1]+        decodeUInt8s ar = let dw = JSDataView.dataView $ JS.buffer ar+                          in return $ map (flip JSDataView.getUint8 dw)+                                          [0 .. JS.length ar - 1]+        decodeUInt16s ar = let dw = JSDataView.dataView $ JS.buffer ar+                           in return $ map (flip JSDataView.getUint16LE dw)+                                           [0 .. JS.length ar - 1]+        decodeFloat32s ar = let dw = JSDataView.dataView $ JS.buffer ar+                            in return $ map (realToFrac .+                                                flip JSDataView.getFloat32LE dw)+                                            [0 .. JS.length ar - 1]          hasVertexArrayObjects =                 (not . isNull <$>) .  getProp "vaoExt" . Object . snd@@ -333,7 +328,9 @@         glLinkProgram (_, c) (TagProgram _ p) = JS.glLinkProgram c p         glPixelStorei = JS.glPixelStorei . snd         glPolygonOffset = JS.glPolygonOffset . snd-        glReadPixels = JS.glReadPixels . snd+        glReadPixelsUInt8 = JS.glReadPixelsUInt8 . snd+        glReadPixelsUInt16 = JS.glReadPixelsUInt16 . snd+        glReadPixelsFloat = JS.glReadPixelsFloat . snd         glRenderbufferStorage = JS.glRenderbufferStorage . snd         glSampleCoverage = JS.glSampleCoverage . snd         glScissor = JS.glScissor . snd@@ -645,6 +642,7 @@         gl_RGB5_A1 = JS.gl_RGB5_A1         gl_RGB565 = JS.gl_RGB565         gl_DEPTH_COMPONENT16 = JS.gl_DEPTH_COMPONENT16+        gl_STENCIL_INDEX = error "STENCIL_INDEX: not supported on WebGL"         gl_STENCIL_INDEX8 = JS.gl_STENCIL_INDEX8         gl_RENDERBUFFER_WIDTH = JS.gl_RENDERBUFFER_WIDTH         gl_RENDERBUFFER_HEIGHT = JS.gl_RENDERBUFFER_HEIGHT

@@ -267,7 +267,13 @@         glPolygonOffset :: Ctx -> Float -> Float -> IO ()  foreign import javascript unsafe "$1.readPixels($2, $3, $4, $5, $6, $7, $8)"-        glReadPixels :: Ctx -> Int32 -> Int32 -> Int32 -> Int32 -> Word -> Word -> Uint8Array -> IO ()+        glReadPixelsUInt8 :: Ctx -> Int32 -> Int32 -> Int32 -> Int32 -> Word -> Word -> Uint8Array -> IO ()++foreign import javascript unsafe "$1.readPixels($2, $3, $4, $5, $6, $7, $8)"+        glReadPixelsUInt16 :: Ctx -> Int32 -> Int32 -> Int32 -> Int32 -> Word -> Word -> Uint16Array -> IO ()++foreign import javascript unsafe "$1.readPixels($2, $3, $4, $5, $6, $7, $8)"+        glReadPixelsFloat :: Ctx -> Int32 -> Int32 -> Int32 -> Int32 -> Word -> Word -> Float32Array -> IO ()  foreign import javascript unsafe "$1.renderbufferStorage($2, $3, $4, $5)"         glRenderbufferStorage :: Ctx -> Word -> Word -> Int32 -> Int32 -> IO ()

@@ -14,6 +14,7 @@         ShaderPrecisionFormat,         getCtx,         noBuffer,+        noFramebuffer,         noTexture,         noVAO, ) where@@ -57,6 +58,9 @@  noBuffer :: Buffer noBuffer = jsNull++noFramebuffer :: FrameBuffer+noFramebuffer = jsNull  noTexture :: Texture noTexture = jsNull

@@ -1,12 +1,33 @@+-- |+-- Module:      Graphics.Rendering.Ombra.Blend+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: portable+--+-- Blending lets you combine the colors in the color buffer with the output of+-- the fragment shader, using a custom operation.+ module Graphics.Rendering.Ombra.Blend (         -- * Types         Mode(..),         Operator(..),         Parameter(..),+        withBlendMode,          -- * Blending modes         transparency,-        additive+        additive, ) where -import Graphics.Rendering.Ombra.Blend.Internal+import Graphics.Rendering.Ombra.Blend.Draw+import Graphics.Rendering.Ombra.Blend.Types++-- | Standard transparency.+transparency :: Mode+transparency = Mode Nothing Add (Just (SourceAlpha, OneMinus SourceAlpha))+                            Add (Just (SourceAlpha, OneMinus SourceAlpha))++-- | Additive blend mode.+additive :: Mode+additive = Mode Nothing Add (Just (One, One)) Add (Just (One, One))

@@ -0,0 +1,46 @@+module Graphics.Rendering.Ombra.Blend.Draw (+        MonadBlend(..),+        equation,+        function+) where++import Graphics.Rendering.Ombra.Blend.Types+import Graphics.Rendering.Ombra.Internal.GL++class (GLES, MonadGL m) => MonadBlend m where+        withBlendMode :: Maybe Mode -> m a -> m a++equation :: GLES => Mode -> (GLEnum, GLEnum)+equation m = (mode $ rgbOperator m, mode $ alphaOperator m)+        where mode Add = gl_FUNC_ADD+              mode Subtract = gl_FUNC_SUBTRACT+              mode ReverseSubtract = gl_FUNC_REVERSE_SUBTRACT+              -- mode Min = gl_MIN+              -- mode Max = gl_MAX++function :: GLES => Mode -> (GLEnum, GLEnum, GLEnum, GLEnum)+function m = (rgbs, rgbd, alphas, alphad)+        where (rgbs, rgbd) = case rgbParameters m of+                                  Just (p, p') -> (param p, param p')+                                  Nothing -> (gl_ZERO, gl_ZERO)+              (alphas, alphad) = case alphaParameters m of+                                      Just (p, p') -> (param p, param p')+                                      Nothing -> (gl_ZERO, gl_ZERO)+              param Zero = gl_ZERO+              param One = gl_ONE+              param SourceColor = gl_SRC_COLOR+              param DestinationColor = gl_DST_COLOR+              param ConstantColor = gl_CONSTANT_COLOR+              param SourceAlpha = gl_SRC_ALPHA+              param DestinationAlpha = gl_DST_ALPHA+              param ConstantAlpha = gl_CONSTANT_ALPHA+              param (OneMinus Zero) = gl_ONE+              param (OneMinus One) = gl_ZERO+              param (OneMinus SourceColor) = gl_ONE_MINUS_SRC_COLOR+              param (OneMinus DestinationColor) = gl_ONE_MINUS_DST_COLOR+              param (OneMinus ConstantColor) = gl_ONE_MINUS_CONSTANT_COLOR+              param (OneMinus SourceAlpha) = gl_ONE_MINUS_SRC_ALPHA+              param (OneMinus DestinationAlpha) = gl_ONE_MINUS_DST_ALPHA+              param (OneMinus ConstantAlpha) = gl_ONE_MINUS_CONSTANT_ALPHA+              param (OneMinus (OneMinus x)) = param x+

@@ -1,65 +0,0 @@-module Graphics.Rendering.Ombra.Blend.Internal where--import Graphics.Rendering.Ombra.Internal.GL-import Graphics.Rendering.Ombra.Vector---- | Blend mode-data Mode = Mode {-        constantColor :: Maybe Vec4,-        rgbOperator :: Operator,-        rgbParameters :: Maybe (Parameter, Parameter),-        alphaOperator :: Operator,-        alphaParameters :: Maybe (Parameter, Parameter)-} deriving Eq---- | Blend operator.-data Operator = Add | Subtract | ReverseSubtract {- Min | Max -} deriving Eq---- | Blend function parameters.-data Parameter = Zero | One | SourceColor | DestinationColor | ConstantColor-               | SourceAlpha | DestinationAlpha | ConstantAlpha-               | OneMinus Parameter deriving Eq---- | Standard transparency (default).-transparency :: Mode-transparency = Mode Nothing Add (Just (SourceAlpha, OneMinus SourceAlpha))-                            Add (Just (SourceAlpha, OneMinus SourceAlpha))---- | Additive blend mode.-additive :: Mode-additive = Mode Nothing Add (Just (One, One)) Add (Just (One, One))--equation :: GLES => Mode -> (GLEnum, GLEnum)-equation m = (mode $ rgbOperator m, mode $ alphaOperator m)-        where mode Add = gl_FUNC_ADD-              mode Subtract = gl_FUNC_SUBTRACT-              mode ReverseSubtract = gl_FUNC_REVERSE_SUBTRACT-              -- mode Min = gl_MIN-              -- mode Max = gl_MAX--function :: GLES => Mode -> (GLEnum, GLEnum, GLEnum, GLEnum)-function m = (rgbs, rgbd, alphas, alphad)-        where (rgbs, rgbd) = case rgbParameters m of-                                  Just (p, p') -> (param p, param p')-                                  Nothing -> (gl_ZERO, gl_ZERO)-              (alphas, alphad) = case alphaParameters m of-                                      Just (p, p') -> (param p, param p')-                                      Nothing -> (gl_ZERO, gl_ZERO)-              param Zero = gl_ZERO-              param One = gl_ONE-              param SourceColor = gl_SRC_COLOR-              param DestinationColor = gl_DST_COLOR-              param ConstantColor = gl_CONSTANT_COLOR-              param SourceAlpha = gl_SRC_ALPHA-              param DestinationAlpha = gl_DST_ALPHA-              param ConstantAlpha = gl_CONSTANT_ALPHA-              param (OneMinus Zero) = gl_ONE-              param (OneMinus One) = gl_ZERO-              param (OneMinus SourceColor) = gl_ONE_MINUS_SRC_COLOR-              param (OneMinus DestinationColor) = gl_ONE_MINUS_DST_COLOR-              param (OneMinus ConstantColor) = gl_ONE_MINUS_CONSTANT_COLOR-              param (OneMinus SourceAlpha) = gl_ONE_MINUS_SRC_ALPHA-              param (OneMinus DestinationAlpha) = gl_ONE_MINUS_DST_ALPHA-              param (OneMinus ConstantAlpha) = gl_ONE_MINUS_CONSTANT_ALPHA-              param (OneMinus _) =-                      error "Invalid blend function (nested OneMinus)"

@@ -0,0 +1,29 @@+module Graphics.Rendering.Ombra.Blend.Types where++import Graphics.Rendering.Ombra.Vector++-- | Blend mode.+data Mode = Mode {+        -- | The color that will be used if you choose the 'ConstantColor' or+        -- 'ConstantAlpha' parameter.+        constantColor :: Maybe Vec4,+        -- | Operation to apply to the colors (first three components of the+        -- color vectors).+        rgbOperator :: Operator,+        -- | Multipliers of the source color and destination color,+        -- respectively.+        rgbParameters :: Maybe (Parameter, Parameter),+        -- | Operation to apply to the alpha component.+        alphaOperator :: Operator,+        -- | Multipliers of the source alpha and destination alpha.+        alphaParameters :: Maybe (Parameter, Parameter)+} deriving Eq++-- | Blend operator.+data Operator = Add | Subtract | ReverseSubtract {- Min | Max -} deriving Eq++-- | Blend function parameters.+data Parameter = Zero | One | SourceColor | DestinationColor | ConstantColor+               | SourceAlpha | DestinationAlpha | ConstantAlpha+               | OneMinus Parameter deriving Eq+

@@ -1,3 +1,10 @@+-- |+-- Module:      Graphics.Rendering.Ombra.Color+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: portable+ module Graphics.Rendering.Ombra.Color where  import Data.Hashable@@ -5,7 +12,7 @@ import Foreign.Ptr (castPtr) import Foreign.Storable --- | An RGBA 32-bit color.+-- | A RGBA 32-bit color. data Color = Color !Word8 !Word8 !Word8 !Word8 deriving (Eq, Show)  instance Hashable Color where

@@ -0,0 +1,9 @@+module Graphics.Rendering.Ombra.Culling.Draw (+        MonadCulling(..)+) where++import Graphics.Rendering.Ombra.Internal.GL+import Graphics.Rendering.Ombra.Culling.Types++class (GLES, MonadGL m) => MonadCulling m where+        withCulling :: Maybe CullFace -> m a -> m a

@@ -0,0 +1,6 @@+module Graphics.Rendering.Ombra.Culling.Types (+        CullFace(..)+) where++-- Side(s) to be culled.+data CullFace = CullFront | CullBack | CullFrontBack deriving Eq

@@ -1,163 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, ConstraintKinds, TypeOperators,-             TypeFamilies #-}--{-| Simplified 2D graphics system. -}-module Graphics.Rendering.Ombra.D2 (-        -- * 2D Objects-        Object2D,-        IsObject2D,-        rect,-        image,-        sprite,-        depth,-        poly,-        -- * Transformations-        trans,-        rot,-        scale,-        scaleV,-        scaleTex,-        scaleTexAR,-        transform,-        -- * Layers-        view,-        viewScreen,-        viewVP,-        layerS,-        -- * Transformation matrices-        transMat3,-        rotMat3,-        scaleMat3,-        screenMat3,-        -- * Uniforms-        Uniforms2D,-        Image(..),-        Depth(..),-        Transform2(..),-        View2(..),-) where--import Graphics.Rendering.Ombra.Backend hiding (Texture, Program)-import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Draw-import Graphics.Rendering.Ombra.Layer-import Graphics.Rendering.Ombra.Object-import Graphics.Rendering.Ombra.Shapes-import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Shader.Default2D (Image(..), Depth(..), Transform2(..), View2(..))-import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Texture-import Graphics.Rendering.Ombra.Transformation-import Graphics.Rendering.Ombra.Vector--type Uniforms2D = '[Image, Depth, Transform2]---- | A simple 2D Object, without the 'View2' matrix.-type Object2D = Object Uniforms2D Geometry2D---- | 2D objects compatible with the standard 2D shader program.-type IsObject2D gs is = ( Subset Geometry2D is, Subset (View2 ': Uniforms2D) gs-                        , ShaderVars is, ShaderVars gs )---- | A rectangle with a specified 'Texture'.-rect :: GLES => Texture -> Object2D-rect = flip poly rectGeometry---- | A 2D object with a specified 'Geometry'.-poly :: GLES => Texture -> Geometry (i ': is) -> Object Uniforms2D (i ': is)-poly t g = withTexture t (Image -=) :~>-           Depth -= 0 :~>-           Transform2 -= idmtx :~>-           geom g---- | A rectangle with the aspect ratio adapted to its texture.-image :: GLES => Texture -> Object2D-image t = scaleTexAR t $ rect t---- | Set the depth of a 2D 'Object'.-depth :: (MemberGlobal Depth gs, GLES)-      => Float -> Object gs is -> Object gs is-depth d obj = const (Depth -= d) ~~> obj---- | A rectangle with the size and aspect ratio adapted to the screen, assuming--- that you're using 'viewScreen' or 'screenMat3'.-sprite :: GLES => Texture -> Object2D-sprite t = scaleTex t $ rect t---- | Create a group of objects with a view matrix.-view :: (ShaderVars gs, ShaderVars is, GLES)-     => Mat3 -> [Object gs is] -> Object (View2 ': gs) is-view m = viewVP $ const m---- | Create a group of objects with a view matrix and 'screenMat3'.-viewScreen :: (ShaderVars gs, ShaderVars is, GLES)-           => Mat3 -> [Object gs is] -> Object (View2 ': gs) is-viewScreen m = viewVP $ \s -> screenMat3 s .*. m---- | Create a group of objects with a view matrix, depending on the size of the--- framebuffer.-viewVP :: (ShaderVars gs, ShaderVars is, GLES)-       => (Vec2 -> Mat3) -> [Object gs is] -> Object (View2 ': gs) is-viewVP mf os = withFramebufferSize (\s -> View2 -= mf (tupleToVec s))-               :~> mconcat os---- | A 'Layer' with the standard 2D program.-layerS :: IsObject2D gs is => Object gs is -> Layer' s t ()-layerS = layer defaultProgram2D---- | Translate a 2D 'Object'.-trans :: (MemberGlobal Transform2 gs, GLES)-      => Vec2 -> Object gs is -> Object gs is-trans v = transform $ transMat3 v---- | Rotate a 2D 'Object'.-rot :: (MemberGlobal Transform2 gs, GLES)-    => Float -> Object gs is -> Object gs is-rot a = transform $ rotMat3 a---- | Scale a 2D 'Object'.-scale :: (MemberGlobal Transform2 gs, GLES)-      => Float -> Object gs is -> Object gs is-scale f = transform $ scaleMat3 (Vec2 f f)---- | Scale a 2D 'Object' in two dimensions.-scaleV :: (MemberGlobal Transform2 gs, GLES)-       => Vec2 -> Object gs is -> Object gs is-scaleV v = transform $ scaleMat3 v---- | Scale an 'Object' so that it has the same size as the 'Texture', assuming--- 'viewScreen' or 'screenMat3'.-scaleTex :: (MemberGlobal Transform2 gs, GLES)-           => Texture -> Object gs is -> Object gs is-scaleTex t = transform' t $ scaleMat3---- | Scale an 'Object' so that it has the same aspect ratio as the 'Texture'--- --- > scaleV $ Vec2 1 (texture height / texture width).-scaleTexAR :: (MemberGlobal Transform2 gs, GLES)-           => Texture -> Object gs is -> Object gs is-scaleTexAR t = transform' t $ (\(Vec2 w h) -> scaleMat3 $ Vec2 1 (h / w))---- | Transform a 2D 'Object'.-transform :: (MemberGlobal Transform2 gs, GLES)-          => Mat3 -> Object gs is -> Object gs is-transform m' o = (\m -> Transform2 -= m .*. m') ~~> o---- | Transform a 2D 'Object'.-transform' :: (MemberGlobal Transform2 gs, GLES)-           => Texture-           -> (Vec2 -> Mat3)-           -> Object gs is-           -> Object gs is-transform' t m' o = (\m -> withTexSize t $-                        \s -> Transform2 -= m .*. m' (tupleToVec s)) ~~> o---- | Convert the screen coordinates to GL coordinates.-screenMat3 :: Vec2      -- ^ Viewport size.-           -> Mat3-screenMat3 (Vec2 w h) = Mat3 (Vec3 (2 / w)          0           0 )-                             (Vec3    0         (- 2 / h)       0 )-                             (Vec3  (- 1)           1           1 )--tupleToVec :: (Int, Int) -> Vec2-tupleToVec (w, h) = Vec2 (fromIntegral w) (fromIntegral h)

@@ -1,183 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleContexts, ConstraintKinds, TypeOperators,-             TypeFamilies, MultiParamTypeClasses, FlexibleInstances,-             UndecidableInstances #-}--{-| Simplified 3D graphics system. -}-module Graphics.Rendering.Ombra.D3 (-        -- * 3D Objects-        Object3D,-        IsObject3D,-        cube,-        mesh,-        -- * Transformations-        trans,-        rotX,-        rotY,-        rotZ,-        rot,-        scale,-        scaleV,-        transform,-        -- * Layers-        view,-        proj,-        viewPersp,-        viewOrtho,-        viewProj,-        layerS,-        -- * Matrices-        -- ** View matrices-        perspectiveMat4,-        perspectiveMat4Size,-        orthoMat4,-        cameraMat4,-        lookAtMat4,-        -- ** Transformation matrices-        transMat4,-        rotXMat4,-        rotYMat4,-        rotZMat4,-        rotMat4,-        scaleMat4,-        -- * Uniforms-        Uniforms3D,-        Texture2(..),-        Transform3(..),-        View3(..),-        Project3(..)-) where--import Graphics.Rendering.Ombra.Backend hiding (Texture, Program)-import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Draw-import Graphics.Rendering.Ombra.Layer-import Graphics.Rendering.Ombra.Object-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(..), 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' 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 (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 (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 and use the identity matrix as--- a projection matrix.-view :: (GLES, ShaderVars gs, ShaderVars is)-     => 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-          -> Float      -- ^ Far-          -> Float      -- ^ FOV-          -> Mat4       -- ^ View matrix-          -> [Object gs is]-          -> 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)-          => Float      -- ^ Near-          -> Float      -- ^ Far-          -> Float      -- ^ Left-          -> Float      -- ^ Right-          -> Float      -- ^ Bottom-          -> Float      -- ^ Top-          -> Mat4       -- ^ View matrix-          -> [Object gs is]-          -> 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 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.-layerS :: IsObject3D gs is => Object gs is -> Layer' s t ()-layerS = layer defaultProgram3D---- | Translate a 3D Object.-trans :: (MemberGlobal Transform3 gs, GLES) => Vec3-      -> Object gs is -> Object gs is-trans v = transform $ transMat4 v---- | Rotate a 3D 'Object' around the X axis.-rotX :: (MemberGlobal Transform3 gs, GLES) => Float-     -> Object gs is -> Object gs is-rotX a = transform $ rotXMat4 a---- | Rotate a 3D 'Object' around the Y axis.-rotY :: (MemberGlobal Transform3 gs, GLES) => Float-     -> Object gs is -> Object gs is-rotY a = transform $ rotYMat4 a---- | Rotate a 3D 'Object' around the Z axis.-rotZ :: (MemberGlobal Transform3 gs, GLES) => Float-     -> Object gs is -> Object gs is-rotZ a = transform $ rotZMat4 a---- | Rotate a 3D 'Object' around a vector.-rot :: (MemberGlobal Transform3 gs, GLES) => Vec3-    -> Float-    -> Object gs is -> Object gs is-rot ax ag = transform $ rotMat4 ax ag---- | Scale a 3D 'Object'.-scale :: (MemberGlobal Transform3 gs, GLES) => Float-      -> Object gs is -> Object gs is-scale f = transform $ scaleMat4 (Vec3 f f f)---- | Scale a 3D 'Object' in three dimensions.-scaleV :: (MemberGlobal Transform3 gs, GLES) => Vec3-       -> Object gs is -> Object gs is-scaleV v = transform $ scaleMat4 v---- | Transform a 3D 'Object'.-transform :: (MemberGlobal Transform3 gs, GLES) => Mat4-          -> Object gs is -> Object gs is-transform m' o = (\m -> Transform3 -= m .*. m') ~~> o---- | 4x4 perspective projection matrix, using width and height instead of the--- aspect ratio.-perspectiveMat4Size :: Float        -- ^ Near-                    -> Float        -- ^ Far-                    -> Float        -- ^ FOV-                    -> Vec2         -- ^ Viewport size-                    -> Mat4-perspectiveMat4Size n f fov (Vec2 w h) = perspectiveMat4 n f fov $ w / h

@@ -1,73 +1,62 @@+-- |+-- Module:      Graphics.Rendering.Ombra.Draw+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only+ module Graphics.Rendering.Ombra.Draw (+        module Graphics.Rendering.Ombra.OutBuffer,         Draw,         DrawState,         Ctx,         -- * Running the Draw monad-        refDrawCtx,-        runDrawCtx,-        execDrawCtx,-        evalDrawCtx,-        drawState,+        runDraw,         -- * Draw actions-        MonadGL(gl),+        MonadDraw(..),+        MonadDrawBuffers(drawBuffers, drawBuffers'),+        MonadRead(..),         MonadScreen(resizeViewport),-        MonadObject,-        drawInit,-        clearBuffers,-        drawLayer,+        clearColor,+        clearDepth,+        clearStencil,+        -- ** Culling+        CullFace(..),+        MonadCulling(withCulling),         -- ** Resources         -- $resources         ResStatus(..),         preloadGeometry,         preloadTexture,-        preloadProgram,         removeGeometry,         removeTexture,-        removeProgram,         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.Backend+import Graphics.Rendering.Ombra.Culling.Draw+import Graphics.Rendering.Ombra.Culling.Types+import Graphics.Rendering.Ombra.Draw.Class+import Graphics.Rendering.Ombra.Draw.Monad+import Graphics.Rendering.Ombra.Internal.GL (evalGL)+import Graphics.Rendering.Ombra.OutBuffer+import Graphics.Rendering.Ombra.Shader.Language.Types (GVec4) import Graphics.Rendering.Ombra.Screen --- | Run a Draw action using an IORef and a context.-refDrawCtx :: GLES => Ctx -> Draw a -> IORef DrawState -> IO a-refDrawCtx ctx d ref = do state <- readIORef ref-                          (ret, state') <- runDrawCtx ctx d state-                          writeIORef ref state'-                          return ret--runDrawCtx :: Ctx               -- ^ Context (use the appropriate backend-                                -- functions)-           -> Draw a            -- ^ Draw action-           -> DrawState         -- ^ State (create it with 'drawState')-           -> IO (a, DrawState)-runDrawCtx ctx d = flip evalGL ctx . runDraw d--execDrawCtx :: Ctx -> Draw a -> DrawState -> IO DrawState-execDrawCtx ctx d = flip evalGL ctx . execDraw d--evalDrawCtx :: Ctx -> Draw a -> DrawState -> IO a-evalDrawCtx ctx d = flip evalGL ctx . evalDraw d---- renderSubLayer :: +runDraw :: GLES+        => Int          -- ^ Viewport width+        -> Int          -- ^ Viewport height+        -> Ctx+        -> Draw GVec4 a+        -> IO a+runDraw w h ctx a = flip evalGL ctx . evalDraw (drawInit >> a) $ drawState w h  -- $resources -- In Ombra, GPU resources are allocated when they're needed, and they're kept -- alive by their corresponding CPU resources. Specifically, these resources are--- Geometries, Textures and Programs. This means that, when a CPU resource is+-- Geometries, Textures and Shaders. 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. Note that if you try to use--- a resource that was deallocated with the remove* functions it will be+-- a resource that was deallocated with the remove* functions, it will be -- allocated again.

@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}++module Graphics.Rendering.Ombra.Draw.Class (+        MonadDraw(..),+        MonadDrawBuffers(..),+        MonadRead(..)+) where++import Data.Word++import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.OutBuffer.Types+import Graphics.Rendering.Ombra.Geometry.Draw+import Graphics.Rendering.Ombra.Texture.Draw+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Screen+import Graphics.Rendering.Ombra.Vector++-- | Monads that can be used to draw 'Image's.+class ( MonadGeometry (m o)+      , MonadProgram (m o)+      , MonadTexture (m o)+      , MonadScreen (m o)+      ) => MonadDraw o m where+        withColorMask :: (Bool, Bool, Bool, Bool) -> m o a -> m o a+        withDepthTest :: Bool -> m o a -> m o a+        withDepthMask :: Bool -> m o a -> m o a++-- | Monads that support drawing to 'GBuffer's and 'DepthBuffer's.+class MonadDrawBuffers m where+        -- | Draw an image to some buffers.+        drawBuffers :: Int                      -- ^ Width of the buffers.+                    -> Int                      -- ^ Height of the buffers.+                    -> Either (GBuffer t o)+                              (GBufferInfo o)   -- ^ The buffer that will+                                                -- contain the output of the+                                                -- fragment shader. Either a+                                                -- previously used buffer, or+                                                -- the info of a new buffer+                                                -- that drawBuffers will create.+                                                -- Do not reuse buffers with a+                                                -- different width or height+                                                -- than the one you specified+                                                -- with the previous argument.+                    -> Either (DepthBuffer t')+                              DepthBufferInfo   -- ^ The buffer that contains+                                                -- the depth (and stencil)+                                                -- values.+                    -> m o a                    -- ^ Image to draw to the+                                                -- buffers.+                    -> (forall t. GBuffer t o -> DepthBuffer t -> a -> m o' b)+                    -> m o' b++        -- | Use this instead of 'drawBuffers' if you need to reuse the newly+        -- created buffers layer. They will be deleted from the GPU when the+        -- 'GBuffer'/'DepthBuffer' is garbage collected.+        drawBuffers' :: Int+                     -> Int+                     -> Either (GBuffer t o) (GBufferInfo o)+                     -> Either (DepthBuffer t1) DepthBufferInfo+                     -> m o a+                     -> m o' (a, GBuffer t2 o, DepthBuffer t3)++class MonadDraw o m => MonadRead o m where+        -- | Read a rectangle of pixel colors from the screen (or texture).+        readColor :: (Int, Int, Int, Int) -> m o [Color]+        -- | 'readColor' variant that read color vectors.+        readColorFloat :: (Int, Int, Int, Int) -> m o [Vec4]+        -- | Read a rectangle of pixel depths from the screen (or texture).+        -- Not supported on WebGL!+        readDepth :: (Int, Int, Int, Int) -> m o [Word16]+        -- | 'readDepth' variants that read floats. Not supported on WebGL as well.+        readDepthFloat :: (Int, Int, Int, Int) -> m o [Float]+        -- | Read a rectangle of stencil values from the screen (or texture).+        -- Not supported on WebGL!+        readStencil :: (Int, Int, Int, Int) -> m o [Word8]

@@ -1,405 +0,0 @@-{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances,-             FlexibleInstances, MultiParamTypeClasses, KindSignatures,-             GeneralizedNewtypeDeriving, PolyKinds, TypeOperators #-}--module Graphics.Rendering.Ombra.Draw.Internal (-        Draw,-        DrawState,-        ResStatus(..),-        drawState,-        drawInit,-        clearBuffers,-        drawLayer,-        drawObject,-        preloadGeometry,-        preloadTexture,-        preloadProgram,-        removeGeometry,-        removeTexture,-        removeProgram,-        checkGeometry,-        checkTexture,-        checkProgram,-        textureSize,-        setProgram,-        resizeViewport,-        runDraw,-        execDraw,-        evalDraw,-        gl,-        drawGet-) where--import qualified Graphics.Rendering.Ombra.Blend.Internal as Blend-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Geometry.Internal-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,-                                                    UniformLocation, cullFace,-                                                    depthMask, colorMask)-import qualified Graphics.Rendering.Ombra.Internal.GL as GL-import Graphics.Rendering.Ombra.Internal.Resource-import Graphics.Rendering.Ombra.Screen-import Graphics.Rendering.Ombra.Shader.Program-import qualified Graphics.Rendering.Ombra.Stencil.Internal as Stencil-import Graphics.Rendering.Ombra.Vector--import Data.Hashable (Hashable)-import Control.Monad (when)-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.State---- | The state of the 'Draw' monad.-data DrawState = DrawState {-        currentProgram :: Maybe ProgramIndex,-        loadedProgram :: Maybe LoadedProgram,-        programs :: ResMap LoadedProgram,-        uniforms :: ResMap UniformLocation,-        elemBuffers :: ResMap LoadedBuffer,-        attributes :: ResMap LoadedAttribute,-        geometries :: ResMap LoadedGeometry,-        textureImages :: ResMap LoadedTexture,-        activeTextures :: Int,-        viewportSize :: (Int, Int),-        blendMode :: Maybe Blend.Mode,-        stencilMode :: Maybe Stencil.Mode,-        cullFace :: Maybe CullFace,-        depthTest :: Bool,-        depthMask :: Bool,-        colorMask :: (Bool, Bool, Bool, Bool)-}---- | A state monad on top of 'GL'.-newtype Draw a = Draw { unDraw :: StateT DrawState GL a }-        deriving (Functor, Applicative, Monad, MonadIO)--instance EmbedIO Draw where-        embedIO f (Draw a) = Draw get >>= Draw . lift . embedIO f . evalStateT a--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-          -> Int         -- ^ Viewport height-          -> IO DrawState-drawState w h = do programs <- newGLResMap-                   elemBuffers <- newGLResMap-                   attributes <- newGLResMap-                   geometries <- newDrawResMap-                   uniforms <- newGLResMap-                   textureImages <- newGLResMap-                   return DrawState { currentProgram = Nothing-                                    , loadedProgram = Nothing-                                    , programs = programs-                                    , elemBuffers = elemBuffers-                                    , attributes = attributes-                                    , geometries = geometries-                                    , uniforms = uniforms-                                    , textureImages = textureImages-                                    , activeTextures = 0-                                    , viewportSize = (w, h)-                                    , blendMode = Nothing-                                    , depthTest = True-                                    , depthMask = True-                                    , stencilMode = Nothing-                                    , cullFace = Nothing-                                    , colorMask = (True, True, True, True)-                                    }--        where newGLResMap :: IO (ResMap r)-              newGLResMap = newResMap-              -              newDrawResMap :: IO (ResMap r)-              newDrawResMap = newResMap---- | Initialize the render engine.-drawInit :: GLES => Draw ()-drawInit = viewportSize <$> Draw get >>=-           \(w, h) -> gl $ do clearColor 0.0 0.0 0.0 1.0-                              enable gl_DEPTH_TEST-                              depthFunc gl_LESS-                              viewport 0 0 (fromIntegral w) (fromIntegral h)---{--maxTexs :: (Integral a, GLES) => a-maxTexs = fromIntegral gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS--}---- | Run a 'Draw' action.-runDraw :: Draw a-        -> DrawState-        -> GL (a, DrawState)-runDraw (Draw a) = runStateT a---- | Execute a 'Draw' action.-execDraw :: Draw a              -- ^ Action.-         -> DrawState           -- ^ State.-         -> GL DrawState-execDraw (Draw a) = execStateT a---- | Evaluate a 'Draw' action.-evalDraw :: Draw a              -- ^ Action.-         -> DrawState           -- ^ State.-         -> GL a-evalDraw (Draw a) = evalStateT a--left :: Either String a -> Maybe String-left (Left x) = Just x-left _ = Nothing---- | 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 (Maybe String)-preloadTexture t = left <$> getTexture t---- | Manually allocate a 'Program' in the GPU.-preloadProgram :: GLES => Program gs is -> Draw (Maybe String)-preloadProgram p = left <$> getProgram p---- | 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.-removeTexture :: GLES => Texture -> Draw ()-removeTexture (TextureImage i) = removeDrawResource gl textureImages i-removeTexture (TextureLoaded l) = gl $ unloadResource-                                        (Nothing :: Maybe TextureImage) l---- | Manually delete a 'Program' from the GPU.-removeProgram :: GLES => Program gs is -> Draw ()-removeProgram = removeDrawResource gl programs---- | Check if a 'Geometry' failed to load.-checkGeometry :: GLES => Geometry (i ': is) -> Draw (ResStatus ())-checkGeometry g = fmap (const ()) <$> checkDrawResource id geometries g---- | 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)--loadedTextureSize :: (GLES, Num a) => LoadedTexture -> (a, a)-loadedTextureSize (LoadedTexture w h _) = (fromIntegral w, fromIntegral h)---- | 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-                                   set new-                                   b <- act-                                   set old-                                   return b--getTextureImage :: GLES => TextureImage-                -> Draw (Either String LoadedTexture)-getTextureImage = getDrawResource gl textureImages--getProgram :: GLES => Program gs is -> Draw (Either String LoadedProgram)-getProgram = getDrawResource gl programs--setBlendMode :: GLES => Maybe Blend.Mode -> Draw ()-setBlendMode Nothing = do m <- blendMode <$> Draw get-                          case m of-                               Just _ -> gl $ disable gl_BLEND-                               Nothing -> return ()-                          Draw . modify $ \s -> s { blendMode = Nothing }-setBlendMode (Just newMode) =-        do mOldMode <- blendMode <$> Draw get-           case mOldMode of-                Nothing -> do gl $ enable gl_BLEND-                              changeColor >> changeEquation >> changeFunction-                Just oldMode ->-                     do when (Blend.constantColor oldMode /= constantColor)-                                changeColor-                        when (Blend.equation oldMode /= equation)-                                changeEquation-                        when (Blend.function oldMode /= function)-                                changeFunction-           Draw . modify $ \s -> s { blendMode = Just newMode }-        where constantColor = Blend.constantColor newMode-              equation@(rgbEq, alphaEq) = Blend.equation newMode-              function@(rgbs, rgbd, alphas, alphad) = Blend.function newMode-              changeColor = case constantColor of-                                 Just (Vec4 r g b a) -> gl $ blendColor r g b a-                                 Nothing -> return ()-              changeEquation = gl $ blendEquationSeparate rgbEq alphaEq-              changeFunction = gl $ blendFuncSeparate rgbs rgbd-                                                      alphas alphad--setStencilMode :: GLES => Maybe Stencil.Mode -> Draw ()-setStencilMode Nothing = do m <- stencilMode <$> Draw get-                            case m of-                                 Just _ -> gl $ disable gl_STENCIL_TEST-                                 Nothing -> return ()-                            Draw . modify $ \s -> s { stencilMode = Nothing }-setStencilMode (Just newMode@(Stencil.Mode newFun newOp)) =-        do mOldMode <- stencilMode <$> Draw get-           case mOldMode of-                Nothing -> do gl $ enable gl_STENCIL_TEST-                              sides newFun changeFunction-                              sides newOp changeOperation-                Just (Stencil.Mode oldFun oldOp) ->-                        do when (oldFun /= newFun) $-                                sides newFun changeFunction-                           when (oldOp /= newOp) $-                                sides newOp changeOperation-           Draw . modify $ \s -> s { stencilMode = Just newMode }-        where changeFunction face f = let (t, v, m) = Stencil.function f-                                      in gl $ stencilFuncSeparate face t v m-              changeOperation face o = let (s, d, n) = Stencil.operation o-                                       in gl $ stencilOpSeparate face s d n-              sides (Stencil.FrontBack x) f = f gl_FRONT_AND_BACK x-              sides (Stencil.Separate x y) f = f gl_FRONT x >> f gl_BACK y--setCullFace :: GLES => Maybe CullFace -> Draw ()-setCullFace Nothing = do old <- cullFace <$> Draw get-                         case old of-                              Just _ -> gl $ disable gl_CULL_FACE-                              Nothing -> return ()-                         Draw . modify $ \s -> s { cullFace = Nothing }-setCullFace (Just newFace) =-        do old <- cullFace <$> Draw get-           when (old == Nothing) . gl $ enable gl_CULL_FACE-           case old of-                Just oldFace | oldFace == newFace -> return ()-                _ -> gl . GL.cullFace $ case newFace of-                                             CullFront -> gl_FRONT-                                             CullBack -> gl_BACK-                                             CullFrontBack -> gl_FRONT_AND_BACK-           Draw . modify $ \s -> s { cullFace = Just newFace }-                   -setDepthTest :: GLES => Bool -> Draw ()-setDepthTest = setFlag depthTest (\x s -> s { depthTest = x })-                       (gl $ enable gl_DEPTH_TEST) (gl $ disable gl_DEPTH_TEST)-                   -setDepthMask :: GLES => Bool -> Draw ()-setDepthMask = setFlag depthMask (\x s -> s { depthMask = x })-                       (gl $ GL.depthMask true) (gl $ GL.depthMask false)--setFlag :: (DrawState -> Bool)-        -> (Bool -> DrawState -> DrawState)-        -> Draw ()-        -> Draw ()-        -> Bool-        -> Draw ()-setFlag getF setF enable disable new =-        do old <- getF <$> Draw get-           case (old, new) of-                   (False, True) -> enable-                   (True, False) -> disable-                   _ -> return ()-           Draw . modify $ setF new--setColorMask :: GLES => (Bool, Bool, Bool, Bool) -> Draw ()-setColorMask new@(r, g, b, a) = do old <- colorMask <$> Draw get-                                   when (old /= new) . gl $-                                           GL.colorMask r' g' b' a'-                                   Draw . modify $ \s -> s { colorMask = new }-        where (r', g', b', a') = (bool r, bool g, bool b, bool a)-              bool True = true-              bool False = false--getDrawResource :: Resource i r m-                => (m (Either String r) -> Draw (Either String r))-                -> (DrawState -> ResMap r)-                -> i-                -> Draw (Either String r)-getDrawResource lft mg i = do-        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)-                   -> i-                   -> Draw ()-removeDrawResource lft mg i = do-        s <- mg <$> Draw get-        lft $ removeResource i s---- | Get the 'DrawState'.-drawGet :: Draw DrawState-drawGet = Draw get

@@ -0,0 +1,752 @@+{-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TypeSynonymInstances,+             FlexibleInstances, MultiParamTypeClasses, KindSignatures,+             GeneralizedNewtypeDeriving, RankNTypes, TypeOperators, CPP,+             ScopedTypeVariables, UndecidableInstances, TypeFamilies #-}++module Graphics.Rendering.Ombra.Draw.Monad (+        Draw,+        DrawState,+        ResStatus(..),+        Buffer(..),+        drawState,+        drawInit,+        clearColor,+        clearDepth,+        clearStencil,+        preloadGeometry,+        preloadTexture,+        preloadProgram,+        removeGeometry,+        removeTexture,+        removeProgram,+        checkGeometry,+        checkTexture,+        checkProgram,+        textureSize,+        setProgram,+        resizeViewport,+        evalDraw,+        gl,+        drawGet+) where++import qualified Graphics.Rendering.Ombra.Blend.Draw as Blend+import qualified Graphics.Rendering.Ombra.Blend.Types as Blend+import Graphics.Rendering.Ombra.Color+import Graphics.Rendering.Ombra.Culling.Draw+import Graphics.Rendering.Ombra.Culling.Types+import Graphics.Rendering.Ombra.Draw.Class+import Graphics.Rendering.Ombra.Geometry+import Graphics.Rendering.Ombra.Geometry.Draw+import Graphics.Rendering.Ombra.OutBuffer.Types+import Graphics.Rendering.Ombra.Texture+import Graphics.Rendering.Ombra.Texture.Draw+import Graphics.Rendering.Ombra.Backend (GLES)+import qualified Graphics.Rendering.Ombra.Backend as GL+import Graphics.Rendering.Ombra.Internal.GL hiding (Texture, Program, Buffer,+                                                    UniformLocation, cullFace,+                                                    depthMask, colorMask,+                                                    drawBuffers, clearColor,+                                                    clearDepth, clearStencil)+import qualified Graphics.Rendering.Ombra.Internal.GL as GL+import Graphics.Rendering.Ombra.Internal.Resource+import Graphics.Rendering.Ombra.Screen+import Graphics.Rendering.Ombra.Shader.Language.Types+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Shader.Types+import qualified Graphics.Rendering.Ombra.Stencil.Draw as Stencil+import qualified Graphics.Rendering.Ombra.Stencil.Types as Stencil+import Graphics.Rendering.Ombra.Vector++import Data.Hashable+import Data.Proxy+import Data.Word+import Control.Monad+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import Control.Monad.Trans.State++-- | The state of the 'Draw' monad.+data DrawState = DrawState+        { currentFrameBuffer :: FrameBuffer+        , currentProgram :: Maybe ProgramIndex+        , loadedProgram :: Maybe LoadedProgram+        , programs :: ResMap LoadedProgram+        , uniforms :: ResMap UniformLocation+        , elemBuffers :: ResMap LoadedBuffer+        , attributes :: ResMap LoadedAttribute+        , geometries :: ResMap LoadedGeometry+        , textureImages :: ResMap LoadedTexture+        , activeTextures :: Int+        , textureCache :: [LoadedTexture]+        , viewportSize :: (Int, Int)+        , blendMode :: Maybe Blend.Mode+        , stencilMode :: Maybe Stencil.Mode+        , cullFace :: Maybe CullFace+        , depthTest :: Bool+        , depthMask :: Bool+        , colorMask :: (Bool, Bool, Bool, Bool)+        }++data Buffer = ColorBuffer+            | DepthBuffer+            | StencilBuffer++-- | An implementation of 'MonadDraw' and 'MonadDrawBuffers'.+newtype Draw o a = Draw { unDraw :: StateT DrawState GL a }+        deriving ( Functor+                 , Applicative+                 , Monad+                 , MonadIO+                 , MonadBase IO+#if __GLASGOW_HASKELL__ >= 802+                 , MonadBaseControl IO+                 )+#else+                 )++instance MonadBaseControl IO (Draw o) where+        type StM (Draw o) a = ComposeSt (StateT DrawState) GL a+        liftBaseWith f = Draw $ liftBaseWith $ \tf -> f (tf . unDraw)+        restoreM = Draw . restoreM+#endif++instance (FragmentShaderOutput o, GLES) => MonadDraw o Draw where+        withColorMask m a = stateReset colorMask setColorMask m a+        withDepthTest d a = stateReset depthTest setDepthTest d a+        withDepthMask m a = stateReset depthMask setDepthMask m a++instance GLES => MonadDrawBuffers Draw where+        drawBuffers w h gBuffer depthBuffer draw cont =+                do (ret, (newGBuffer, gBuffer'), (newDepthBuffer, depthBuffer'))+                        <- permanentDrawBuffers w h gBuffer depthBuffer draw+                   ret' <- cont gBuffer' depthBuffer' ret+                   when newGBuffer $ unusedTextures (textures gBuffer')+                   when newDepthBuffer $ unusedTextures (textures depthBuffer')+                   return ret'+        drawBuffers' w h gBuffer depthBuffer draw =+                do (ret, (newGBuffer, gBuffer'), (newDepthBuffer, depthBuffer'))+                        <- permanentDrawBuffers w h gBuffer depthBuffer draw+                   gl $ do when newGBuffer $ bufferUnloader gBuffer'+                           when newDepthBuffer $ bufferUnloader depthBuffer'+                   return (ret, gBuffer', depthBuffer')+                where bufferUnloader buf = +                        mapM_ (\lt -> unloader buf+                                               (Nothing :: Maybe TextureImage)+                                               lt+                              ) (textures buf)++instance GLES => MonadRead GVec4 Draw where+        readColor = flip readPixels gl_RGBA+        readColorFloat = flip readPixels gl_RGBA+        readDepth = flip readPixels gl_DEPTH_COMPONENT+        readDepthFloat = flip readPixels gl_DEPTH_COMPONENT+        readStencil = flip readPixels gl_STENCIL_INDEX++instance GLES => MonadScreen (Draw o) where+        currentViewport = viewportSize <$> Draw get+        resizeViewport w h = do setViewport w h+                                Draw . modify $ \s ->+                                        s { viewportSize = (w, h) }++instance GLES => MonadProgram (Draw o) 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 id = do mprg <- loadedProgram <$> Draw get+                           case mprg of+                                Just prg -> do map <- uniforms <$> Draw get+                                               gl $ getResource' (Just prg)+                                                                 (prg, id)+                                                                 map+                                Nothing -> return $ Left "No loaded program."++instance GLES => MonadCulling (Draw o) where+        withCulling face a = stateReset cullFace setCullFace face a++instance GLES => Blend.MonadBlend (Draw o) where+        withBlendMode m a = stateReset blendMode setBlendMode m a++instance GLES => Stencil.MonadStencil (Draw o) where+        withStencilMode m a = stateReset stencilMode setStencilMode m a++instance GLES => MonadTexture (Draw o) 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 params i initialize =+                do cache <- textureCache <$> Draw get+                   let (c1, c2) = flip break cache $+                                        \(LoadedTexture cw ch i' t) ->+                                                w' == cw && h' == ch && i == i'+                   case c2 of+                        [] -> gl $ do t <- emptyTexture params+                                      initialize t+                                      return $ LoadedTexture w' h' i t+                        (lt : c2') -> do Draw . modify $ \s ->+                                                s { textureCache = c1 ++ c2' }+                                         return lt+                where (w', h') = (fromIntegral w, fromIntegral h)+        unusedTextures ts =+                do cache <- textureCache <$> Draw get+                   let (cache', excess) = splitAt textureCacheMaxSize+                                                  (ts ++ cache)+                   Draw . modify $ \s -> s { textureCache = cache' }+                   mapM_ (removeTexture . TextureLoaded) excess++instance GLES => MonadGeometry (Draw o) where+        getAttribute = getDrawResource gl attributes+        getElementBuffer = getDrawResource gl elemBuffers+        getGeometry = getDrawResource id geometries++instance MonadGL (Draw o) where+        gl = Draw . lift++-- | Create a 'DrawState'.+drawState :: GLES+          => Int         -- ^ Viewport width+          -> Int         -- ^ Viewport height+          -> DrawState+drawState w h = DrawState { currentFrameBuffer = noFramebuffer+                          , currentProgram = Nothing+                          , loadedProgram = Nothing+                          , textureCache = []+                          , activeTextures = 0+                          , viewportSize = (w, h)+                          , blendMode = Nothing+                          , depthTest = True+                          , depthMask = True+                          , stencilMode = Nothing+                          , cullFace = Nothing+                          , colorMask = (True, True, True, True)+                          , programs = err+                          , elemBuffers = err+                          , attributes = err+                          , geometries = err+                          , uniforms = err+                          , textureImages = err+                          }+        where err = error "Call drawInit first"++-- | Initialize the render engine.+drawInit :: GLES => Draw GVec4 ()+drawInit = do programs <- liftIO newResMap+              elemBuffers <- liftIO newResMap+              attributes <- liftIO newResMap+              geometries <- liftIO newResMap+              uniforms <- liftIO newResMap+              textureImages <- liftIO newResMap++              (w, h) <- viewportSize <$> Draw get+              gl $ do GL.clearColor 0.0 0.0 0.0 1.0+                      enable gl_DEPTH_TEST+                      depthFunc gl_LESS+                      viewport 0 0 (fromIntegral w) (fromIntegral h)++              Draw . modify $ \s -> s { programs = programs+                                      , elemBuffers = elemBuffers+                                      , attributes = attributes+                                      , geometries = geometries+                                      , uniforms = uniforms+                                      , textureImages = textureImages+                                      }++{-+maxTexs :: (Integral a, GLES) => a+maxTexs = fromIntegral gl_MAX_COMBINED_TEXTURE_IMAGE_UNITS+-}++{-+-- | Run a 'Draw' action.+runDraw :: Draw GVec4 a+        -> DrawState+        -> GL (a, DrawState)+runDraw (Draw a) = runStateT a++-- | Execute a 'Draw' action.+execDraw :: Draw GVec4 a+         -> DrawState+         -> GL DrawState+execDraw (Draw a) = execStateT a+-}++-- | Evaluate a 'Draw' action.+evalDraw :: Draw GVec4 a+         -> DrawState+         -> GL a+evalDraw (Draw a) = evalStateT a++left :: Either String a -> Maybe String+left (Left x) = Just x+left _ = Nothing++-- | Manually allocate a 'Geometry' in the GPU. Eventually returns an error+-- string.+preloadGeometry :: (GLES, GeometryVertex g)+                => Geometry g+                -> Draw o (Maybe String)+preloadGeometry g = left <$> getGeometry g++-- | Manually allocate a 'Texture' in the GPU.+preloadTexture :: GLES => Texture -> Draw o (Maybe String)+preloadTexture t = left <$> getTexture t++-- | Manually allocate a 'Program' in the GPU.+preloadProgram :: GLES => Program gs is -> Draw o (Maybe String)+preloadProgram p = left <$> getProgram p++-- | Manually delete a 'Geometry' from the GPU.+removeGeometry :: (GLES, GeometryVertex g) => Geometry g -> Draw o ()+removeGeometry g = removeDrawResource id geometries g++-- | Manually delete a 'Texture' from the GPU.+removeTexture :: GLES => Texture -> Draw o ()+removeTexture (TextureImage i) = removeDrawResource gl textureImages i+removeTexture (TextureLoaded l) = gl $ unloadResource+                                        (Nothing :: Maybe TextureImage) l++-- | Manually delete a 'Program' from the GPU.+removeProgram :: GLES => Program gs is -> Draw o ()+removeProgram = removeDrawResource gl programs++-- | Check if a 'Geometry' failed to load.+checkGeometry :: (GLES, GeometryVertex g)+              => Geometry g+              -> Draw o (ResStatus ())+checkGeometry g = fmap (const ()) <$> checkDrawResource id geometries g++-- | Check if a 'Texture' failed to load. Eventually returns the texture width+-- and height.+checkTexture :: (GLES, Num a) => Texture -> Draw o (ResStatus (a, a))+checkTexture (TextureImage i) =+        fmap loadedTextureSize <$> checkDrawResource gl textureImages i+checkTexture (TextureLoaded l) = return $ Loaded (loadedTextureSize l)++loadedTextureSize :: (GLES, Num a) => LoadedTexture -> (a, a)+loadedTextureSize (LoadedTexture w h _ _) = (fromIntegral w, fromIntegral h)++-- | Check if a 'Program' failed to load.+checkProgram :: GLES => Program gs is -> Draw o (ResStatus ())+checkProgram p = fmap (const ()) <$> checkDrawResource gl programs p++stateReset :: (DrawState -> a)+           -> (a -> Draw o ())+           -> a+           -> Draw o b+           -> Draw o b+stateReset getOld set new act = do old <- getOld <$> Draw get+                                   set new+                                   b <- act+                                   set old+                                   return b++getTextureImage :: GLES => TextureImage+                -> Draw o (Either String LoadedTexture)+getTextureImage = getDrawResource gl textureImages++getProgram :: GLES => Program gs is -> Draw o (Either String LoadedProgram)+getProgram = getDrawResource' gl programs Nothing++setBlendMode :: GLES => Maybe Blend.Mode -> Draw o ()+setBlendMode Nothing = do m <- blendMode <$> Draw get+                          case m of+                               Just _ -> gl $ disable gl_BLEND+                               Nothing -> return ()+                          Draw . modify $ \s -> s { blendMode = Nothing }+setBlendMode (Just newMode) =+        do mOldMode <- blendMode <$> Draw get+           case mOldMode of+                Nothing -> do gl $ enable gl_BLEND+                              changeColor >> changeEquation >> changeFunction+                Just oldMode ->+                     do when (Blend.constantColor oldMode /= constantColor)+                                changeColor+                        when (Blend.equation oldMode /= equation)+                                changeEquation+                        when (Blend.function oldMode /= function)+                                changeFunction+           Draw . modify $ \s -> s { blendMode = Just newMode }+        where constantColor = Blend.constantColor newMode+              equation@(rgbEq, alphaEq) = Blend.equation newMode+              function@(rgbs, rgbd, alphas, alphad) = Blend.function newMode+              changeColor = case constantColor of+                                 Just (Vec4 r g b a) -> gl $ blendColor r g b a+                                 Nothing -> return ()+              changeEquation = gl $ blendEquationSeparate rgbEq alphaEq+              changeFunction = gl $ blendFuncSeparate rgbs rgbd+                                                      alphas alphad++setStencilMode :: GLES => Maybe Stencil.Mode -> Draw o ()+setStencilMode Nothing = do m <- stencilMode <$> Draw get+                            case m of+                                 Just _ -> gl $ disable gl_STENCIL_TEST+                                 Nothing -> return ()+                            Draw . modify $ \s -> s { stencilMode = Nothing }+setStencilMode (Just newMode@(Stencil.Mode newFun newOp)) =+        do mOldMode <- stencilMode <$> Draw get+           case mOldMode of+                Nothing -> do gl $ enable gl_STENCIL_TEST+                              sides newFun changeFunction+                              sides newOp changeOperation+                Just (Stencil.Mode oldFun oldOp) ->+                        do when (oldFun /= newFun) $+                                sides newFun changeFunction+                           when (oldOp /= newOp) $+                                sides newOp changeOperation+           Draw . modify $ \s -> s { stencilMode = Just newMode }+        where changeFunction face f = let (t, v, m) = Stencil.function f+                                      in gl $ stencilFuncSeparate face t v m+              changeOperation face o = let (s, d, n) = Stencil.operation o+                                       in gl $ stencilOpSeparate face s d n+              sides (Stencil.FrontBack x) f = f gl_FRONT_AND_BACK x+              sides (Stencil.Separate x y) f = f gl_FRONT x >> f gl_BACK y++setCullFace :: GLES => Maybe CullFace -> Draw o ()+setCullFace Nothing = do old <- cullFace <$> Draw get+                         case old of+                              Just _ -> gl $ disable gl_CULL_FACE+                              Nothing -> return ()+                         Draw . modify $ \s -> s { cullFace = Nothing }+setCullFace (Just newFace) =+        do old <- cullFace <$> Draw get+           when (old == Nothing) . gl $ enable gl_CULL_FACE+           case old of+                Just oldFace | oldFace == newFace -> return ()+                _ -> gl . GL.cullFace $ case newFace of+                                             CullFront -> gl_FRONT+                                             CullBack -> gl_BACK+                                             CullFrontBack -> gl_FRONT_AND_BACK+           Draw . modify $ \s -> s { cullFace = Just newFace }+                   +setDepthTest :: GLES => Bool -> Draw o ()+setDepthTest = setFlag depthTest (\x s -> s { depthTest = x })+                       (gl $ enable gl_DEPTH_TEST) (gl $ disable gl_DEPTH_TEST)+                   +setDepthMask :: GLES => Bool -> Draw o ()+setDepthMask = setFlag depthMask (\x s -> s { depthMask = x })+                       (gl $ GL.depthMask true) (gl $ GL.depthMask false)++setFlag :: (DrawState -> Bool)+        -> (Bool -> DrawState -> DrawState)+        -> Draw o ()+        -> Draw o ()+        -> Bool+        -> Draw o ()+setFlag getF setF enable disable new =+        do old <- getF <$> Draw get+           case (old, new) of+                   (False, True) -> enable+                   (True, False) -> disable+                   _ -> return ()+           Draw . modify $ setF new++setColorMask :: GLES => (Bool, Bool, Bool, Bool) -> Draw o ()+setColorMask new@(r, g, b, a) = do old <- colorMask <$> Draw get+                                   when (old /= new) . gl $+                                           GL.colorMask r' g' b' a'+                                   Draw . modify $ \s -> s { colorMask = new }+        where (r', g', b', a') = (bool r, bool g, bool b, bool a)+              bool True = true+              bool False = false++getDrawResource :: Resource i r m+                => (m (Either String r) -> Draw o (Either String r))+                -> (DrawState -> ResMap r)+                -> i+                -> Draw o (Either String r)+getDrawResource lft mg i = do+        map <- mg <$> Draw get+        lft $ getResource i map++getDrawResource' :: Resource i r m+                => (m (Either String r) -> Draw o (Either String r))+                -> (DrawState -> ResMap r)+                -> Maybe k+                -> i+                -> Draw o (Either String r)+getDrawResource' lft mg k i = do+        map <- mg <$> Draw get+        lft $ getResource' k i map++checkDrawResource :: Resource i r m+                  => (m (ResStatus r) -> Draw o (ResStatus r))+                  -> (DrawState -> ResMap r)+                  -> i+                  -> Draw o (ResStatus r)+checkDrawResource lft mg i = do+        map <- mg <$> Draw get+        lft $ checkResource i map++removeDrawResource :: (Resource i r m, Hashable i)+                   => (m () -> Draw o ())+                   -> (DrawState -> ResMap r)+                   -> i+                   -> Draw o ()+removeDrawResource lft mg i = do+        s <- mg <$> Draw get+        lft $ removeResource i s++textureCacheMaxSize :: Num a => a+textureCacheMaxSize = 16++-- | Clear the color buffer.+clearColor :: (GLES, MonadGL m) => m ()+clearColor = clearBuffers [ColorBuffer]++-- | Clear the depth buffer.+clearDepth :: (GLES, MonadGL m) => m ()+clearDepth = clearBuffers [DepthBuffer]++-- | Clear the stencil buffer.+clearStencil :: (GLES, MonadGL m) => m ()+clearStencil = clearBuffers [StencilBuffer]++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++createOutBuffer :: forall m t t' o. (GLES, MonadTexture m)+                => Int+                -> Int+                -> OutBufferInfo o+                -> m (OutBuffer t' o)+createOutBuffer w h empty = +        do let loader t = do 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++           textures <- replicateM (fromIntegral texNum)+                                  (newTexture w h params cacheIdentifier loader)+           return $ case empty of+                         EmptyFloatGBuffer _ -> TextureFloatGBuffer textures+                         EmptyByteGBuffer _ -> TextureByteGBuffer textures+                         EmptyDepthBuffer _ ->+                                 TextureDepthBuffer $ head textures+                         EmptyDepthStencilBuffer _ ->+                                 TextureDepthStencilBuffer $ head textures+        where (w', h') = (fromIntegral w, fromIntegral h)+              cacheIdentifier = hash ( fromIntegral internalFormat :: Int+                                     , fromIntegral format :: Int+                                     , fromIntegral pixelType :: Int+                                     , params+                                     )+              (internalFormat, format, pixelType, params, texNum) =+                      case empty of+                           EmptyByteGBuffer params ->+                                   ( fromIntegral gl_RGBA+                                   , gl_RGBA+                                   , gl_UNSIGNED_BYTE+                                   , params+                                   , textureCount (Proxy :: Proxy o)+                                   )+                           EmptyFloatGBuffer params ->+                                   ( fromIntegral gl_RGBA32F+                                   , gl_RGBA+                                   , gl_FLOAT+                                   , params+                                   , textureCount (Proxy :: Proxy o)+                                   )+                           EmptyDepthBuffer params ->+                                   ( fromIntegral gl_DEPTH_COMPONENT+                                   , gl_DEPTH_COMPONENT+                                   , gl_UNSIGNED_SHORT+                                   , params+                                   , 1+                                   )+                           EmptyDepthStencilBuffer params ->+                                   ( fromIntegral gl_DEPTH_STENCIL+                                   , gl_DEPTH_STENCIL+                                   , gl_UNSIGNED_INT_24_8+                                   , params+                                   , 1+                                   )++permanentDrawBuffers :: GLES+                     => Int+                     -> Int+                     -> Either (GBuffer t o) (GBufferInfo o)+                     -> Either (DepthBuffer t1) DepthBufferInfo+                     -> Draw o a+                     -> Draw o' ( a+                                , (Bool, GBuffer t2 o)+                                , (Bool, DepthBuffer t3)+                                )+permanentDrawBuffers w h gBuffer depthBuffer draw =+        do (newColor, gBuffer') <-+                case gBuffer of+                     Right b -> (,) True <$> createOutBuffer w h b+                     Left b -> return (False, castBuffer b)+           (newDepth, shouldClearStencil, depthBuffer') <-+                case depthBuffer of+                     Right b@(EmptyDepthBuffer _) ->+                             (,,) True False <$> createOutBuffer w h b+                     Right b@(EmptyDepthStencilBuffer _) ->+                             (,,) True True <$> createOutBuffer w h b+                     Left b -> return (False, False, castBuffer b)+           ret <- drawUsedBuffers w h gBuffer' depthBuffer' $+                   do when newColor clearColor+                      when newDepth clearDepth+                      when shouldClearStencil clearStencil+                      draw+           return (ret, (newColor, gBuffer'), (newDepth, depthBuffer'))++drawUsedBuffers :: GLES+                => Int+                -> Int+                -> GBuffer t o+                -> DepthBuffer t1+                -> Draw o a+                -> Draw o' a+drawUsedBuffers w h gBuffer depthBuffer draw =+        do oldFb <- currentFrameBuffer <$> Draw get+           ret <- drawToTextures useDrawBuffers attachments w h oldFb $ \fb -> +                do Draw . modify $ \s -> s { currentFrameBuffer = fb }+                   castDraw draw+           Draw . modify $ \s -> s { currentFrameBuffer = oldFb }+           return ret+        where colorAttachments = zipWith (\(LoadedTexture _ _ _ t) n ->+                                                (t, gl_COLOR_ATTACHMENT0 + n)+                                         )+                                         (textures gBuffer)+                                         [0 ..]+              depthAttachment =+                      case depthBuffer of+                           TextureDepthBuffer (LoadedTexture _ _ _ t) ->+                                (t, gl_DEPTH_ATTACHMENT)+                           TextureDepthStencilBuffer (LoadedTexture _ _ _ t) ->+                                (t, gl_DEPTH_STENCIL_ATTACHMENT)+              attachments = depthAttachment : colorAttachments+              useDrawBuffers | (_ : _ : _) <- colorAttachments = True+                              | otherwise = False+drawToTextures :: (GLES, MonadScreen m, MonadGL m)+               => Bool+               -> [(GL.Texture, GLEnum)]+               -> Int+               -> Int+               -> FrameBuffer+               -> (FrameBuffer -> m a)+               -> m a+drawToTextures useDrawBuffers atts w h oldFb draw =+        do fb <- gl createFramebuffer +           gl $ bindFramebuffer gl_FRAMEBUFFER fb++           buffersToDraw <- fmap concat . flip mapM atts $+                   \(t, attach) ->+                           do let drawAttachment =+                                   [ fromIntegral attach+                                   | attach /= gl_DEPTH_ATTACHMENT+                                   , attach /= gl_DEPTH_STENCIL_ATTACHMENT+                                   ]+                                        +                              gl $ framebufferTexture2D gl_FRAMEBUFFER attach+                                                        gl_TEXTURE_2D t 0+                              return drawAttachment++           when useDrawBuffers $+                   liftIO (encodeInts buffersToDraw) >>= gl . GL.drawBuffers++           (sw, sh) <- currentViewport+           resizeViewport (fromIntegral w) (fromIntegral h)++           ret <- draw fb++           resizeViewport sw sh+           gl $ do deleteFramebuffer fb+                   bindFramebuffer gl_FRAMEBUFFER oldFb++           return ret++class ReadPixels r where+        readPixels :: MonadGL m => (Int, Int, Int, Int) -> GLEnum -> m r++instance GLES => ReadPixels [Color] where+        readPixels (x, y, rw, rh) format =+                        do arr <- liftIO . newUInt8Array $+                                        fromIntegral rw * fromIntegral rh * 4+                           gl $ readPixelsUInt8 (fromIntegral x)+                                                (fromIntegral y)+                                                (fromIntegral rw)+                                                (fromIntegral rh)+                                                format gl_UNSIGNED_BYTE arr+                           liftIO $ fmap wordsToColors (decodeUInt8s arr)+                where wordsToColors (r : g : b : a : xs) =+                                Color r g b a : wordsToColors xs+                      wordsToColors _ = []++instance GLES => ReadPixels [Vec4] where+        readPixels (x, y, rw, rh) format =+                        do arr <- liftIO . newFloat32Array $+                                        fromIntegral rw * fromIntegral rh * 4+                           gl $ readPixelsFloat (fromIntegral x)+                                                (fromIntegral y)+                                                (fromIntegral rw)+                                                (fromIntegral rh)+                                                format gl_FLOAT arr+                           liftIO $ fmap floatsToVecs (decodeFloat32s arr)+                where floatsToVecs (r : g : b : a : xs) =+                                Vec4 r g b a : floatsToVecs xs+                      floatsToVecs _ = []++instance GLES => ReadPixels [Word8] where+        readPixels (x, y, rw, rh) format =+                        do arr <- liftIO . newUInt8Array $+                                        fromIntegral rw * fromIntegral rh+                           gl $ readPixelsUInt8 (fromIntegral x)+                                                (fromIntegral y)+                                                (fromIntegral rw)+                                                (fromIntegral rh)+                                                format gl_UNSIGNED_BYTE arr+                           liftIO $ decodeUInt8s arr++instance GLES => ReadPixels [Word16] where+        readPixels (x, y, rw, rh) format =+                        do arr <- liftIO . newUInt16Array $+                                        fromIntegral rw * fromIntegral rh+                           gl $ readPixelsUInt16 (fromIntegral x)+                                                 (fromIntegral y)+                                                 (fromIntegral rw)+                                                 (fromIntegral rh)+                                                 format gl_UNSIGNED_SHORT arr+                           liftIO $ decodeUInt16s arr++instance GLES => ReadPixels [Float] where+        readPixels (x, y, rw, rh) format =+                        do arr <- liftIO . newFloat32Array $+                                        fromIntegral rw * fromIntegral rh+                           gl $ readPixelsFloat (fromIntegral x)+                                                (fromIntegral y)+                                                (fromIntegral rw)+                                                (fromIntegral rh)+                                                format gl_FLOAT arr+                           liftIO $ decodeFloat32s arr++castDraw :: Draw o a -> Draw o' a+castDraw (Draw x) = Draw x+++-- | Get the 'DrawState'.+drawGet :: Draw o DrawState+drawGet = Draw get

@@ -1,13 +1,20 @@-{-# LANGUAGE GADTs, KindSignatures, DataKinds, ScopedTypeVariables,-             TypeOperators, FlexibleContexts #-}+{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,+             MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables,+             PolyKinds, TypeFamilies, RankNTypes, ConstraintKinds,+             UndecidableInstances #-} +-- |+-- Module:      Graphics.Rendering.Ombra.Geometry+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only+ module Graphics.Rendering.Ombra.Geometry (         Geometry,-        Vertex(..),         Triangle(..),         mkGeometry,         mapVertices,-        removeAttribute,         decompose,         -- * Geometry builder         Attributes,@@ -18,82 +25,165 @@         triangle,         buildGeometry,         buildGeometryT,-        -- * 2D and 3D geometries-        D2.Geometry2D,-        D3.Geometry3D,-        mkGeometry2D,-        mkGeometry3D,-        mkGeometry2D',-        mkGeometry3D',-        vertex2D,-        vertex3D+        -- *+        GeometryVertex(..) ) where -import Control.Monad-import Control.Monad.ST-import Data.Foldable (foldrM)-import Data.Hashable+import Control.Monad.Trans.State+import Data.Foldable (foldlM)+import qualified Data.Hashable as H+import qualified Data.HashMap.Lazy as H+import Data.List (foldl') import Data.Proxy import Data.Word (Word16)-import qualified Data.HashTable.ST.Basic as H+ 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.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.Vector --- | Create a 3D 'Geometry'.-mkGeometry3D :: GLES-             => [Triangle (Vec3, Vec2, Vec3)] -- ^ (Position, UV, Normal)-             -> Geometry D3.Geometry3D-mkGeometry3D = mkGeometry . map (fmap $ \(v, u, n) -> mkVertex3D v u n)+rehashGeometry :: Geometry g -> Geometry g+rehashGeometry g = let Triangles elemsHash _ = elements g+                   in g { geometryHash = H.hashWithSalt (topHash g) elemsHash } --- | Create an extended 3D 'Geometry'.-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 $ mkVertex3D v u n)+emptyGeometry :: GeometryVertex g => Geometry g+emptyGeometry = rehashGeometry $ Geometry 0 0 emptyAttrCol (Triangles 0 []) (-1) --- | Create a 2D 'Geometry'.-mkGeometry2D :: GLES-             => [Triangle (Vec2, Vec2)] -- ^ (Position, Texture UV coordinates)-             -> Geometry D2.Geometry2D-mkGeometry2D = mkGeometry . map (fmap $ \(v, u) -> mkVertex2D v u)+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') --- | Create an extended 2D 'Geometry'.-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)+addVertex :: GeometryVertex g+          => VertexAttributes (AttributeTypes g)+          -> Geometry g+          -> (AttrVertex (AttributeTypes g), Geometry g)+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+                                }+           ) --- | 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+addTriangle :: GeometryVertex g+            => Triangle (AttrVertex (AttributeTypes g))+            -> Geometry g+            -> Geometry g+addTriangle t g = let Triangles h ts = elements g+                      elements' = Triangles (H.hashWithSalt (H.hash t) h)+                                            (t : ts)+                  in rehashGeometry $ g { elements = elements' } --- | 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+-- | Create a new vertex that can be used in 'addTriangle'.+vertex :: (Monad m, GeometryVertex g)+       => Vertex g+       -> GeometryBuilderT g m (AttrVertex (AttributeTypes g))+vertex = GeometryBuilderT . state . addVertex . toVertexAttributes -mkVertex3D :: GLES => Vec3 -> Vec2 -> Vec3 -> Vertex D3.Geometry3D-mkVertex3D p u n = Attr D3.Position3 p :~ Attr D3.UV u :~ Attr D3.Normal3 n+-- | Add a triangle to the current geometry.+triangle :: (Monad m, GeometryVertex g)+         => AttrVertex (AttributeTypes g)+         -> AttrVertex (AttributeTypes g)+         -> AttrVertex (AttributeTypes g)+         -> GeometryBuilderT g m ()+triangle x y z = GeometryBuilderT . state $ \g -> ((), addTriangle t g)+        where t = Triangle x y z -mkVertex2D :: GLES => Vec2 -> Vec2 -> Vertex D2.Geometry2D-mkVertex2D p u = Attr D2.Position2 p :~ Attr D2.UV u+-- | Create a 'Geometry' using the 'GeometryBuilder' monad. This is more+-- efficient than 'mkGeometry'.+buildGeometry :: GeometryVertex g => GeometryBuilder g () -> Geometry g+buildGeometry (GeometryBuilderT m) = execState m emptyGeometry -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+buildGeometryT :: (Monad m, GeometryVertex g)+               => GeometryBuilderT g m ()+               -> m (Geometry g)+buildGeometryT (GeometryBuilderT m) = execStateT m emptyGeometry++-- | Create a 'Geometry' using a list of triangles.+mkGeometry :: (GLES, GeometryVertex g)+           => [Triangle (Vertex g)]+           -> Geometry g+mkGeometry t = buildGeometry (foldlM add H.empty t >> return ())+        where add verts (Triangle v1 v2 v3) =+                do (verts1, av1) <- mvertex verts $ toVertexAttributes v1+                   (verts2, av2) <- mvertex verts1 $ toVertexAttributes v2+                   (verts3, av3) <- mvertex verts2 $ toVertexAttributes v3+                   triangle av1 av2 av3+                   return verts3+              mvertex vertices v =+                case H.lookup v vertices of+                     Just av -> return (vertices, av)+                     Nothing -> do av <- vertex $ fromVertexAttributes v+                                   return (H.insert v av vertices, av)++attrVertexToVertex :: Attributes is => AttrVertex is -> VertexAttributes is+attrVertexToVertex (AttrVertex _ tab) = rowToVertexAttributes tab++-- | Convert a 'Geometry' back to a list of triangles.+decompose :: GeometryVertex g => Geometry g -> [Triangle (Vertex g)] +decompose g@(Geometry _ _ _ (Triangles _ triangles) _) =+        flip map triangles $ fmap (fromVertexAttributes . 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 :: forall a g g'. (GLES, GeometryVertex g, GeometryVertex g')+            => (Triangle (Vertex g) -> a)+            -> ([a] -> Vertex g -> Vertex g')+            -> Geometry g+            -> Geometry g'+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 ( fromVertexAttributes+                                                . attrVertexToVertex+                                                ) tri+                        values' = foldr (flip (H.insertWith (++)) [value])+                                        values+                                        [v1, v2, v3]+                        tri' = fmap (vertMap H.!) tri+                    in (values', tri' : triangles)++            accVertex :: H.HashMap (AttrVertex (AttributeTypes g)) [a]+                      -> AttrVertex (AttributeTypes g)+                      -> ( H.HashMap (AttrVertex (AttributeTypes g))+                                     (AttrVertex (AttributeTypes g'))+                         , Geometry g'+                         )+                      -> ( H.HashMap (AttrVertex (AttributeTypes g))+                                     (AttrVertex (AttributeTypes g'))+                         , Geometry g'+                         )+            accVertex valueMap avert (vertMap, geom) =+                    let value = valueMap H.! avert+                        vert = fromVertexAttributes $ attrVertexToVertex avert+                        vert' = toVertexAttributes $ 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'

@@ -0,0 +1,137 @@+{-# LANGUAGE TypeOperators, KindSignatures, DataKinds, FlexibleContexts,+             FlexibleInstances, ConstraintKinds, ScopedTypeVariables,+             MultiParamTypeClasses, GADTs #-}++module Graphics.Rendering.Ombra.Geometry.Draw (+        MonadGeometry(..),+        LoadedBuffer,+        LoadedAttribute,+        LoadedGeometry(..),+        drawGeometry+) where++import Control.Monad.Trans.Control+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+import Control.Monad.Trans.State+import Data.Proxy++import Graphics.Rendering.Ombra.Geometry.Types+import Graphics.Rendering.Ombra.Internal.GL+import Graphics.Rendering.Ombra.Internal.Resource+import Graphics.Rendering.Ombra.Shader.CPU+import Graphics.Rendering.Ombra.Shader.Language.Types (ShaderType(size))++class (GLES, MonadGL m) => MonadGeometry m where+        getAttribute :: BaseAttribute i+                     => AttrCol (i ': is)+                     -> m (Either String LoadedAttribute)+        getElementBuffer :: Elements is -> m (Either String LoadedBuffer)+        getGeometry :: GeometryVertex g+                    => Geometry g+                    -> m (Either String LoadedGeometry)+++data LoadedGeometry = LoadedGeometry {+        -- elementType :: GLEnum,+        elementCount :: Int,+        vao :: VertexArrayObject+}++newtype LoadedBuffer = LoadedBuffer Buffer++data LoadedAttribute = LoadedAttribute GLUInt [(Buffer, GLUInt -> GL ())]++instance (GLES, BaseAttribute i) =>+        Resource (AttrCol (i ': is)) LoadedAttribute GL where+        loadResource (AttrTop _ _ down :: AttrCol (i ': is)) =+                fmap (Right . uncurry LoadedAttribute) .+                flip execStateT (0, []) $+                        do (i, as) <- get+                           arr <- lift $ encodeAttribute (Proxy :: Proxy i) vs+                           buf <- lift $ loadBuffer gl_ARRAY_BUFFER arr+                           let sz = fromIntegral . size $ (undefined :: i)+                               set = setAttribute (Proxy :: Proxy i) . (+ i)+                           put (i + sz, (buf, set) : as)+                where vs = downList down []+        unloadResource _ (LoadedAttribute _ as) =+                mapM_ (\(buf, _) -> deleteBuffer buf) as++instance GLES => Resource (Elements is) LoadedBuffer GL where+        loadResource (Triangles _ ts) =+                liftIO (encodeUInt16s 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++instance (GLES, MonadGeometry m, MonadBaseControl IO m, GeometryVertex g) =>+        Resource (Geometry g) LoadedGeometry m where+        loadResource = loadGeometry+        unloadResource _ = gl . deleteGeometry++downList :: NotTop p => AttrTable p (i ': is) -> [CPUBase i] -> [CPUBase i]+downList AttrEnd xs = xs+downList (AttrCell x _ down) xs = downList down $ x : xs++loadGeometry :: (GLES, MonadGeometry m, GeometryVertex g)+             => Geometry g+             -> m (Either String LoadedGeometry)+loadGeometry geometry@(Geometry _ _ _ _ _) = runExceptT $+        do vao <- lift $ gl createVertexArray+           lift . gl $ bindVertexArray vao++           ExceptT . setAttrTop (0 :: GLUInt) $ top geometry+           LoadedBuffer eb <- ExceptT . getElementBuffer $ elements geometry++           lift . gl $ do bindBuffer gl_ELEMENT_ARRAY_BUFFER eb+                          bindVertexArray noVAO+                          bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer+                          bindBuffer gl_ARRAY_BUFFER noBuffer++           return $ LoadedGeometry (elementCount $ elements geometry) vao+        where elementCount (Triangles _ ts) = 3 * length ts++setAttrTop :: (GLES, MonadGeometry m, Attributes is)+           => GLUInt+           -> AttrCol 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++loadBuffer :: GLES => GLEnum -> AnyArray -> GL Buffer+loadBuffer ty bufData =+        do buffer <- createBuffer+           bindBuffer ty buffer+           bufferData ty bufData gl_STATIC_DRAW+           bindBuffer ty noBuffer+           return buffer++drawGeometry :: (MonadGeometry m, GeometryVertex g) => Geometry g -> 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

@@ -1,317 +0,0 @@-{-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,-             MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables,-             PolyKinds, TypeFamilies, RankNTypes, ConstraintKinds,-             UndecidableInstances #-}--module Graphics.Rendering.Ombra.Geometry.Internal (-        MonadGeometry(..),-        LoadedBuffer,-        LoadedAttribute,-        LoadedGeometry(..),-        vertex,-        triangle,-        mkGeometry,-        buildGeometry,-        buildGeometryT,-        decompose,-        mapVertices,-        removeAttribute,-        drawGeometry-) where--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 qualified Data.HashMap.Lazy as H-import Data.List (foldl')-import Data.Proxy-import Data.Word (Word16)--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.Language.Types (ShaderType(size))-import Graphics.Rendering.Ombra.Vector--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 LoadedGeometry = LoadedGeometry {-        -- elementType :: GLEnum,-        elementCount :: Int,-        vao :: VertexArrayObject-}--newtype LoadedBuffer = LoadedBuffer Buffer--data LoadedAttribute = LoadedAttribute GLUInt [(Buffer, GLUInt -> GL ())]--rehashGeometry :: Geometry is -> Geometry is-rehashGeometry g = let Triangles elemsHash _ = elements g-                   in g { geometryHash = H.hashWithSalt (topHash g) elemsHash }--emptyGeometry :: Attributes is => Geometry is-emptyGeometry = rehashGeometry $ Geometry 0 0 emptyAttrCol (Triangles 0 []) (-1)--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--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')--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-                                }-           )--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' }---- | 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---- | 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---- | 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--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-                   , Attributes is-                   , Attributes (Remove i is)-                   , GLES-                   )-                => (a -> i)      -- ^ Attribute constructor (or any other-                                 -- function with that type).-                -> Geometry is-                -> Geometry (Remove i is)-removeAttribute g = mapVertices (const ()) (const $ removeAttr g)--class RemoveAttr i is where-        removeAttr :: (a -> i) -> Vertex is -> Vertex (Remove i is)--instance {-# OVERLAPPING #-} (Remove i '[i', i] ~ '[i']) =>-        RemoveAttr i '[i', i] where-        removeAttr g (Attr g' x :~ _) = Attr g' x--instance {-# OVERLAPPING #-} RemoveAttr i is' => RemoveAttr i (i ': is') where-        removeAttr g (Attr _ _ :~ v) = removeAttr g v--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 $-                                \_ (g :: Proxy g) c ->-                                        do (i, as) <- get-                                           arr <- lift $ encodeAttribute g c-                                           buf <- lift $-                                                   loadBuffer gl_ARRAY_BUFFER-                                                              arr-                                           let sz = fromIntegral . size $-                                                        (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 (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--instance (GLES, MonadGeometry m, EmbedIO m) =>-        Resource (Geometry (i ': is)) LoadedGeometry m where-        loadResource = loadGeometry-        unloadResource _ = gl . deleteGeometry--loadGeometry :: (GLES, MonadGeometry m)-             => Geometry (i ': is)-             -> m (Either String LoadedGeometry)-loadGeometry geometry@(Geometry _ _ _ _ _) = runExceptT $-        do vao <- lift $ gl createVertexArray-           lift . gl $ bindVertexArray vao--           ExceptT . setAttrTop (0 :: GLUInt) $ top geometry-           LoadedBuffer eb <- ExceptT . getElementBuffer $ elements geometry--           lift . gl $ do bindBuffer gl_ELEMENT_ARRAY_BUFFER eb-                          bindVertexArray noVAO-                          bindBuffer gl_ELEMENT_ARRAY_BUFFER noBuffer-                          bindBuffer gl_ARRAY_BUFFER noBuffer--           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--loadBuffer :: GLES => GLEnum -> AnyArray -> GL Buffer-loadBuffer ty bufData =-        do buffer <- createBuffer-           bindBuffer ty buffer-           bufferData ty bufData gl_STATIC_DRAW-           bindBuffer ty noBuffer-           return buffer--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

@@ -1,9 +1,13 @@ {-# LANGUAGE GADTs, TypeOperators, KindSignatures, DataKinds, FlexibleContexts,-             FlexibleInstances, UndecidableInstances, TypeFamilies, RankNTypes,-             GeneralizedNewtypeDeriving, ConstraintKinds #-}+             FlexibleInstances, TypeFamilies, RankNTypes, UndecidableInstances,+             GeneralizedNewtypeDeriving, ConstraintKinds, MultiParamTypeClasses,+             TypeFamilyDependencies, ScopedTypeVariables, DefaultSignatures,+             CPP #-}  module Graphics.Rendering.Ombra.Geometry.Types (-        Vertex(..),+        GeometryVertex(..),+        GGeometryVertex(..),+        VertexAttributes(..),         Triangle(..),         AttrTable(..),         AttrCol,@@ -23,41 +27,83 @@ import GHC.Exts (Constraint) import qualified Data.Hashable as H import Data.Functor.Identity (Identity)+import Data.Int (Int32) import Data.Word (Word16)+import Data.Proxy+import GHC.Generics +import Graphics.Rendering.Ombra.Backend (GLES)+import Graphics.Rendering.Ombra.Internal.TList import Graphics.Rendering.Ombra.Shader.CPU+import Graphics.Rendering.Ombra.Shader.Language.Types+import Graphics.Rendering.Ombra.Vector +-- | Types that can be used as 'Geometry' vertices.+class Attributes (AttributeTypes a) => GeometryVertex a where+        type AttributeTypes a :: [*]+        type AttributeTypes a = GAttributeTypes (Rep a) (Rep (Vertex a))++        type Vertex a = v | v -> a++        toVertexAttributes :: Vertex a -> VertexAttributes (AttributeTypes a)+        default toVertexAttributes :: ( Generic a+                                      , Generic (Vertex a)+                                      , GGeometryVertex (Rep a) (Rep (Vertex a))+                                      , VertexAttributes (AttributeTypes a) ~ +                                        VertexAttributes+                                            (GAttributeTypes (Rep a)+                                                             (Rep (Vertex a)))++                                      )+                                   => Vertex a+                                   -> VertexAttributes (AttributeTypes a)+        toVertexAttributes = gtoVertexAttributes (Proxy :: Proxy (Rep a)) . from++        fromVertexAttributes :: VertexAttributes (AttributeTypes a) -> Vertex a+        default fromVertexAttributes :: ( Generic a+                                        , Generic (Vertex a)+                                        , GGeometryVertex (Rep a)+                                                          (Rep (Vertex a))+                                        , VertexAttributes (AttributeTypes a) ~ +                                          VertexAttributes+                                              (GAttributeTypes (Rep a)+                                                               (Rep (Vertex a)))++                                        )+                                   => VertexAttributes (AttributeTypes a)+                                   -> Vertex a+        fromVertexAttributes =+                to . gfromVertexAttributes (Proxy :: Proxy (Rep a))+ 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)+-- TODO: use AttrTable rows instead+data VertexAttributes (is :: [*]) where+        Attr :: (Eq (CPUBase i), H.Hashable (CPUBase i), BaseAttribute i)+             => CPUBase i+             -> VertexAttributes '[i]+        (:~) :: VertexAttributes '[i]+             -> VertexAttributes is+             -> VertexAttributes (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: ?+data Geometry g where+        Geometry :: { topHash :: Int            -- TODO: ?                     , geometryHash :: Int       -- TODO: ?-                    , top :: AttrCol is-                    , elements :: Elements is+                    , top :: AttrCol (AttributeTypes g)+                    , elements :: Elements (AttributeTypes g)                     , lastIndex :: Int                     }-                 -> Geometry is+                 -> Geometry g -newtype GeometryBuilderT is m a = GeometryBuilderT (StateT (Geometry is) m a)+newtype GeometryBuilderT g m a = GeometryBuilderT (StateT (Geometry g) m a)         deriving (Functor, Applicative, Monad, MonadTrans) -type GeometryBuilder is = GeometryBuilderT is Identity+type GeometryBuilder g = GeometryBuilderT g Identity  -- | A vertex in a 'Geometry'. data AttrVertex (is :: [*]) where@@ -76,13 +122,12 @@ data AttrTable (b :: AttrPosition) (is :: [*]) where         AttrNil :: AttrTable b '[]         AttrEnd :: AttrTable End is-        AttrTop :: (NotTop p, Attribute 'S i)+        AttrTop :: NotTop p                 => Int                 -> AttrTable Top is                 -> AttrTable p (i ': is)                 -> AttrTable Top (i ': is)-        AttrCell :: (H.Hashable (CPU S i), Attribute 'S i)-                 => CPU 'S i+        AttrCell :: CPUBase i                  -> AttrTable (Previous p) is                  -> AttrTable p (i ': is)                  -> AttrTable (Previous p) (i ': is)@@ -90,50 +135,58 @@ type AttrCol = AttrTable Top type NotTop p = Previous p ~ Previous p -class Attributes is where+class Empty is ~ 'False => 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)+        cell :: VertexAttributes is+             -> AttrTable p is+             -> AttrTable (Previous p) is+        addTop :: VertexAttributes is -> AttrCol is -> AttrCol is+        foldTop :: (forall i is. BaseAttribute i => b -> AttrCol (i ': is) -> b)                 -> b                 -> AttrCol is                 -> b-        rowToVertex :: NotTop p => AttrTable p is -> Vertex is+        rowToVertexAttributes :: NotTop p+                              => AttrTable p is+                              -> VertexAttributes is -instance (Attribute 'S i, Eq (CPU 'S i)) => Attributes '[i] where+instance (BaseAttribute i, Eq (CPUBase i), H.Hashable (CPUBase 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) =+        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+        rowToVertexAttributes (AttrCell x _ _) = Attr x -instance (Attribute 'S i1, Eq (CPU 'S i1), Attributes (i2 ': is)) =>-        Attributes (i1 ': (i2 ': is)) where+instance ( BaseAttribute i1+         , Eq (CPUBase i1)+         , Attributes (i2 ': is)+         , H.Hashable (CPUBase i1)+         ) => Attributes (i1 ': (i2 ': is)) where         emptyAttrCol = AttrTop (H.hash (0 :: Int)) emptyAttrCol AttrEnd-        cell (Attr _ x :~ v) down1@(AttrCell _ down2 _) =+        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) =+        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+        rowToVertexAttributes (AttrCell x next _) =+                Attr x :~ rowToVertexAttributes 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+instance H.Hashable (VertexAttributes 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 Eq (VertexAttributes 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)@@ -163,3 +216,170 @@  instance Eq (AttrCol (i ': is)) where         (AttrTop h _ _) == (AttrTop h' _ _) = h == h'++class (Attributes as, Attributes bs, Attributes (Append as bs)) =>+        BreakVertex (as :: [*]) (bs :: [*]) where+        breakVertexAttributes :: VertexAttributes (Append as bs)+                              -> (VertexAttributes as, VertexAttributes bs)++instance (Attributes '[a], Attributes bs, Attributes (a ': bs)) =>+        BreakVertex '[a] bs where+        breakVertexAttributes (attr :~ rest) = (attr, rest)++instance ( Attributes (a1 ': a2 ': as)+         , BreakVertex (a2 ': as) bs+         , Attributes (Append (a1 ': a2 ': as) bs)+         ) => BreakVertex (a1 ': a2 ': as) bs where+        breakVertexAttributes (a1 :~ rest) =+                let (a2as, bs) = breakVertexAttributes rest+                in (a1 :~ a2as, bs)++class (Attributes as, Attributes bs, Attributes (Append as bs)) =>+        AppendVertex (as :: [*]) (bs :: [*]) where+        appendVertexAttributes :: VertexAttributes as+                               -> VertexAttributes bs+                               -> VertexAttributes (Append as bs)++instance (Attributes '[a], Attributes bs, Attributes (a ': bs)) =>+        AppendVertex '[a] bs where+        appendVertexAttributes x@(Attr _) xs = x :~ xs++instance ( Attributes (a1 ': a2 ': as)+         , Attributes (a1 ': Append (a2 ': as) bs)+         , AppendVertex (a2 ': as) bs+         ) => AppendVertex (a1 ': a2 ': as) bs where+        appendVertexAttributes (x@(Attr _) :~ xs1) xs2 =+                x :~ appendVertexAttributes xs1 xs2++class GGeometryVertex (g :: * -> *) (v :: * -> *) where+        type GAttributeTypes g v :: [*]+        gtoVertexAttributes :: Proxy g+                            -> v p+                            -> VertexAttributes (GAttributeTypes g v)+        gfromVertexAttributes :: Proxy g+                              -> VertexAttributes (GAttributeTypes g v)+                              -> v p++instance GGeometryVertex c v => GGeometryVertex (M1 i d c) (M1 i' d' v) where+        type GAttributeTypes (M1 i d c) (M1 i' d' v) = GAttributeTypes c v+        gtoVertexAttributes (Proxy :: Proxy (M1 i d c)) (M1 v) =+                gtoVertexAttributes (Proxy :: Proxy c) v+        gfromVertexAttributes (Proxy :: Proxy (M1 i d c)) va =+                M1 $ gfromVertexAttributes (Proxy :: Proxy c) va++instance (GeometryVertex c, v ~ Vertex c) =>+        GGeometryVertex (K1 i c) (K1 i v) where+        type GAttributeTypes (K1 i c) (K1 i v) = AttributeTypes c+        gtoVertexAttributes _ (K1 v) = toVertexAttributes v+        gfromVertexAttributes _ va = K1 $ fromVertexAttributes va++instance ( GGeometryVertex c v+         , GGeometryVertex c' v'+         , AppendVertex (GAttributeTypes c v) (GAttributeTypes c' v')+         , BreakVertex (GAttributeTypes c v) (GAttributeTypes c' v')+         ) => GGeometryVertex (c :*: c') (v :*: v') where+        type GAttributeTypes (c :*: c') (v :*: v') =+                Append (GAttributeTypes c v) (GAttributeTypes c' v')+        gtoVertexAttributes (Proxy :: Proxy (c :*: c')) (v :*: v') =+                let va = gtoVertexAttributes (Proxy :: Proxy c) v+                    va' = gtoVertexAttributes (Proxy :: Proxy c') v'+                in appendVertexAttributes va va'+        gfromVertexAttributes (Proxy :: Proxy (c :*: c')) va =+                let (vaa, vab) = breakVertexAttributes va+                in gfromVertexAttributes (Proxy :: Proxy c) vaa :*:+                   gfromVertexAttributes (Proxy :: Proxy c') vab++instance ( GeometryVertex a+         , GeometryVertex b+         , BreakVertex (AttributeTypes a) (AttributeTypes b)+         , AppendVertex (AttributeTypes a) (AttributeTypes b)+         ) => GeometryVertex (a, b) where+        type AttributeTypes (a, b) = Append (AttributeTypes a)+                                            (AttributeTypes b)+        type Vertex (a, b) = (Vertex a, Vertex b)+        toVertexAttributes (a, b) =+                appendVertexAttributes (toVertexAttributes a)+                                       (toVertexAttributes b)+        fromVertexAttributes v = let (va, vb) = breakVertexAttributes v+                                 in ( fromVertexAttributes va+                                    , fromVertexAttributes vb+                                    )++instance ( GeometryVertex a+         , GeometryVertex b+         , GeometryVertex c+         , BreakVertex (AttributeTypes a) (Append (AttributeTypes b)+                                                  (AttributeTypes c))+         , BreakVertex (AttributeTypes b) (AttributeTypes c)+         , AppendVertex (AttributeTypes a) (Append (AttributeTypes b)+                                                   (AttributeTypes c))+         , AppendVertex (AttributeTypes b) (AttributeTypes c)+         ) => GeometryVertex (a, b, c) where+        type AttributeTypes (a, b, c) = Append (AttributeTypes a)+                                               (Append (AttributeTypes b)+                                                       (AttributeTypes c))+        type Vertex (a, b, c) = (Vertex a, Vertex b, Vertex c)+        toVertexAttributes (a, b, c) =+                appendVertexAttributes (toVertexAttributes a) $+                        appendVertexAttributes (toVertexAttributes b)+                                               (toVertexAttributes c)+        fromVertexAttributes v = let (va, vbc) = breakVertexAttributes v+                                     (vb, vc) = breakVertexAttributes vbc+                                 in ( fromVertexAttributes va+                                    , fromVertexAttributes vb+                                    , fromVertexAttributes vc+                                    )++instance GLES => GeometryVertex GFloat where+        type AttributeTypes GFloat = '[GFloat]+        type Vertex GFloat = Float+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GBool where+        type AttributeTypes GBool = '[GBool]+        type Vertex GBool = Bool+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GInt where+        type AttributeTypes GInt = '[GInt]+        type Vertex GInt = Int32+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GVec2 where+        type AttributeTypes GVec2 = '[GVec2]+        type Vertex GVec2 = Vec2+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GVec3 where+        type AttributeTypes GVec3 = '[GVec3]+        type Vertex GVec3 = Vec3+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GVec4 where+        type AttributeTypes GVec4 = '[GVec4]+        type Vertex GVec4 = Vec4+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GIVec2 where+        type AttributeTypes GIVec2 = '[GIVec2]+        type Vertex GIVec2 = IVec2+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GIVec3 where+        type AttributeTypes GIVec3 = '[GIVec3]+        type Vertex GIVec3 = IVec3+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x++instance GLES => GeometryVertex GIVec4 where+        type AttributeTypes GIVec4 = '[GIVec4]+        type Vertex GIVec4 = IVec4+        toVertexAttributes x = Attr x+        fromVertexAttributes (Attr x) = x

@@ -0,0 +1,74 @@+module Graphics.Rendering.Ombra.Image (+        Image,+        image,+        uimage,+        draw+) where++import Data.Foldable+import Data.Functor.Identity+import Data.Proxy++import Graphics.Rendering.Ombra.Internal.GL (gl)+import Graphics.Rendering.Ombra.Draw.Class+import Graphics.Rendering.Ombra.Geometry+import Graphics.Rendering.Ombra.Geometry.Draw+import Graphics.Rendering.Ombra.Shader+import Graphics.Rendering.Ombra.Shader.CPU+import Graphics.Rendering.Ombra.Shader.GLSL+import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Shader.Types+import Graphics.Rendering.Ombra.Image.Types+import Graphics.Rendering.Ombra.Texture.Draw++-- | Create an 'Image'.+image :: (ShaderInput i, GeometryVertex i, ShaderInput v)+      => VertexShader i (GVec4, v)+      -> FragmentShader v o+      -> Geometry i+      -> Image o+image vs fs g = uimage (const vs) (const fs) (Identity (g, (), ()))++-- | Create an 'Image' using the same shader with different uniforms for each+-- geometry. The resulting image can be rendered more efficiently than an+-- equivalent sequence of images created with 'image'.+uimage :: (ShaderInput i, GeometryVertex i, ShaderInput v, Foldable t)+       => (UniformSetter vu -> VertexShader i (GVec4, v))+       -> (UniformSetter fu -> FragmentShader v o)+       -> t (Geometry i, vu, fu)+       -> Image o+uimage vs fs g = Image g vs fs++-- | Draw an 'Image'.+draw :: (MonadDraw o m, FragmentShaderOutput o) => Image o -> m o ()+draw (Image geometries vs fs) =+        let prg = program (vs undefined) (fs undefined)+            -- XXX+        in do setProgram prg+              for_ geometries $ \(geometry, vu, fu) ->+                let (uid, unisv, texsv) = uniformList (vs $ return vu) 0+                    (_, unisf, texsf) = uniformList (fs $ return fu) uid+                    unis = unisv ++ unisf+                    texs = texsv ++ texsf+                in withActiveTextures texs (const $ return ()) $ \samplers ->+                        withUniforms unis+                                     (zip texs samplers)+                                     (drawGeometry geometry)+                     +        where withUniforms unis texs a = (>> a) .+                for_ unis $ \(uid, uniformValue) ->+                        getUniform uid >>= \eu ->+                                case eu of+                                     Right (UniformLocation l) ->+                                        case uniformValue of+                                             UniformValue proxy value ->+                                                gl $ setUniform l proxy value+                                             UniformTexture tex ->+                                                let proxy = Proxy+                                                        :: Proxy TextureSampler+                                                    Just value = lookup tex texs+                                                in gl $ setUniform l proxy value+                                     Left _ -> return ()++draw (SeqImage i i') = draw i >> draw i'+draw NoImage = return ()

@@ -0,0 +1,35 @@+{-# LANGUAGE GADTs, DataKinds, MultiParamTypeClasses #-}++module Graphics.Rendering.Ombra.Image.Types where++import Data.Foldable+import Data.Semigroup+import Control.Arrow+import Graphics.Rendering.Ombra.Geometry.Types+import Graphics.Rendering.Ombra.Shader++data Image o where+       Image :: (ShaderInput i, ShaderInput v, Foldable t, GeometryVertex i)+             => t (Geometry i, vu, fu)+             -> (UniformSetter vu -> VertexShader i (GVec4, v))+             -> (UniformSetter fu -> FragmentShader v o)+             -> Image o+       SeqImage :: Image o -> Image o -> Image o+       NoImage :: Image o++instance Functor Image where+        fmap f (Image g vs fs) = Image g vs (\fu -> fs fu >>^ f)+        fmap f (SeqImage i i') = SeqImage (fmap f i) (fmap f i')+        fmap _ NoImage = NoImage++instance MapShader Image FragmentShaderStage where+        mapShader f (Image g vs fs) = Image g vs (\fu -> fs fu >>> f)+        mapShader f (SeqImage i i') = SeqImage (mapShader f i) (mapShader f i')+        mapShader _ NoImage = NoImage++instance Semigroup (Image o) where+        (<>) = SeqImage++instance Monoid (Image o) where+        mappend = (<>)+        mempty = NoImage

@@ -1,9 +1,20 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, UndecidableInstances #-} +#if __GLASGOW_HASKELL__ < 802+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}+#endif++-- |+-- Module:      Graphics.Rendering.Ombra.Internal.GL+-- License:     BSD3+-- Maintainer:  ziocroc@gmail.com+-- Stability:   experimental+-- Portability: GHC only+ module Graphics.Rendering.Ombra.Internal.GL (         MonadGL(..),         GL,-        ActiveTexture(..),+        Sampler2D(..),         module Graphics.Rendering.Ombra.Backend,         liftIO,         evalGL,@@ -87,7 +98,9 @@         linkProgram,         pixelStorei,         polygonOffset,-        readPixels,+        readPixelsUInt8,+        readPixelsUInt16,+        readPixelsFloat,         renderbufferStorage,         sampleCoverage,         scissor,@@ -136,16 +149,32 @@         viewport ) where +import Control.Monad.Base import Control.Monad.IO.Class+import Control.Monad.Trans.Control import Control.Monad.Trans.Reader import Data.Int (Int32)  import Graphics.Rendering.Ombra.Backend-import Graphics.Rendering.Ombra.Internal.Resource (EmbedIO(..))         -newtype GL a = GL (ReaderT Ctx IO a)-        deriving (Functor, Applicative, Monad, MonadIO)+newtype GL a = GL { unGL :: ReaderT Ctx IO a }+        deriving ( Functor+                 , Applicative+                 , Monad+                 , MonadIO+                 , MonadBase IO+#if __GLASGOW_HASKELL__ >= 802+                 , MonadBaseControl IO+                 )+#else+                 ) +instance MonadBaseControl IO GL where+        type StM GL a = ComposeSt (ReaderT Ctx) IO a+        liftBaseWith f = GL $ liftBaseWith $ \tf -> f (tf . unGL)+        restoreM = GL . restoreM+#endif+ class MonadIO m => MonadGL m where         gl :: GL a -> m a @@ -153,10 +182,7 @@         gl = id  -- | A Texture ready to be passed as an uniform.-newtype ActiveTexture = ActiveTexture Word--instance EmbedIO GL where-        embedIO f a = GL ask >>= \c -> liftIO . f $ evalGL a c+newtype Sampler2D = Sampler2D Word  evalGL :: GL a -> Ctx -> IO a evalGL (GL m) = runReaderT m@@ -431,8 +457,14 @@ polygonOffset :: GLES => Float -> Float -> GL () polygonOffset a b = getCtx >>= \ctx -> liftIO $ glPolygonOffset ctx a b -readPixels :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt8Array -> GL ()-readPixels a b c d e f g = getCtx >>= \ctx -> liftIO $ glReadPixels ctx a b c d e f g+readPixelsUInt8 :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt8Array -> GL ()+readPixelsUInt8 a b c d e f g = getCtx >>= \ctx -> liftIO $ glReadPixelsUInt8 ctx a b c d e f g++readPixelsUInt16 :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> UInt16Array -> GL ()+readPixelsUInt16 a b c d e f g = getCtx >>= \ctx -> liftIO $ glReadPixelsUInt16 ctx a b c d e f g++readPixelsFloat :: GLES => GLInt -> GLInt -> GLSize -> GLSize -> GLEnum -> GLEnum -> Float32Array -> GL ()+readPixelsFloat a b c d e f g = getCtx >>= \ctx -> liftIO $ glReadPixelsFloat ctx a b c d e f g  renderbufferStorage :: GLES => GLEnum -> GLEnum -> GLSize -> GLSize -> GL () renderbufferStorage a b c d = getCtx >>= \ctx -> liftIO $ glRenderbufferStorage ctx a b c d

@@ -5,7 +5,6 @@         ResMap,         ResStatus(..),         Resource(..),-        EmbedIO(..),         newResMap,         addResource,         getResource,@@ -15,7 +14,8 @@         unloader ) where -import Control.Monad.IO.Class+import Control.Monad.Base+import Control.Monad.Trans.Control import qualified Data.HashTable.IO as H import Data.Hashable import System.Mem.Weak@@ -26,16 +26,13 @@                  | Unloaded                  | Error String -class (Eq i, Applicative m, EmbedIO m, Hashable i) =>+class (Eq i, Applicative m, MonadBaseControl IO m, Hashable i) =>         Resource i r m where         loadResource :: i -> m (Either String r)         unloadResource :: Maybe i -> r -> m () -class MonadIO m => EmbedIO m where-        embedIO :: (IO a -> IO b) -> m a -> m b--newResMap :: MonadIO m => m (ResMap r)-newResMap = ResMap <$> liftIO H.new+newResMap :: MonadBase IO m => m (ResMap r)+newResMap = ResMap <$> liftBase H.new  addResource :: Resource i r m => i -> ResMap r -> m () addResource i m = () <$ getResource i m@@ -51,7 +48,7 @@                -> Int                -> ResMap r                -> m (ResStatus r)-checkResource' _ i (ResMap map) = do m <- liftIO $ H.lookup map i+checkResource' _ i (ResMap map) = do m <- liftBase $ H.lookup map i                                      return $ case m of                                                    Just (Right r) -> Loaded r                                                    Just (Left e) -> Error e@@ -59,23 +56,27 @@   getResource :: Resource i r m => i -> ResMap r -> m (Either String r)-getResource i = getResource' i i+getResource i = getResource' (Just i) i -getResource' :: Resource i r m => k -> i -> ResMap r -> m (Either String r)-getResource' k (i :: i) rmap@(ResMap map) =+getResource' :: Resource i r m => Maybe k -> i -> ResMap r -> m (Either String r)+getResource' mk (i :: i) rmap@(ResMap map) =         do status <- checkResource i rmap            case status of                    Unloaded ->                         do r <- loadResource i -                           liftIO $ case r of-                                         Left s -> H.insert map ihash $ Left s-                                         Right r -> H.insert map ihash $ Right r+                           liftBase $+                                   case r of+                                        Left s -> H.insert map ihash $ Left s+                                        Right r -> H.insert map ihash $ Right r -                           embedIO (addFinalizer k) $-                                   removeResource' (Nothing :: Maybe i)-                                                   ihash rmap-                           meRes <- liftIO . H.lookup map $ ihash+                           case mk of+                                Just k -> liftBaseDiscard (addFinalizer k) $+                                        removeResource' (Nothing :: Maybe i)+                                                        ihash rmap+                                Nothing -> return ()++                           meRes <- liftBase . H.lookup map $ ihash                            return $ case meRes of                                          Just eRes -> eRes                                          Nothing -> Left "Resource finalized"@@ -94,10 +95,10 @@            case status of                 Loaded r -> unloadResource mi r                 _ -> return ()-           liftIO $ H.delete map i+           liftBase $ H.delete map i -unloader :: (Resource i r m, EmbedIO m) => k -> Maybe i -> r -> m ()-unloader k i r = embedIO (addFinalizer k) $ unloadResource i r+unloader :: (Resource i r m, MonadBaseControl IO m) => k -> Maybe i -> r -> m ()+unloader k i r = liftBaseDiscard (addFinalizer k) $ unloadResource i r  instance Functor ResStatus where         fmap f (Loaded r) = Loaded (f r)

@@ -1,214 +0,0 @@-module Graphics.Rendering.Ombra.Layer (-        Buffer(..),-        Layer,-        layer,-        over,-        clear,-        -- * Programs-        Compatible,-        Program,-        program,-        -- * Sublayers-        subLayer,-        colorSubLayer,-        depthSubLayer,-        colorDepthSubLayer,-        colorStencilSubLayer,-        colorSubLayer',-        depthSubLayer',-        colorDepthSubLayer',-        colorStencilSubLayer',-        buffersSubLayer,-        buffersDepthSubLayer,-        buffersStencilSubLayer,-        -- * Layers with return values-        -- $extlayers-        Layer',-        LayerStatus(..),-        drawable,-        castLayer,-        -- ** Temporary textures-        TTexture,-        withTTexture,-        permanent,-        -- ** Drawing to textures-        depthToTexture,-        colorDepthToTexture,-        colorStencilToTexture,-        colorToTexture',-        depthToTexture',-        colorDepthToTexture',-        colorStencilToTexture',-        buffersDepthToTexture,-        buffersStencilToTexture-) where--import Data.Word (Word8)-import Graphics.Rendering.Ombra.Backend (GLES)-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Layer.Internal-import Graphics.Rendering.Ombra.Layer.Types-import Graphics.Rendering.Ombra.Object-import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Texture---- | Create a simple Layer from a Program and an Object.-layer :: (Subset progAttr grpAttr, Subset progUni grpUni)-      => Program progUni progAttr -> Object grpUni grpAttr -> Layer' s t ()-layer = Layer--infixl 1 `over`--- | Draw the first Layer over the second one. This means that the first Layer--- will use the same buffers (color, depth, stencil) of the second, but--- the visibility of the objects still depends on their depth.-over :: Layer -> Layer -> Layer-over = flip (>>)---- | Alias for 'colorSubLayer'.-subLayer :: Int -> Int -> Layer -> (Texture -> Layer) -> Layer-subLayer = colorSubLayer---- | Use a 'Layer' as a 'Texture' on another.-colorSubLayer :: Int                    -- ^ Texture width.-              -> Int                    -- ^ Texture height.-              -> Layer                  -- ^ Layer to draw on a 'Texture'.-              -> (Texture -> Layer)     -- ^ Layers using the texture.-              -> Layer-colorSubLayer w h l = colorDepthSubLayer w h l . flip . const---- | Use a 'Layer' as a depth 'Texture' on another.-depthSubLayer :: Int                         -- ^ Texture width.-              -> Int                         -- ^ Texture height.-              -> Layer                       -- ^ Layer to draw on a-                                             -- depth 'Texture'.-              -> (Texture -> Layer)          -- ^ Layers using the texture.-              -> Layer-depthSubLayer w h l f = drawable $-        depthToTexture w h (castLayer l) >>= \(_, t) -> withTTexture t f---- | Combination of 'colorSubLayer' and 'depthSubLayer'.-colorDepthSubLayer :: Int                               -- ^ Texture width.-                   -> Int                               -- ^ Texture height.-                   -> Layer                             -- ^ Layer to draw on the-                                                        -- 'Texture's.-                   -> (Texture -> Texture -> Layer)     -- ^ Color, depth.-                   -> Layer-colorDepthSubLayer w h l f = drawable $-        colorDepthToTexture w h (castLayer l) >>=-                \(_, ct, dt) -> withTTextures [ct, dt] $-                        \[ct', dt'] -> f ct' dt'---- | 'colorSubLayer' with a stencil buffer.-colorStencilSubLayer :: Int                     -- ^ Texture width.-                     -> Int                     -- ^ Texture height.-                     -> Layer                   -- ^ Layer to draw on a 'Texture'-                     -> (Texture -> Layer)      -- ^ Color.-                     -> Layer-colorStencilSubLayer w h l f = drawable $-        colorStencilToTexture w h (castLayer l) >>= \(_, t) -> withTTexture t f---- | Extended version of 'colorSubLayer' that reads and converts the Texture--- pixels.-colorSubLayer'-        :: Int                          -- ^ Texture width.-        -> Int                          -- ^ Texture height.-        -> Int                          -- ^ First pixel to read X-        -> Int                          -- ^ First pixel to read Y-        -> Int                          -- ^ Width of the rectangle to read-        -> Int                          -- ^ Height of the rectangle to read-        -> Layer                        -- ^ Layer to draw on a 'Texture'.-        -> (Texture -> [Color] -> Layer) -- ^ Function using the texture.-        -> Layer-colorSubLayer' w h rx ry rw rh l f = drawable $-        colorToTexture' w h rx ry rw rh (castLayer l) >>=-                \(_, t, c) -> withTTexture t $ flip f c---- | Extended version of 'depthSubLayer'. Not supported on WebGL.-depthSubLayer'-        :: Int                          -- ^ Texture width.-        -> Int                          -- ^ Texture height.-        -> Int                          -- ^ First pixel to read X-        -> Int                          -- ^ First pixel to read Y-        -> Int                          -- ^ Width of the rectangle to read-        -> Int                          -- ^ Height of the rectangle to read-        -> Layer                        -- ^ Layer to draw on a depth 'Texture'.-        -> (Texture -> [Word8] -> Layer) -- ^ Layers using the texture.-        -> Layer-depthSubLayer' w h rx ry rw rh l f = drawable $-        depthToTexture' w h rx ry rw rh (castLayer l) >>=-                \(_, t, d) -> withTTexture t $ flip f d---- | Extended version of 'colorDepthSubLayer'. Not supported on WebGL.-colorDepthSubLayer'-        :: Int         -- ^ Texture width.-        -> Int         -- ^ Texture height.-        -> Int         -- ^ First pixel to read X-        -> Int         -- ^ First pixel to read Y-        -> Int         -- ^ Width of the rectangle to read-        -> Int         -- ^ Height of the rectangle to read-        -> Layer       -- ^ Layer to draw on a 'Texture'-        -> (Texture -> Texture -> [Color] -> [Word8] -> Layer) -- ^ Layers using-                                                               -- the texture.-        -> Layer-colorDepthSubLayer' w h rx ry rw rh l f = drawable $-        colorDepthToTexture' w h rx ry rw rh (castLayer l) >>=-                \(_, ct, dt, c, d) -> withTTextures [ct, dt] $-                        \[ct', dt'] -> f ct' dt' c d---- | 'colorSubLayer'' with an additional stencil buffer.-colorStencilSubLayer'-        :: Int                          -- ^ Texture width.-        -> Int                          -- ^ Texture height.-        -> Int                          -- ^ First pixel to read X-        -> Int                          -- ^ First pixel to read Y-        -> Int                          -- ^ Width of the rectangle to read-        -> Int                          -- ^ Height of the rectangle to read-        -> Layer                        -- ^ Layer to draw on a 'Texture'.-        -> (Texture -> [Color] -> Layer) -- ^ Function using the texture.-        -> Layer-colorStencilSubLayer' w h rx ry rw rh l f = drawable $-        colorStencilToTexture' w h rx ry rw rh (castLayer l) >>=-                \(_, t, c) -> withTTexture t $ flip f c---- | Draw a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's and use them to--- create another Layer.-buffersSubLayer :: Int                          -- ^ Textures width.-                -> Int                          -- ^ Textures height.-                -> Int                          -- ^ Number of colors.-                -> Layer                        -- ^ Layer to draw.-                -> ([Texture] -> Layer)         -- ^ Function using the textures.-                -> Layer-buffersSubLayer w h n l = buffersDepthSubLayer w h n l . flip . const---- | Combination of 'buffersSubLayer' and 'depthSubLayer'.-buffersDepthSubLayer :: Int                             -- ^ Textures width.-                   -> Int                               -- ^ Textures height.-                   -> Int                               -- ^ Number of colors.-                   -> Layer                             -- ^ Layer to draw.-                   -> ([Texture] -> Texture -> Layer)   -- ^ Function using the-                                                        -- buffers textures and-                                                        -- the depth texture.-                   -> Layer-buffersDepthSubLayer w h n l f = drawable $-        buffersDepthToTexture w h n (castLayer l) >>=-                \(_, bts, dt) -> withTTextures (dt : bts) $-                        \(dt' : bts') -> f bts' dt'---- | 'buffersSubLayer' with an additional stencil buffer.-buffersStencilSubLayer :: Int                   -- ^ Textures width.-                       -> Int                   -- ^ Textures height.-                       -> Int                   -- ^ Number of colors.-                       -> Layer                 -- ^ Layer to draw.-                       -> ([Texture] -> Layer)  -- ^ Function using the texture.-                       -> Layer-buffersStencilSubLayer w h n l f = drawable $-        buffersStencilToTexture w h n (castLayer l) >>=-                \(_, bts) -> withTTextures bts f---- $extlayers--- Functions like 'subLayer' create temporary textures that usually have to be--- freed immediately after drawing the layer, otherwise they may waste a lot of--- GPU memory if @subLayer@ is called in every frame. The 'Layer'' type lets--- you extract those textures after having made permanent.

@@ -1,333 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes, DataKinds, KindSignatures #-}--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-import Graphics.Rendering.Ombra.Texture.Types---- TODO: document buffers.--- | Layer that clear some buffers. For instance, @clear ['ColorBuffer']@ fills--- the screen with a black rectangle, without affecting the depth buffer.-clear :: [Buffer] -> Layer' s t ()-clear = Clear---- | Free the temporary resources associated with a NonDrawable layer, before--- drawing it.-drawable :: (forall t. Layer' NonDrawable t a) -> Layer' s t a-drawable = Free--castDrawable :: Layer' Drawable t a -> Layer' Drawable t' a-castDrawable = Cast---- | Make the type of a simple 'Layer' more generic.-castLayer :: Layer -> Layer' Drawable t ()-castLayer = castDrawable---- | Make a 'TTexture' permanent. Its lifetime is still bound to the 'Texture'--- returned.-permanent :: TTexture t -> Layer' NonDrawable t Texture-permanent = Permanent---- | Draw a Layer using a temporary texture.-withTTexture :: TTexture t -> (Texture -> Layer) -> Layer' NonDrawable t ()-withTTexture pt f = WithTTextures [pt] $ \[t] -> f t---- | Draw a Layer using a list of temporary textures.-withTTextures :: [TTexture t] -> ([Texture] -> Layer) -> Layer' NonDrawable t ()-withTTextures = WithTTextures--castTTexture :: TTexture t -> TTexture t'-castTTexture (TTexture lt) = TTexture lt---- | Draw a 'Layer' to a depth 'Texture'.-depthToTexture :: Int           -- ^ Textures width.-               -> Int           -- ^ Textures height.-               -> Layer' s t a  -- ^ Layer to draw.-               -> Layer' NonDrawable t (a, TTexture t)-depthToTexture w h l =-        fmap (\(x, [t], _, _) -> (x, t)) $-                TextureLayer False [DepthLayer] (w, h) (0, 0, 0, 0)-                             False False l---- | Draw a 'Layer' to a color 'Texture' and a depth 'Texture'.-colorDepthToTexture :: Int              -- ^ Textures width.-                    -> Int              -- ^ Textures height.-                    -> Layer' s t a     -- ^ Layer to draw.-                    -> Layer' NonDrawable t (a, TTexture t, TTexture t)-colorDepthToTexture w h l =-        fmap (\(x, [ct, dt], _, _) -> (x, ct, dt)) $-                TextureLayer False [ColorLayer, DepthLayer] (w, h) (0, 0, 0, 0)-                             False False l---- | Draw a 'Layer' to a color 'Texture' with an additional stencil buffer.-colorStencilToTexture :: Int -- ^ Texture width.-                      -> Int -- ^ Texture height.-                      -> Layer' s t a-                      -> Layer' NonDrawable t (a, TTexture t)-colorStencilToTexture w h l =-        fmap (\(x, [ct, _], _, _) -> (x, ct)) $-                TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)-                             (0, 0, 0, 0) False False l---- | Draw a 'Layer' to a 'Texture', reading the content of the texture.-colorToTexture' :: Int          -- ^ Texture width.-                -> Int          -- ^ Texture height.-                -> Int          -- ^ First pixel to read X.-                -> Int          -- ^ First pixel to read Y.-                -> Int          -- ^ Width of the rectangle to read.-                -> Int          -- ^ Height of the rectangle to read.-                -> Layer' s t a -- ^ Layer to draw.-                -> Layer' NonDrawable t (a, TTexture t, [Color])-colorToTexture' w h rx ry rw rh l =-        fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $-                TextureLayer False [ColorLayer, DepthLayer] (w, h)-                             (rx, ry, rw, rh) True False l---- | Draw a 'Layer' to a depth 'Texture', reading the content of the texture.--- Not supported on WebGL.-depthToTexture' :: Int          -- ^ Texture width.-                -> Int          -- ^ Texture height.-                -> Int          -- ^ First pixel to read X.-                -> Int          -- ^ First pixel to read Y.-                -> Int          -- ^ Width of the rectangle to read.-                -> Int          -- ^ Height of the rectangle to read.-                -> Layer' s t a -- ^ Layer to draw.-                -> Layer' NonDrawable t (a, TTexture t, [Word8])-depthToTexture' w h rx ry rw rh l =-        fmap (\(x, [t], _, Just d) -> (x, t, d)) $-                TextureLayer False [DepthLayer] (w, h) (rx, ry, rw, rh)-                             False True l---- | Combination of 'colorToTexture'' and 'depthToTexture''. Not supported--- on WebGL.-colorDepthToTexture' :: Int             -- ^ Texture width.-                     -> Int             -- ^ Texture height.-                     -> Int             -- ^ First pixel to read X.-                     -> Int             -- ^ First pixel to read Y.-                     -> Int             -- ^ Width of the rectangle to read.-                     -> Int             -- ^ Height of the rectangle to read.-                     -> Layer' s t a    -- ^ Layer to draw.-                     -> Layer' NonDrawable t-                               (a, TTexture t, TTexture t, [Color], [Word8])-colorDepthToTexture' w h rx ry rw rh l =-        fmap (\(x, [ct, dt], Just c, Just d) -> (x, ct, dt, c, d)) $-                TextureLayer False [ColorLayer, DepthLayer] (w, h)-                             (rx, ry, rw, rh) True True l---- | 'colorToTexture'' with an additional stencil buffer.-colorStencilToTexture' :: Int           -- ^ Texture width.-                       -> Int           -- ^ Texture height.-                       -> Int           -- ^ First pixel to read X.-                       -> Int           -- ^ First pixel to read Y.-                       -> Int           -- ^ Width of the rectangle to read.-                       -> Int           -- ^ Height of the rectangle to read.-                       -> Layer' s t a  -- ^ Layer to draw.-                       -> Layer' NonDrawable t (a, TTexture t, [Color])-colorStencilToTexture' w h rx ry rw rh l =-        fmap (\(x, [t, _], Just c, _) -> (x, t, c)) $-                TextureLayer False [ColorLayer, DepthStencilLayer] (w, h)-                             (rx, ry, rw, rh) True False l---- | Draw a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's and to a depth--- Texture.-buffersDepthToTexture :: Int            -- ^ Texture width.-                      -> Int            -- ^ Texture height.-                      -> Int            -- ^ Number of colors.-                      -> Layer' s t a   -- ^ Layer to draw.-                      -> Layer' NonDrawable t (a, [TTexture t], TTexture t)-buffersDepthToTexture w h n l =-        fmap (\(x, dt : ts, _, _) -> (x, ts, dt)) $-                TextureLayer True (DepthLayer : map BufferLayer [0 .. n - 1])-                             (w, h) (0, 0, 0, 0) False False l---- | Draw a 'Layer' with multiple floating point colors--- (use 'Fragment2', 'Fragment3', etc.) to some 'Texture's with an additional--- stencil buffer.-buffersStencilToTexture :: Int          -- ^ Texture width.-                        -> Int          -- ^ Texture height.-                        -> Int          -- ^ Number of colors.-                        -> Layer' s t a -- ^ Layer to draw.-                        -> Layer' NonDrawable t (a, [TTexture t])-buffersStencilToTexture w h n l =-        fmap (\(x, _ : ts, _, _) -> (x, ts)) $-                TextureLayer True-                             (DepthStencilLayer : map BufferLayer [0 .. n - 1])-                             (w, h) (0, 0, 0, 0) False False l--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)

@@ -1,70 +0,0 @@-{-# 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-

@@ -1,221 +0,0 @@-{-# LANGUAGE TypeOperators, DataKinds, ConstraintKinds, MultiParamTypeClasses,-             TypeFamilies, FlexibleContexts, FlexibleInstances #-}--module Graphics.Rendering.Ombra.Object (-        -- * Creating and modifying objects-        Object((:~>)),-        nothing,-        -- merge,-        geom,-        modifyGeometry,--        -- * Object properties-        depthTest,-        depthMask,-        colorMask,-        ShaderVars,-        VOShaderVars,-        -- ** Blending-        blend,-        noBlend,-        Blend.transparency,-        Blend.additive,-        -- ** Stencil test-        stencil,-        noStencil,-        -- ** Culling-        CullFace(..),-        cull,-        noCull,--        -- * Globals-        Global,-        (-=),-        withTexture,-        withTexSize,-        withFramebufferSize,-        ActiveTexture,-        -- ** Mirror globals-        mirror,-        CPUMirror,-        -- ** Modifying globals-        MemberGlobal((~~>)),-        RemoveGlobal((*~>)),-) where--import Data.Typeable-import Data.Type.Equality-import Data.Word (Word8)-import Graphics.Rendering.Ombra.Backend (GLES)-import qualified Graphics.Rendering.Ombra.Blend as Blend-import qualified Graphics.Rendering.Ombra.Stencil as Stencil-import Graphics.Rendering.Ombra.Geometry-import Graphics.Rendering.Ombra.Color-import Graphics.Rendering.Ombra.Object.Types-import Graphics.Rendering.Ombra.Internal.GL (ActiveTexture)-import Graphics.Rendering.Ombra.Internal.TList-import Graphics.Rendering.Ombra.Shader.CPU hiding (mirror)-import Graphics.Rendering.Ombra.Shader.Program-import Graphics.Rendering.Ombra.Shader.ShaderVar-import Graphics.Rendering.Ombra.Shader.Stages-import Graphics.Rendering.Ombra.Texture---- | Enable blending and set the blending mode for an 'Object'.-blend :: Blend.Mode -> Object gs is -> Object gs is-blend m = Prop . Blend $ Just m---- | Disable blending for a 'Object'.-noBlend :: Object gs is -> Object gs is-noBlend = Prop $ Blend Nothing---- | Enable stencil testing and set the stencil mode for an 'Object'.-stencil :: Stencil.Mode -> Object gs is -> Object gs is-stencil m = Prop . Stencil $ Just m---- | Disable stencil testing on a 'Object' of objects.-noStencil :: Object gs is -> Object gs is-noStencil = Prop $ Stencil Nothing---- | Enable/disable depth testing for a 'Object'.-depthTest :: Bool -> Object gs is -> Object gs is-depthTest d = Prop $ DepthTest d---- | Enable/disable writing into the depth buffer for a 'Object'.-depthMask :: Bool -> Object gs is -> Object gs is-depthMask m = Prop $ DepthMask m---- | Enable/disable writing into the four channels of the color buffer for a--- 'Object'.-colorMask :: (Bool, Bool, Bool, Bool) -> Object gs is -> Object gs is-colorMask m = Prop $ ColorMask m---- | Enable face culling.-cull :: CullFace -> Object gs is -> Object gs is-cull m = Prop . Cull $ Just m---- | Disable face culling.-noCull :: Object gs is -> Object gs is-noCull = Prop $ Cull Nothing---- | An empty object.-nothing :: Object '[] '[]-nothing = NoMesh---- | An object with a specified 'Geometry'.-geom :: Geometry (i ': is) -> Object '[] (i ': is)-geom = Mesh---- TODO: Either (CPU 'S g) (CPU 'M g) ???-class MemberGlobal g gs where-        -- | Modify the global of an 'Object'. This doesn't work with mirror-        -- globals.-        (~~>) :: (Uniform 'S g)-              => (CPU 'S g -> Global g)  -- ^ Changing function-              -> Object gs is-              -> Object gs is--instance {-# OVERLAPPING #-} MemberGlobal g (g ': gs) where-        f ~~> (g :~> o) = globalApply f g :~> o-        f ~~> (Prop p o) = Prop p $ f ~~> o-        f ~~> (Append o o') = Append (f ~~> o) (f ~~> o')-        f ~~> NoMesh = NoMesh--instance {-# OVERLAPPABLE #-} ((g == g1) ~ False, MemberGlobal g gs) =>-         MemberGlobal g (g1 ': gs) where-        f ~~> (g :~> o) = g :~> (f ~~> o)-        f ~~> (Prop p o) = Prop p $ f ~~> o-        f ~~> (Append o o') = Append (f ~~> o) (f ~~> o')-        f ~~> NoMesh = NoMesh-        -globalApply :: (Uniform 'S g)-            => (CPU 'S g -> Global g)-            -> Global g-            -> Global g-globalApply f (Single g c) = f c-globalApply f (WithTexture t g) = WithTexture t $ globalApply f . g-globalApply f (WithTextureSize t g) = WithTextureSize t $ globalApply f . g-globalApply f (WithFramebufferSize g) = WithFramebufferSize $ globalApply f . g-globalApply f g = g--infixr 2 ~~>--class RemoveGlobal g gs' where-        -- | Remove a global from an 'Object'.-        (*~>) :: (a -> g) -> Object gs' is -> Object (Remove g gs') is--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 #-} ( 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')-        r *~> NoMesh = NoMesh--infixr 2 *~>---- | Modify the geometry of an 'Object'.-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-modifyGeometry fg (Append o o') = Append (modifyGeometry fg o)-                                         (modifyGeometry fg o')-modifyGeometry fg NoMesh = NoMesh---- | Create a 'Global' from a pure value. The first argument is ignored,--- it just provides the type (you can use the constructor of the GPU type).--- You can use this to set the value of a shader uniform.-(-=) :: (ShaderVar g, Uniform 'S g) => (a -> g) -> CPU 'S g -> Global g-(-=) = Single--infixr 4 -=---- | Create a 'Global' activating a 'Texture'. Note that the corresponding CPU--- type of 'Sampler2D' is 'ActiveTexture', not Texture.-withTexture :: Texture -> (ActiveTexture -> Global g) -> Global g-withTexture = WithTexture---- | Create a 'Global' using the size of a 'Texture'.-withTexSize :: Texture -> ((Int, Int) -> Global g) -> Global g-withTexSize = WithTextureSize---- | Create a 'Global' using the size of the framebuffer.-withFramebufferSize :: ((Int, Int) -> Global g) -> Global g-withFramebufferSize = WithFramebufferSize---- TODO: remove Proxy?--- | Like '-=' but for mirror types.-mirror :: (ShaderVar g, Uniform 'M g) => Proxy g -> CPU 'M g -> Global g-mirror = Mirror--{--type EqualMerge x y v = EqualOrErr x y (Text "Can't merge groups with " :<>:-                                        Text "different " :<>: v :<>:-                                        Text "." :$$:-                                        Text "    Left group " :<>: v :<>:-                                        Text ": " :<>: ShowType x :$$:-                                        Text "    Right group " :<>: v :<>:-                                        Text ": " :<>: ShowType y)----- | Merge two objects. This is more generic than 'mappend'.-merge :: (EqualMerge gs gs' (Text "globals"), EqualMerge is is' (Text "inputs"))-      => Object gs is -> Object gs' is'-      -> Object (Union gs gs') (Union is is')-merge = Append--}--{---- | Merge two objects, even if they don't provide the same variables.-unsafeMerge :: Object gs is -> Object gs' is'-            -> Object (Union gs gs') (Union is is')-unsafeMerge = Append--}

@@ -1,67 +0,0 @@-{-# LANGUAGE GADTs, DataKinds, PolyKinds, ConstraintKinds #-}--module Graphics.Rendering.Ombra.Object.Internal (-        MonadObject,-        MonadDrawingMode(..),-        drawObject-) where--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.Program-import Graphics.Rendering.Ombra.Shader.ShaderVar (varBuild)-import Graphics.Rendering.Ombra.Stencil as Stencil-import Graphics.Rendering.Ombra.Texture.Internal--type MonadObject m = ( MonadProgram m-                     , MonadTexture m-                     , MonadScreen m-                     , MonadGeometry m-                     , MonadDrawingMode m-                     )--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--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--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'

@@ -1,53 +0,0 @@-{-# 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,52 @@+{-# LANGUAGE DataKinds #-}++module Graphics.Rendering.Ombra.OutBuffer (+        GBuffer,+        DepthBuffer,+        GBufferInfo,+        DepthBufferInfo,+        GBufferSampler,+        DepthBufferSampler,+        sampleGBuffer,+        sampleDepthBuffer,+        floatGBuffer,+        byteGBuffer,+        depthBuffer,+        depthStencilBuffer,+        -- * Conversion between buffers and textures+        toTextureSampler,+        fromTextureSampler+) where++import Graphics.Rendering.Ombra.OutBuffer.Types+import Graphics.Rendering.Ombra.Shader+import Graphics.Rendering.Ombra.Shader.Types+import Graphics.Rendering.Ombra.Texture.Types++-- | Sample a value from a 'GBufferSampler'.+sampleGBuffer :: GBufferSampler t o -> GVec2 -> o+sampleGBuffer (GBufferSampler samplers) st =+        fromGVec4s $ map (flip sample st) samplers++-- | Sample a value from a 'DepthBufferSampler'.+sampleDepthBuffer :: DepthBufferSampler t -> GVec2 -> GFloat+sampleDepthBuffer (DepthBufferSampler sampler) st =+        let GVec4 x _ _ _ = sample sampler st in x++fromTextureSampler :: TextureSampler -> GBufferSampler t GVec4+fromTextureSampler sampler = GBufferSampler [sampler]++toTextureSampler :: GBufferSampler t GVec4 -> TextureSampler+toTextureSampler (GBufferSampler (sampler : _)) = sampler++floatGBuffer :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o+floatGBuffer = EmptyFloatGBuffer++byteGBuffer :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o+byteGBuffer = EmptyByteGBuffer++depthBuffer :: TextureParameters -> DepthBufferInfo+depthBuffer = EmptyDepthBuffer++depthStencilBuffer :: TextureParameters -> DepthBufferInfo+depthStencilBuffer = EmptyDepthStencilBuffer

@@ -0,0 +1,100 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeFamilies,+             ScopedTypeVariables #-}++module Graphics.Rendering.Ombra.OutBuffer.Types where++import Data.Proxy+import Graphics.Rendering.Ombra.Shader.Types+import Graphics.Rendering.Ombra.Shader.Language.Types+import Graphics.Rendering.Ombra.Texture.Types++-- | A GPU object that can be used to retrieve data from a 'GBuffer'.+data GBufferSampler t o = FragmentShaderOutput o => GBufferSampler [GSampler2D]++-- | A GPU object that can be used to retrieve data from a 'DepthBuffer'.+newtype DepthBufferSampler t = DepthBufferSampler GSampler2D++data OutDepthBuffer++data OutBufferInfo o where+        EmptyFloatGBuffer               :: FragmentShaderOutput o+                                        => TextureParameters+                                        -> OutBufferInfo o++        EmptyByteGBuffer                :: FragmentShaderOutput o+                                        => TextureParameters+                                        -> OutBufferInfo o++        EmptyDepthBuffer                :: TextureParameters+                                        -> OutBufferInfo OutDepthBuffer++        EmptyDepthStencilBuffer         :: TextureParameters+                                        -> OutBufferInfo OutDepthBuffer++data OutBuffer t o where+        TextureFloatGBuffer             :: FragmentShaderOutput o+                                        => [LoadedTexture]+                                        -> OutBuffer t o++        TextureByteGBuffer              :: FragmentShaderOutput o+                                        => [LoadedTexture]+                                        -> OutBuffer t o++        TextureDepthBuffer              :: LoadedTexture+                                        -> OutBuffer t OutDepthBuffer++        TextureDepthStencilBuffer       :: LoadedTexture+                                        -> OutBuffer t OutDepthBuffer++instance FragmentShaderOutput o => MultiShaderType (GBufferSampler t o) where+        type ExprMST (GBufferSampler t o) = [ExprMST GSampler2D]+        mapMST f (GBufferSampler x) = GBufferSampler $ map f x+        foldrMST f s (GBufferSampler x) = foldr f s x+        toExprMST (GBufferSampler x) = map toExprMST x+        fromExprMST = GBufferSampler . map fromExprMST++instance FragmentShaderOutput o => ShaderInput (GBufferSampler t o) where+        buildMST f i = (GBufferSampler $ take n infiniteSamplers, i + n)+                where n = textureCount (Proxy :: Proxy o)+                      infiniteSamplers = map f [i ..]++instance FragmentShaderOutput o => Uniform (GBufferSampler t o) where+        type CPUUniform (GBufferSampler t o) = GBuffer t o+        foldrUniform _ f s buf =+                foldr (\u s -> f (UniformTexture $ TextureLoaded u) s)+                      s (textures buf)++instance MultiShaderType (DepthBufferSampler t) where+        type ExprMST (DepthBufferSampler t) = ExprMST GSampler2D+        mapMST f (DepthBufferSampler x) = DepthBufferSampler $ f x+        foldrMST f s (DepthBufferSampler x) = foldrMST f s x+        toExprMST (DepthBufferSampler x) = toExprMST x+        fromExprMST = DepthBufferSampler . fromExprMST++instance ShaderInput (DepthBufferSampler t) where+        buildMST f i = (DepthBufferSampler $ f i, i + 1)++instance Uniform (DepthBufferSampler t) where+        type CPUUniform (DepthBufferSampler t) = DepthBuffer t+        foldrUniform _ f s buf =+                f (UniformTexture . TextureLoaded . head . textures $ buf) s++-- | A container that can be used to store the output of some drawing operation.+type GBuffer = OutBuffer+-- | A container for depth/stencil values.+type DepthBuffer t = OutBuffer t OutDepthBuffer++type GBufferInfo = OutBufferInfo+type DepthBufferInfo = OutBufferInfo OutDepthBuffer++textures :: OutBuffer t o -> [LoadedTexture]+textures (TextureFloatGBuffer ts) = ts+textures (TextureByteGBuffer ts) = ts+textures (TextureDepthBuffer t) = [t]+textures (TextureDepthStencilBuffer t) = [t]++castBuffer :: OutBuffer t o -> OutBuffer t' o+castBuffer (TextureFloatGBuffer ts) = TextureFloatGBuffer ts+castBuffer (TextureByteGBuffer ts) = TextureByteGBuffer ts+castBuffer (TextureDepthBuffer t) = TextureDepthBuffer t+castBuffer (TextureDepthStencilBuffer t) = TextureDepthStencilBuffer t

@@ -5,8 +5,9 @@  import Graphics.Rendering.Ombra.Internal.GL -class GLES => MonadScreen m where+class (GLES, Monad m) => MonadScreen m where         currentViewport :: m (Int, Int)+        -- | Resize the drawing space.         resizeViewport :: Int -> Int -> m ()  setViewport :: (GLES, MonadGL m) => Int -> Int -> m ()

@@ -1,464 +1,233 @@-{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, MultiParamTypeClasses,-             TypeFamilyDependencies, TypeFamilies, FlexibleInstances,-             UndecidableInstances, DeriveGeneric #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, DataKinds, KindSignatures,+             TypeFamilies, FlexibleContexts, UndecidableInstances,+             FlexibleInstances, DefaultSignatures, TypeOperators #-}  {-|-An example of shader variable:--@-        data Transform2 = Transform2 GMat3 deriving Generic-@--An example of vertex shader:--@-        vertexShader :: VertexShader-        -- The types of the uniforms:-                                '[Transform2, View2, Depth]-        -- The types of the attributes:-                                '[Position2, UV]-        -- The types of the varying (outputs), excluding 'VertexShaderOutput'.-                                '[UV]-        vertexShader -        -- Set of uniforms:-                     (Transform2 trans :- View2 view :- Depth z :- N)-        -- Set of attributes:-                     (Position2 (GVec2 x y) :- uv@(UV _) :- N) =-        -- Matrix and vector multiplication:-                        let GVec3 x' y' _ = view .*. trans .* GVec3 x y 1-        -- Set of outputs:-                        in Vertex (GVec4 x' y' z 1) -- Vertex position.-                           :- uv :- N-@-+Module:      Graphics.Rendering.Ombra.Shader+License:     BSD3+Maintainer:  ziocroc@gmail.com+Stability:   experimental+Portability: GHC only -}  module Graphics.Rendering.Ombra.Shader (-        module Data.Boolean,-        module Data.VectorSpace,-        module Data.Cross,-        -- * Types-        Shader.Shader,-        Shader.VertexShader,-        Shader.FragmentShader,-        Shader.VertexShaderOutput(..),-        Shader.FragmentShaderOutput(..),-        Shader.ShaderVars,-        Shader.VOShaderVars,-        Shader.Uniform,-        Shader.Attribute,-        Shader.Generic,-        Shader.SVList(..),-        -- ** GPU types-        Shader.GBool,-        Shader.GFloat,-        Shader.GInt,-        Shader.GSampler2D,-        Shader.GSamplerCube,-        Shader.GVec2(..),-        Shader.GVec3(..),-        Shader.GVec4(..),-        Shader.GBVec2(..),-        Shader.GBVec3(..),-        Shader.GBVec4(..),-        Shader.GIVec2(..),-        Shader.GIVec3(..),-        Shader.GIVec4(..),-        Shader.GMat2(..),-        Shader.GMat3(..),-        Shader.GMat4(..),-        Shader.GArray,-        -- * GPU functions-        (Shader.!),-        Shader.loop,-        Shader.store,-        Shader.texture2D,-        Shader.texture2DBias,-        Shader.texture2DProj,-        Shader.texture2DProjBias,-        Shader.texture2DProj4,-        Shader.texture2DProjBias4,-        Shader.texture2DLod,-        Shader.texture2DProjLod,-        Shader.texture2DProjLod4,-        Shader.arrayLength,-        -- ** Various math functions-        Matrix(..),-        Ext(..),-        minG,-        maxG,-        modG,-        floorG,-        ceilingG,-        Shader.radians,-        Shader.degrees,-        Shader.exp2,-        Shader.log2,-        Shader.inversesqrt,-        Shader.fract,-        Shader.clamp,-        Shader.mix,-        Shader.step,-        Shader.smoothstep,-        Shader.distance, -- TODO: implement AffineSpace?-        -- Shader.length,-        Shader.faceforward,-        Shader.reflect,-        Shader.refract,-        Shader.matrixCompMult,-        Shader.dFdx,-        Shader.dFdy,-        Shader.fwidth,-        -- *** Vector relational functions-        Shader.VecOrd,-        Shader.VecEq,-        Shader.lessThan,-        Shader.lessThanEqual,-        Shader.greaterThan,-        Shader.greaterThanEqual,-        Shader.equal,-        Shader.notEqual,-        Shader.GBoolVector,-        Shader.anyBV,-        Shader.allBV,-        Shader.notBV,-        -- ** Constructors-        Shader.ToGBool,-        Shader.bool,-        Shader.ToGInt,-        Shader.int,-        Shader.ToGFloat,-        Shader.float,-        -- TODO: better vector constructors-        {--        Shader.Components,-        Shader.CompList,-        Shader.ToCompList,-        (Shader.#),-        Shader.ToGVec2,-        Shader.vec2,-        Shader.ToGVec3,-        Shader.vec3,-        Shader.ToGVec4,-        Shader.vec4,-        Shader.ToGBVec2,-        Shader.bvec2,-        Shader.ToGBVec3,-        Shader.bvec3,-        Shader.ToGBVec4,-        Shader.bvec4,-        Shader.ToGIVec2,-        Shader.ivec2,-        Shader.ToGIVec3,-        Shader.ivec3,-        Shader.ToGIVec4,-        Shader.ivec4,-        Shader.ToGMat2,-        Shader.mat2,-        Shader.ToGMat3,-        Shader.mat3,-        Shader.ToGMat4,-        Shader.mat4,-        -}-        -- ** Other-        Shader.position,-        Shader.fragData,-        Shader.fragCoord,-        Shader.fragFrontFacing,-        -- * Common shader variables-        UV(..)+        module Graphics.Rendering.Ombra.Shader.Language,+        ShaderStage(..),+        Shader,+        VertexShader,+        FragmentShader,+        -- * Uniforms+        uniform,+        (~~),+        foldUniforms,+        -- * Optimized shaders+        UniformSetter,+        shader,+        sarr,+        shaderParam,+        pshader,+        ushader,+        pushader,+        uniform',+        (~*),+        -- * Fragment shader functionalities+        Fragment(..),+        farr,+        fragment,+        -- * Loops+        forLoop,+        foldGArray,+        -- * Classes+        MultiShaderType(..),+        ShaderInput(..),+        FragmentShaderOutput(..),+        MapShader(..),+        Uniform(..) ) where +import Control.Arrow+import Control.Applicative+import Control.Category+import Data.Hashable+import Data.MemoTrie import Data.Proxy-import GHC.Generics (Generic)+import GHC.Generics+import GHC.TypeLits+import Graphics.Rendering.Ombra.Backend (GLES)+import Graphics.Rendering.Ombra.Internal.GL (Sampler2D)+import Graphics.Rendering.Ombra.Shader.Language+import qualified Graphics.Rendering.Ombra.Shader.Language.Functions as Shader+import Graphics.Rendering.Ombra.Shader.Language.Types import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.Language ((#))-import qualified Graphics.Rendering.Ombra.Shader.Language as Shader-import Graphics.Rendering.Ombra.Shader.ShaderVar hiding (Shader)-import Graphics.Rendering.Ombra.Shader.Stages-import Graphics.Rendering.Ombra.Vector--import Data.Boolean-import qualified Data.Boolean.Numbers as B-import Data.Cross-import Data.VectorSpace-import Prelude--data UV = UV Shader.GVec2 deriving Generic--type instance BooleanOf Shader.GBool = Shader.GBool-type instance BooleanOf Shader.GFloat = Shader.GBool-type instance BooleanOf Shader.GInt = Shader.GBool-type instance BooleanOf Shader.GSampler2D = Shader.GBool-type instance BooleanOf Shader.GSamplerCube = Shader.GBool-type instance BooleanOf Shader.GVec2 = Shader.GBool-type instance BooleanOf Shader.GVec3 = Shader.GBool-type instance BooleanOf Shader.GVec4 = Shader.GBool-type instance BooleanOf Shader.GBVec2 = Shader.GBool-type instance BooleanOf Shader.GBVec3 = Shader.GBool-type instance BooleanOf Shader.GBVec4 = Shader.GBool-type instance BooleanOf Shader.GIVec2 = Shader.GBool-type instance BooleanOf Shader.GIVec3 = Shader.GBool-type instance BooleanOf Shader.GIVec4 = Shader.GBool-type instance BooleanOf Shader.GMat2 = Shader.GBool-type instance BooleanOf Shader.GMat3 = Shader.GBool-type instance BooleanOf Shader.GMat4 = Shader.GBool-type instance BooleanOf (Shader.GArray n t) = Shader.GBool--instance Boolean Shader.GBool where-        true = Shader.true-        false = Shader.false-        (&&*) = (Shader.&&)-        (||*) = (Shader.||)-        notB = Shader.not--instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => IfB a where-        ifB = Shader.ifThenElse--instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => EqB a where-        (==*) = (Shader.==)-        (/=*) = (Shader./=)--instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => OrdB a where-        (<*) = (Shader.<)-        (<=*) = (Shader.<=)-        (>*) = (Shader.>)-        (>=*) = (Shader.>=)-        --- | Faster GPU 'max'/'B.maxB'.-maxG :: Shader.GenTypeGFloat a b => a -> b -> a-maxG = Shader.max---- | Faster GPU 'min'/'B.minB'.-minG :: Shader.GenTypeGFloat a b => a -> b -> a-minG = Shader.min--instance Num Shader.GFloat where-        (+) = (Shader.+)-        (-) = (Shader.-)-        (*) = (Shader.*)-        abs = Shader.abs-        signum = Shader.sign-        fromInteger = Shader.fromInteger-        negate = Shader.negate--instance Num Shader.GInt where-        (+) = (Shader.+)-        (-) = (Shader.-)-        (*) = (Shader.*)-        abs = Shader.absI-        signum = Shader.signI-        fromInteger = Shader.fromInteger-        negate = Shader.negateI--instance B.NumB Shader.GFloat where-        type IntegerOf Shader.GFloat = Shader.GInt-        fromIntegerB = Shader.float--instance B.NumB Shader.GInt where-        type IntegerOf Shader.GInt = Shader.GInt-        fromIntegerB = id--instance AdditiveGroup Shader.GFloat where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negate---- | GPU 'mod' that can be used on floats and float vectors.-modG :: Shader.GenType a => a -> a -> a-modG = Shader.mod--instance B.IntegralB Shader.GInt where-        quotRem a b = let q = a Shader./ b in (q, a - b * q)-        -- XXX: ???-        divMod a b = let (q, r) = B.quotRem a b-                         f = 1 - abs (signum r + signum b)-                     in (q - f, r + b * f)-        toIntegerB = id--instance Fractional Shader.GFloat where-        (/) = (Shader./)-        fromRational = Shader.fromRational--instance Floating Shader.GFloat where-        pi = 3.1415926535897932384626433832795-        exp = Shader.exp-        log = Shader.log-        sqrt = Shader.sqrt-        (**) = (Shader.^)-        sin = Shader.sin-        cos = Shader.cos-        tan = Shader.tan-        asin = Shader.asin-        acos = Shader.acos-        atan = Shader.atan-        -- TODO-        sinh = error "Hyperbolic functions are not implemented."-        cosh = error "Hyperbolic functions are not implemented."-        asinh = error "Hyperbolic functions are not implemented."-        acosh = error "Hyperbolic functions are not implemented."-        atanh = error "Hyperbolic functions are not implemented."--floatToInt :: (B.NumB b, B.IntegerOf b ~ Shader.GInt) => Shader.GFloat -> b-floatToInt = B.fromIntegerB . Shader.int--instance B.RealFracB Shader.GFloat where-        properFraction x = let tx = signum x * floorG (abs x)-                           in (floatToInt tx, x - tx)-        -- truncate x = floatToInt $ signum x * floorG (abs x)-        round x = floatToInt . floorG $ x + 0.5-        ceiling = floatToInt . ceilingG-        floor = floatToInt . floorG--floorG :: Shader.GenType a => a -> a-floorG = Shader.floor--ceilingG :: Shader.GenType a => a -> a-ceilingG = Shader.ceil--instance B.RealFloatB Shader.GFloat where-        isNaN = error "isNaN: not supported"-        isInfinite = error "isInfinite: not supported"-        isNegativeZero = error "isNegativeZero: not supported"-        isIEEE = error "isIEEE: not supported"-        atan2 = Shader.atan2---- Vectors--instance AdditiveGroup Shader.GVec2 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negate--instance VectorSpace Shader.GVec2 where-        type Scalar Shader.GVec2 = Shader.GFloat-        (*^) = (Shader.*)+import Graphics.Rendering.Ombra.Shader.Types+import Graphics.Rendering.Ombra.Texture (Texture)+import Prelude hiding (id, (.)) -instance InnerSpace Shader.GVec2 where-        (<.>) = Shader.dot+newtype UniformSetter x = UniformSetter { unUniformSetter :: x } -instance Ext Shader.GVec2 where-        type Extended Shader.GVec2 = Shader.GVec3-        v ^| z = Shader.vec3 $ v # z-        v ^|^ Shader.GVec3 _ _ z = Shader.vec3 $ v # z-        extract = Shader.vec2+instance Functor UniformSetter where+        fmap f (UniformSetter x) = UniformSetter $ f x -instance AdditiveGroup Shader.GVec3 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negate+instance Applicative UniformSetter where+        pure = UniformSetter+        UniformSetter f <*> UniformSetter x = UniformSetter $ f x -instance VectorSpace Shader.GVec3 where-        type Scalar Shader.GVec3 = Shader.GFloat-        (*^) = (Shader.*)+instance Monad UniformSetter where+        return = pure+        UniformSetter x >>= f = f x -instance InnerSpace Shader.GVec3 where-        (<.>) = Shader.dot+hashMST :: MultiShaderType a => a -> a+hashMST = mapMST (fromExpr . HashDummy . hash . toExpr) -instance HasCross3 Shader.GVec3 where-        cross3 = Shader.cross+-- | Create a shader function that can be reused efficiently.+shader :: (MultiShaderType i, MultiShaderType o) => Shader s i o -> Shader s i o+shader (Shader f hf) = Shader f (memoHash hf)+-- BUG: shader modifies the hash of the shader -instance Ext Shader.GVec3 where-        type Extended Shader.GVec3 = Shader.GVec4-        v ^| w = Shader.vec4 $ v # w-        v ^|^ Shader.GVec4 _ _ _ w = Shader.vec4 $ v # w-        extract = Shader.vec3+-- | This variant of 'shader' can be used with shaders that have a mostly static+-- parameter. It will create a different shader every time the parameter changes+-- to a new value, therefore parameters should not be used for things like+-- model matrices (for which uniforms are more appropriate). Unlike uniforms,+-- parameters can be used anywhere, in particular they can be used to change the+-- shader structure.+shaderParam :: (HasTrie p, MultiShaderType i, MultiShaderType o)+            => Shader s (p, i) o+            -> Shader s (p, i) o+shaderParam (Shader f hf) =+        let hf' = memo (\p -> memoHash $ \(uid, i) -> hf (uid, (p, i)))+        in Shader f (\(uid, (p, i)) -> hf' p (uid, i)) -instance AdditiveGroup Shader.GVec4 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negate+-- | See 'shaderParam'.+pshader :: (HasTrie p, MultiShaderType i, MultiShaderType o)+        => (p -> Shader s i o)+        -> (p -> Shader s i o)+pshader shaderf = let shader' = shaderParam $ first shaderf ^>> app+                  in \p -> const p &&& id ^>> shader' -instance VectorSpace Shader.GVec4 where-        type Scalar Shader.GVec4 = Shader.GFloat-        (*^) = (Shader.*)+-- | 'shader' with an additional parameter that can be used to set the values of+-- the uniforms.+ushader :: (MultiShaderType i, MultiShaderType o)+        => (UniformSetter x -> Shader s i o)+        -> (UniformSetter x -> Shader s i o)+ushader shaderf = let err = "ushader: not an uniform value"+                      Shader _ hf = shaderf $ error err+                      hf' = memoHash hf+                  in \x -> let Shader f _ = shaderf x in Shader f hf' -instance InnerSpace Shader.GVec4 where-        (<.>) = Shader.dot+-- | Combination of 'pshader' and 'ushader'.+pushader :: (HasTrie p, MultiShaderType i, MultiShaderType o)+         => (p -> UniformSetter x -> Shader s i o)+         -> (p -> UniformSetter x -> Shader s i o)+pushader shaderf = let err = error "pushader: not an uniform value"+                       hf' = memo $ \p -> let Shader _ hf = shaderf p err+                                          in memoHash hf+                   in \p x -> let Shader f _ = shaderf p x+                              in Shader f $ hf' p --- Matrices+-- | @'shader' . 'arr'@+sarr :: (MultiShaderType i, MultiShaderType o) => (i -> o) -> Shader s i o+sarr = shader . arr -instance AdditiveGroup Shader.GMat2 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negateM+memoHash :: (MultiShaderType i, MultiShaderType o)+         => ((UniformID, i) -> (UniformID, o))+         -> ((UniformID, i) -> (UniformID, o))+memoHash hf = let mf = memo $ second hashMST . hf . second fromExprMST+              in mf . second toExprMST -instance VectorSpace Shader.GMat2 where-        type Scalar Shader.GMat2 = Shader.GFloat-        (*^) = (Shader.*)+-- | Add a shader variable that can be set with a CPU value.+uniform :: forall u s. Uniform u => Shader s (CPUUniform u) u+uniform = Shader (\(ShaderState uid umap tmap, multiValue) ->+                        let (uniExpr, uid') =+                                buildMST' (\t -> fromExpr . Uniform t) uid+                            acc value@(UniformValue _ _) (uid, umap, tmap) =+                                    (uid - 1, (uid, value) : umap, tmap)+                            acc value@(UniformTexture tex) (uid, umap, tmap) =+                                    (uid - 1, (uid, value) : umap, tex : tmap)+                            (_, umap', tmap') =+                                    foldrUniform (Proxy :: Proxy u) acc+                                                 (uid' - 1, umap, tmap)+                                                 multiValue+                        in (ShaderState uid' umap' tmap', uniExpr)+                 )+                 (\(uid, _) ->+                       let (uniExpr, uid') =+                               buildMST' (\t -> fromExpr . Uniform t) uid+                       in (uid', uniExpr)+                 ) -instance AdditiveGroup Shader.GMat3 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negateM+-- | Like 'uniform' but uses a 'UniformSetter'.+uniform' :: Uniform u => Shader s (UniformSetter (CPUUniform u)) u+uniform' = unUniformSetter ^>> uniform -instance Ext Shader.GMat2 where-        type Extended Shader.GMat2 = Shader.GMat3-        v ^| z = Shader.mat3 $ v # z # z # z # z # z-        Shader.GMat2 x y ^|^ Shader.GMat3 x' y' z' =-                Shader.GMat3 (x ^|^ x') (y ^|^ y') z'-        extract = Shader.mat2+-- | Add a uniform and directly set it with the second operand.+infixl 9 ~~+(~~) :: Uniform u => Shader s (u, i) o -> CPUUniform u -> Shader s i o+shader ~~ u = (const u ^>> uniform) &&& id >>> shader -instance Matrix Shader.GMat2 where-        type Row Shader.GMat2 = Shader.GVec2-        idmtx = Shader.mat2 (1.0 :: Shader.GFloat)-        (.*.) = (Shader.*)-        (.*) = (Shader.*)-        (*.) = (Shader.*)-        transpose (Shader.GMat2 (Shader.GVec2 a b) (Shader.GVec2 c d)) =-                Shader.GMat2 (Shader.GVec2 a c) (Shader.GVec2 b d)+-- | Add a uniform and directly set it with a 'UniformSetter'.+infixl 9 ~*+(~*) :: Uniform u+     => Shader s (u, i) o+     -> UniformSetter (CPUUniform u)+     -> Shader s i o+shader ~* u = (const u ^>> uniform') &&& id >>> shader -instance VectorSpace Shader.GMat3 where-        type Scalar Shader.GMat3 = Shader.GFloat-        (*^) = (Shader.*)+-- | This works like 'sarr' but provides a 'Fragment'.+farr :: (MultiShaderType i, MultiShaderType o)+     => (Fragment -> i -> o)+     -> FragmentShader i o+farr f = shader $ arr (f frag) -instance Ext Shader.GMat3 where-        type Extended Shader.GMat3 = Shader.GMat4-        v ^| z = Shader.mat4 $ v # z # z # z # z # z # z # z-        Shader.GMat3 x y z ^|^ Shader.GMat4 x' y' z' w' =-                Shader.GMat4 (x ^|^ x') (y ^|^ y') (z ^|^ z') w'-        extract = Shader.mat3+fragment :: FragmentShader a Fragment+fragment = arr $ const frag -instance Matrix Shader.GMat3 where-        type Row Shader.GMat3 = Shader.GVec3-        idmtx = Shader.mat3 (1.0 :: Shader.GFloat)-        (.*.) = (Shader.*)-        (.*) = (Shader.*)-        (*.) = (Shader.*)-        transpose (Shader.GMat3 (Shader.GVec3 a b c)-                                (Shader.GVec3 d e f)-                                (Shader.GVec3 g h i)) =-                        Shader.GMat3 (Shader.GVec3 a d g)-                                     (Shader.GVec3 b e h)-                                     (Shader.GVec3 c f i)+frag :: Fragment+frag = Fragment { fragCoord = Shader.fragCoord+                , fragFrontFacing = Shader.fragFrontFacing+                , dFdx = Shader.dFdx+                , dFdy = Shader.dFdy+                , fwidth = Shader.fwidth+                } -instance AdditiveGroup Shader.GMat4 where-        zeroV = Shader.zero-        (^+^) = (Shader.+)-        (^-^) = (Shader.-)-        negateV = Shader.negateM+-- | This function implements raw GLSL loops. The same effect can be achieved+-- using Haskell list functions, but that may result in a large compiled GLSL+-- source, which in turn might slow down compilation or cause an out of memory+-- error.+forLoop :: ShaderInput a +        => Int -- ^ Maximum number of iterations (should be as low as possible)+        -> a -- ^ Initial value+        -> (GInt -> a -> (a, GBool)) -- ^ Iteration -> Old value -> (Next, Stop)+        -> a+forLoop iters iacc f = buildFromExprList $+        Shader.unsafeLoop (fromExpr . Literal "int" $ show iters)+                          (foldrMST (\x -> ((typeName x, toExpr x) :)) [] iacc)+                          (\i es -> let acc = buildFromExprList es+                                        (acc', stop) = f i acc+                                        es' = foldrMST (\x -> (toExpr x :))+                                                       [] acc'+                                    in (es', stop))+        -- XXX+        where buildFromExprList es = fst $ buildMST (\i -> fromExpr $ es !! i) 0 -instance VectorSpace Shader.GMat4 where-        type Scalar Shader.GMat4 = Shader.GFloat-        (*^) = (Shader.*)+foldGArray :: forall t n a. (ShaderType t, KnownNat n, ShaderInput a)+           => (a -> t -> a)+           -> a+           -> GArray n t+           -> a+foldGArray f iacc arr = forLoop (fromIntegral $ natVal (Proxy :: Proxy n))+                                iacc+                                (\i acc -> (f acc $ arr ! i, false)) -instance Matrix Shader.GMat4 where-        type Row Shader.GMat4 = Shader.GVec4-        idmtx = Shader.mat4 (1.0 :: Shader.GFloat)-        (.*.) = (Shader.*)-        (.*) = (Shader.*)-        (*.) = (Shader.*)-        transpose (Shader.GMat4 (Shader.GVec4 a b c d)-                                (Shader.GVec4 e f g h)-                                (Shader.GVec4 i j k l)-                                (Shader.GVec4 m n o p)) =-                        Shader.GMat4 (Shader.GVec4 a e i m)-                                     (Shader.GVec4 b f j n)-                                     (Shader.GVec4 c g k o)-                                     (Shader.GVec4 d h l p)+foldUniforms :: forall a u s. (ShaderInput a, ArrayUniform u, GLES)+             => Shader s (((a -> u -> a), a), [CPUBase u]) a+foldUniforms = (\((f, i), us) -> case someNatVal . fromIntegral $ length us of+                                      Just (SomeNat p) -> (foldArray p f i, us)+               ) ^>> app+        where foldArray :: forall n. KnownNat n+                        => Proxy n+                        -> (a -> u -> a)+                        -> a+                        -> Shader s [CPUBase u] a+              foldArray p f i = baseUniformGArray p (Proxy :: Proxy u) $+                                        uniform >>^ \(arr :: GArray n u) ->+                                                        foldGArray f i arr

@@ -3,14 +3,10 @@              UndecidableInstances, ScopedTypeVariables #-}  module Graphics.Rendering.Ombra.Shader.CPU (-        CPUSetterType(..),-        CPU,         CPUBase,-        CPUMirror,         BaseUniform(..),         BaseAttribute(..),-        Uniform(..),-        Attribute(..),+        ArrayUniform(..),         toGPUBool ) where @@ -21,37 +17,17 @@ import Graphics.Rendering.Ombra.Vector import GHC.Generics hiding (S) import qualified GHC.Generics as G+import GHC.TypeLits import Prelude as CPU --- | This kind represents the way you are setting a GPU value.-data CPUSetterType k-        = S             -- ^ Single CPU type (only for types with one field)-        | M             -- ^ Mirror type (a data type identical to the GPU-                        -- one but with CPU single types instead of GPU)--type family CPU (s :: CPUSetterType *) g where-        CPU 'S x = CPUSingle x-        CPU 'M x = CPUMirror x- type family CPUBase g --- | The mirror type of a certain global.--- --- For instance:------ @---      data T = T GVec3 Float -- In the shader module---      data T = T Vec3 Float -- CPU version of the uniform type---      type CPUMirror GPU.T = T--- @-type family CPUMirror g - -- type family CPUAutoSetter (g :: * -> *) :: CPUSetterType -- type CPUAuto g = CPU (CPUAutoSetter g) g  -- | CPU types convertible to GPU types (as uniforms).-class BaseUniform g where+class ShaderType g => BaseUniform g where         setUniform :: UniformLocation -> proxy g -> CPUBase g -> GL ()  -- | CPU types convertible to GPU types (as attributes).@@ -59,183 +35,67 @@         encodeAttribute :: proxy g -> [CPUBase g] -> GL AnyArray         setAttribute :: proxy g -> GLUInt -> GL () -class Generic g => Uniform (s :: CPUSetterType *) g where-        withUniforms :: Applicative f-                     => proxy s-                     -> g-                     -> CPU s g-                     -> (forall g. BaseUniform g => Int -> Proxy g-                                                 -> CPUBase g -> f ())-                     -> f ()--class Generic g => Attribute (s :: CPUSetterType *) g where-        withAttributes :: Applicative f-                       => proxy s-                       -> g-                       -> [CPU s g]-                       -> (forall g. BaseAttribute g => Int -> Proxy g-                                                     -> [CPUBase g] -> f ())-                       -> f ()--instance (BaseUniform (GGPUValue (Rep g)), Generic g) => Uniform S g where-        withUniforms _ (_ :: g) c f =-                f 0 (Proxy :: Proxy (GGPUValue (Rep g))) c--instance (BaseAttribute (GGPUValue (Rep g)), Generic g) => Attribute S g where-        withAttributes _ (_ :: g) c f =-                f 0 (Proxy :: Proxy (GGPUValue (Rep g))) c--instance ( GUniformMirror (Rep g) (Rep (CPUMirror g))-                                  (TData (Rep (CPUMirror g)))-                                  (TCons (Rep (CPUMirror g)))-         , Generic g, Generic (CPUMirror g) )-         => Uniform M g where-        withUniforms _ (g :: g) c f =-                fst $ gWithUniformMirror-                        (Proxy :: Proxy (MTuple (TData (Rep (CPUMirror g)))-                                                (TCons (Rep (CPUMirror g)))) )-                        0 (from g) (from c) f--{--instance ( GAttributeMirror (Rep g) (Rep (CPUMirror g))-                                    (TData (Rep (CPUMirror g)))-                                    (TCons (Rep (CPUMirror g)))-         , Generic g, Generic (CPUMirror g) )-         => Attribute M g where-        withAttributes _ (g :: g) c f =-                fst $ gWithAttributeMirror-                        (Proxy :: Proxy ( (TData (Rep (CPUMirror g)))-                                        , (TCons (Rep (CPUMirror g)))) )-                        0 (from g) (from c) f--}--type family TData (g :: * -> *) :: Meta where-        TData (M1 D d a) = d--type family TCons (g :: * -> *) :: Meta where-        TCons (M1 D d a) = TCons a-        TCons (M1 C c a) = c--type family GGPUValue (g :: * -> *) where-        GGPUValue (M1 i c a) = GGPUValue a-        GGPUValue (K1 i a) = a--type CPUSingle g = GCPUSingle (Rep g)-type GCPUSingle g = CPUBase (GGPUValue g)---type family GCPUMirror (g :: * -> *) d c :: * -> * where-        GCPUMirror (a :*: b) d c = GCPUMirror a d c :*: GCPUMirror b d c-        GCPUMirror (M1 D gd a) d c = M1 D d (GCPUMirror a d c)-        GCPUMirror (M1 C gc a) d c = M1 C c (GCPUMirror a d c)-        GCPUMirror (M1 G.S s a) d c = M1 G.S s (GCPUMirror a d c)-        GCPUMirror (K1 i a) d c = K1 i (CPUBase a)--data MTuple (d :: k) (c :: k)--class GUniformMirror (g :: * -> *) (m :: * -> *) (d :: Meta) (c :: Meta) where-        gWithUniformMirror :: Applicative f-                           => proxy (MTuple d c)-                           -> Int-                           -> g a-                           -> m b-                           -> (forall u. BaseUniform u => Int -> Proxy u-                                                       -> CPUBase u -> f ())-                           -> (f (), Int)--instance ( GUniformMirror a (GCPUMirror a d c) d c-         , GUniformMirror b (GCPUMirror b d c) d c-         , m ~ GCPUMirror (a :*: b) d c )-         => GUniformMirror (a :*: b) m d c where-        gWithUniformMirror p i (x :*: y) (mx :*: my) f =-                let (a1, i') = gWithUniformMirror p i x mx f-                    (a2, i'') = gWithUniformMirror p i' y my f-                in (a1 *> a2, i'')--instance ( GUniformMirror a ma d c-         , M1 mi mv ma ~ GCPUMirror (M1 i v a) d c )-        => GUniformMirror (M1 i v a) (M1 mi mv ma) d c where-        gWithUniformMirror p i (M1 x) (M1 mx) = gWithUniformMirror p i x mx--instance (BaseUniform a, m ~ GCPUMirror (K1 i a) d c)-        => GUniformMirror (K1 i a) m d c where-        gWithUniformMirror _ i (K1 (_ :: t)) (K1 mx) f =-                (f i (Proxy :: Proxy t) mx, i + 1)--{--class GAttributeMirror (g :: * -> *) (m :: * -> *) d c where-        gWithAttributeMirror :: Applicative f-                             => proxy (MTuple d c)-                             -> Int-                             -> g a-                             -> m b-                             -> (forall u. BaseAttribute u => Int -> Proxy u-                                                           -> CPUBase u-                                                           -> f ())-                             -> (f (), Int)--instance ( GAttributeMirror a (GCPUMirror a d c) d c-         , GAttributeMirror b (GCPUMirror b d c) d c-         , m ~ GCPUMirror (a :*: b) d c )-         => GAttributeMirror (a :*: b) m d c where-        gWithAttributeMirror p i (x :*: y) (mx :*: my) f =-                let (a1, i') = gWithAttributeMirror p i x mx f-                    (a2, i'') = gWithAttributeMirror p i' y my f-                in (a1 *> a2, i'')--instance ( GAttributeMirror a ma d c-         , M1 mi mv ma ~ GCPUMirror (M1 i v a) d c )-        => GAttributeMirror (M1 i v a) (M1 mi mv ma) d c where-        gWithAttributeMirror p i (M1 x) (M1 mx) f =-                gWithAttributeMirror p i x mx f+class ShaderType t => ArrayUniform t where+        baseUniformGArray :: KnownNat n+                          => Proxy n+                          -> Proxy t+                          -> (BaseUniform (GArray n t) => a)+                          -> a -instance (BaseAttribute a, m ~ GCPUMirror (K1 i a) d c)-        => GAttributeMirror (K1 i a) m d c where-        gWithAttributeMirror _ i (K1 (x :: t)) (K1 mx) f =-                (f i (Proxy :: Proxy t) mx, i + 1)--}+type instance CPUBase (GArray n t) = [CPUBase t]  -- Float  type instance CPUBase GFloat = Float-type instance CPUBase (GArray n GFloat) = [Float]  instance GLES => BaseUniform GFloat where         setUniform l _ = uniform1f l -instance GLES => BaseUniform (GArray n GFloat) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GFloat) where         setUniform l _ v = liftIO (encodeFloats v) >>= uniform1fv l +instance GLES => ArrayUniform GFloat where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GFloat where         encodeAttribute _ a = liftIO . fmap fromFloat32Array $ encodeFloats a         setAttribute _ i = attr gl_FLOAT i 1  -- Bool -type instance CPUBase GBool = Int32-type instance CPUBase (GArray n GBool) = [Int32]+type instance CPUBase GBool = Bool +toBool :: Bool -> Int32+toBool True = 1+toBool False = 0+ instance GLES => BaseUniform GBool where-        setUniform l _ = uniform1i l+        setUniform l _ = uniform1i l . toBool -instance GLES => BaseUniform (GArray n GBool) where-        setUniform l _ v = liftIO (encodeInts v) >>= uniform1iv l+instance (GLES, KnownNat n) => BaseUniform (GArray n GBool) where+        setUniform l _ v = liftIO (encodeInts $ map toBool v) >>= uniform1iv l +instance GLES => ArrayUniform GBool where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GBool where-        encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeInts a+        encodeAttribute _ a = liftIO . fmap fromInt32Array $+                                encodeInts (map toBool a)         setAttribute _ i = attr gl_INT i 1  -- Int  type instance CPUBase GInt = Int32-type instance CPUBase (GArray n GInt) = [Int32]  instance GLES => BaseUniform GInt where         setUniform l _ = uniform1i l -instance GLES => BaseUniform (GArray n GInt) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GInt) where         setUniform l _ v = liftIO (encodeInts v) >>= uniform1iv l +instance GLES => ArrayUniform GInt where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GInt where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeInts a         setAttribute _ i = attr gl_INT i 1@@ -243,26 +103,35 @@ -- TODO: sampler arrays (they're problematic to safely access in the shaders) -- Samplers -type instance CPUBase GSampler2D = ActiveTexture-type instance CPUBase GSamplerCube = ActiveTexture+type instance CPUBase GSampler2D = Sampler2D+-- type instance CPUBase GSamplerCube = ActiveTexture  instance GLES => BaseUniform GSampler2D where-        setUniform l _ (ActiveTexture v) = uniform1i l $ fromIntegral v+        setUniform l _ (Sampler2D v) = uniform1i l $ fromIntegral v +{-+instance GLES => ArrayUniform GSampler2D where+        baseUniformGArray _ _ = id+-}++{- instance GLES => BaseUniform GSamplerCube where         setUniform l _ (ActiveTexture v) = uniform1i l $ fromIntegral v+-}  -- Vec2  type instance CPUBase GVec2 = Vec2-type instance CPUBase (GArray n GVec2) = [Vec2]  instance GLES => BaseUniform GVec2 where         setUniform l _ (Vec2 x y) = uniform2f l x y -instance GLES => BaseUniform (GArray n GVec2) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GVec2) where         setUniform l _ v = liftIO (encodeVec2s v) >>= uniform2fv l +instance GLES => ArrayUniform GVec2 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GVec2 where         encodeAttribute _ a = liftIO . fmap fromFloat32Array $ encodeVec2s a         setAttribute _ i = attr gl_FLOAT i 2@@ -270,14 +139,16 @@ -- Vec3  type instance CPUBase GVec3 = Vec3-type instance CPUBase (GArray n GVec3) = [Vec3]  instance GLES => BaseUniform GVec3 where         setUniform l _ (Vec3 x y z) = uniform3f l x y z -instance GLES => BaseUniform (GArray n GVec3) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GVec3) where         setUniform l _ v = liftIO (encodeVec3s v) >>= uniform3fv l +instance GLES => ArrayUniform GVec3 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GVec3 where         encodeAttribute _ a = liftIO . fmap fromFloat32Array $ encodeVec3s a         setAttribute _ i = attr gl_FLOAT i 3@@ -285,14 +156,16 @@ -- Vec4  type instance CPUBase GVec4 = Vec4-type instance CPUBase (GArray n GVec4) = [Vec4]  instance GLES => BaseUniform GVec4 where         setUniform l _ (Vec4 x y z w) = uniform4f l x y z w -instance GLES => BaseUniform (GArray n GVec4) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GVec4) where         setUniform l _ v = liftIO (encodeVec4s v) >>= uniform4fv l +instance GLES => ArrayUniform GVec4 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GVec4 where         encodeAttribute _ a = liftIO . fmap fromFloat32Array $ encodeVec4s a         setAttribute _ i = attr gl_FLOAT i 4@@ -300,14 +173,16 @@ -- IVec2  type instance CPUBase GIVec2 = IVec2-type instance CPUBase (GArray n GIVec2) = [IVec2]  instance GLES => BaseUniform GIVec2 where         setUniform l _ (IVec2 x y) = uniform2i l x y -instance GLES => BaseUniform (GArray n GIVec2) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec2) where         setUniform l _ v = liftIO (encodeIVec2s v) >>= uniform2iv l +instance GLES => ArrayUniform GIVec2 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GIVec2 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec2s a         setAttribute _ i = attr gl_INT i 2@@ -315,14 +190,16 @@ -- IVec3  type instance CPUBase GIVec3 = IVec3-type instance CPUBase (GArray n GIVec3) = [IVec3]  instance GLES => BaseUniform GIVec3 where         setUniform l _ (IVec3 x y z) = uniform3i l x y z -instance GLES => BaseUniform (GArray n GIVec3) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec3) where         setUniform l _ v = liftIO (encodeIVec3s v) >>= uniform3iv l +instance GLES => ArrayUniform GIVec3 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GIVec3 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec3s a         setAttribute _ i = attr gl_INT i 3@@ -330,14 +207,16 @@ -- IVec4  type instance CPUBase GIVec4 = IVec4-type instance CPUBase (GArray n GIVec4) = [IVec4]  instance GLES => BaseUniform GIVec4 where         setUniform l _ (IVec4 x y z w) = uniform4i l x y z w -instance GLES => BaseUniform (GArray n GIVec4) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec4) where         setUniform l _ v = liftIO (encodeIVec4s v) >>= uniform4iv l +instance GLES => ArrayUniform GIVec4 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GIVec4 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec4s a         setAttribute _ i = attr gl_INT i 4@@ -345,14 +224,16 @@ -- BVec2  type instance CPUBase GBVec2 = IVec2-type instance CPUBase (GArray n GBVec2) = [IVec2]  instance GLES => BaseUniform GBVec2 where         setUniform l _ (IVec2 x y) = uniform2i l x y -instance GLES => BaseUniform (GArray n GBVec2) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec2) where         setUniform l _ v = liftIO (encodeIVec2s v) >>= uniform2iv l +instance GLES => ArrayUniform GBVec2 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GBVec2 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec2s a         setAttribute _ i = attr gl_INT i 2@@ -360,14 +241,16 @@ -- BVec3  type instance CPUBase GBVec3 = IVec3-type instance CPUBase (GArray n GBVec3) = [IVec3]  instance GLES => BaseUniform GBVec3 where         setUniform l _ (IVec3 x y z) = uniform3i l x y z -instance GLES => BaseUniform (GArray n GBVec3) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec3) where         setUniform l _ v = liftIO (encodeIVec3s v) >>= uniform3iv l +instance GLES => ArrayUniform GBVec3 where+        baseUniformGArray _ _ = id+ instance GLES => BaseAttribute GBVec3 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec3s a         setAttribute _ i = attr gl_INT i 3@@ -375,13 +258,15 @@ -- BVec4  type instance CPUBase GBVec4 = IVec4-type instance CPUBase (GArray n GBVec4) = [IVec4]  instance GLES => BaseUniform GBVec4 where         setUniform l _ (IVec4 x y z w) = uniform4i l x y z w -instance GLES => BaseUniform (GArray n GBVec4) where+instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec4) where         setUniform l _ v = liftIO (encodeIVec4s v) >>= uniform4iv l++instance GLES => ArrayUniform GBVec4 where+        baseUniformGArray _ _ = id  instance GLES => BaseAttribute GBVec4 where         encodeAttribute _ a = liftIO . fmap fromInt32Array $ encodeIVec4s a

@@ -1,47 +0,0 @@-{-# LANGUAGE DataKinds, DeriveGeneric, GADTs #-}--module Graphics.Rendering.Ombra.Shader.Default2D (-        Uniforms,-        Geometry2D,-        Image(..),-        Depth(..),-        Transform2(..),-        View2(..),-        Position2(..),-        UV(..),-        vertexShader,-        fragmentShader-) where--import Graphics.Rendering.Ombra.Shader--type Uniforms = '[View2, Image, Depth, Transform2]---- | 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---- | An uniform that represents the depth used in the default 2D shader.-data Depth = Depth GFloat deriving Generic---- | An uniform that represents the transformation matrix used in the default--- 2D shader.-data Transform2 = Transform2 GMat3 deriving Generic--- | An uniform that represents the view matrix used in the default 2D shader.-data View2 = View2 GMat3 deriving Generic--data Position2 = Position2 GVec2 deriving Generic--vertexShader :: VertexShader '[Transform2, View2, Depth]-                             '[Position2, UV]-                             '[UV]-vertexShader (Transform2 trans :- View2 view :- Depth z :- N)-             (Position2 pos :- uv@(UV _) :- N) =-                let GVec3 x' y' _ = view .*. trans .* (pos ^| 1)-                in Vertex (GVec4 x' y' z 1) :- uv :- N--fragmentShader :: FragmentShader '[Image] '[UV]-fragmentShader (Image sampler :- N) (UV (GVec2 s t) :- N) =-                Fragment (texture2D sampler (GVec2 s $ 1 - t)) :- N

@@ -1,55 +0,0 @@-{-# LANGUAGE DataKinds, DeriveGeneric, GADTs #-}--module Graphics.Rendering.Ombra.Shader.Default3D (-        Uniforms,-        Geometry3D,-        Texture2(..),-        Transform3(..),-        View3(..),-        Project3(..),-        Position3(..),-        UV(..),-        Normal3(..),-        vertexShader,-        fragmentShader-) where--import Graphics.Rendering.Ombra.Shader--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---- | The output position and normal are in view space.-vertexShader :: VertexShader '[ Project3, View3, Transform3 ]-                             Geometry3D-                             '[ Position3, UV, Normal3 ]-vertexShader (  Project3 projMatrix-             :- View3 viewMatrix-             :- Transform3 modelMatrix-             :- N)-             (Position3 pos :- uv :- Normal3 norm :- 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) =-        Fragment (texture2D sampler $ GVec2 s (1 - t)) :- N

@@ -2,126 +2,103 @@              DataKinds, TypeOperators, ConstraintKinds #-}  module Graphics.Rendering.Ombra.Shader.GLSL (-        vertexToGLSLAttr,-        vertexToGLSL,-        fragmentToGLSL,-        shaderToGLSL,+        compileVertexShader,+        compileFragmentShader,         uniformName ) where +import Control.Arrow import Data.List (find)-import Data.Hashable (hash) -- TODO: use ST hashtables+import Data.Hashable (hash) import qualified Data.HashMap.Strict as H import Data.Typeable-import Graphics.Rendering.Ombra.Shader.ShaderVar-import Graphics.Rendering.Ombra.Shader.Language.Types hiding (Int, Bool)-import Graphics.Rendering.Ombra.Shader.Stages (VertexShader, FragmentShader,-                                               VOShaderVars)+import Graphics.Rendering.Ombra.Shader+import Graphics.Rendering.Ombra.Shader.Language.Types+import Graphics.Rendering.Ombra.Shader.Types import Text.Printf -data VarPrefix = Global | Varying | Attribute--data SV = SV {-        uniformVars :: [(String, String)],-        inputVars :: [(String, String, Int)],-        outputVars :: [(String, String, Expr)]-}--vertexToGLSLAttr :: (ShaderVars g, ShaderVars i, VOShaderVars o)-                 => VertexShader g i o -                 -> (String, [(String, Int)])-vertexToGLSLAttr v =-        let r@(SV _ is _) = vars False v-        in ( shaderToGLSL "#version 100\n" "attribute" "varying"-                          r [("hvVertexShaderOutput0", "gl_Position")]-           , map (\(_, n, s) -> (n, s)) is)--vertexToGLSL :: (ShaderVars g, ShaderVars i, VOShaderVars o)-             => VertexShader g i o -> String-vertexToGLSL = fst . vertexToGLSLAttr--fragmentToGLSL :: (ShaderVars g, ShaderVars i) => FragmentShader g i -> String-fragmentToGLSL v =-        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]")-                      , ("hvFragmentShaderOutput4", "gl_FragData[4]")-                      , ("hvFragmentShaderOutput5", "gl_FragData[5]")-                      , ("hvFragmentShaderOutput6", "gl_FragData[6]")-                      , ("hvFragmentShaderOutput7", "gl_FragData[7]")-                      , ("hvFragmentShaderOutput8", "gl_FragData[8]")-                      , ("hvFragmentShaderOutput9", "gl_FragData[9]")-                      , ("hvFragmentShaderOutput10", "gl_FragData[10]")-                      , ("hvFragmentShaderOutput11", "gl_FragData[11]")-                      , ("hvFragmentShaderOutput12", "gl_FragData[12]")-                      , ("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-        [ header-        , concatMap (var "uniform") gs-        , concatMap (\(t, n, _) -> var ins (t, n)) is-        , concatMap (\(t, n, _) -> if any ((== n) . fst) predec-                                          then []-                                          else var outs (t, n)-                    ) os-        , "void main(){"-        , actions-        , concatMap (\(n, s) -> replace n predec ++ "=" ++ s ++ ";")-                    compiledOuts-        , "}" ]-        where var qual (ty, nm) = qual ++ " " ++ ty ++ " " ++ nm ++ ";"-              replace x xs = case filter ((== x) . fst) xs of-                                        [(_, y)] -> y-                                        _ -> x-              (_, outNames, outExprs) = unzip3 os-              (actions, outStrs) = compile outExprs-              compiledOuts = zip outNames outStrs--vars :: (ShaderVars gs, ShaderVars is, ShaderVars os)-     => Bool -> Shader gs is os -> SV-vars isFragment (shader :: Shader gs is os) =-        SV (svToList globalVar globals)-           (svToList inputVar inputs)-           (svToList outputVar outputs)-        where globals = staticSVList (Proxy :: Proxy gs) $ varExpr Global-              inputs = staticSVList (Proxy :: Proxy is) $ varExpr inputPrefix-              outputs = shader globals inputs+-- TODO: IntMap instead of HashMap+-- TODO: use fgl+-- TODO: detect identical uniforms -              inputPrefix = if isFragment then Varying else Attribute+compileVertexShader :: (ShaderInput i, ShaderInput o)+                    => VertexShader i (GVec4, o)+                    -> (String, (UniformID, [(String, Int)]))+compileVertexShader s = compileShader True header ["gl_Position"] 0 exprShader+        where exprShader = s >>^ \(pos, outs) -> ([toExpr pos], outExprs outs)+              outExprs = foldrMST (\x l -> (typeName x, toExpr x) : l) []+              header = "#version 100\nprecision mediump float;" -              globalVar :: ShaderVar v => v -> [(String, String)]-              globalVar var = varToList-                                (\n x -> (typeName x, varName Global var n))-                                var+compileFragmentShader :: (ShaderInput i, FragmentShaderOutput o)+                      => UniformID+                      -> FragmentShader i o+                      -> String+compileFragmentShader i s = fst $ compileShader False header outs i exprShader+        where exprShader = s >>^ flip (,) [] . map toExpr . toGVec4s+              header = concat [ "#version 100\n"+                              , ext "GL_EXT_draw_buffers"+                              , ext "GL_OES_standard_derivatives"+                              , "precision mediump float;"+                              ]+              ext e = "#extension " ++ e ++ " : enable\n"+              outs = map (\n -> "gl_FragData[" ++ show n ++ "]") [0 .. 15] -              inputVar :: ShaderVar v => v -> [(String, String, Int)]-              inputVar var = varToList (\n x -> ( typeName x-                                                , varName inputPrefix var n-                                                , size x )) var+compileShader :: ShaderInput i+              => Bool+              -> String+              -> [String]+              -> UniformID+              -> Shader s i ([Expr], [(String, Expr)])+              -> (String, (UniformID, [(String, Int)]))+compileShader useAttributes header outNames uniformID (Shader shaderFun _) =+        let inputFun | useAttributes = Attribute+                     | otherwise = Input+            (input, _) = buildMST' (\t -> fromExpr . inputFun t) 0+            inputTypes = foldrMST (\x -> (typeName x :)) [] input+            ((ShaderState uniformID' uniMap _), (outs, outVaryings)) =+                    shaderFun (ShaderState uniformID [] [], input)+            (outVaryingTypes, outVaryingExprs) = unzip outVaryings -              outputVar :: ShaderVar v => v -> [(String, String, Expr)]-              outputVar var = varToList (\n x -> ( typeName x-                                                 , varName Varying var n-                                                 , toExpr x )) var+            showVar qual ty nm = concat [qual, " ", ty', " ", nm', ";"]+                where (ty', arr) = break (== '[') ty+                      nm' = nm ++ arr+            showVars qual name vars = concatMap (\(ty, n) -> showVar qual ty+                                                                     (name n))+                                                (zip vars [0 ..])+            uniType (UniformValue (_ :: Proxy g) _) = typeName (undefined :: g)+            uniType (UniformTexture _) = typeName (undefined :: GSampler2D)+            uniVars = concatMap (\(uid, val) -> showVar "uniform"+                                                        (uniType val)+                                                        (uniformName uid))+                                uniMap+            inputVars | useAttributes = showVars "attribute" attributeName+                                                 inputTypes+                      | otherwise = showVars "varying" varyingName inputTypes+            outVaryingVars = showVars "varying" varyingName outVaryingTypes -              varExpr :: ShaderVar v => VarPrefix -> Proxy v -> v-              varExpr p (pvar :: Proxy v) =-                      varBuild (fromExpr . Read . varName p var) pvar-                where var = undefined :: v+            outVaryingNames = map varyingName [0 ..]+            (compiledActions, outStrs) = compile (outs ++ outVaryingExprs)+            compiledOuts = zipWith (\n s -> showString (n ++ "=") . s .+                                            showString ";")+                                   (outNames ++ outVaryingNames)+                                   outStrs+        in ( concat [ header+                    , uniVars+                    , inputVars+                    , outVaryingVars+                    , "void main(){"+                    , compiledActions ""+                    , foldr (.) id compiledOuts $ ""+                    , "}"+                    ]+            , ( uniformID'+              , if useAttributes+                   then zipWith (\size n -> (attributeName n, size))+                               (foldrMST (\x -> (size x :)) [] input)+                               [0 ..]+                   else []+              )+            )  type ActionID = Int type ActionMap = H.HashMap ActionID Action@@ -133,12 +110,8 @@         actionContext :: ActionContext } -type ActionGenerator = String -> String+type ActionGenerator = ShowS -> ShowS --- | The context is where an action should be put. Only for-loops are considered--- contexts, because there is no reason to put an action inside another block.--- Of course, an action could have many contexts (e.g. for(..) { for (..) {--- act; } }), but only one is actually needed to compile the action. data ActionContext = ShallowContext ActionSet       -- ^ The contexts of the expressions used in the action.                    | DeepContext ActionSet          -- ^ All the contexts (including those of the dependencies).                    deriving (Show)@@ -146,15 +119,44 @@ type ActionGraph = H.HashMap ActionID ActionInfo  -- | Compile a list of 'Expr', sharing their actions.-compile :: [Expr] -> (String, [String])-compile exprs = let (strs, deps, _) = unzip3 $ map compileExpr exprs+compile :: [Expr] -> (ShowS, [ShowS])+compile exprs = let exprs' = optimize 1 exprs+                    (strs, deps, _) = unzip3 $ map compileExpr exprs'                     depGraph = contextAll deep . buildActionGraph $ H.unions deps                     sorted = sortActions depGraph-                in (sorted >>= uncurry generate, strs)+                in (genList sorted, strs) -generate :: ActionGenerator -> ActionGraph -> String-generate gen graph = gen $ sortActions graph >>= uncurry generate+optimize :: Int         -- ^ 1 = store only the repeated expressions,+                        --   2 = store everything+         -> [Expr]+         -> [Expr]+optimize n exprs = let reps fullExprMap expr (optimizedExprs, exprMap) =+                        let h = hash expr+                            exprMap' = H.insertWith (+) h n exprMap+                            sub = subExprs expr+                            (optimizedSubExprs, exprMap'') =+                                    foldr (reps fullExprMap)+                                          ([], exprMap')+                                          sub+                            expr' = replaceSubExprs expr optimizedSubExprs+                            storedExpr = case exprType expr' of+                                              Just t -> Action (Store t expr') 0+                                              Nothing -> expr'+                            optimizedExpr | length sub < 1 = expr'+                                          | fullExprMap H.! h > 1 = storedExpr+                                          | otherwise = expr'+                            optimizedExprs' = optimizedExpr : optimizedExprs+                        in (optimizedExprs', exprMap'')+                       (optimizedExprs, fullExprMap) =+                               foldr (reps fullExprMap) ([], H.empty) exprs+                   in optimizedExprs +generate :: ActionGenerator -> ActionGraph -> ShowS+generate gen graph = gen . genList $ sortActions graph++genList :: [(ActionGenerator, ActionGraph)] -> ShowS+genList = foldr (.) id . map (uncurry generate)+ sortActions :: ActionGraph -> [(ActionGenerator, ActionGraph)] sortActions fullGraph = visitLoop (H.empty, [], fullGraph)         where visitLoop state@(childrenMap, sortedIDs, graph)@@ -232,94 +234,141 @@  -- | Compile an 'Expr'. Returns the compiled expression, the map of dependencies -- and the context.-compileExpr :: Expr -> (String, ActionMap, ActionSet)-compileExpr Empty = ("", H.empty, H.empty)-compileExpr (Read s) = (s, H.empty, H.empty)+compileExpr :: Expr -> (ShowS, ActionMap, ActionSet)+compileExpr Empty = (showString "", H.empty, H.empty)+compileExpr (Read _ s) = (showString s, H.empty, H.empty) -compileExpr (Op1 s e) = first3 (\x -> "(" ++ s ++ x ++ ")") $ compileExpr e+compileExpr (Op1 _ s e) = let left = showString ("(" ++ s)+                              right = showString ")"+                          in first3 (\x -> left . x . right) $ compileExpr e -compileExpr (Op2 s ex ey) = let (x, ax, cx) = compileExpr ex-                                (y, ay, cy) = compileExpr ey-                            in ( "(" ++ x ++ s ++ y ++ ")"-                               , H.union ax ay, H.union cx cy )+compileExpr (Op2 _ s ex ey) = let (x, ax, cx) = compileExpr ex+                                  (y, ay, cy) = compileExpr ey+                                  str = showString "(" .+                                        x . showString s . y .+                                        showString ")"+                              in (str, H.union ax ay, H.union cx cy) -compileExpr (Apply s es) = let (vs, as, cs) = unzip3 $ map compileExpr es-                           in ( concat $ [ s, "(" , tail (vs >>= (',' :)), ")" ]-                              , H.unions as, H.unions cs)+compileExpr (Apply _ s es) = let (v : vs, as, cs) = unzip3 $ map compileExpr es+                                 addArg vs v = vs . showString "," . v+                                 args = v . foldl addArg id vs+                                 str = showString (s ++ "(") . args . showString ")"+                             in (str, H.unions as, H.unions cs) -compileExpr (X e) = first3 (++ "[0]") $ compileExpr e-compileExpr (Y e) = first3 (++ "[1]") $ compileExpr e-compileExpr (Z e) = first3 (++ "[2]") $ compileExpr e-compileExpr (W e) = first3 (++ "[3]") $ compileExpr e-compileExpr (Literal s) = (s, H.empty, H.empty)-compileExpr (Action a) = let h = hash a-                         in (actionName h, H.singleton h a, H.empty)+compileExpr (X e) = first3 (. showString "[0]") $ compileExpr e+compileExpr (Y e) = first3 (. showString "[1]") $ compileExpr e+compileExpr (Z e) = first3 (. showString "[2]") $ compileExpr e+compileExpr (W e) = first3 (. showString "[3]") $ compileExpr e+compileExpr (Literal _ s) = (showString s, H.empty, H.empty)+compileExpr (Input _ i) = (showString $ varyingName i, H.empty, H.empty)+compileExpr (Attribute _ i) = (showString $ attributeName i, H.empty, H.empty)+compileExpr (Uniform _ i) = (showString $ uniformName i, H.empty, H.empty)+compileExpr (Action a n) = let h = hash a+                               var = showString $ actionName h n+                           in (var, H.singleton h a, H.empty) compileExpr (Dummy _) = error "compileExpr: Dummy"-compileExpr (ArrayIndex eArr ei) = let (arr, aArr, cArr) = compileExpr eArr-                                       (i, ai, ci) = compileExpr ei-                                   in ( "(" ++ arr ++ "[" ++ i ++ "])"-                                      , H.union aArr ai, H.union cArr ci )-compileExpr (ContextVar i t) = (contextVarName t i, H.empty, H.singleton i ())+compileExpr (HashDummy _) = error "compileExpr: HashDummy"+compileExpr (ArrayIndex _ eArr ei) = let (arr, aArr, cArr) = compileExpr eArr+                                         (i, ai, ci) = compileExpr ei+                                         str = showString "(" . arr .+                                               showString "[" . i .+                                               showString "])"+                                     in (str, H.union aArr ai, H.union cArr ci)+compileExpr (ContextVar _ i t) = ( showString $ contextVarName t i+                                 , H.empty+                                 , H.singleton i ()+                                 ) +compileExprOptimized :: Int -> Expr -> (ShowS, ActionMap, ActionSet)+compileExprOptimized n = compileExpr . head . optimize n . (: [])+ first3 :: (a -> a') -> (a, b, c) -> (a', b, c) first3 f (a, b, c) = (f a, b, c)  compileAction :: ActionID -> Action -> (ActionInfo, ActionMap) compileAction aID (Store ty expr) =         let (eStr, deps, ctxs) = compileExpr expr-        in ( ActionInfo  (\c -> concat [ c, ty, " ", actionName aID-                                       , "=", eStr, ";" ])+        in ( ActionInfo  (\c -> c .+                                showString (ty ++ " " ++ actionName aID 0 ++ "=") .+                                eStr . showString ";")                          (H.map (const ()) deps)                          (ShallowContext ctxs)            , deps )  compileAction aID (If cExpr ty tExpr fExpr) =-        let (cStr, cDeps, cCtxs) = compileExpr cExpr-            (tStr, tDeps, tCtxs) = compileExpr tExpr-            (fStr, fDeps, fCtxs) = compileExpr fExpr+        let (cStr, cDeps, cCtxs) = compileExprOptimized 1 cExpr+            (tStr, tDeps, tCtxs) = compileExprOptimized 1 tExpr+            (fStr, fDeps, fCtxs) = compileExprOptimized 1 fExpr             deps = H.unions [cDeps, tDeps, fDeps]-            name = actionName aID-        in ( ActionInfo (\c -> concat [ ty, " ", name, ";if("-                                      , cStr, "){", c, name, "=", tStr-                                      , ";}else{" , name, "=", fStr, ";}" ])+            name = actionName aID 0+            nameS = showString name+        in ( ActionInfo (\c -> showString (ty ++ " " ++ name ++ ";if(") .+                               cStr . showString "){" . c . nameS .+                               showString "=" . tStr . showString ";}else{" .+                               nameS . showString "=" . fStr . showString ";}")                         (H.map (const ()) deps)                         (ShallowContext $ H.unions [cCtxs, tCtxs, fCtxs])            , deps ) -compileAction aID (For iters ty initVal body) =-        let iterName = contextVarName LoopIteration aID-            valueName = contextVarName LoopValue aID-            (nExpr, sExpr) = body (ContextVar aID LoopIteration)-                                  (ContextVar aID LoopValue)-            (iStr, iDeps, iCtxs) = compileExpr initVal-            (nStr, nDeps, nCtxs) = compileExpr nExpr-            (sStr, sDeps, sCtxs) = compileExpr sExpr-            deps = H.unions [iDeps, nDeps, sDeps]-        in ( ActionInfo (\c -> concat [ ty, " ", valueName, "=", iStr, ";"-                                      , "for(float ", iterName, "=0.0;"-                                      , iterName, "<", show iters, ".0;"-                                      , "++", iterName, "){", c-                                      , "if(", sStr, "){break;}"-                                      , valueName, "=", nStr, ";}" ])+compileAction aID (For iters initValuesTypes body) =+        let iterNameS = showString $ contextVarName LoopIteration aID+            valueNameSs = map (\i -> showString $ contextVarName (LoopValue i)+                                                                 aID)+                              [0 ..]+            (iterStr, _, _) = compileExpr iters+            Just iterType = exprType iters+            iterTypeS = showString iterType+            (initTypes, initValues) = unzip initValuesTypes+            (nExprs, sExpr) = body (ContextVar iterType aID LoopIteration)+                                   (zipWith (\ty i -> ContextVar ty aID+                                                                 (LoopValue i))+                                            initTypes [0 ..])+            (iStrs, iDepss, iCtxss) = unzip3 $ map (compileExprOptimized 1)+                                                   initValues+            (nStrs, nDepss, nCtxss) = unzip3 $ map (compileExprOptimized 2)+                                                   nExprs+            (sStr, sDeps, sCtxs) = compileExprOptimized 2 sExpr+            deps = H.unions $ sDeps : (iDepss ++ nDepss)+            initialization = foldr (\(iStr, ty, valueNameS) str ->+                                        showString (ty ++ " ") . valueNameS .+                                        showString "=" . iStr .+                                        showString ";" . str+                                   )+                                   (showString "")+                                   (zip3 iStrs initTypes valueNameSs)+            update = foldr (\(valueNameS, nStr) str ->+                               valueNameS .  showString "=" .+                               nStr . showString ";" . str+                           )+                           (showString "")+                           (zip valueNameSs nStrs)+        in ( ActionInfo (\c -> initialization .+                               showString "for(" . iterTypeS . showString " " .+                               iterNameS .  showString "=0;" . iterNameS .+                               showString "<" . iterStr .+                               showString ";++" . iterNameS .+                               showString "){" . c .  showString "if(" . sStr .+                               showString "){break;}" . update .+                               showString "}")                         (H.map (const ()) deps)-                        (ShallowContext $ H.unions [iCtxs, nCtxs, sCtxs])+                        (ShallowContext . H.unions $ sCtxs : (iCtxss ++ nCtxss))            , deps ) -actionName :: ActionID -> String-actionName = ('a' :) . hashName+actionName :: ActionID -> Int -> String+actionName aID i = concat ["a", hashName aID ++ "_" ++ show i]  contextVarName :: ContextVarType -> ActionID -> String contextVarName LoopIteration = ('l' :) . hashName-contextVarName LoopValue = actionName+contextVarName (LoopValue i) = flip actionName i  hashName :: ActionID -> String hashName = printf "%x" -uniformName :: ShaderVar v => v -> Int -> String-uniformName = varName Global+uniformName :: Int -> String+uniformName = ('u' :) . show -varName :: ShaderVar v => VarPrefix -> v -> Int -> String-varName prefix var n = prefixName prefix ++ varPreName var ++ show n-        where prefixName Global = "hg"-              prefixName Varying = "hv"-              prefixName Attribute = "ha"+varyingName :: Int -> String+varyingName = ('v' :) . show++attributeName :: Int -> String+attributeName = ('t' :) . show

@@ -1,189 +1,427 @@-{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-}+{-# LANGUAGE DataKinds, FlexibleContexts, RankNTypes, MultiParamTypeClasses,+             TypeFamilyDependencies, TypeFamilies, FlexibleInstances,+             UndecidableInstances, DeriveGeneric #-} +{-|+Module:      Graphics.Rendering.Ombra.Shader.Language+License:     BSD3+Maintainer:  ziocroc@gmail.com+Stability:   experimental+Portability: GHC only++This module exports the shader EDSL.+-}+ module Graphics.Rendering.Ombra.Shader.Language (+        module Data.Boolean,+        module Data.VectorSpace,+        module Data.Cross,         -- * Types-        Shader,-        VertexShader,-        FragmentShader,-        VertexShaderOutput(Vertex),-        FragmentShaderOutput(..),-        ShaderType(zero),-        ShaderVars,-        VOShaderVars,-        Uniform,-        Attribute,-        Generic,-        SVList((:-), N),         -- ** GPU types-        GenType,-        GenTypeGFloat,-        GMatrix,-        GBool,-        GFloat,-        GInt,-        GSampler2D,-        GSamplerCube,-        GVec2(..),-        GVec3(..),-        GVec4(..),-        GBVec2(..),-        GBVec3(..),-        GBVec4(..),-        GIVec2(..),-        GIVec3(..),-        GIVec4(..),-        GMat2(..),-        GMat3(..),-        GMat4(..),-        GArray,-        -- * Functions-        loop,-        store,-        texture2D,-        texture2DBias,-        texture2DProj,-        texture2DProjBias,-        texture2DProj4,-        texture2DProjBias4,-        texture2DLod,-        texture2DProjLod,-        texture2DProjLod4,-        arrayLength,-        -- ** Math functions-        radians,-        degrees,-        sin,-        cos,-        tan,-        asin,-        acos,-        atan,-        atan2,-        exp,-        log,-        exp2,-        log2,-        sqrt,-        inversesqrt,-        abs,-        absI,-        sign,-        signI,-        floor,-        ceil,-        fract,-        mod,-        min,-        max,-        clamp,-        mix,-        step,-        smoothstep,-        length,-        distance,-        dot,-        cross,-        normalize,-        faceforward,-        reflect,-        refract,-        matrixCompMult,-        dFdx,-        dFdy,-        fwidth,+        Shader.GBool,+        Shader.GFloat,+        Shader.GInt,+        TextureSampler,+        -- Shader.GSamplerCube,+        Shader.GVec2(..),+        Shader.GVec3(..),+        Shader.GVec4(..),+        Shader.GBVec2(..),+        Shader.GBVec3(..),+        Shader.GBVec4(..),+        Shader.GIVec2(..),+        Shader.GIVec3(..),+        Shader.GIVec4(..),+        Shader.GMat2(..),+        Shader.GMat3(..),+        Shader.GMat4(..),+        Shader.GenType,+        Shader.GenTypeGFloat,+        Shader.GArray,+        -- * GPU functions+        (Shader.!),+        -- Shader.store,+        sample,+        {-+        Shader.texture2DBias,+        Shader.texture2DProj,+        Shader.texture2DProjBias,+        Shader.texture2DProj4,+        Shader.texture2DProjBias4,+        Shader.texture2DLod,+        Shader.texture2DProjLod,+        Shader.texture2DProjLod4,+        -}+        Shader.arrayLength,+        -- ** Various math functions+        Matrix(..),+        Ext(..),+        minG,+        maxG,+        modG,+        floorG,+        ceilingG,+        Shader.radians,+        Shader.degrees,+        Shader.exp2,+        Shader.log2,+        Shader.inversesqrt,+        Shader.fract,+        Shader.clamp,+        Shader.mix,+        Shader.step,+        -- Shader.smoothstep,+        Shader.distance, -- TODO: implement AffineSpace?+        -- Shader.length,+        Shader.faceforward,+        Shader.reflect,+        Shader.refract,+        Shader.matrixCompMult,         -- *** Vector relational functions-        VecOrd,-        VecEq,-        lessThan,-        lessThanEqual,-        greaterThan,-        greaterThanEqual,-        equal,-        notEqual,-        GBoolVector,-        anyBV,-        allBV,-        notBV,+        Shader.VecOrd,+        Shader.VecEq,+        Shader.lessThan,+        Shader.lessThanEqual,+        Shader.greaterThan,+        Shader.greaterThanEqual,+        Shader.equal,+        Shader.notEqual,+        Shader.GBoolVector,+        Shader.anyBV,+        Shader.allBV,+        Shader.notBV,         -- ** Constructors-        true,-        false,-        ToGBool,-        bool,-        ToGInt,-        int,-        ToGFloat,-        float,-        Components,-        CompList,-        ToCompList,-        (#),-        ToGVec2,-        vec2,-        ToGVec3,-        vec3,-        ToGVec4,-        vec4,-        ToGBVec2,-        bvec2,-        ToGBVec3,-        bvec3,-        ToGBVec4,-        bvec4,-        ToGIVec2,-        ivec2,-        ToGIVec3,-        ivec3,-        ToGIVec4,-        ivec4,-        ToGMat2,-        mat2,-        ToGMat3,-        mat3,-        ToGMat4,-        mat4,-        -- ** Operators-        (*),-        (/),-        (+),-        (-),-        (^),-        (&&),-        (||),-        (==),-        (/=),-        (>=),-        (<=),-        (<),-        (>),-        (!),-        not,-        -- ** Rebinding functions-        fromInteger,-        fromRational,-        ifThenElse,-        negate,-        negateI,-        negateM,-        -- ** Prelude functions-        (.),-        id,-        const,-        flip,-        ($),-        CPU.fst,-        CPU.snd,-        -- * Variables-        position,-        fragData,-        fragCoord,-        fragFrontFacing+        Shader.ToGBool,+        Shader.bool,+        Shader.ToGInt,+        Shader.int,+        Shader.ToGFloat,+        Shader.float,+        -- TODO: better vector constructors+        {-+        Shader.Components,+        Shader.CompList,+        Shader.ToCompList,+        (Shader.#),+        Shader.ToGVec2,+        Shader.vec2,+        Shader.ToGVec3,+        Shader.vec3,+        Shader.ToGVec4,+        Shader.vec4,+        Shader.ToGBVec2,+        Shader.bvec2,+        Shader.ToGBVec3,+        Shader.bvec3,+        Shader.ToGBVec4,+        Shader.bvec4,+        Shader.ToGIVec2,+        Shader.ivec2,+        Shader.ToGIVec3,+        Shader.ivec3,+        Shader.ToGIVec4,+        Shader.ivec4,+        Shader.ToGMat2,+        Shader.mat2,+        Shader.ToGMat3,+        Shader.mat3,+        Shader.ToGMat4,+        Shader.mat4,+        -}+        -- ** Other ) where -import GHC.Generics (Generic)+import Data.Proxy import Graphics.Rendering.Ombra.Shader.CPU-import Graphics.Rendering.Ombra.Shader.Language.Types-import Graphics.Rendering.Ombra.Shader.Language.Functions-import Graphics.Rendering.Ombra.Shader.ShaderVar-import Graphics.Rendering.Ombra.Shader.Stages-import Prelude ((.), id, const, flip, ($))-import qualified Prelude as CPU+import Graphics.Rendering.Ombra.Shader.Language.Functions ((#))+import qualified Graphics.Rendering.Ombra.Shader.Language.Types as Shader+import qualified Graphics.Rendering.Ombra.Shader.Language.Functions as Shader+import Graphics.Rendering.Ombra.Vector++import Data.Boolean+import qualified Data.Boolean.Numbers as B+import Data.Cross+import Data.VectorSpace++type instance BooleanOf Shader.GBool = Shader.GBool+type instance BooleanOf Shader.GFloat = Shader.GBool+type instance BooleanOf Shader.GInt = Shader.GBool+type instance BooleanOf Shader.GSampler2D = Shader.GBool+-- type instance BooleanOf Shader.GSamplerCube = Shader.GBool+type instance BooleanOf Shader.GVec2 = Shader.GBool+type instance BooleanOf Shader.GVec3 = Shader.GBool+type instance BooleanOf Shader.GVec4 = Shader.GBool+type instance BooleanOf Shader.GBVec2 = Shader.GBool+type instance BooleanOf Shader.GBVec3 = Shader.GBool+type instance BooleanOf Shader.GBVec4 = Shader.GBool+type instance BooleanOf Shader.GIVec2 = Shader.GBool+type instance BooleanOf Shader.GIVec3 = Shader.GBool+type instance BooleanOf Shader.GIVec4 = Shader.GBool+type instance BooleanOf Shader.GMat2 = Shader.GBool+type instance BooleanOf Shader.GMat3 = Shader.GBool+type instance BooleanOf Shader.GMat4 = Shader.GBool+type instance BooleanOf (Shader.GArray n t) = Shader.GBool++instance Boolean Shader.GBool where+        true = Shader.true+        false = Shader.false+        (&&*) = (Shader.&&)+        (||*) = (Shader.||)+        notB = Shader.not++instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => IfB a where+        ifB = Shader.ifThenElse++instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => EqB a where+        (==*) = (Shader.==)+        (/=*) = (Shader./=)++instance (Shader.ShaderType a, BooleanOf a ~ Shader.GBool) => OrdB a where+        (<*) = (Shader.<)+        (<=*) = (Shader.<=)+        (>*) = (Shader.>)+        (>=*) = (Shader.>=)+        +-- | Faster GPU 'max'/'B.maxB'.+maxG :: Shader.GenTypeGFloat a b => a -> b -> a+maxG = Shader.max++-- | Faster GPU 'min'/'B.minB'.+minG :: Shader.GenTypeGFloat a b => a -> b -> a+minG = Shader.min++instance Num Shader.GFloat where+        (+) = (Shader.+)+        (-) = (Shader.-)+        (*) = (Shader.*)+        abs = Shader.abs+        signum = Shader.sign+        fromInteger = Shader.fromInteger+        negate = Shader.negate++instance Num Shader.GInt where+        (+) = (Shader.+)+        (-) = (Shader.-)+        (*) = (Shader.*)+        abs = Shader.absI+        signum = Shader.signI+        fromInteger = Shader.fromInteger+        negate = Shader.negateI++instance B.NumB Shader.GFloat where+        type IntegerOf Shader.GFloat = Shader.GInt+        fromIntegerB = Shader.float++instance B.NumB Shader.GInt where+        type IntegerOf Shader.GInt = Shader.GInt+        fromIntegerB = id++instance AdditiveGroup Shader.GFloat where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negate++-- | GPU 'mod' that can be used on floats and float vectors.+modG :: Shader.GenType a => a -> a -> a+modG = Shader.mod++instance B.IntegralB Shader.GInt where+        quotRem a b = let q = a Shader./ b in (q, a - b * q)+        -- XXX: ???+        divMod a b = let (q, r) = B.quotRem a b+                         f = 1 - abs (signum r + signum b)+                     in (q - f, r + b * f)+        toIntegerB = id++instance Fractional Shader.GFloat where+        (/) = (Shader./)+        fromRational = Shader.fromRational++instance Floating Shader.GFloat where+        pi = 3.1415926535897932384626433832795+        exp = Shader.exp+        log = Shader.log+        sqrt = Shader.sqrt+        (**) = (Shader.^)+        sin = Shader.sin+        cos = Shader.cos+        tan = Shader.tan+        asin = Shader.asin+        acos = Shader.acos+        atan = Shader.atan+        -- TODO+        sinh = error "Hyperbolic functions are not implemented."+        cosh = error "Hyperbolic functions are not implemented."+        asinh = error "Hyperbolic functions are not implemented."+        acosh = error "Hyperbolic functions are not implemented."+        atanh = error "Hyperbolic functions are not implemented."++floatToInt :: (B.NumB b, B.IntegerOf b ~ Shader.GInt) => Shader.GFloat -> b+floatToInt = B.fromIntegerB . Shader.int++instance B.RealFracB Shader.GFloat where+        properFraction x = let tx = signum x * floorG (abs x)+                           in (floatToInt tx, x - tx)+        -- truncate x = floatToInt $ signum x * floorG (abs x)+        round x = floatToInt . floorG $ x + 0.5+        ceiling = floatToInt . ceilingG+        floor = floatToInt . floorG++floorG :: Shader.GenType a => a -> a+floorG = Shader.floor++ceilingG :: Shader.GenType a => a -> a+ceilingG = Shader.ceil++instance B.RealFloatB Shader.GFloat where+        isNaN = error "isNaN: not supported"+        isInfinite = error "isInfinite: not supported"+        isNegativeZero = error "isNegativeZero: not supported"+        isIEEE = error "isIEEE: not supported"+        atan2 = Shader.atan2++-- Vectors++instance AdditiveGroup Shader.GVec2 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negate++instance VectorSpace Shader.GVec2 where+        type Scalar Shader.GVec2 = Shader.GFloat+        (*^) = (Shader.*)++instance InnerSpace Shader.GVec2 where+        (<.>) = Shader.dot++instance Ext Shader.GVec2 where+        type Extended Shader.GVec2 = Shader.GVec3+        v ^| z = Shader.vec3 $ v # z+        v ^|^ Shader.GVec3 _ _ z = Shader.vec3 $ v # z+        extract = Shader.vec2++instance AdditiveGroup Shader.GVec3 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negate++instance VectorSpace Shader.GVec3 where+        type Scalar Shader.GVec3 = Shader.GFloat+        (*^) = (Shader.*)++instance InnerSpace Shader.GVec3 where+        (<.>) = Shader.dot++instance HasCross3 Shader.GVec3 where+        cross3 = Shader.cross++instance Ext Shader.GVec3 where+        type Extended Shader.GVec3 = Shader.GVec4+        v ^| w = Shader.vec4 $ v # w+        v ^|^ Shader.GVec4 _ _ _ w = Shader.vec4 $ v # w+        extract = Shader.vec3++instance AdditiveGroup Shader.GVec4 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negate++instance VectorSpace Shader.GVec4 where+        type Scalar Shader.GVec4 = Shader.GFloat+        (*^) = (Shader.*)++instance InnerSpace Shader.GVec4 where+        (<.>) = Shader.dot++-- Matrices++instance AdditiveGroup Shader.GMat2 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negateM++instance VectorSpace Shader.GMat2 where+        type Scalar Shader.GMat2 = Shader.GFloat+        (*^) = (Shader.*)++instance AdditiveGroup Shader.GMat3 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negateM++instance Ext Shader.GMat2 where+        type Extended Shader.GMat2 = Shader.GMat3+        v ^| z = Shader.mat3 $ v # z # z # z # z # z+        Shader.GMat2 x y ^|^ Shader.GMat3 x' y' z' =+                Shader.GMat3 (x ^|^ x') (y ^|^ y') z'+        extract = Shader.mat2++instance Matrix Shader.GMat2 where+        type Row Shader.GMat2 = Shader.GVec2+        idmtx = Shader.mat2 (1.0 :: Shader.GFloat)+        (.*.) = (Shader.*)+        (.*) = (Shader.*)+        (*.) = (Shader.*)+        transpose (Shader.GMat2 (Shader.GVec2 a b) (Shader.GVec2 c d)) =+                Shader.GMat2 (Shader.GVec2 a c) (Shader.GVec2 b d)++instance VectorSpace Shader.GMat3 where+        type Scalar Shader.GMat3 = Shader.GFloat+        (*^) = (Shader.*)++instance Ext Shader.GMat3 where+        type Extended Shader.GMat3 = Shader.GMat4+        v ^| z = Shader.mat4 $ v # z # z # z # z # z # z # z+        Shader.GMat3 x y z ^|^ Shader.GMat4 x' y' z' w' =+                Shader.GMat4 (x ^|^ x') (y ^|^ y') (z ^|^ z') w'+        extract = Shader.mat3++instance Matrix Shader.GMat3 where+        type Row Shader.GMat3 = Shader.GVec3+        idmtx = Shader.mat3 (1.0 :: Shader.GFloat)+        (.*.) = (Shader.*)+        (.*) = (Shader.*)+        (*.) = (Shader.*)+        transpose (Shader.GMat3 (Shader.GVec3 a b c)+                                (Shader.GVec3 d e f)+                                (Shader.GVec3 g h i)) =+                        Shader.GMat3 (Shader.GVec3 a d g)+                                     (Shader.GVec3 b e h)+                                     (Shader.GVec3 c f i)++instance AdditiveGroup Shader.GMat4 where+        zeroV = Shader.zero+        (^+^) = (Shader.+)+        (^-^) = (Shader.-)+        negateV = Shader.negateM++instance VectorSpace Shader.GMat4 where+        type Scalar Shader.GMat4 = Shader.GFloat+        (*^) = (Shader.*)++instance Matrix Shader.GMat4 where+        type Row Shader.GMat4 = Shader.GVec4+        idmtx = Shader.mat4 (1.0 :: Shader.GFloat)+        (.*.) = (Shader.*)+        (.*) = (Shader.*)+        (*.) = (Shader.*)+        transpose (Shader.GMat4 (Shader.GVec4 a b c d)+                                (Shader.GVec4 e f g h)+                                (Shader.GVec4 i j k l)+                                (Shader.GVec4 m n o p)) =+                        Shader.GMat4 (Shader.GVec4 a e i m)+                                     (Shader.GVec4 b f j n)+                                     (Shader.GVec4 c g k o)+                                     (Shader.GVec4 d h l p)++type TextureSampler = Shader.GSampler2D++-- | Sample a texel from a texture.+sample :: TextureSampler -> Shader.GVec2 -> Shader.GVec4+sample = Shader.texture2D