ombra 1.0.0.0 → 1.1.0.0

raw patch · 21 files changed

+824/−446 lines, 21 filesdep ~vector-spacePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vector-space

API changes (from Hackage documentation)

Files

• CHANGES.md +10/−0
• Graphics/Rendering/Ombra/Culling/Draw.hs +1/−1
• Graphics/Rendering/Ombra/Draw.hs +12/−6
• Graphics/Rendering/Ombra/Draw/Class.hs +52/−28
• Graphics/Rendering/Ombra/Draw/Monad.hs +129/−81
• Graphics/Rendering/Ombra/Geometry.hs +143/−88
• Graphics/Rendering/Ombra/Geometry/Draw.hs +35/−24
• Graphics/Rendering/Ombra/Geometry/Types.hs +55/−12
• Graphics/Rendering/Ombra/Image.hs +19/−20
• Graphics/Rendering/Ombra/Image/Types.hs +6/−2
• Graphics/Rendering/Ombra/OutBuffer.hs +30/−15
• Graphics/Rendering/Ombra/OutBuffer/Types.hs +46/−35
• Graphics/Rendering/Ombra/Screen.hs +7/−4
• Graphics/Rendering/Ombra/Shader.hs +24/−16
• Graphics/Rendering/Ombra/Shader/CPU.hs +44/−43
• Graphics/Rendering/Ombra/Shader/Language.hs +8/−5
• Graphics/Rendering/Ombra/Shader/Program.hs +13/−7
• Graphics/Rendering/Ombra/Shader/Types.hs +166/−42
• Graphics/Rendering/Ombra/Texture.hs +5/−2
• Graphics/Rendering/Ombra/Texture/Draw.hs +18/−14
• ombra.cabal +1/−1

@@ -0,0 +1,10 @@+## 1.1.0++  * Renamed (~~) to (~<) and (~*) to (~<*)+  * Added sampleTexture = sample+  * Added clearColorWith, clearDepthWith, clearStencilWith+  * Added Point and Line geometries+  * Removed the 't' parameter from GBuffer and DepthBuffer, and added BufferPair+  * Redesigned MonadDrawBuffers+  * resizeViewport can now change the position of the viewport+  * Shader can now be used as a parameter for shaderParam

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

