packages feed

sdl2-compositor 1.0.1 → 1.1

raw patch · 5 files changed

+202/−26 lines, 5 files

Files

SDL/Compositor.hs view
@@ -15,12 +15,23 @@ -- You should have received a copy of the GNU General Public License -- along with this program.  If not, see <http://www.gnu.org/licenses/>. +-- | 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
+ SDL/Compositor/ResIndependent.hs view
@@ -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
example.hs view
@@ -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
+ resolution-independent.hs view
@@ -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
sdl2-compositor.cabal view
@@ -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,