diff --git a/SDL/Compositor.hs b/SDL/Compositor.hs --- a/SDL/Compositor.hs +++ b/SDL/Compositor.hs @@ -15,12 +15,23 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . +-- | This module provides the means for declarative image generation +-- using sdl2 primitives as a basis. Atomical operations for image +-- composition are rotation, translation, mirroring, color modulation, +-- changing blend modes and primitive drawing. +-- +-- This packages aims to provide a basic interface via type classes. +-- This means that you could write your own implementation but still +-- use eventual utility functions provided by this package. The +-- authors decided to split the functionality into several typeclasses +-- to allow partial implementations while preserving type safety. module SDL.Compositor ( -- * Interface Compositor (..) , Blender (..) , Manipulator (..) , Drawer (..) + , AbsoluteSize (..) -- * Utility , withZIndex -- * Implementation @@ -89,11 +100,14 @@ NoOP `overC` node2 = node2 node1 `overC` node2 = node2 `Under` node1 rotateC = Rotated - translateC _ NoOP = NoOP - translateC v node = Translated v node flipC _ NoOP = NoOP flipC f node = Flipped f node +instance AbsoluteSize CompositingNode where + translateA _ NoOP = NoOP + translateA v node = Translated v node + sizedA = Sized + instance Drawer (CompositingNode a) where rectangleC = Rectangle filledRectangleC = FilledRectangle @@ -125,12 +139,24 @@ infixr 5 `overC` +-- | A Compositor is a thing that can overlap, rotate and mirror +-- objects. class Compositor c where + -- | @overC x y@ positions x over y. The meaning of this depends on + -- the context. For Textures and drawings this means that x should + -- be drawn after y was drawn. overC :: c -> c -> c rotateC :: Double -> c -> c - translateC :: V2 Int -> c -> c + -- | This function takes a 'V2 Bool' that represents mirroring + -- action. The first component of the vector represents mirroring + -- along the y-axis (horizontally) and the second component + -- represents mirroring along the x-axis (vertically). flipC :: V2 Bool -> c -> c +class AbsoluteSize c where + translateA :: V2 Int -> c a -> c a + sizedA :: V2 Int -> a -> c a + -- | Arrange all given compositions in one composition. -- -- This function takes a list of pairs where the first element of the @@ -181,8 +207,10 @@ -- | Render a composed image. runRenderer :: SDL.Renderer -> CompositingNode SDL.Texture -> IO () -runRenderer target node = +runRenderer target node = do + currentDrawColor <- SDL.get (SDL.rendererDrawColor target) evalStateT (renderNode node) (defaultState target) + SDL.rendererDrawColor target SDL.$= currentDrawColor renderNode :: CompositingNode SDL.Texture -> RenderEnv SDL.Renderer () renderNode NoOP = return () @@ -192,9 +220,11 @@ renderNode (BlueMod m node) = withBlueMod m (renderNode node) renderNode (Translated vec node) = do currentAngle <- rotationAngle <$> get + V2 horFlip verFlip <- flipping <$> get let rotatedVec = (rotateV2 currentAngle (fromIntegral <$> vec)) + transVec = V2 (if horFlip then -1 else 1) (if verFlip then -1 else 1) * rotatedVec currentTranslation <- translationVec <$> get - withTranslation (currentTranslation + rotatedVec) (renderNode node) + withTranslation (currentTranslation + transVec) (renderNode node) renderNode (node1 `Under` node2) = do renderNode node1 renderNode node2 @@ -212,13 +242,13 @@ renderNode node setFlip oldFlipping where setFlip x = modify $ \st -> st {flipping = x} - combineFlip f1 f2 = addFlips <$> f1 <*> f2 - addFlips False b = b - addFlips b False = b - addFlips True True = False + combineFlip f1 f2 = (/=) <$> f1 <*> f2 renderNode (Rotated ang node) = do currentAngle <- rotationAngle <$> get - setAngle (currentAngle + ang) + V2 horFlip verFlip <- flipping <$> get + if horFlip /= verFlip + then setAngle (currentAngle - ang) + else setAngle (currentAngle + ang) renderNode node setAngle currentAngle where setAngle a = modify $ \st -> st {rotationAngle = a} @@ -247,7 +277,6 @@ env <- get let rend = renderTarget env -- get old values - oldColors <- SDL.get (SDL.rendererDrawColor rend) oldTarget <- SDL.get (SDL.rendererRenderTarget rend) -- set new values tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims) @@ -260,17 +289,19 @@ SDL.rendererRenderTarget rend $= oldTarget -- render created texture renderNode (Sized dims tex) - -- retrieve old values - SDL.rendererDrawColor rend $= oldColors SDL.destroyTexture tex renderNode (Line dims colors) = do env <- get let rend = renderTarget env + flippingVector = (\b -> if b then (-1) else 1) <$> flipping env -- get old values - oldColors <- SDL.get (SDL.rendererDrawColor rend) oldTarget <- SDL.get (SDL.rendererRenderTarget rend) -- set new values - tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims) + tex <- SDL.createTexture + rend + SDL.RGBA8888 + SDL.TextureAccessTarget + (fromIntegral <$> dims*flippingVector) SDL.rendererRenderTarget rend $= Just tex SDL.rendererDrawColor rend $= V4 0 0 0 0 SDL.clear rend @@ -280,27 +311,22 @@ SDL.rendererRenderTarget rend $= oldTarget -- render created texture renderNode (Sized dims tex) - -- retrieve old values - SDL.rendererDrawColor rend $= oldColors SDL.destroyTexture tex renderNode (FilledRectangle dims colors) = do env <- get let rend = renderTarget env -- get old values - oldColors <- SDL.get (SDL.rendererDrawColor rend) oldTarget <- SDL.get (SDL.rendererRenderTarget rend) -- set new values SDL.rendererDrawColor rend $= fromIntegral <$> colors tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims) SDL.rendererRenderTarget rend $= Just tex SDL.clear rend - SDL.fillRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims))) SDL.present rend SDL.rendererRenderTarget rend $= oldTarget -- render created texture renderNode (Sized dims tex) -- retrieve old values - SDL.rendererDrawColor rend $= oldColors SDL.destroyTexture tex getCurrentBlendMode :: RenderEnv t SDL.BlendMode diff --git a/SDL/Compositor/ResIndependent.hs b/SDL/Compositor/ResIndependent.hs new file mode 100644 --- /dev/null +++ b/SDL/Compositor/ResIndependent.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides an implementation for simple resolution +-- independent drawing and rendering. You can do the same stuff with +-- the resolution independent compositor as with a regular one. +-- +-- One important difference is that the 'translateA' function as well +-- as the standard drawing functions don't work with 'ResIndependent'. +-- Instead there are replacement functions for these operations. +-- +-- This implementation finds the biggest square that fits into the +-- dimensions of the rendering surface. The top left corner of this +-- sqare is @V2 0 0@, the bottom right corner is @V2 1 1@. + +module SDL.Compositor.ResIndependent + ( -- * Wrapping and unwrapping + ResIndependent + , fromRelativeCompositor + -- * Drawing + , drawRectangle + , fillRectangle + , drawLine + -- * Composition + , RelativeSize (..) + ) +where + +import Data.Word +import Linear.V2 +import Linear.V4 + +import SDL.Compositor + +class RelativeSize c where + -- | Translate a composition by a given resolution independent + -- vector. + translateR :: V2 Float -> c a -> c a + -- | This function takes a rectangular area given as resolution + -- independent coordinates and an object and constructs a + -- compositing node from it that spans the given area. + sizedR :: V2 Float -> a -> c a + +newtype ResIndependent c a = ResIndependent (V2 Int -> c a) + deriving (Functor,Monoid) + +instance Compositor (c a) => Compositor (ResIndependent c a) where + overC (ResIndependent fun1) (ResIndependent fun2) = + ResIndependent $ \dims -> fun1 dims `overC` fun2 dims + rotateC ang (ResIndependent fun) = ResIndependent $ \dims -> rotateC ang (fun dims) + flipC flipping (ResIndependent fun) = ResIndependent $ \dims -> flipC flipping (fun dims) + +instance (AbsoluteSize c) => RelativeSize (ResIndependent c) where + translateR coords (ResIndependent fun) = ResIndependent $ \dims -> + translateA (scaleToFormat dims coords) (fun dims) + sizedR texDims tex = ResIndependent $ \dims -> + sizedA (scaleToFormat dims texDims) tex + +instance Manipulator (c a) => Manipulator (ResIndependent c a) where + modulateAlphaM val (ResIndependent fun) = ResIndependent $ \dims -> modulateAlphaM val (fun dims) + modulateRedM val (ResIndependent fun) = ResIndependent $ \dims -> modulateRedM val (fun dims) + modulateGreenM val (ResIndependent fun) = ResIndependent $ \dims -> modulateGreenM val (fun dims) + modulateBlueM val (ResIndependent fun) = ResIndependent $ \dims -> modulateBlueM val (fun dims) + +instance Blender (c a) => Blender (ResIndependent c a) where + overrideBlendMode mode (ResIndependent fun) = ResIndependent $ \dims -> overrideBlendMode mode (fun dims) + preserveBlendMode mode (ResIndependent fun) = ResIndependent $ \dims -> preserveBlendMode mode (fun dims) + +scaleToFormat :: V2 Int -> V2 Float -> V2 Int +scaleToFormat (V2 w h) coords = + round <$> scale * coords where + scale = fromIntegral (min w h) + +shiftToFormat :: V2 Int -> V2 Int -> V2 Int +shiftToFormat (V2 w h) (V2 x y) + | w == h = V2 x y + | w > h = let delta = (w - h) `div` 2 + in V2 (x + delta) y + | otherwise = let delta = (h - w) `div` 2 + in V2 x (y + delta) + +-- | Convert a resolution independent compositor into a compositor for +-- a fixed screen size by specifying the size of the screen. +fromRelativeCompositor :: (Compositor (c a), AbsoluteSize c) => + V2 Int -> ResIndependent c a -> c a +fromRelativeCompositor dims (ResIndependent fun) = translateA (shiftToFormat dims 0) (fun dims) + +drawRectangle :: (Drawer (c a)) => V2 Float -> V4 Word8 -> ResIndependent c a +drawRectangle rectDims colors = ResIndependent $ \dims -> + rectangleC (scaleToFormat dims rectDims) colors + +fillRectangle :: (Drawer (c a)) => V2 Float -> V4 Word8 -> ResIndependent c a +fillRectangle rectDims colors = ResIndependent $ \dims -> + filledRectangleC (scaleToFormat dims rectDims) colors + +drawLine :: (Drawer (c a)) => V2 Float -> V4 Word8 -> ResIndependent c a +drawLine lineCoords colors = ResIndependent $ \dims -> + lineC (scaleToFormat dims lineCoords) colors diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -7,7 +7,7 @@ createRenderer, RendererConfig(rendererTargetTexture), defaultRenderer, rendererLogicalSize, ($=), present, clear, quit, BlendMode(BlendAlphaBlend)) -import SDL.Compositor (filledRectangleC, rotateC, translateC, runRenderer, overC, +import SDL.Compositor (filledRectangleC, translateA, runRenderer, overC, modulateAlphaM, preserveBlendMode) main :: IO () @@ -29,7 +29,7 @@ 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) + translateToCenter = translateA (V2 250 300) -- draw everything runRenderer rend ( ( -- enable alpha blending for the whole subtree @@ -41,8 +41,8 @@ ) ( -- red, green and blue rectRed `overC` - translateC (V2 150 0) (rectGreen `overC` - translateC (V2 150 0) rectBlue) + translateA (V2 150 0) (rectGreen `overC` + translateA (V2 150 0) rectBlue) ) ) -- show the drawn image on the screen diff --git a/resolution-independent.hs b/resolution-independent.hs new file mode 100644 --- /dev/null +++ b/resolution-independent.hs @@ -0,0 +1,49 @@ + +import Data.Text (pack) +import Linear.V2 (V2(..)) +import SDL (initialize, InitFlag(InitVideo), createWindow, + WindowConfig(windowInitialSize), defaultWindow, + createRenderer, defaultRenderer, clear, present, + RendererConfig(rendererTargetTexture,rendererType), + quit,($=), rendererLogicalSize, + RendererType(SoftwareRenderer) + ) +import System.Environment (getArgs) +import Linear.V4 (V4(..)) +import SDL.Compositor.ResIndependent (translateR, fillRectangle, + fromRelativeCompositor) +import SDL.Compositor (runRenderer) +import Control.Concurrent (threadDelay) + +main :: IO () +main = do + -- Initialize sdl + initialize [InitVideo] + -- read window dimensions from command line args + dims <- (\(w:h:_) -> V2 (read w) (read h)) <$> getArgs + -- create a window with the given dimensions + window <- createWindow (pack "test window") (defaultWindow {windowInitialSize = dims}) + -- create a renderer for the windows surface, software for + -- compatibility reasons + renderer <- createRenderer window (-1) + (defaultRenderer {rendererTargetTexture = True + ,rendererType = SoftwareRenderer}) + -- setting the logical size is optional + rendererLogicalSize renderer $= Just dims + -- clear the window + clear renderer + -- draw a white square with length 0.99 for the edges + let square = fillRectangle (V2 0.99 0.99) (V4 255 255 255 255) + -- draw everything + runRenderer + renderer + ( fromRelativeCompositor (fromIntegral <$> dims) $ + translateR (V2 0.5 0.5) -- move the square to the center of + square + ) + -- present what we have drawn to the user + present renderer + -- wait for 5 seconds + threadDelay (5 * 10^6) + -- quit sdl + quit diff --git a/sdl2-compositor.cabal b/sdl2-compositor.cabal --- a/sdl2-compositor.cabal +++ b/sdl2-compositor.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor -version: 1.0.1 +version: 1.1 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition @@ -17,7 +17,8 @@ copyright: (c) 2015 Sebastian Jordan category: Graphics build-type: Simple -extra-source-files: example.hs +extra-source-files: example.hs, + resolution-independent.hs cabal-version: >=1.10 library @@ -25,6 +26,7 @@ SDL.Compositor.Manipulator, SDL.Compositor.Blender, SDL.Compositor.Drawer + SDL.Compositor.ResIndependent -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9,