@@ -8,18 +8,23 @@ module Graphics.Rendering.Ombra.Draw (         module Graphics.Rendering.Ombra.OutBuffer,         Draw,-        DrawState,         Ctx,         -- * Running the Draw monad         runDraw,         -- * Draw actions-        MonadDraw(..),-        MonadDrawBuffers(drawBuffers, drawBuffers'),+        MonadDraw( withColorMask+                 , withDepthTest+                 , withDepthMask+                 , clearColor+                 , clearColorWith+                 , clearDepth+                 , clearDepthWith+                 , clearStencil+                 , clearStencilWith+                 ),+        MonadDrawBuffers(..),         MonadRead(..),         MonadScreen(resizeViewport),-        clearColor,-        clearDepth,-        clearStencil,         -- ** Culling         CullFace(..),         MonadCulling(withCulling),@@ -44,6 +49,7 @@ import Graphics.Rendering.Ombra.Shader.Language.Types (GVec4) import Graphics.Rendering.Ombra.Screen +-- | Run a 'Draw' program. runDraw :: GLES         => Int          -- ^ Viewport width         -> Int          -- ^ Viewport height

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}  module Graphics.Rendering.Ombra.Draw.Class (         MonadDraw(..),@@ -11,8 +11,11 @@ import Graphics.Rendering.Ombra.Color import Graphics.Rendering.Ombra.OutBuffer.Types import Graphics.Rendering.Ombra.Geometry.Draw+import Graphics.Rendering.Ombra.Geometry.Types+import Graphics.Rendering.Ombra.Internal.GL (MonadGL) import Graphics.Rendering.Ombra.Texture.Draw import Graphics.Rendering.Ombra.Shader.Program+import Graphics.Rendering.Ombra.Shader.Types import Graphics.Rendering.Ombra.Screen import Graphics.Rendering.Ombra.Vector @@ -22,44 +25,65 @@       , MonadTexture (m o)       , MonadScreen (m o)       ) => MonadDraw o m where+        drawGeometry :: (GeometryVertex g, ElementType e)+                     => Geometry e g+                     -> m o ()+        default drawGeometry :: (MonadGL (m o), GeometryVertex g, ElementType e)+                             => Geometry e g+                             -> m o ()+        drawGeometry = defaultDrawGeometry+        -- | Enable/disable writing to one or more color channels.         withColorMask :: (Bool, Bool, Bool, Bool) -> m o a -> m o a+        -- | Enable/disable depth testing.         withDepthTest :: Bool -> m o a -> m o a+        -- | Enable/disable writing to the depth buffer.         withDepthMask :: Bool -> m o a -> m o a+        -- | Clear the color buffer.+        clearColor :: m o ()+        clearColor = clearColorWith $ Vec4 0 0 0 1+        -- | Clear the color buffer filling it with the given color.+        clearColorWith :: Vec4 -> m o ()+        -- | Clear the depth buffer.+        clearDepth :: m o ()+        clearDepth = clearDepthWith 1+        -- | Clear the depth buffer filling it with the given value.+        clearDepthWith :: Double -> m o ()+        -- | Clear the stencil buffer.+        clearStencil :: m o ()+        clearStencil = clearStencilWith 0+        -- | Clear the stencil buffer filling it with the given value.+        clearStencilWith :: Int -> m o ()  -- | 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+        -- | Create a 'GBuffer' and a 'DepthBuffer' and draw something to them.+        createBuffers :: FragmentShaderOutput o+                      => Int                    -- ^ Width.+                      -> Int                    -- ^ Height.+                      -> 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+                                                -- fragment shader.+                      -> DepthBufferInfo        -- ^ The buffer that contains                                                 -- the depth (and stencil)                                                 -- values.+                      -> m o a                  -- ^ Initializer.+                      -> m o' (a, BufferPair o)+        createGBuffer :: FragmentShaderOutput o+                      => GBufferInfo o+                      -> DepthBuffer+                      -> m o a+                      -> m o' (a, BufferPair o)+        createDepthBuffer :: FragmentShaderOutput o+                          => GBuffer o+                          -> DepthBufferInfo+                          -> m o a+                          -> m o' (a, BufferPair o)+        -- | Draw an image to some buffers.+        drawBuffers :: FragmentShaderOutput o+                    => BufferPair o                     -> 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)+                    -> m o' a  class MonadDraw o m => MonadRead o m where         -- | Read a rectangle of pixel colors from the screen (or texture).

@@ -80,8 +80,8 @@         , geometries :: ResMap LoadedGeometry         , textureImages :: ResMap LoadedTexture         , activeTextures :: Int-        , textureCache :: [LoadedTexture]-        , viewportSize :: (Int, Int)+        -- , textureCache :: [LoadedTexture]+        , viewportSize :: ((Int, Int), (Int, Int))         , blendMode :: Maybe Blend.Mode         , stencilMode :: Maybe Stencil.Mode         , cullFace :: Maybe CullFace@@ -117,8 +117,24 @@         withColorMask m a = stateReset colorMask setColorMask m a         withDepthTest d a = stateReset depthTest setDepthTest d a         withDepthMask m a = stateReset depthMask setDepthMask m a+        clearColor = clearBuffers [ColorBuffer]+        clearColorWith (Vec4 r g b a) = gl $ do GL.clearColor (realToFrac r)+                                                              (realToFrac g)+                                                              (realToFrac b)+                                                              (realToFrac a)+                                                clearBuffers [ColorBuffer]+                                                GL.clearColor 0.0 0.0 0.0 1.0+        clearDepth = clearBuffers [DepthBuffer]+        clearDepthWith value = gl $ do GL.clearDepth $ realToFrac value+                                       clearBuffers [DepthBuffer]+                                       GL.clearDepth 1+        clearStencil = clearBuffers [StencilBuffer]+        clearStencilWith value = gl $ do GL.clearStencil $ fromIntegral value+                                         clearBuffers [StencilBuffer]+                                         GL.clearStencil 0  instance GLES => MonadDrawBuffers Draw where+        {-         drawBuffers w h gBuffer depthBuffer draw cont =                 do (ret, (newGBuffer, gBuffer'), (newDepthBuffer, depthBuffer'))                         <- permanentDrawBuffers w h gBuffer depthBuffer draw@@ -126,17 +142,41 @@                    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)+        -}+        createBuffers w h gBufferInfo depthBufferInfo draw =+                do (ret, gBuffer, depthBuffer) <-+                        drawBuffers' w h+                                     True+                                     (Right gBufferInfo)+                                     (Right depthBufferInfo)+                                     draw+                   return (ret, BufferPair gBuffer depthBuffer)+        createGBuffer gBufferInfo depthBuffer draw =+                do let (w, h) = bufferSize depthBuffer+                   (ret, gBuffer, _) <-+                        drawBuffers' w h+                                     True+                                     (Right gBufferInfo)+                                     (Left depthBuffer)+                                     draw+                   return (ret, BufferPair gBuffer depthBuffer)+        createDepthBuffer gBuffer depthBufferInfo draw =+                do let (w, h) = bufferSize gBuffer+                   (ret, _, depthBuffer) <-+                        drawBuffers' w h+                                     True+                                     (Left gBuffer)+                                     (Right depthBufferInfo)+                                     draw+                   return (ret, BufferPair gBuffer depthBuffer)+        drawBuffers (BufferPair gBuffer depthBuffer) draw =+                do let (w, h) = bufferSize gBuffer+                   (ret, _, _) <- drawBuffers' w h+                                               True+                                               (Left gBuffer)+                                               (Left depthBuffer)+                                               draw+                   return ret  instance GLES => MonadRead GVec4 Draw where         readColor = flip readPixels gl_RGBA@@ -147,24 +187,12 @@  instance GLES => MonadScreen (Draw o) where         currentViewport = viewportSize <$> Draw get-        resizeViewport w h = do setViewport w h+        resizeViewport p w = do setViewport p w                                 Draw . modify $ \s ->-                                        s { viewportSize = (w, h) }-+                                        s { viewportSize = (p, w) } 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 ()+        setProgram p = withProgram p $ \(LoadedProgram glp _ _) ->+                                                gl $ useProgram glp         getUniform id = do mprg <- loadedProgram <$> Draw get                            case mprg of                                 Just prg -> do map <- uniforms <$> Draw get@@ -185,10 +213,15 @@ 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 }+        withActiveTextures =+                defaultWithActiveTextures (activeTextures <$> Draw get)+                                          (\n -> Draw . modify  $ \s ->+                                                s { activeTextures = n })         newTexture w h params i initialize =+                gl $ do t <- emptyTexture params+                        initialize t+                        return $ LoadedTexture w' h' i t+                {-                 do cache <- textureCache <$> Draw get                    let (c1, c2) = flip break cache $                                         \(LoadedTexture cw ch i' t) ->@@ -200,13 +233,16 @@                         (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@@ -224,9 +260,9 @@ drawState w h = DrawState { currentFrameBuffer = noFramebuffer                           , currentProgram = Nothing                           , loadedProgram = Nothing-                          , textureCache = []+                          -- , textureCache = []                           , activeTextures = 0-                          , viewportSize = (w, h)+                          , viewportSize = ((0, 0), (w, h))                           , blendMode = Nothing                           , depthTest = True                           , depthMask = True@@ -251,11 +287,14 @@               uniforms <- liftIO newResMap               textureImages <- liftIO newResMap -              (w, h) <- viewportSize <$> Draw get+              ((x, y), (w, h)) <- viewportSize <$> Draw get               gl $ do GL.clearColor 0.0 0.0 0.0 1.0+                      GL.clearDepth 1+                      GL.clearStencil 0                       enable gl_DEPTH_TEST                       depthFunc gl_LESS-                      viewport 0 0 (fromIntegral w) (fromIntegral h)+                      viewport (fromIntegral x) (fromIntegral y)+                               (fromIntegral w) (fromIntegral h)                Draw . modify $ \s -> s { programs = programs                                       , elemBuffers = elemBuffers@@ -296,8 +335,8 @@  -- | Manually allocate a 'Geometry' in the GPU. Eventually returns an error -- string.-preloadGeometry :: (GLES, GeometryVertex g)-                => Geometry g+preloadGeometry :: (GLES, GeometryVertex g, ElementType e)+                => Geometry e g                 -> Draw o (Maybe String) preloadGeometry g = left <$> getGeometry g @@ -310,7 +349,9 @@ preloadProgram p = left <$> getProgram p  -- | Manually delete a 'Geometry' from the GPU.-removeGeometry :: (GLES, GeometryVertex g) => Geometry g -> Draw o ()+removeGeometry :: (GLES, GeometryVertex g, ElementType e)+               => Geometry e g+               -> Draw o () removeGeometry g = removeDrawResource id geometries g  -- | Manually delete a 'Texture' from the GPU.@@ -324,8 +365,8 @@ removeProgram = removeDrawResource gl programs  -- | Check if a 'Geometry' failed to load.-checkGeometry :: (GLES, GeometryVertex g)-              => Geometry g+checkGeometry :: (GLES, GeometryVertex g, ElementType e)+              => Geometry e g               -> Draw o (ResStatus ()) checkGeometry g = fmap (const ()) <$> checkDrawResource id geometries g @@ -361,6 +402,21 @@ getProgram :: GLES => Program gs is -> Draw o (Either String LoadedProgram) getProgram = getDrawResource' gl programs Nothing +withProgram :: GLES => Program i o -> (LoadedProgram -> Draw x ()) -> Draw x ()+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 err -> error err+ setBlendMode :: GLES => Maybe Blend.Mode -> Draw o () setBlendMode Nothing = do m <- blendMode <$> Draw get                           case m of@@ -503,29 +559,17 @@ 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)+createOutBuffer :: forall m o. (GLES, MonadTexture m)                 => Int                 -> Int                 -> OutBufferInfo o-                -> m (OutBuffer t' o)+                -> m (OutBuffer o) createOutBuffer w h empty =          do let loader t = do bindTexture gl_TEXTURE_2D t                              if pixelType == gl_FLOAT@@ -541,12 +585,12 @@            textures <- replicateM (fromIntegral texNum)                                   (newTexture w h params cacheIdentifier loader)            return $ case empty of-                         EmptyFloatGBuffer _ -> TextureFloatGBuffer textures-                         EmptyByteGBuffer _ -> TextureByteGBuffer textures+                         EmptyFloatGBuffer _ -> TextureFloatGBuffer w h textures+                         EmptyByteGBuffer _ -> TextureByteGBuffer w h textures                          EmptyDepthBuffer _ ->-                                 TextureDepthBuffer $ head textures+                                 TextureDepthBuffer w h $ head textures                          EmptyDepthStencilBuffer _ ->-                                 TextureDepthStencilBuffer $ head textures+                                 TextureDepthStencilBuffer w h $ head textures         where (w', h') = (fromIntegral w, fromIntegral h)               cacheIdentifier = hash ( fromIntegral internalFormat :: Int                                      , fromIntegral format :: Int@@ -584,40 +628,43 @@                                    , 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 =+drawBuffers' :: (GLES, FragmentShaderOutput o)+             => Int+             -> Int+             -> Bool+             -> Either (GBuffer o) (GBufferInfo o)+             -> Either DepthBuffer DepthBufferInfo+             -> Draw o a+             -> Draw o' (a, GBuffer o, DepthBuffer)+drawBuffers' w h addUnloader gBuffer depthBuffer draw =         do (newColor, gBuffer') <-                 case gBuffer of                      Right b -> (,) True <$> createOutBuffer w h b-                     Left b -> return (False, castBuffer b)+                     Left b -> return (False, 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)+                     Left b -> return (False, False, b)            ret <- drawUsedBuffers w h gBuffer' depthBuffer' $                    do when newColor clearColor                       when newDepth clearDepth                       when shouldClearStencil clearStencil                       draw-           return (ret, (newColor, gBuffer'), (newDepth, depthBuffer'))+           gl $ do when (addUnloader && newColor) $ bufferUnloader gBuffer'+                   when (addUnloader && newDepth) $ bufferUnloader depthBuffer'+           return (ret, gBuffer', depthBuffer')+        where bufferUnloader buf = +                        mapM_ (unloader buf (Nothing :: Maybe TextureImage))+                              (textures buf)  drawUsedBuffers :: GLES                 => Int                 -> Int-                -> GBuffer t o-                -> DepthBuffer t1+                -> GBuffer o+                -> DepthBuffer                 -> Draw o a                 -> Draw o' a drawUsedBuffers w h gBuffer depthBuffer draw =@@ -634,13 +681,14 @@                                          [0 ..]               depthAttachment =                       case depthBuffer of-                           TextureDepthBuffer (LoadedTexture _ _ _ t) ->+                           TextureDepthBuffer _ _ (LoadedTexture _ _ _ t) ->                                 (t, gl_DEPTH_ATTACHMENT)-                           TextureDepthStencilBuffer (LoadedTexture _ _ _ t) ->+                           TextureDepthStencilBuffer _ _ (LoadedTexture _ _ _ t) ->                                 (t, gl_DEPTH_STENCIL_ATTACHMENT)               attachments = depthAttachment : colorAttachments               useDrawBuffers | (_ : _ : _) <- colorAttachments = True-                              | otherwise = False+                             | otherwise = False+ drawToTextures :: (GLES, MonadScreen m, MonadGL m)                => Bool                -> [(GL.Texture, GLEnum)]@@ -668,12 +716,12 @@            when useDrawBuffers $                    liftIO (encodeInts buffersToDraw) >>= gl . GL.drawBuffers -           (sw, sh) <- currentViewport-           resizeViewport (fromIntegral w) (fromIntegral h)+           (sp, ss) <- currentViewport+           resizeViewport (0, 0) (fromIntegral w, fromIntegral h)             ret <- draw fb -           resizeViewport sw sh+           resizeViewport sp ss            gl $ do deleteFramebuffer fb                    bindFramebuffer gl_FRAMEBUFFER oldFb 

@@ -12,9 +12,12 @@  module Graphics.Rendering.Ombra.Geometry (         Geometry,+        Point(..),+        Line(..),         Triangle(..),         mkGeometry,         mapVertices,+        foldGeometry,         decompose,         -- * Geometry builder         Attributes,@@ -22,15 +25,18 @@         GeometryBuilder,         GeometryBuilderT,         vertex,+        point,+        line,         triangle,         buildGeometry,         buildGeometryT,         -- *-        GeometryVertex(..)+        GeometryVertex(..),+        ElementType ) where  import Control.Monad.Trans.State-import Data.Foldable (foldlM)+import Data.Foldable (toList, foldlM, foldrM) import qualified Data.Hashable as H import qualified Data.HashMap.Lazy as H import Data.List (foldl')@@ -43,29 +49,29 @@ import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Vector -rehashGeometry :: Geometry g -> Geometry g-rehashGeometry g = let Triangles elemsHash _ = elements g+rehashGeometry :: Geometry e g -> Geometry e g+rehashGeometry g = let Elements elemsHash _ = elements g                    in g { geometryHash = H.hashWithSalt (topHash g) elemsHash } -emptyGeometry :: GeometryVertex g => Geometry g-emptyGeometry = rehashGeometry $ Geometry 0 0 emptyAttrCol (Triangles 0 []) (-1)+emptyGeometry :: GeometryVertex g => Geometry e g+emptyGeometry = rehashGeometry $ Geometry 0 0 emptyAttrCol (Elements 0 []) (-1) -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+foldAttrVertices :: NotTop p+                 => (AttrVertex is -> b -> b)+                 -> b+                 -> AttrTable p is+                 -> (Int, b)+foldAttrVertices f acc AttrEnd = (-1, acc)+foldAttrVertices f acc cell@(AttrCell _ _ down) =+        let (didx, acc') = foldAttrVertices f acc down             idx = didx + 1             widx = fromIntegral idx         in (idx, f (AttrVertex widx cell) acc')  addVertex :: GeometryVertex g           => VertexAttributes (AttributeTypes g)-          -> Geometry g-          -> (AttrVertex (AttributeTypes g), Geometry g)+          -> Geometry e g+          -> (AttrVertex (AttributeTypes g), Geometry e g) addVertex v g =         let top' = addTop v $ top g             topHash = H.hash top'@@ -79,51 +85,73 @@                                 }            ) -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)+addElement :: (GeometryVertex g, H.Hashable (e (AttrVertex (AttributeTypes g))))+           => e (AttrVertex (AttributeTypes g))+           -> Geometry e g+           -> Geometry e g+addElement t g = let Elements h ts = elements g+                     elements' = Elements (H.hashWithSalt (H.hash t) h)+                                          (t : ts)                   in rehashGeometry $ g { elements = elements' } --- | Create a new vertex that can be used in 'addTriangle'.+-- | Create a new vertex that can be used in 'triangle', 'line' and 'point'. vertex :: (Monad m, GeometryVertex g)        => Vertex g-       -> GeometryBuilderT g m (AttrVertex (AttributeTypes g))+       -> GeometryBuilderT e g m (AttrVertex (AttributeTypes g)) vertex = GeometryBuilderT . state . addVertex . toVertexAttributes +-- | Add a point to the current geometry.+point :: (Monad m, GeometryVertex g)+      => AttrVertex (AttributeTypes g)+      -> GeometryBuilderT Point g m ()+point x = GeometryBuilderT . state $ \g -> ((), addElement (Point x) g)++-- | Add a line to the current geometry.+line :: (Monad m, GeometryVertex g)+     => AttrVertex (AttributeTypes g)+     -> AttrVertex (AttributeTypes g)+     -> GeometryBuilderT Line g m ()+line x y = GeometryBuilderT . state $ \g -> ((), addElement t g)+        where t = Line x y+ -- | 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)+         -> GeometryBuilderT Triangle g m ()+triangle x y z = GeometryBuilderT . state $ \g -> ((), addElement t g)         where t = Triangle x y z  -- | Create a 'Geometry' using the 'GeometryBuilder' monad. This is more -- efficient than 'mkGeometry'.-buildGeometry :: GeometryVertex g => GeometryBuilder g () -> Geometry g+buildGeometry :: GeometryVertex g => GeometryBuilder e g () -> Geometry e g buildGeometry (GeometryBuilderT m) = execState m emptyGeometry  buildGeometryT :: (Monad m, GeometryVertex g)-               => GeometryBuilderT g m ()-               -> m (Geometry g)+               => GeometryBuilderT e g m ()+               -> m (Geometry e g) buildGeometryT (GeometryBuilderT m) = execStateT m emptyGeometry --- | Create a 'Geometry' using a list of triangles.-mkGeometry :: (GLES, GeometryVertex g)-           => [Triangle (Vertex g)]-           -> Geometry g+-- | Create a 'Geometry' using a list of points, lines or triangles.+mkGeometry :: ( GLES+              , GeometryVertex g+              , ElementType e+              , H.Hashable (e (AttrVertex (AttributeTypes g)))+              )+           => [e (Vertex g)]    -- ^ List of elements.+           -> Geometry e 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+        where add verts e =+                do vsavs <- foldrM (\v (verts, avs) ->+                                        do let attrs = toVertexAttributes v+                                           (verts', av) <- mvertex verts attrs+                                           return (verts', av : avs))+                                   (verts, [])+                                   e+                   let ae = elementFromList $ snd vsavs+                   GeometryBuilderT . state $ \g -> ((), addElement ae g)+                   return $ fst vsavs               mvertex vertices v =                 case H.lookup v vertices of                      Just av -> return (vertices, av)@@ -133,57 +161,84 @@ 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)+-- | Convert a 'Geometry' back to a list of elements.+decompose :: (GeometryVertex g, Functor e) => Geometry e g -> [e (Vertex g)] +decompose g@(Geometry _ _ _ (Elements _ elems) _) =+        flip map elems $ 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)+-- | Transform each vertex of a geometry.+mapVertices :: (GLES, GeometryVertex g, GeometryVertex g', ElementType e)+            => (e (Vertex g) -> a)            -- ^ Value to associate to each+                                              -- element.+            -> ([a] -> Vertex g -> Vertex g') -- ^ The first argument is the+                                              -- list of values associated with+                                              -- the elements the vertex belongs+                                              -- to.+            -> Geometry e g+            -> Geometry e g'+mapVertices valf f = +        let addValue elem valMap = let val = valf $ fmap ( fromVertexAttributes+                                                         . attrVertexToVertex+                                                         ) elem+                                   in foldr (flip (H.insertWith (++)) [val])+                                            valMap+                                            (toList elem)+            mapVertex valMap avert _ = let attrs = attrVertexToVertex avert+                                           vert = fromVertexAttributes attrs+                                           vert' = f (valMap H.! avert) vert+                                           attrs' = toVertexAttributes vert'+                                       in ((), attrs')+        in snd . modifyVertices addValue mapVertex H.empty () -            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+-- | Fold elements and then vertices.+foldGeometry :: forall g e vacc eacc. (GLES, GeometryVertex g, ElementType e)+             => (e (Vertex g) -> eacc -> eacc)+             -> (eacc -> Vertex g -> vacc -> vacc)+             -> eacc+             -> vacc+             -> Geometry e g+             -> (eacc, vacc)+foldGeometry ef vf eacc vacc g =+        let accElems e = ef $ fmap (fromVertexAttributes . attrVertexToVertex) e+            accVerts eacc av vacc = let v = attrVertexToVertex av+                                        vacc' = vf eacc+                                                   (fromVertexAttributes v)+                                                   vacc+                                    in (vacc', v)+            (accs', _) = modifyVertices accElems accVerts eacc vacc g+                                :: ((eacc, vacc), Geometry e g)+        in accs'++-- | Fold triangles, then map and fold vertices using the previously accumulated+-- value.+modifyVertices :: forall e eacc vacc g g'.+                  (GLES, GeometryVertex g, GeometryVertex g', ElementType e)+               => (e (AttrVertex (AttributeTypes g)) -> eacc -> eacc)+               -> (   eacc+                   -> AttrVertex (AttributeTypes g)+                   -> vacc+                   -> (vacc, VertexAttributes (AttributeTypes g'))+                  )+               -> eacc+               -> vacc+               -> Geometry e g+               -> ((eacc, vacc), Geometry e g')+modifyVertices ef vf eacc vacc+               (Geometry _ _ (AttrTop _ _ row0) (Elements thash elems) _) =+        let accElem vertMap elem (eacc, elems) =+                    (ef elem eacc, fmap (vertMap H.!) elem : elems)+            accVertex eacc avert (vertMap, vacc, (geom :: Geometry e g')) =+                    let (vacc', attrs') = vf eacc avert vacc+                        (avert', geom') = addVertex attrs' geom                         vertMap' = H.insert avert avert' vertMap-                    in (vertMap', geom')+                    in (vertMap', vacc', 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'+            (eacc', elems') = foldr (accElem vertMap) (eacc, []) elems+            (_, (vertMap, vacc', Geometry tophash' _ top' _ lidx)) =+                    foldAttrVertices (accVertex eacc')+                                     (H.empty, vacc, emptyGeometry)+                                     row0+            geom' = Geometry tophash' 0 top' (Elements thash elems') lidx+        in ((eacc', vacc'), rehashGeometry geom')

@@ -7,13 +7,14 @@         LoadedBuffer,         LoadedAttribute,         LoadedGeometry(..),-        drawGeometry+        defaultDrawGeometry ) where  import Control.Monad.Trans.Control import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except import Control.Monad.Trans.State+import Data.Foldable (toList) import Data.Proxy  import Graphics.Rendering.Ombra.Geometry.Types@@ -22,18 +23,18 @@ import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Shader.Language.Types (ShaderType(size)) -class (GLES, MonadGL m) => MonadGeometry m where+class (GLES, Monad 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+        getElementBuffer :: ElementType e+                         => Elements e is+                         -> m (Either String LoadedBuffer)+        getGeometry :: (GeometryVertex g, ElementType e)+                    => Geometry e g                     -> m (Either String LoadedGeometry) - data LoadedGeometry = LoadedGeometry {-        -- elementType :: GLEnum,         elementCount :: Int,         vao :: VertexArrayObject }@@ -51,26 +52,28 @@                            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)+                               set = setBaseAttribute (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) >>=+instance (GLES, ElementType e) => Resource (Elements e is) LoadedBuffer GL where+        loadResource (Elements _ es) =+                liftIO (encodeUInt16s $ es >>= map idx . toList) >>=                         fmap (Right . LoadedBuffer) .                         loadBuffer gl_ELEMENT_ARRAY_BUFFER                         . fromUInt16Array-                where elems = ts >>= ids-                      ids (Triangle (AttrVertex x _)-                                    (AttrVertex y _)-                                    (AttrVertex z _)) = [x, y, z]+                where idx (AttrVertex i _) = i         unloadResource _ (LoadedBuffer buf) = deleteBuffer buf -instance (GLES, MonadGeometry m, MonadBaseControl IO m, GeometryVertex g) =>-        Resource (Geometry g) LoadedGeometry m where+instance ( MonadGeometry m+         , MonadGL m+         , MonadBaseControl IO m+         , GeometryVertex g+         , ElementType e+         ) =>+        Resource (Geometry e g) LoadedGeometry m where         loadResource = loadGeometry         unloadResource _ = gl . deleteGeometry @@ -78,8 +81,8 @@ downList AttrEnd xs = xs downList (AttrCell x _ down) xs = downList down $ x : xs -loadGeometry :: (GLES, MonadGeometry m, GeometryVertex g)-             => Geometry g+loadGeometry :: (MonadGeometry m, MonadGL m, GeometryVertex g, ElementType e)+             => Geometry e g              -> m (Either String LoadedGeometry) loadGeometry geometry@(Geometry _ _ _ _ _) = runExceptT $         do vao <- lift $ gl createVertexArray@@ -94,9 +97,10 @@                           bindBuffer gl_ARRAY_BUFFER noBuffer             return $ LoadedGeometry (elementCount $ elements geometry) vao-        where elementCount (Triangles _ ts) = 3 * length ts+        where elementCount (Elements _ ts) =+                length (head ts) * length ts -setAttrTop :: (GLES, MonadGeometry m, Attributes is)+setAttrTop :: (GLES, MonadGeometry m, MonadGL m, Attributes is)            => GLUInt            -> AttrCol is            -> m (Either String ())@@ -124,13 +128,20 @@            bindBuffer ty noBuffer            return buffer -drawGeometry :: (MonadGeometry m, GeometryVertex g) => Geometry g -> m ()-drawGeometry g = getGeometry g >>= \eg ->+defaultDrawGeometry :: forall e m g.+                       ( MonadGeometry m+                       , MonadGL m+                       , GeometryVertex g+                       , ElementType e+                       )+                    => Geometry e g+                    -> m ()+defaultDrawGeometry g = getGeometry g >>= \eg ->         case eg of              Left _ -> return ()              Right (LoadedGeometry ec vao) ->                      gl $ do bindVertexArray vao-                             drawElements gl_TRIANGLES+                             drawElements (elementType (Proxy :: Proxy e))                                           (fromIntegral ec)                                           gl_UNSIGNED_SHORT                                           nullGLPtr

@@ -8,6 +8,9 @@         GeometryVertex(..),         GGeometryVertex(..),         VertexAttributes(..),+        ElementType(..),+        Point(..),+        Line(..),         Triangle(..),         AttrTable(..),         AttrCol,@@ -34,6 +37,7 @@  import Graphics.Rendering.Ombra.Backend (GLES) import Graphics.Rendering.Ombra.Internal.TList+import Graphics.Rendering.Ombra.Internal.GL import Graphics.Rendering.Ombra.Shader.CPU import Graphics.Rendering.Ombra.Shader.Language.Types import Graphics.Rendering.Ombra.Vector@@ -75,6 +79,24 @@         fromVertexAttributes =                 to . gfromVertexAttributes (Proxy :: Proxy (Rep a)) +class (Functor e, Foldable e) => ElementType e where+        elementType :: GLES => proxy e -> GLEnum+        elementFromList :: [a] -> e a++instance ElementType Point where+        elementType _ = gl_POINTS+        elementFromList [x] = Point x++instance ElementType Line where+        elementType _ = gl_LINES+        elementFromList [x, y] = Line x y++instance ElementType Triangle where+        elementType _ = gl_TRIANGLES+        elementFromList [x, y, z] = Triangle x y z++data Point a = Point a+data Line a = Line a a data Triangle a = Triangle a a a  -- TODO: use AttrTable rows instead@@ -88,22 +110,22 @@  infixr 5 :~ -data Elements is = Triangles Int [Triangle (AttrVertex is)]+data Elements e is = Elements Int [e (AttrVertex is)]  -- | A set of triangles.-data Geometry g where+data Geometry e g where         Geometry :: { topHash :: Int            -- TODO: ?                     , geometryHash :: Int       -- TODO: ?                     , top :: AttrCol (AttributeTypes g)-                    , elements :: Elements (AttributeTypes g)+                    , elements :: Elements e (AttributeTypes g)                     , lastIndex :: Int                     }-                 -> Geometry g+                 -> Geometry e g -newtype GeometryBuilderT g m a = GeometryBuilderT (StateT (Geometry g) m a)+newtype GeometryBuilderT e g m a = GeometryBuilderT (StateT (Geometry e g) m a)         deriving (Functor, Applicative, Monad, MonadTrans) -type GeometryBuilder g = GeometryBuilderT g Identity+type GeometryBuilder e g = GeometryBuilderT e g Identity  -- | A vertex in a 'Geometry'. data AttrVertex (is :: [*]) where@@ -177,6 +199,12 @@         rowToVertexAttributes (AttrCell x next _) =                 Attr x :~ rowToVertexAttributes next +instance Functor Point where+        fmap f (Point x) = Point (f x)++instance Functor Line where+        fmap f (Line x y) = Line (f x) (f y)+ instance Functor Triangle where         fmap f (Triangle x y z) = Triangle (f x) (f y) (f z) @@ -188,20 +216,35 @@         (Attr x) == (Attr x') = x == x'         (Attr x :~ v) == (Attr x' :~ v') = x == x' && v == v' +instance H.Hashable a => H.Hashable (Point a) where+        hashWithSalt salt (Point x) = H.hashWithSalt salt x++instance H.Hashable a => H.Hashable (Line a) where+        hashWithSalt salt (Line x y) = H.hashWithSalt salt (x, y)+ instance H.Hashable a => H.Hashable (Triangle a) where         hashWithSalt salt (Triangle x y z) = H.hashWithSalt salt (x, y, z) -instance Eq (Geometry is) where+instance Foldable Point where+        foldr f s (Point x) = f x s++instance Foldable Line where+        foldr f s (Line x y) = f x $ f y s++instance Foldable Triangle where+        foldr f s (Triangle x y z) = f x $ f y $ f z s++instance Eq (Geometry e is) where         g == g' = geometryHash g == geometryHash g' -instance H.Hashable (Geometry is) where+instance H.Hashable (Geometry e is) where         hashWithSalt salt = H.hashWithSalt salt . geometryHash -instance H.Hashable (Elements is) where-        hashWithSalt salt (Triangles h _) = H.hashWithSalt salt h+instance H.Hashable (Elements e is) where+        hashWithSalt salt (Elements h _) = H.hashWithSalt salt h -instance Eq (Elements is) where-        (Triangles h _) == (Triangles h' _) = h == h'+instance Eq (Elements e is) where+        (Elements h _) == (Elements h' _) = h == h'  instance H.Hashable (AttrVertex is) where         hashWithSalt salt (AttrVertex i _) = H.hashWithSalt salt i

@@ -22,20 +22,25 @@ import Graphics.Rendering.Ombra.Texture.Draw  -- | Create an 'Image'.-image :: (ShaderInput i, GeometryVertex i, ShaderInput v)+image :: (ShaderInput i, GeometryVertex i, ElementType e, ShaderInput v)       => VertexShader i (GVec4, v)       -> FragmentShader v o-      -> Geometry i+      -> Geometry e 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)+uimage :: ( ShaderInput i+          , GeometryVertex i+          , ElementType e+          , ShaderInput v+          , Foldable t+          )        => (UniformSetter vu -> VertexShader i (GVec4, v))        -> (UniformSetter fu -> FragmentShader v o)-       -> t (Geometry i, vu, fu)+       -> t (Geometry e i, vu, fu)        -> Image o uimage vs fs g = Image g vs fs @@ -51,24 +56,18 @@                     unis = unisv ++ unisf                     texs = texsv ++ texsf                 in withActiveTextures texs (const $ return ()) $ \samplers ->-                        withUniforms unis-                                     (zip texs samplers)-                                     (drawGeometry geometry)+                        do setUniforms unis $ zip texs samplers+                           drawGeometry geometry                      -        where withUniforms unis texs a = (>> a) .+        where setUniforms unis texs =                 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 ()+                        case uniformValue of+                             UniformValue proxy value ->+                                setUniform uid proxy value+                             UniformTexture tex ->+                                let proxy = Proxy :: Proxy TextureSampler+                                    Just value = lookup tex texs+                                in setUniform uid proxy value  draw (SeqImage i i') = draw i >> draw i' draw NoImage = return ()

@@ -9,8 +9,12 @@ import Graphics.Rendering.Ombra.Shader  data Image o where-       Image :: (ShaderInput i, ShaderInput v, Foldable t, GeometryVertex i)-             => t (Geometry i, vu, fu)+       Image :: ( ShaderInput i+                , ShaderInput v+                , Foldable t+                , GeometryVertex i+                , ElementType e)+             => t (Geometry e i, vu, fu)              -> (UniformSetter vu -> VertexShader i (GVec4, v))              -> (UniformSetter fu -> FragmentShader v o)              -> Image o

@@ -3,16 +3,21 @@ module Graphics.Rendering.Ombra.OutBuffer (         GBuffer,         DepthBuffer,+        BufferPair,         GBufferInfo,         DepthBufferInfo,         GBufferSampler,         DepthBufferSampler,         sampleGBuffer,         sampleDepthBuffer,-        floatGBuffer,-        byteGBuffer,+        floatGBufferInfo,+        byteGBufferInfo,+        depthBufferInfo,+        depthStencilBufferInfo,+        bufferPair,+        gBuffer,         depthBuffer,-        depthStencilBuffer,+        bufferSize,         -- * Conversion between buffers and textures         toTextureSampler,         fromTextureSampler@@ -23,30 +28,40 @@ import Graphics.Rendering.Ombra.Shader.Types import Graphics.Rendering.Ombra.Texture.Types +bufferPair :: GBuffer o -> DepthBuffer -> Maybe (BufferPair o)+bufferPair g d | bufferSize g == bufferSize d = Just $ BufferPair g d+               | otherwise = Nothing++gBuffer :: BufferPair o -> GBuffer o+gBuffer (BufferPair buf _) = buf++depthBuffer :: BufferPair o -> DepthBuffer+depthBuffer (BufferPair _ buf) = buf+ -- | Sample a value from a 'GBufferSampler'.-sampleGBuffer :: GBufferSampler t o -> GVec2 -> o+sampleGBuffer :: GBufferSampler 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 -> GVec2 -> GFloat sampleDepthBuffer (DepthBufferSampler sampler) st =         let GVec4 x _ _ _ = sample sampler st in x -fromTextureSampler :: TextureSampler -> GBufferSampler t GVec4+fromTextureSampler :: TextureSampler -> GBufferSampler GVec4 fromTextureSampler sampler = GBufferSampler [sampler] -toTextureSampler :: GBufferSampler t GVec4 -> TextureSampler+toTextureSampler :: GBufferSampler GVec4 -> TextureSampler toTextureSampler (GBufferSampler (sampler : _)) = sampler -floatGBuffer :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o-floatGBuffer = EmptyFloatGBuffer+floatGBufferInfo :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o+floatGBufferInfo = EmptyFloatGBuffer -byteGBuffer :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o-byteGBuffer = EmptyByteGBuffer+byteGBufferInfo :: FragmentShaderOutput o => TextureParameters -> GBufferInfo o+byteGBufferInfo = EmptyByteGBuffer -depthBuffer :: TextureParameters -> DepthBufferInfo-depthBuffer = EmptyDepthBuffer+depthBufferInfo :: TextureParameters -> DepthBufferInfo+depthBufferInfo = EmptyDepthBuffer -depthStencilBuffer :: TextureParameters -> DepthBufferInfo-depthStencilBuffer = EmptyDepthStencilBuffer+depthStencilBufferInfo :: TextureParameters -> DepthBufferInfo+depthStencilBufferInfo = EmptyDepthStencilBuffer

@@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeFamilies,-             ScopedTypeVariables #-}+             ScopedTypeVariables, UndecidableInstances #-}  module Graphics.Rendering.Ombra.OutBuffer.Types where @@ -9,10 +9,10 @@ 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]+data GBufferSampler o = FragmentShaderOutput o => GBufferSampler [GSampler2D]  -- | A GPU object that can be used to retrieve data from a 'DepthBuffer'.-newtype DepthBufferSampler t = DepthBufferSampler GSampler2D+newtype DepthBufferSampler = DepthBufferSampler GSampler2D  data OutDepthBuffer @@ -31,70 +31,81 @@         EmptyDepthStencilBuffer         :: TextureParameters                                         -> OutBufferInfo OutDepthBuffer -data OutBuffer t o where+data OutBuffer o where         TextureFloatGBuffer             :: FragmentShaderOutput o-                                        => [LoadedTexture]-                                        -> OutBuffer t o+                                        => Int+                                        -> Int+                                        -> [LoadedTexture]+                                        -> OutBuffer o          TextureByteGBuffer              :: FragmentShaderOutput o-                                        => [LoadedTexture]-                                        -> OutBuffer t o+                                        => Int+                                        -> Int+                                        -> [LoadedTexture]+                                        -> OutBuffer o -        TextureDepthBuffer              :: LoadedTexture-                                        -> OutBuffer t OutDepthBuffer+        TextureDepthBuffer              :: Int+                                        -> Int+                                        -> LoadedTexture+                                        -> OutBuffer OutDepthBuffer -        TextureDepthStencilBuffer       :: LoadedTexture-                                        -> OutBuffer t OutDepthBuffer+        TextureDepthStencilBuffer       :: Int+                                        -> Int+                                        -> LoadedTexture+                                        -> OutBuffer OutDepthBuffer -instance FragmentShaderOutput o => MultiShaderType (GBufferSampler t o) where-        type ExprMST (GBufferSampler t o) = [ExprMST GSampler2D]+-- | A 'GBuffer' and a 'DepthBuffer' of the same size.+data BufferPair o = BufferPair (GBuffer o) DepthBuffer++instance FragmentShaderOutput o => MultiShaderType (GBufferSampler o) where+        type ExprMST (GBufferSampler 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+instance FragmentShaderOutput o => ShaderInput (GBufferSampler o) where         buildMST f i = (GBufferSampler $ take n infiniteSamplers, i + n)                 where n = textureCount (Proxy :: Proxy o)                       infiniteSamplers = map f [i ..]+        foldrMST f s (GBufferSampler x) = foldr f s x -instance FragmentShaderOutput o => Uniform (GBufferSampler t o) where-        type CPUUniform (GBufferSampler t o) = GBuffer t o+instance FragmentShaderOutput o => Uniform (GBufferSampler o) where+        type CPUUniform (GBufferSampler o) = GBuffer 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+instance MultiShaderType DepthBufferSampler where+        type ExprMST DepthBufferSampler = 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+instance ShaderInput DepthBufferSampler where         buildMST f i = (DepthBufferSampler $ f i, i + 1)+        foldrMST f s (DepthBufferSampler x) = foldrMST f s x -instance Uniform (DepthBufferSampler t) where-        type CPUUniform (DepthBufferSampler t) = DepthBuffer t+instance Uniform DepthBufferSampler where+        type CPUUniform DepthBufferSampler = DepthBuffer         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 DepthBuffer = OutBuffer 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]+textures :: OutBuffer 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+bufferSize :: OutBuffer o -> (Int, Int)+bufferSize (TextureFloatGBuffer w h _) = (w, h)+bufferSize (TextureByteGBuffer w h _) = (w, h)+bufferSize (TextureDepthBuffer w h _) = (w, h)+bufferSize (TextureDepthStencilBuffer w h _) = (w, h)

@@ -6,9 +6,12 @@ import Graphics.Rendering.Ombra.Internal.GL  class (GLES, Monad m) => MonadScreen m where-        currentViewport :: m (Int, Int)+        currentViewport :: m ((Int, Int), (Int, Int))         -- | Resize the drawing space.-        resizeViewport :: Int -> Int -> m ()+        resizeViewport :: (Int, Int)    -- ^ (x, y)+                       -> (Int, Int)    -- ^ (width, height)+                       -> m () -setViewport :: (GLES, MonadGL m) => Int -> Int -> m ()-setViewport w h = gl $ viewport 0 0 (fromIntegral w) (fromIntegral h)+setViewport :: (GLES, MonadGL m) => (Int, Int) -> (Int, Int) -> m ()+setViewport (x, y) (w, h) = gl $ viewport (fromIntegral x) (fromIntegral y)+                                          (fromIntegral w) (fromIntegral h)

@@ -18,7 +18,7 @@         FragmentShader,         -- * Uniforms         uniform,-        (~~),+        (~<),         foldUniforms,         -- * Optimized shaders         UniformSetter,@@ -29,7 +29,7 @@         ushader,         pushader,         uniform',-        (~*),+        (~<*),         -- * Fragment shader functionalities         Fragment(..),         farr,@@ -79,7 +79,10 @@ hashMST :: MultiShaderType a => a -> a hashMST = mapMST (fromExpr . HashDummy . hash . toExpr) --- | Create a shader function that can be reused efficiently.+-- | Create a shader function that can be reused efficiently. Ideally, every+-- operation on G* and *Sampler types should be performed by a top level Shader+-- created with this function, while arrow combinators and uniforms can appear+-- anywhere. 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@@ -89,7 +92,7 @@ -- 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.+-- shader structure. 'Shader's themselves can be used as parameters. shaderParam :: (HasTrie p, MultiShaderType i, MultiShaderType o)             => Shader s (p, i) o             -> Shader s (p, i) o@@ -97,7 +100,9 @@         let hf' = memo (\p -> memoHash $ \(uid, i) -> hf (uid, (p, i)))         in Shader f (\(uid, (p, i)) -> hf' p (uid, i)) --- | See 'shaderParam'.+-- | See 'shaderParam'. The result of partially applying this function is a+-- function for which the same rules of 'shader' apply (that is, it should be+-- reused rather than recreated at every frame). pshader :: (HasTrie p, MultiShaderType i, MultiShaderType o)         => (p -> Shader s i o)         -> (p -> Shader s i o)@@ -105,7 +110,8 @@                   in \p -> const p &&& id ^>> shader'  -- | 'shader' with an additional parameter that can be used to set the values of--- the uniforms.+-- the uniforms. Like 'pshader', this should be used as a function of+-- functions, not a function with two arguments. ushader :: (MultiShaderType i, MultiShaderType o)         => (UniformSetter x -> Shader s i o)         -> (UniformSetter x -> Shader s i o)@@ -160,17 +166,17 @@ uniform' = unUniformSetter ^>> uniform  -- | 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+infixl 9 ~<+(~<) :: Uniform u => Shader s (u, i) o -> CPUUniform u -> Shader s i o+shader ~< u = (const u ^>> uniform) &&& id >>> shader  -- | Add a uniform and directly set it with a 'UniformSetter'.-infixl 9 ~*-(~*) :: Uniform u+infixl 9 ~<*+(~<*) :: Uniform u      => Shader s (u, i) o      -> UniformSetter (CPUUniform u)      -> Shader s i o-shader ~* u = (const u ^>> uniform') &&& id >>> shader+shader ~<* u = (const u ^>> uniform') &&& id >>> shader  -- | This works like 'sarr' but provides a 'Fragment'. farr :: (MultiShaderType i, MultiShaderType o)@@ -189,10 +195,10 @@                 , fwidth = Shader.fwidth                 } --- | 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.+-- | Repeatedly apply a function to a shader value. This is compiled to an+-- actual for loop, therefore it won't duplicate the function code (doing that+-- could slow down compilation or cause an out of memory error). The same+-- applies to derived functions like 'foldGArray' and 'foldUniforms'. forLoop :: ShaderInput a          => Int -- ^ Maximum number of iterations (should be as low as possible)         -> a -- ^ Initial value@@ -218,6 +224,8 @@                                 iacc                                 (\i acc -> (f acc $ arr ! i, false)) +-- | Create an array uniform and then fold over it with the given function and+-- initial value. 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

@@ -28,12 +28,12 @@  -- | CPU types convertible to GPU types (as uniforms). class ShaderType g => BaseUniform g where-        setUniform :: UniformLocation -> proxy g -> CPUBase g -> GL ()+        setBaseUniform :: UniformLocation -> proxy g -> CPUBase g -> GL ()  -- | CPU types convertible to GPU types (as attributes). class ShaderType g => BaseAttribute g where         encodeAttribute :: proxy g -> [CPUBase g] -> GL AnyArray-        setAttribute :: proxy g -> GLUInt -> GL ()+        setBaseAttribute :: proxy g -> GLUInt -> GL ()  class ShaderType t => ArrayUniform t where         baseUniformGArray :: KnownNat n@@ -49,17 +49,17 @@ type instance CPUBase GFloat = Float  instance GLES => BaseUniform GFloat where-        setUniform l _ = uniform1f l+        setBaseUniform l _ = uniform1f l  instance (GLES, KnownNat n) => BaseUniform (GArray n GFloat) where-        setUniform l _ v = liftIO (encodeFloats v) >>= uniform1fv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_FLOAT i 1  -- Bool @@ -70,10 +70,11 @@ toBool False = 0  instance GLES => BaseUniform GBool where-        setUniform l _ = uniform1i l . toBool+        setBaseUniform l _ = uniform1i l . toBool  instance (GLES, KnownNat n) => BaseUniform (GArray n GBool) where-        setUniform l _ v = liftIO (encodeInts $ map toBool v) >>= uniform1iv l+        setBaseUniform l _ v = liftIO (encodeInts $ map toBool v) >>=+                               uniform1iv l  instance GLES => ArrayUniform GBool where         baseUniformGArray _ _ = id@@ -81,24 +82,24 @@ instance GLES => BaseAttribute GBool where         encodeAttribute _ a = liftIO . fmap fromInt32Array $                                 encodeInts (map toBool a)-        setAttribute _ i = attr gl_INT i 1+        setBaseAttribute _ i = attr gl_INT i 1  -- Int  type instance CPUBase GInt = Int32  instance GLES => BaseUniform GInt where-        setUniform l _ = uniform1i l+        setBaseUniform l _ = uniform1i l  instance (GLES, KnownNat n) => BaseUniform (GArray n GInt) where-        setUniform l _ v = liftIO (encodeInts v) >>= uniform1iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 1  -- TODO: sampler arrays (they're problematic to safely access in the shaders) -- Samplers@@ -107,7 +108,7 @@ -- type instance CPUBase GSamplerCube = ActiveTexture  instance GLES => BaseUniform GSampler2D where-        setUniform l _ (Sampler2D v) = uniform1i l $ fromIntegral v+        setBaseUniform l _ (Sampler2D v) = uniform1i l $ fromIntegral v  {- instance GLES => ArrayUniform GSampler2D where@@ -116,7 +117,7 @@  {- instance GLES => BaseUniform GSamplerCube where-        setUniform l _ (ActiveTexture v) = uniform1i l $ fromIntegral v+        setBaseUniform l _ (ActiveTexture v) = uniform1i l $ fromIntegral v -}  -- Vec2@@ -124,153 +125,153 @@ type instance CPUBase GVec2 = Vec2  instance GLES => BaseUniform GVec2 where-        setUniform l _ (Vec2 x y) = uniform2f l x y+        setBaseUniform l _ (Vec2 x y) = uniform2f l x y  instance (GLES, KnownNat n) => BaseUniform (GArray n GVec2) where-        setUniform l _ v = liftIO (encodeVec2s v) >>= uniform2fv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_FLOAT i 2  -- Vec3  type instance CPUBase GVec3 = Vec3  instance GLES => BaseUniform GVec3 where-        setUniform l _ (Vec3 x y z) = uniform3f l x y z+        setBaseUniform l _ (Vec3 x y z) = uniform3f l x y z  instance (GLES, KnownNat n) => BaseUniform (GArray n GVec3) where-        setUniform l _ v = liftIO (encodeVec3s v) >>= uniform3fv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_FLOAT i 3  -- Vec4  type instance CPUBase GVec4 = Vec4  instance GLES => BaseUniform GVec4 where-        setUniform l _ (Vec4 x y z w) = uniform4f l x y z w+        setBaseUniform l _ (Vec4 x y z w) = uniform4f l x y z w  instance (GLES, KnownNat n) => BaseUniform (GArray n GVec4) where-        setUniform l _ v = liftIO (encodeVec4s v) >>= uniform4fv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_FLOAT i 4  -- IVec2  type instance CPUBase GIVec2 = IVec2  instance GLES => BaseUniform GIVec2 where-        setUniform l _ (IVec2 x y) = uniform2i l x y+        setBaseUniform l _ (IVec2 x y) = uniform2i l x y  instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec2) where-        setUniform l _ v = liftIO (encodeIVec2s v) >>= uniform2iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 2  -- IVec3  type instance CPUBase GIVec3 = IVec3  instance GLES => BaseUniform GIVec3 where-        setUniform l _ (IVec3 x y z) = uniform3i l x y z+        setBaseUniform l _ (IVec3 x y z) = uniform3i l x y z  instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec3) where-        setUniform l _ v = liftIO (encodeIVec3s v) >>= uniform3iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 3  -- IVec4  type instance CPUBase GIVec4 = IVec4  instance GLES => BaseUniform GIVec4 where-        setUniform l _ (IVec4 x y z w) = uniform4i l x y z w+        setBaseUniform l _ (IVec4 x y z w) = uniform4i l x y z w  instance (GLES, KnownNat n) => BaseUniform (GArray n GIVec4) where-        setUniform l _ v = liftIO (encodeIVec4s v) >>= uniform4iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 4  -- BVec2  type instance CPUBase GBVec2 = IVec2  instance GLES => BaseUniform GBVec2 where-        setUniform l _ (IVec2 x y) = uniform2i l x y+        setBaseUniform l _ (IVec2 x y) = uniform2i l x y  instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec2) where-        setUniform l _ v = liftIO (encodeIVec2s v) >>= uniform2iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 2  -- BVec3  type instance CPUBase GBVec3 = IVec3  instance GLES => BaseUniform GBVec3 where-        setUniform l _ (IVec3 x y z) = uniform3i l x y z+        setBaseUniform l _ (IVec3 x y z) = uniform3i l x y z  instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec3) where-        setUniform l _ v = liftIO (encodeIVec3s v) >>= uniform3iv l+        setBaseUniform 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+        setBaseAttribute _ i = attr gl_INT i 3  -- BVec4  type instance CPUBase GBVec4 = IVec4  instance GLES => BaseUniform GBVec4 where-        setUniform l _ (IVec4 x y z w) = uniform4i l x y z w+        setBaseUniform l _ (IVec4 x y z w) = uniform4i l x y z w  instance (GLES, KnownNat n) => BaseUniform (GArray n GBVec4) where-        setUniform l _ v = liftIO (encodeIVec4s v) >>= uniform4iv l+        setBaseUniform 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-        setAttribute _ i = attr gl_INT i 4+        setBaseAttribute _ i = attr gl_INT i 4  -- Matrices @@ -279,13 +280,13 @@ type instance CPUBase GMat4 = Mat4  instance GLES => BaseUniform GMat2 where-        setUniform l _ m = liftIO (encodeMat2 m) >>= uniformMatrix2fv l false+        setBaseUniform l _ m = liftIO (encodeMat2 m) >>= uniformMatrix2fv l false  instance GLES => BaseUniform GMat3 where-        setUniform l _ m = liftIO (encodeMat3 m) >>= uniformMatrix3fv l false+        setBaseUniform l _ m = liftIO (encodeMat3 m) >>= uniformMatrix3fv l false  instance GLES => BaseUniform GMat4 where-        setUniform l _ m = liftIO (encodeMat4 m) >>= uniformMatrix4fv l false+        setBaseUniform l _ m = liftIO (encodeMat4 m) >>= uniformMatrix4fv l false  class BaseUniforms (xs :: [*]) instance BaseUniform x => BaseUniforms (x ': '[])

@@ -14,8 +14,6 @@  module Graphics.Rendering.Ombra.Shader.Language (         module Data.Boolean,-        module Data.VectorSpace,-        module Data.Cross,         -- * Types         -- ** GPU types         Shader.GBool,@@ -40,7 +38,7 @@         Shader.GArray,         -- * GPU functions         (Shader.!),-        -- Shader.store,+        sampleTexture,         sample,         {-         Shader.texture2DBias,@@ -422,6 +420,11 @@  type TextureSampler = Shader.GSampler2D --- | Sample a texel from a texture.+-- | Alias for 'sampleTexture'. sample :: TextureSampler -> Shader.GVec2 -> Shader.GVec4-sample = Shader.texture2D+sample = sampleTexture++-- | Sample a texel from a texture. Sampling in the vertex shader is not+-- supported on some hardware.+sampleTexture :: TextureSampler -> Shader.GVec2 -> Shader.GVec4+sampleTexture = Shader.texture2D

@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, ConstraintKinds,              KindSignatures, DataKinds, GADTs, RankNTypes, FlexibleInstances,              ScopedTypeVariables, TypeOperators, ImpredicativeTypes,-             TypeSynonymInstances, FlexibleContexts #-}+             TypeSynonymInstances, FlexibleContexts, DefaultSignatures #-}  module Graphics.Rendering.Ombra.Shader.Program (         MonadProgram(..),@@ -9,7 +9,6 @@         Program,         ProgramIndex,         program,-        setProgram,         UniformLocation(..),         programIndex ) where@@ -69,9 +68,19 @@ programIndex :: Program gs is -> ProgramIndex programIndex (Program _ _ h) = ProgramIndex h -class (GLES, MonadGL m) => MonadProgram m where-        withProgram :: Program i o -> (LoadedProgram -> m ()) -> m ()+class (GLES, Monad m) => MonadProgram m where+        setProgram :: Program i o -> m ()         getUniform :: UniformID -> m (Either String UniformLocation)+        setUniform :: BaseUniform g => UniformID -> proxy g -> CPUBase g -> m ()+        default setUniform :: (MonadGL m, BaseUniform g)+                           => UniformID+                           -> proxy g+                           -> CPUBase g+                           -> m ()+        setUniform uid g val = getUniform uid >>= \eu ->+                case eu of+                     Right (UniformLocation l) -> gl $ setBaseUniform l g val+                     Left _ -> return ()  {- setUniformValue :: (MonadProgram m, ShaderVar g, BaseUniform g)@@ -85,9 +94,6 @@                      Right (UniformLocation l) -> gl $ setUniform l ug uc                      Left _ -> return () -}--setProgram :: MonadProgram m => Program i o -> m ()-setProgram p = withProgram p $ \(LoadedProgram glp _ _) -> gl $ useProgram glp  loadProgram :: GLES => Program g i -> GL (Either String LoadedProgram) loadProgram (Program (vss, attrs) fss h) =

@@ -32,15 +32,6 @@                        -> a         mapMST f = to . gmapMST f . from --        foldrMST :: (forall x. ShaderType x => x -> b -> b) -> b -> a -> b-        default foldrMST :: (Generic a, GMultiShaderType (Rep a))-                         => (forall x. ShaderType x => x -> b -> b)-                         -> b-                         -> a-                         -> b-        foldrMST f s = gfoldrMST f s . from-         toExprMST :: a -> ExprMST a         default toExprMST :: ( Generic a                              , GMultiShaderType (Rep a)@@ -68,6 +59,14 @@                          -> (a, Int)         buildMST f = first to . gbuildMST f +        foldrMST :: (forall x. ShaderType x => x -> b -> b) -> b -> a -> b+        default foldrMST :: (Generic a, GShaderInput (Rep a))+                         => (forall x. ShaderType x => x -> b -> b)+                         -> b+                         -> a+                         -> b+        foldrMST f s = gfoldrMST f s . from+ -- | Types that contain uniform values. class ShaderInput a => Uniform a where         type CPUUniform a@@ -115,7 +114,7 @@                       GVec4 x y z w : toGVec4sList xs  -- | Types that contain 'GFloat's.-class (MultiShaderType o, KnownNat (NFloats o)) => FragmentShaderOutput o where+class (ShaderInput o, KnownNat (NFloats o)) => FragmentShaderOutput o where         type NFloats o :: Nat         type NFloats o = GNFloats (Rep o) @@ -168,11 +167,12 @@ instance ArrowChoice (Shader s) where         left = leftApp -instance (ShaderInput i, MultiShaderType o) => Hashable (Shader s i o) where+instance (ShaderInput i, ShaderInput o) => Hashable (Shader s i o) where         hashWithSalt salt (Shader _ hf) =-                let (input, _) = buildMST' (\t -> fromExpr .  Input t) 0+                let (input, _) = buildMST' (\t -> fromExpr . Input t) 0                     (_, output) = hf (0, input)-                in hashWithSalt salt $ hashListMST output+                    outHash = foldrMST (\x l -> hash (toExpr x) : l) [] output+                in hashWithSalt salt outHash  data ShaderStage = VertexShaderStage | FragmentShaderStage @@ -200,26 +200,32 @@ instance MultiShaderType GBool where         type ExprMST GBool = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GBool where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GBool where         type CPUUniform GBool = CPUBase GBool         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GBool where+        newtype (GBool :->: b) = GBoolTrie (ExprMST GBool :->: b)+        trie f = GBoolTrie $ trie (f . fromExprMST)+        untrie (GBoolTrie t) = untrie t . toExprMST+        enumerate (GBoolTrie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GFloat where         type ExprMST GFloat = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GFloat where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GFloat where         type CPUUniform GFloat = CPUBase GFloat@@ -230,43 +236,61 @@         fromGFloats (x : xs) = (x, xs)         toGFloats x = (x :) +instance HasTrie GFloat where+        newtype (GFloat :->: b) = GFloatTrie (ExprMST GFloat :->: b)+        trie f = GFloatTrie $ trie (f . fromExprMST)+        untrie (GFloatTrie t) = untrie t . toExprMST+        enumerate (GFloatTrie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GInt where         type ExprMST GInt = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GInt where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GInt where         type CPUUniform GInt = CPUBase GInt         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GInt where+        newtype (GInt :->: b) = GIntTrie (ExprMST GInt :->: b)+        trie f = GIntTrie $ trie (f . fromExprMST)+        untrie (GIntTrie t) = untrie t . toExprMST+        enumerate (GIntTrie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GSampler2D where         type ExprMST GSampler2D = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GSampler2D where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GSampler2D where         type CPUUniform GSampler2D = Texture         foldrUniform _ f s u = f (UniformTexture u) s +instance HasTrie GSampler2D where+        newtype (GSampler2D :->: b) = GSampler2DTrie (ExprMST GSampler2D :->: b)+        trie f = GSampler2DTrie $ trie (f . fromExprMST)+        untrie (GSampler2DTrie t) = untrie t . toExprMST+        enumerate (GSampler2DTrie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GVec2 where         type ExprMST GVec2 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GVec2 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GVec2 where         type CPUUniform GVec2 = CPUBase GVec2@@ -277,15 +301,21 @@         fromGFloats (x : y : xs) = (GVec2 x y, xs)         toGFloats (GVec2 x y) xs = x : y : xs +instance HasTrie GVec2 where+        newtype (GVec2 :->: b) = GVec2Trie (ExprMST GVec2 :->: b)+        trie f = GVec2Trie $ trie (f . fromExprMST)+        untrie (GVec2Trie t) = untrie t . toExprMST+        enumerate (GVec2Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GVec3 where         type ExprMST GVec3 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GVec3 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GVec3 where         type CPUUniform GVec3 = CPUBase GVec3@@ -296,15 +326,21 @@         fromGFloats (x : y : z : xs) = (GVec3 x y z, xs)         toGFloats (GVec3 x y z) xs = x : y : z : xs +instance HasTrie GVec3 where+        newtype (GVec3 :->: b) = GVec3Trie (ExprMST GVec3 :->: b)+        trie f = GVec3Trie $ trie (f . fromExprMST)+        untrie (GVec3Trie t) = untrie t . toExprMST+        enumerate (GVec3Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GVec4 where         type ExprMST GVec4 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GVec4 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GVec4 where         type CPUUniform GVec4 = CPUBase GVec4@@ -315,156 +351,222 @@         fromGFloats (x : y : z : w : xs) = (GVec4 x y z w, xs)         toGFloats (GVec4 x y z w) xs = x : y : z : w : xs +instance HasTrie GVec4 where+        newtype (GVec4 :->: b) = GVec4Trie (ExprMST GVec4 :->: b)+        trie f = GVec4Trie $ trie (f . fromExprMST)+        untrie (GVec4Trie t) = untrie t . toExprMST+        enumerate (GVec4Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GIVec2 where         type ExprMST GIVec2 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GIVec2 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GIVec2 where         type CPUUniform GIVec2 = CPUBase GIVec2         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GIVec2 where+        newtype (GIVec2 :->: b) = GIVec2Trie (ExprMST GIVec2 :->: b)+        trie f = GIVec2Trie $ trie (f . fromExprMST)+        untrie (GIVec2Trie t) = untrie t . toExprMST+        enumerate (GIVec2Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GIVec3 where         type ExprMST GIVec3 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GIVec3 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GIVec3 where         type CPUUniform GIVec3 = CPUBase GIVec3         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GIVec3 where+        newtype (GIVec3 :->: b) = GIVec3Trie (ExprMST GIVec3 :->: b)+        trie f = GIVec3Trie $ trie (f . fromExprMST)+        untrie (GIVec3Trie t) = untrie t . toExprMST+        enumerate (GIVec3Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GIVec4 where         type ExprMST GIVec4 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GIVec4 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GIVec4 where         type CPUUniform GIVec4 = CPUBase GIVec4         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GIVec4 where+        newtype (GIVec4 :->: b) = GIVec4Trie (ExprMST GIVec4 :->: b)+        trie f = GIVec4Trie $ trie (f . fromExprMST)+        untrie (GIVec4Trie t) = untrie t . toExprMST+        enumerate (GIVec4Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GBVec2 where         type ExprMST GBVec2 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GBVec2 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GBVec2 where         type CPUUniform GBVec2 = CPUBase GBVec2         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GBVec2 where+        newtype (GBVec2 :->: b) = GBVec2Trie (ExprMST GBVec2 :->: b)+        trie f = GBVec2Trie $ trie (f . fromExprMST)+        untrie (GBVec2Trie t) = untrie t . toExprMST+        enumerate (GBVec2Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GBVec3 where         type ExprMST GBVec3 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GBVec3 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GBVec3 where         type CPUUniform GBVec3 = CPUBase GBVec3         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GBVec3 where+        newtype (GBVec3 :->: b) = GBVec3Trie (ExprMST GBVec3 :->: b)+        trie f = GBVec3Trie $ trie (f . fromExprMST)+        untrie (GBVec3Trie t) = untrie t . toExprMST+        enumerate (GBVec3Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GBVec4 where         type ExprMST GBVec4 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GBVec4 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GBVec4 where         type CPUUniform GBVec4 = CPUBase GBVec4         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GBVec4 where+        newtype (GBVec4 :->: b) = GBVec4Trie (ExprMST GBVec4 :->: b)+        trie f = GBVec4Trie $ trie (f . fromExprMST)+        untrie (GBVec4Trie t) = untrie t . toExprMST+        enumerate (GBVec4Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GMat2 where         type ExprMST GMat2 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GMat2 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GMat2 where         type CPUUniform GMat2 = CPUBase GMat2         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GMat2 where+        newtype (GMat2 :->: b) = GMat2Trie (ExprMST GMat2 :->: b)+        trie f = GMat2Trie $ trie (f . fromExprMST)+        untrie (GMat2Trie t) = untrie t . toExprMST+        enumerate (GMat2Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GMat3 where         type ExprMST GMat3 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GMat3 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GMat3 where         type CPUUniform GMat3 = CPUBase GMat3         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GMat3 where+        newtype (GMat3 :->: b) = GMat3Trie (ExprMST GMat3 :->: b)+        trie f = GMat3Trie $ trie (f . fromExprMST)+        untrie (GMat3Trie t) = untrie t . toExprMST+        enumerate (GMat3Trie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType GMat4 where         type ExprMST GMat4 = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance ShaderInput GMat4 where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance GLES => Uniform GMat4 where         type CPUUniform GMat4 = CPUBase GMat4         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance HasTrie GMat4 where+        newtype (GMat4 :->: b) = GMat4Trie (ExprMST GMat4 :->: b)+        trie f = GMat4Trie $ trie (f . fromExprMST)+        untrie (GMat4Trie t) = untrie t . toExprMST+        enumerate (GMat4Trie t) = map (first fromExprMST) (enumerate t)+ instance (KnownNat n, ShaderType t) => MultiShaderType (GArray n t) where         type ExprMST (GArray n t) = Expr         mapMST f = f-        foldrMST f = flip f         toExprMST = toExpr         fromExprMST = fromExpr  instance (KnownNat n, ShaderType t) => ShaderInput (GArray n t) where         buildMST f i = (f i, i + 1)+        foldrMST f = flip f  instance (KnownNat n, ShaderType t, BaseUniform (GArray n t), GLES) =>         Uniform (GArray n t) where         type CPUUniform (GArray n t) = CPUBase (GArray n t)         foldrUniform proxy f s u = f (UniformValue proxy u) s +instance (KnownNat n, ShaderType t) => HasTrie (GArray n t) where+        newtype (GArray n t :->: b) = GArrayTrie (ExprMST (GArray n t) :->: b)+        trie f = GArrayTrie $ trie (f . fromExprMST)+        untrie (GArrayTrie t) = untrie t . toExprMST+        enumerate (GArrayTrie t) = map (first fromExprMST) (enumerate t)+ instance MultiShaderType () where         type ExprMST () = ()         mapMST _ = id-        foldrMST _ x _ = x         toExprMST = id         fromExprMST = id  instance ShaderInput () where         buildMST _ i = ((), i)+        foldrMST _ x _ = x  instance Uniform () where         type CPUUniform () = ()@@ -478,7 +580,6 @@ instance (MultiShaderType a, MultiShaderType b) => MultiShaderType (a, b) where         type ExprMST (a, b) = (ExprMST a, ExprMST b)         mapMST f (x, y) = (mapMST f x, mapMST f y)-        foldrMST f s (x, y) = foldrMST f (foldrMST f s y) x         toExprMST (x, y) = (toExprMST x, toExprMST y)         fromExprMST (x, y) = (fromExprMST x, fromExprMST y) @@ -486,7 +587,6 @@         MultiShaderType (a, b, c) where         type ExprMST (a, b, c) = (ExprMST a, ExprMST b, ExprMST c)         mapMST f (x, y, z) = (mapMST f x, mapMST f y, mapMST f z)-        foldrMST f s (x, y, z) = foldrMST f (foldrMST f (foldrMST f s z) y) x         toExprMST (x, y, z) = (toExprMST x, toExprMST y, toExprMST z)         fromExprMST (x, y, z) = (fromExprMST x, fromExprMST y, fromExprMST z) @@ -494,6 +594,7 @@         buildMST f i = let (a, i') = buildMST f i                            (b, i'') = buildMST f i'                        in ((a, b), i'')+        foldrMST f s (x, y) = foldrMST f (foldrMST f s y) x  instance ( ShaderInput a, ShaderInput b, ShaderInput c          ) => ShaderInput (a, b, c) where@@ -501,6 +602,7 @@                            (b, i2) = buildMST f i1                            (c, i3) = buildMST f i2                        in ((a, b, c), i3)+        foldrMST f s (x, y, z) = foldrMST f (foldrMST f (foldrMST f s z) y) x  instance (Uniform a, Uniform b) => Uniform (a, b) where         type CPUUniform (a, b) = (CPUUniform a, CPUUniform b)@@ -544,38 +646,60 @@ instance MultiShaderType a => MultiShaderType [a] where         type ExprMST [a] = [ExprMST a]         mapMST f = map $ mapMST f-        foldrMST f = foldr . flip $ foldrMST f         toExprMST = map toExprMST         fromExprMST = map fromExprMST  instance (ShaderInput a, MultiShaderType b) => MultiShaderType (a -> b) where         type ExprMST (a -> b) = ExprMST b         mapMST f g = \x -> mapMST f $ g x-        foldrMST f s = foldrMST f s . dummyFun         toExprMST = toExprMST . dummyFun         fromExprMST x = const $ fromExprMST x +instance (ShaderInput a, MultiShaderType b) => HasTrie (a -> b) where+        newtype ((a -> b) :->: c) = FunTrie (ExprMST (a -> b) :->: c)+        trie f = FunTrie $ trie (f . fromExprMST)+        untrie (FunTrie t) = untrie t . toExprMST+        enumerate (FunTrie t) = map (first fromExprMST) (enumerate t)++instance (ShaderInput a, MultiShaderType b) =>+        MultiShaderType (Shader s a b) where+        type ExprMST (Shader s a b) = (ExprMST b, UniformID)+        mapMST f s = s >>^ mapMST f+        toExprMST (Shader _ hf) = let err = "This shader can't be used as MST"+                                      (uid, _) = hf (0, error err)+                                      out = snd . dummyFun $ hf . (,) 0+                                  in (toExprMST out, uid)+        fromExprMST (out, dif) = let hf (uid, _) = (uid + dif, fromExprMST out)+                                     f (ShaderState uid u t, _) =+                                          ( ShaderState (uid + dif) u t+                                          , fromExprMST out+                                          )+                                 in Shader f hf++instance (ShaderInput a, MultiShaderType b) => HasTrie (Shader s a b) where+        newtype (Shader s a b :->: c) = SFunTrie (ExprMST (Shader s a b) :->: c)+        trie f = SFunTrie $ trie (f . fromExprMST)+        untrie (SFunTrie t) = untrie t . toExprMST+        enumerate (SFunTrie t) = map (first fromExprMST) (enumerate t)+ dummyFun :: ShaderInput a => (a -> b) -> b dummyFun g = g . fst $ buildMST (fromExpr . Dummy) 0  class GMultiShaderType (g :: * -> *) where         type GExprMST g :: *         gmapMST :: (forall x. ShaderType x => x -> x) -> g p -> g p-        gfoldrMST :: (forall x. ShaderType x => x -> b -> b) -> b -> g p -> b         gtoExprMST :: g p -> GExprMST g         gfromExprMST :: GExprMST g -> g p  instance GMultiShaderType a => GMultiShaderType (M1 i d a) where         type GExprMST (M1 i d a) = GExprMST a         gmapMST f (M1 x) = M1 $ gmapMST f x-        gfoldrMST f s (M1 x) = gfoldrMST f s x         gtoExprMST (M1 x) = gtoExprMST x         gfromExprMST x = M1 $ gfromExprMST x  instance MultiShaderType c => GMultiShaderType (K1 i c) where         type GExprMST (K1 i c) = ExprMST c         gmapMST f (K1 x) = K1 $ mapMST f x-        gfoldrMST f s (K1 x) = foldrMST f s x         gtoExprMST (K1 x) = toExprMST x         gfromExprMST x = K1 $ fromExprMST x @@ -583,23 +707,26 @@         GMultiShaderType (a :*: b) where         type GExprMST (a :*: b) = (GExprMST a, GExprMST b)         gmapMST f (a :*: b) = gmapMST f a :*: gmapMST f b-        gfoldrMST f s (a :*: b) = gfoldrMST f (gfoldrMST f s b) a         gtoExprMST (a :*: b) = (gtoExprMST a, gtoExprMST b)         gfromExprMST (a, b) = gfromExprMST a :*: gfromExprMST b  class GShaderInput g where         gbuildMST :: (forall x. ShaderType x => Int -> x) -> Int -> (g p, Int)+        gfoldrMST :: (forall x. ShaderType x => x -> b -> b) -> b -> g p -> b  instance GShaderInput a => GShaderInput (M1 i d a) where         gbuildMST f = first M1 . gbuildMST f+        gfoldrMST f s (M1 x) = gfoldrMST f s x  instance ShaderInput c => GShaderInput (K1 i c) where         gbuildMST f = first K1 . buildMST f+        gfoldrMST f s (K1 x) = foldrMST f s x  instance (GShaderInput a, GShaderInput b) => GShaderInput (a :*: b) where         gbuildMST f i = let (a, i') = gbuildMST f i                             (b, i'') = gbuildMST f i'                         in (a :*: b, i'')+        gfoldrMST f s (a :*: b) = gfoldrMST f (gfoldrMST f s b) a  class GUniform (a :: * -> *) (c :: * -> *) where         gfoldrUniform :: Proxy a@@ -645,9 +772,6 @@                               (y, xs'') = gfromGFloats xs'                           in (x :*: y, xs'')         gtoGFloats (x :*: y) = gtoGFloats x . gtoGFloats y--hashListMST :: MultiShaderType a => a -> [Int]-hashListMST = foldrMST (\x l -> hash (toExpr x) : l) []  uniformList :: ShaderInput i             => Shader s i o

@@ -42,7 +42,9 @@ -- height is not a power of two. potParameters :: (Filter, Maybe Filter) -- ^ Minification filter.               -> Filter                 -- ^ Magnification filter.-              -> Bool                   -- ^ Generate mipmaps automatically.+              -> Bool                   -- ^ Generate mipmaps automatically. Do+                                        -- not use mipmaps with 'GBuffer's or+                                        -- 'DepthBuffer's.               -> WrappingFunction       -- ^ Horizontal wrapping function.               -> WrappingFunction       -- ^ Vertical wrapping function.               -> TextureParameters@@ -51,7 +53,8 @@ -- | 'potParameters' with linear filters and repeat. potLinear :: Bool               -- ^ Generate mipmaps           -> TextureParameters-potLinear g = potParameters (Linear, Just Nearest) Linear g Repeat Repeat+potLinear g = potParameters (Linear, mipf) Linear g Repeat Repeat+        where mipf = if g then Just Nearest else Nothing  -- | Creates a 'Texture' from a list of pixels. mkTexture :: GLES

@@ -5,7 +5,7 @@         Texture(..),         TextureImage,         LoadedTexture(..),-        withActiveTextures,+        defaultWithActiveTextures,         textureSize,         emptyTexture ) where@@ -20,32 +20,36 @@ import Graphics.Rendering.Ombra.Internal.Resource import Graphics.Rendering.Ombra.Texture.Types -class (MonadGL m, GLES) => MonadTexture m where+class (Monad m, GLES) => MonadTexture m where         getTexture :: Texture -> m (Either String LoadedTexture)-        getActiveTexturesCount :: m Int-        setActiveTexturesCount :: Int -> m ()+        withActiveTextures :: [Texture]+                           -> (String -> m a)+                           -> ([Sampler2D] -> m a)+                           -> m a         newTexture :: Int                    -> Int                    -> TextureParameters                    -> Int                    -> (GL.Texture -> GL ())                    -> m LoadedTexture-        unusedTextures :: [LoadedTexture] -> m ()+        -- unusedTextures :: [LoadedTexture] -> m ()  instance GLES => Resource TextureImage LoadedTexture GL where         loadResource i = Right <$> loadTextureImage i         unloadResource _ (LoadedTexture _ _ _ t) = deleteTexture t -withActiveTextures :: MonadTexture m-                   => [Texture]-                   -> (String -> m a)-                   -> ([Sampler2D] -> m a)-                   -> m a-withActiveTextures textures fail f =+defaultWithActiveTextures :: (MonadTexture m, MonadGL m)+                          => m Int+                          -> (Int -> m ())+                          -> [Texture]+                          -> (String -> m a)+                          -> ([Sampler2D] -> m a)+                          -> m a+defaultWithActiveTextures getActiveCount setActiveCount textures fail f =         do let n = length textures            eloadedTextures <- runExceptT $ mapM (ExceptT . getTexture) textures-           atn <- getActiveTexturesCount-           setActiveTexturesCount $ atn + n+           atn <- getActiveCount+           setActiveCount $ atn + n            let units = [atn .. atn + n - 1]            ret <- case eloadedTextures of                        Left err -> fail err@@ -57,7 +61,7 @@                                  )                                  (zip units loadedTextures)                            f $ map (Sampler2D . fromIntegral) units-           setActiveTexturesCount $ atn+           setActiveCount $ atn            return ret  -- | Get the dimensions of a 'Texture'.

@@ -1,5 +1,5 @@ name:                ombra-version:             1.0.0.0+version:             1.1.0.0 synopsis:            Render engine. description:          homepage:            https://github.com/ziocroc/Ombra