diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 diff --git a/Graphics/Rendering/Ombra/Culling/Draw.hs b/Graphics/Rendering/Ombra/Culling/Draw.hs --- a/Graphics/Rendering/Ombra/Culling/Draw.hs +++ b/Graphics/Rendering/Ombra/Culling/Draw.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Draw.hs b/Graphics/Rendering/Ombra/Draw.hs --- a/Graphics/Rendering/Ombra/Draw.hs +++ b/Graphics/Rendering/Ombra/Draw.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Draw/Class.hs b/Graphics/Rendering/Ombra/Draw/Class.hs --- a/Graphics/Rendering/Ombra/Draw/Class.hs +++ b/Graphics/Rendering/Ombra/Draw/Class.hs @@ -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). diff --git a/Graphics/Rendering/Ombra/Draw/Monad.hs b/Graphics/Rendering/Ombra/Draw/Monad.hs --- a/Graphics/Rendering/Ombra/Draw/Monad.hs +++ b/Graphics/Rendering/Ombra/Draw/Monad.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Geometry.hs b/Graphics/Rendering/Ombra/Geometry.hs --- a/Graphics/Rendering/Ombra/Geometry.hs +++ b/Graphics/Rendering/Ombra/Geometry.hs @@ -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') diff --git a/Graphics/Rendering/Ombra/Geometry/Draw.hs b/Graphics/Rendering/Ombra/Geometry/Draw.hs --- a/Graphics/Rendering/Ombra/Geometry/Draw.hs +++ b/Graphics/Rendering/Ombra/Geometry/Draw.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Geometry/Types.hs b/Graphics/Rendering/Ombra/Geometry/Types.hs --- a/Graphics/Rendering/Ombra/Geometry/Types.hs +++ b/Graphics/Rendering/Ombra/Geometry/Types.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Image.hs b/Graphics/Rendering/Ombra/Image.hs --- a/Graphics/Rendering/Ombra/Image.hs +++ b/Graphics/Rendering/Ombra/Image.hs @@ -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 () diff --git a/Graphics/Rendering/Ombra/Image/Types.hs b/Graphics/Rendering/Ombra/Image/Types.hs --- a/Graphics/Rendering/Ombra/Image/Types.hs +++ b/Graphics/Rendering/Ombra/Image/Types.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/OutBuffer.hs b/Graphics/Rendering/Ombra/OutBuffer.hs --- a/Graphics/Rendering/Ombra/OutBuffer.hs +++ b/Graphics/Rendering/Ombra/OutBuffer.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/OutBuffer/Types.hs b/Graphics/Rendering/Ombra/OutBuffer/Types.hs --- a/Graphics/Rendering/Ombra/OutBuffer/Types.hs +++ b/Graphics/Rendering/Ombra/OutBuffer/Types.hs @@ -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) diff --git a/Graphics/Rendering/Ombra/Screen.hs b/Graphics/Rendering/Ombra/Screen.hs --- a/Graphics/Rendering/Ombra/Screen.hs +++ b/Graphics/Rendering/Ombra/Screen.hs @@ -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) diff --git a/Graphics/Rendering/Ombra/Shader.hs b/Graphics/Rendering/Ombra/Shader.hs --- a/Graphics/Rendering/Ombra/Shader.hs +++ b/Graphics/Rendering/Ombra/Shader.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Shader/CPU.hs b/Graphics/Rendering/Ombra/Shader/CPU.hs --- a/Graphics/Rendering/Ombra/Shader/CPU.hs +++ b/Graphics/Rendering/Ombra/Shader/CPU.hs @@ -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 ': '[]) diff --git a/Graphics/Rendering/Ombra/Shader/Language.hs b/Graphics/Rendering/Ombra/Shader/Language.hs --- a/Graphics/Rendering/Ombra/Shader/Language.hs +++ b/Graphics/Rendering/Ombra/Shader/Language.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Shader/Program.hs b/Graphics/Rendering/Ombra/Shader/Program.hs --- a/Graphics/Rendering/Ombra/Shader/Program.hs +++ b/Graphics/Rendering/Ombra/Shader/Program.hs @@ -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) = diff --git a/Graphics/Rendering/Ombra/Shader/Types.hs b/Graphics/Rendering/Ombra/Shader/Types.hs --- a/Graphics/Rendering/Ombra/Shader/Types.hs +++ b/Graphics/Rendering/Ombra/Shader/Types.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Texture.hs b/Graphics/Rendering/Ombra/Texture.hs --- a/Graphics/Rendering/Ombra/Texture.hs +++ b/Graphics/Rendering/Ombra/Texture.hs @@ -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 diff --git a/Graphics/Rendering/Ombra/Texture/Draw.hs b/Graphics/Rendering/Ombra/Texture/Draw.hs --- a/Graphics/Rendering/Ombra/Texture/Draw.hs +++ b/Graphics/Rendering/Ombra/Texture/Draw.hs @@ -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'. diff --git a/ombra.cabal b/ombra.cabal --- a/ombra.cabal +++ b/ombra.cabal @@ -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