diff --git a/SDL/Compositor.hs b/SDL/Compositor.hs --- a/SDL/Compositor.hs +++ b/SDL/Compositor.hs @@ -21,6 +21,8 @@ , Blender (..) , Manipulator (..) , Drawer (..) + -- * Utility + , withZIndex -- * Implementation , CompositingNode , sizedCompositingLeaf @@ -29,6 +31,7 @@ where import Control.Monad.Trans.State +import Data.List import Data.Maybe import Data.Word import Foreign.C.Types @@ -57,33 +60,69 @@ | Flipped (V2 Bool) (CompositingNode a) | Rotated Double (CompositingNode a) | Translated (V2 Int) (CompositingNode a) + | NoOP deriving (Show,Read,Eq) --- | Create a Graphics object with the given size. +-- | Create a Graphics object with the given size on the rendering +-- surface. sizedCompositingLeaf :: V2 Int -> a -> CompositingNode a sizedCompositingLeaf = Sized instance Manipulator (CompositingNode a) where + modulateAlphaM _ NoOP = NoOP modulateAlphaM modulator node = AlphaMod (fromIntegral modulator) node + modulateRedM _ NoOP = NoOP modulateRedM modulator node = RedMod (fromIntegral modulator) node + modulateGreenM _ NoOP = NoOP modulateGreenM modulator node = GreenMod (fromIntegral modulator) node + modulateBlueM _ NoOP = NoOP modulateBlueM modulator node = BlueMod (fromIntegral modulator) node instance Blender (CompositingNode a) where - overrideBlendMode = OverrideBlendMode - preserveBlendMode = PreserveBlendMode + overrideBlendMode _ NoOP = NoOP + overrideBlendMode mode node = OverrideBlendMode mode node + preserveBlendMode _ NoOP = NoOP + preserveBlendMode mode node = PreserveBlendMode mode node instance Compositor (CompositingNode a) where + node1 `overC` NoOP = node1 + NoOP `overC` node2 = node2 node1 `overC` node2 = node2 `Under` node1 rotateC = Rotated - translateC = Translated - flipC = Flipped + translateC _ NoOP = NoOP + translateC v node = Translated v node + flipC _ NoOP = NoOP + flipC f node = Flipped f node instance Drawer (CompositingNode a) where rectangleC = Rectangle filledRectangleC = FilledRectangle lineC = Line +-- | 'mempty' represents no painting at all. Also +-- +-- prop> mappend a b == overC a b +instance Monoid (CompositingNode a) where + mempty = NoOP + mappend = flip overC + +instance Functor CompositingNode where + fun `fmap` (Sized vec a) = Sized vec (fun a) + fun `fmap` (AlphaMod d n) = AlphaMod d (fun `fmap` n) + fun `fmap` (RedMod d n) = RedMod d (fun `fmap` n) + fun `fmap` (GreenMod d n) = GreenMod d (fun `fmap` n) + fun `fmap` (BlueMod d n) = BlueMod d (fun `fmap` n) + fun `fmap` (OverrideBlendMode b n) = OverrideBlendMode b (fun `fmap` n) + fun `fmap` (PreserveBlendMode b n) = PreserveBlendMode b (fun `fmap` n) + fun `fmap` (x1 `Under` x2) = (fun `fmap` x1) `Under` (fun `fmap` x2) + fun `fmap` (Flipped f n) = Flipped f (fun `fmap` n) + fun `fmap` (Rotated d n) = Rotated d (fun `fmap` n) + fun `fmap` (Translated vec n) = Translated vec (fun `fmap` n) + _ `fmap` NoOP = NoOP + _ `fmap` (FilledRectangle rect color) = FilledRectangle rect color + _ `fmap` (Rectangle rect color) = FilledRectangle rect color + _ `fmap` (Line vec color) = FilledRectangle vec color + infixr 5 `overC` class Compositor c where @@ -92,6 +131,27 @@ translateC :: V2 Int -> c -> c flipC :: V2 Bool -> c -> c +-- | Arrange all given compositions in one composition. +-- +-- This function takes a list of pairs where the first element of the +-- pair is the z-index and the second element is the composition. +-- Elements of with a higher z-index will be rendered "in front of" +-- elements with lower indices. If elements have the same index then +-- the element that comes first in the list will be drawn over all the +-- later ones. +-- +-- This method can only arrange compositions that are in the "the same +-- list of arguments". That means that +-- +-- > withZIndex [(1,a),(2,b)] `overC` withZIndex [(3,c)] +-- +-- will always result in @b@ being rendered "in front of" @a@ and @c@, +-- no matter how large the z-index of @c@ is. +withZIndex :: (Compositor c, Monoid c) => + [(Int,c)] -> c +withZIndex = go.map snd.sortOn (negate.fst) where + go cs = foldl overC mempty cs + type RenderEnv t a = StateT (RendState t) IO a data RendState t = RendState { alphaMod :: Double , redMod :: Double @@ -125,6 +185,7 @@ evalStateT (renderNode node) (defaultState target) renderNode :: CompositingNode SDL.Texture -> RenderEnv SDL.Renderer () +renderNode NoOP = return () renderNode (AlphaMod m node) = withAlphaMod m (renderNode node) renderNode (RedMod m node) = withRedMod m (renderNode node) renderNode (GreenMod m node) = withGreenMod m (renderNode node) @@ -272,7 +333,6 @@ SDL.textureAlphaMod tex $= oldAlpha SDL.textureColorMod tex $= oldRGB SDL.textureBlendMode tex $= oldBlend --- liftIO $ print oldBlend return result rotateV2 :: Double -> V2 Double -> V2 Double diff --git a/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -0,0 +1,53 @@ + +import Control.Concurrent (threadDelay) +import Data.Text (pack) +import Linear.V2 (V2(..)) +import Linear.V4 (V4(..)) +import SDL (initialize, InitFlag(InitVideo), createWindow, defaultWindow, + createRenderer, RendererConfig(rendererTargetTexture), defaultRenderer, + rendererLogicalSize, ($=), present, clear, quit, + BlendMode(BlendAlphaBlend)) +import SDL.Compositor (filledRectangleC, rotateC, translateC, runRenderer, overC, + modulateAlphaM, preserveBlendMode) + +main :: IO () +main = do + -- intialize SDL + initialize [InitVideo] + -- create a window + window <- createWindow (pack "test window") defaultWindow + -- create a renderer for the window + rend <- createRenderer window (-1) (defaultRenderer {rendererTargetTexture = True}) + -- set the logical size of the window to 800x600 + rendererLogicalSize rend $= (Just (V2 800 600)) + -- clear the renderer + clear rend + let + -- 3 rectangles, one in red, one in green and one in blue, width: + -- 100, height 150 + rectRed = filledRectangleC (V2 100 150) (V4 255 100 100 255) + rectGreen = filledRectangleC (V2 100 150) (V4 100 255 100 255) + rectBlue = filledRectangleC (V2 100 150) (V4 100 100 255 255) + -- translate an image by (250,300) pixels + translateToCenter = translateC (V2 250 300) + -- draw everything + runRenderer rend + ( ( -- enable alpha blending for the whole subtree + preserveBlendMode BlendAlphaBlend . + -- make all the images slightly transparent + modulateAlphaM 150 . + -- align the images in the center + translateToCenter + ) + ( -- red, green and blue + rectRed `overC` + translateC (V2 150 0) (rectGreen `overC` + translateC (V2 150 0) rectBlue) + ) + ) + -- show the drawn image on the screen + present rend + -- pause for 5 seconds + threadDelay (5 * (10::Int)^(6::Int)) + -- quit SDL + quit diff --git a/sdl2-compositor.cabal b/sdl2-compositor.cabal --- a/sdl2-compositor.cabal +++ b/sdl2-compositor.cabal @@ -1,8 +1,8 @@ --- Initial sdl2-compositor.cabal generated by cabal init. For further +-- Initial sdl2-compositor.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor -version: 1.0.0.1 +version: 1.0.1 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition @@ -17,7 +17,7 @@ copyright: (c) 2015 Sebastian Jordan category: Graphics build-type: Simple --- extra-source-files: +extra-source-files: example.hs cabal-version: >=1.10 library @@ -25,13 +25,13 @@ SDL.Compositor.Manipulator, SDL.Compositor.Blender, SDL.Compositor.Drawer - -- other-modules: - -- other-extensions: + -- other-modules: + -- other-extensions: build-depends: base >=4.8 && <4.9, sdl2 == 2.*, - transformers, - linear - -- hs-source-dirs: + transformers == 0.4.*, + linear == 1.19.* + -- hs-source-dirs: default-language: Haskell2010 source-repository head