sdl2-compositor 1.2.0.1 → 1.2.0.3

raw patch · 9 files changed

+141/−151 lines, 9 filesdep ~basedep ~lineardep ~sdl2PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, linear, sdl2, stm, transformers

API changes (from Hackage documentation)

Files

• SDL/Compositor.hs +46/−112
• SDL/Compositor/ResIndependent.hs +9/−9
• SDL/Compositor/TTF.hs +1/−1
• SDL/Data/Cache.hs +23/−5
• SDL/Data/Texture.hs +43/−7
• example.hs +4/−3
• font-test.hs +2/−2
• resolution-independent.hs +7/−6
• sdl2-compositor.cabal +6/−6

@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- Declarative image composition based on sdl2 -- Copyright (C) 2015  Sebastian Jordan --@@ -32,9 +34,9 @@     , Manipulator (..)     , Drawer (..)     , AbsoluteSize (..)-    , FontSupport (..)-    , Alignment (..)     , Texture(..)+    , Renderer(..)+    , Renderable(..)     -- * Utility     , withZIndex     -- * Implementation@@ -46,31 +48,24 @@     ) where -import           Control.Arrow import           Control.Lens (over, Lens, lens, view, set) import           Control.Monad (when)-import           Control.Monad.IO.Class import           Data.List import           Data.Maybe-import           Data.Text hiding (foldl, map)+import           Data.StateVar (get,($=)) import           Data.Word-import           Foreign.C.Types-import qualified Graphics.UI.SDL.TTF.FFI as SDL (TTFFont) import           Linear.Affine import           Linear.V2 import           Linear.V3 import           Linear.V4-import           SDL (($=))-import qualified SDL as SDL-import qualified SDL.Raw as SDL (Color)+import qualified SDL  import           SDL.Compositor.Blender import           SDL.Compositor.Drawer import           SDL.Compositor.Manipulator-import           SDL.Compositor.TTF-import           SDL.Data.Cache-import SDL.Data.Texture (Texture(..))+import           SDL.Data.Texture (Texture(..), Renderable(..), Renderer(..)) +-- | A compositing node represents a compound graphical resource. data CompositingNode a = Sized (V2 Int) a                        | FilledRectangle (V2 Int) (V4 Word8)                        | Rectangle (V2 Int) (V4 Word8)@@ -84,14 +79,9 @@                        | Flipped (V2 Bool) (CompositingNode a)                        | Rotated Double (CompositingNode a)                        | Translated (V2 Int) (CompositingNode a)-                       | SCText Alignment SDL.Color Text-                       | SCFont SDL.TTFFont (CompositingNode a)                        | NoOP                        deriving (Show,Eq) -newtype CompositingNodeKey a = CompositingNodeKey (CompositingNode a)-                             deriving (Eq,Show)- instance Manipulator (CompositingNode a) where   modulateAlphaM _ NoOP = NoOP   modulateAlphaM modulator node = AlphaMod (fromIntegral modulator) node@@ -124,10 +114,6 @@   filledRectangleC dims = FilledRectangle dims . colorToVector   lineC dims = Line dims . colorToVector -instance FontSupport CompositingNode where-  showText = SCText-  withFont = SCFont- -- | 'mempty' represents no painting at all. Also -- -- prop> mappend a b == overC a b@@ -176,7 +162,6 @@ withZIndex = go.map snd.sortOn (negate.fst) where   go = foldl overC mempty -type RenderEnv t a = IO a data RendState rend tex = RendState { _alphaMod :: Double                                     , _redMod :: Double                                     , _greenMod :: Double@@ -186,8 +171,6 @@                                     , _rotationAngle :: Double                                     , _blendMode :: Maybe SDL.BlendMode                                     , _flipping :: V2 Bool-                                    , _fontkey :: Maybe FontKey-                                    , _fontcache :: Maybe (Cache FontKey tex)                                     }  defaultState :: r -> RendState r t@@ -201,8 +184,6 @@             , _rotationAngle = 0             , _blendMode = Nothing             , _flipping = V2 False False-            , _fontkey = Nothing-            , _fontcache = Nothing             }  alphaMod,redMod,greenMod,blueMod,rotationAngle@@ -213,12 +194,6 @@ blueMod = lens _blueMod (\st b -> st{_blueMod=b}) rotationAngle = lens _rotationAngle (\st a -> st{_rotationAngle=a}) -fontkey :: Lens (RendState r t) (RendState r t) (Maybe FontKey) (Maybe FontKey)-fontkey = lens _fontkey (\st fk -> st{_fontkey=fk})--fontcache :: Lens (RendState r t) (RendState r t) (Maybe (Cache FontKey t)) (Maybe (Cache FontKey t))-fontcache = lens _fontcache (\st fc -> st{_fontcache=fc})- renderTarget :: Lens (RendState r t) (RendState r t) r r renderTarget = lens _renderTarget (\st rt -> st{_renderTarget=rt}) @@ -232,63 +207,22 @@ bm = lens _blendMode (\st b -> st{_blendMode=b})  -- | Render a composed image.-runRenderer :: SDL.Renderer -> CompositingNode SDL.Texture -> IO ()+runRenderer :: forall tex rend . (Texture tex, Renderer rend, Renderable rend tex) =>+               rend -> CompositingNode tex -> IO () runRenderer target node = do-  currentDrawColor <- SDL.get (SDL.rendererDrawColor target)+  currentDrawColor <- SDL.get (rendererDrawColor target)   renderNode (defaultState target) node-  SDL.rendererDrawColor target SDL.$= currentDrawColor+  rendererDrawColor target SDL.$= currentDrawColor -renderNode :: RendState SDL.Renderer SDL.Texture-           -> CompositingNode SDL.Texture-           -> RenderEnv SDL.Renderer ()+renderNode :: forall tex rend . (Texture tex, Renderable rend tex, Renderer rend) =>+              RendState rend tex+           -> CompositingNode tex+           -> IO () renderNode _ NoOP = return () renderNode env (AlphaMod m node) = renderNode (over alphaMod (*(m/255)) env) node renderNode env (RedMod m node) = renderNode (over redMod (*(m/255)) env) node renderNode env (GreenMod m node) = renderNode (over greenMod (*(m/255)) env) node renderNode env (BlueMod m node) = renderNode (over blueMod (*(m/255)) env) node-renderNode env (SCFont font node) =-  renderNode-  ( over fontkey (\s -> case s of Nothing -> Just $ defaultFontKey font-                                  Just fk -> Just $ fk {fkFont = font})-    env-  )-  node-renderNode env (SCText align color t) = do-  let cache = view fontcache env-      rend = view renderTarget env-      go tex = do-        (w,h) <- (SDL.textureWidth &&& SDL.textureHeight) <$> SDL.queryTexture tex-        let trans =-              case align of-                AlignTopCenter -> Translated (V2 0 down)-                AlignTopLeft -> Translated (V2 right down)-                AlignTopRight -> Translated (V2 left down)-                AlignLeft -> Translated (V2 right 0)-                AlignCenter -> id-                AlignRight -> Translated (V2 left 0)-                AlignBottomLeft -> Translated (V2 right up)-                AlignBottomRight -> Translated (V2 left up)-                AlignBottomCenter -> Translated (V2 0 up)-            left = - fromIntegral w `div` 2-            right = fromIntegral w `mod` 2 + fromIntegral w `div` 2-            up = - fromIntegral h `div` 2-            down = fromIntegral h `div` 2 + fromIntegral h `mod` 2-        renderNode env (trans (Sized (fromIntegral <$> V2 w h) tex))-      mkey =  (\key -> key { fkColor = ColorWrapper color-                           , fkMessage = t}) <$>-              view fontkey env-  maybe-    (return ())-    (\key ->-      case cache of-       Just c -> do-         tex <- liftIO $ throughCache c key (textureFromKey rend key)-         go tex-       Nothing -> do-         tex <- liftIO $ textureFromKey rend key-         go tex-         SDL.destroyTexture tex)-    mkey renderNode env (Translated vec node) =   let currentAngle = view rotationAngle env       V2 horFlip verFlip = view flipping env@@ -320,60 +254,60 @@         (P (midPoint - (fromIntegral <$> dims) / 2))         (fromIntegral <$> dims)   setColorsAndBlend env tex-  SDL.copyEx renderer tex Nothing (Just targetRect) (CDouble ang)+  copyEx renderer tex Nothing (Just targetRect) ang     Nothing (view flipping env) renderNode env (Rectangle dims colors) = do   let rend = view renderTarget env   -- get old values-  oldTarget <- SDL.get (SDL.rendererRenderTarget rend)+  oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)   -- set new values-  tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)-  SDL.rendererRenderTarget rend $= Just tex-  SDL.rendererDrawColor rend $= V4 0 0 0 0-  SDL.clear rend-  SDL.rendererDrawColor rend $= fromIntegral <$> colors-  SDL.drawRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims)))-  SDL.present rend-  SDL.rendererRenderTarget rend $= oldTarget+  tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)+  rendererRenderTarget rend $= Just tex+  rendererDrawColor rend $= V4 0 0 0 0+  clear rend+  rendererDrawColor rend $= fromIntegral <$> colors+  drawRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims)))+  present rend+  rendererRenderTarget rend $= oldTarget   -- render created texture   renderNode env (Sized dims tex)-  SDL.destroyTexture tex+  destroyTexture tex renderNode env (Line dims colors) = do   let rend = view renderTarget env       flippingVector = (\b -> if b then (-1) else 1) <$> view flipping env   -- get old values-  oldTarget <- SDL.get (SDL.rendererRenderTarget rend)+  oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)   -- set new values-  tex <- SDL.createTexture+  tex <- 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-  SDL.rendererDrawColor rend $= fromIntegral <$> colors-  SDL.drawLine rend 0 (P $ fromIntegral <$> dims)-  SDL.present rend-  SDL.rendererRenderTarget rend $= oldTarget+         (dims*flippingVector)+  rendererRenderTarget rend $= Just tex+  rendererDrawColor rend $= V4 0 0 0 0+  clear rend+  rendererDrawColor rend $= fromIntegral <$> colors+  drawLine rend 0 (P $ fromIntegral <$> dims)+  present rend+  rendererRenderTarget rend $= oldTarget   -- render created texture   renderNode env (Sized dims tex)-  SDL.destroyTexture tex+  destroyTexture tex renderNode env(FilledRectangle dims colors) = do   let rend = view renderTarget env   -- get old values-  oldTarget <- SDL.get (SDL.rendererRenderTarget rend)+  oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)   -- 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.present rend-  SDL.rendererRenderTarget rend $= oldTarget+  rendererDrawColor rend $= fromIntegral <$> colors+  tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)+  rendererRenderTarget rend $= Just tex+  clear rend+  present rend+  rendererRenderTarget rend $= oldTarget   -- render created texture   renderNode env (Sized dims tex)   -- retrieve old values-  SDL.destroyTexture tex+  destroyTexture tex  getCurrentBlendMode :: RendState r t -> SDL.BlendMode getCurrentBlendMode env =

@@ -19,9 +19,9 @@       ResIndependent     , fromRelativeCompositor       -- * Drawing-    , drawRectangle-    , fillRectangle-    , drawLine+    , rectangleR+    , filledRectangleR+    , lineR       -- * Composition     , RelativeSize (..)     )@@ -83,14 +83,14 @@                           V2 Int -> ResIndependent c a -> c a fromRelativeCompositor dims (ResIndependent fun) = translateA (shiftToFormat dims 0) (fun dims) -drawRectangle :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a-drawRectangle rectDims colors = ResIndependent $ \dims ->+rectangleR :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a+rectangleR rectDims colors = ResIndependent $ \dims ->   rectangleC (scaleToFormat dims rectDims) colors -fillRectangle :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a-fillRectangle rectDims colors = ResIndependent $ \dims ->+filledRectangleR :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a+filledRectangleR rectDims colors = ResIndependent $ \dims ->   filledRectangleC (scaleToFormat dims rectDims) colors -drawLine :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a-drawLine lineCoords colors = ResIndependent $ \dims ->+lineR :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a+lineR lineCoords colors = ResIndependent $ \dims ->   lineC (scaleToFormat dims lineCoords) colors

@@ -48,7 +48,7 @@           , fkHinting = TTFHNormal           , fkKerning = True           , fkMessage = pack ""-          , fkColor = (ColorWrapper (Color 255 255 255 255))+          , fkColor = ColorWrapper (Color 255 255 255 255)           }  class FontSupport c where

@@ -1,3 +1,7 @@+-- | This module provides a simple caching implementation based on the+-- LRU caching strategy.  The cache is implemented via software+-- transactional memory, which means that you can use the cache from+-- different threads. module SDL.Data.Cache     (       Cacheable (..)@@ -9,11 +13,14 @@ where  import Control.Concurrent.STM.TMVar-import Control.Monad.STM-import Data.Cache.LRU+  (TMVar,newTMVar,tryReadTMVar,tryTakeTMVar,putTMVar)+import Control.Monad.STM (atomically)+import Data.Cache.LRU (LRU,newLRU,insert,insertInforming,lookup) import Prelude hiding (lookup)-import SDL+import SDL (Texture, destroyTexture,Surface,freeSurface) +-- | Something is cacheable if there is an action to release the+-- resource (if necessary). class Cacheable r where   releaseResource :: r -> IO () @@ -25,7 +32,10 @@  data Cache k a = Cache (TMVar (LRU k a)) Int -newCache :: (Ord k) => Int -> IO (Cache k a)+-- | Create a new cache instance.+newCache :: (Ord k) =>+            Int -- ^ the size of the cache to be created (in elements)+         -> IO (Cache k a) newCache s = Cache <$>              atomically (newTMVar (newLRU (Just (fromIntegral s)))) <*>              pure s@@ -60,13 +70,21 @@        putTMVar var newLru        return mVal -throughCache :: (Cacheable r, Ord k) => Cache k r -> k -> IO r -> IO r+-- | Check if a certain element is already cached.  If not execute the+-- action the generate this element.+throughCache :: (Cacheable r, Ord k) =>+                Cache k r -- ^ cache instance+             -> k         -- ^ cache key+             -> IO r      -- ^ action to generate the rsource+             -> IO r throughCache cache key action = do   mVal <- lookupFromCache cache key   case mVal of    Nothing -> putInCache cache key action    Just val -> return val +-- | Invalidate every element in the cache and release the resources+-- accordingly. emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO () emptyCache (Cache var _) = do   mlru <- atomically $ tryTakeTMVar var

@@ -2,17 +2,19 @@ module SDL.Data.Texture        ( Renderable(..)        , Texture(..)+       , Renderer(..)        )        where +import           Control.Monad (void)+import           Data.StateVar (StateVar)+import           Data.Word (Word8)+import           Foreign.C (CDouble(..))+import           Linear.Affine (Point(..))+import           Linear.V2 (V2(..))+import           Linear.V3 (V3)+import           Linear.V4 (V4) import qualified SDL-import Control.Monad (void)-import Linear.V2 (V2(..))-import Linear.Affine (Point(..))-import Linear.V3 (V3)-import Foreign.C (CDouble(..))-import Data.StateVar (StateVar)-import Data.Word (Word8)  -- | This class modells that something can be rendered to another -- thing.@@ -25,6 +27,12 @@          -> Maybe (Point V2 Int)      -- ^ rotation center          -> V2 Bool                   -- ^ flipping          -> IO ()+  createTexture :: rend+                -> SDL.PixelFormat+                -> SDL.TextureAccess+                -> V2 Int+                -> IO tex+  rendererRenderTarget :: rend -> StateVar (Maybe tex)  instance Renderable SDL.Renderer SDL.Texture where   copyEx rend tex sourceRect destRect rot center flipping =@@ -32,13 +40,41 @@     SDL.copyEx rend tex (fmap fromIntegral <$> sourceRect)     (fmap fromIntegral <$> destRect) (CDouble rot)     (fmap fromIntegral <$> center) flipping+  createTexture r pf ta = SDL.createTexture r pf ta . fmap fromIntegral+  rendererRenderTarget = SDL.rendererRenderTarget  class Texture tex where   textureAlphaMod :: tex -> StateVar Word8   textureColorMod :: tex -> StateVar (V3 Word8)   textureBlendMode :: tex -> StateVar SDL.BlendMode+  textureWidth :: tex -> IO Int+  textureHeight :: tex -> IO Int+  textureDims :: tex -> IO (V2 Int)+  textureDims t =+    V2 <$> textureWidth t <*> textureHeight t+  destroyTexture :: tex -> IO ()  instance Texture SDL.Texture where   textureAlphaMod = SDL.textureAlphaMod   textureColorMod = SDL.textureColorMod   textureBlendMode = SDL.textureBlendMode+  textureWidth = fmap (fromIntegral . SDL.textureWidth) . SDL.queryTexture+  textureHeight = fmap (fromIntegral . SDL.textureHeight) . SDL.queryTexture+  textureDims = fmap (\q -> fromIntegral <$>+                            V2 (SDL.textureWidth q) (SDL.textureHeight q)) .+                SDL.queryTexture+  destroyTexture = SDL.destroyTexture++class Renderer rend where+  rendererDrawColor :: rend -> StateVar (V4 Word8)+  clear :: rend -> IO ()+  present :: rend -> IO ()+  drawRect :: rend -> Maybe (SDL.Rectangle Int) -> IO ()+  drawLine :: rend -> Point V2 Int -> Point V2 Int -> IO ()++instance Renderer SDL.Renderer where+  rendererDrawColor = SDL.rendererDrawColor+  clear = SDL.clear+  present = SDL.present+  drawRect r = SDL.drawRect r . fmap (fmap fromIntegral)+  drawLine r a b = SDL.drawLine r (fromIntegral <$> a) (fromIntegral <$> b)

@@ -5,9 +5,9 @@ import SDL (initialize, InitFlag(InitVideo), createWindow, defaultWindow,             createRenderer, RendererConfig(rendererTargetTexture),             defaultRenderer, rendererLogicalSize, ($=), present, clear, quit,-            BlendMode(BlendAlphaBlend))+            BlendMode(BlendAlphaBlend), Texture) import SDL.Compositor (filledRectangleC, translateA, runRenderer, overC,-                       modulateAlphaM, blendMode, rgba)+                       modulateAlphaM, blendMode, rgba, CompositingNode)  main :: IO () main = do@@ -18,12 +18,13 @@   -- 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))+  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, rectGreen, rectBlue :: CompositingNode Texture     rectRed = filledRectangleC (V2 100 150) (rgba 255 100 100 255)     rectGreen = filledRectangleC (V2 100 150) (rgba 100 255 100 255)     rectBlue = filledRectangleC (V2 100 150) (rgba 100 100 255 255)

@@ -19,11 +19,11 @@   rend <- createRenderer window (-1) defaultRenderer   let hello = withFont font $               showText AlignLeft (Color 255 255 255 255) (pack "Hello, World!")-      rectangle = filledRectangleC (V2 400 200) (rgba 255 0 0 255)+      rectangle = filledRectangleC (V2 400 200) (V4 255 0 0 255)   clear rend   runRenderer rend (translateA (V2 400 300) $                     preserveBlendMode BlendAlphaBlend $-                    (hello `overC` rectangle))+                    (hello `overC` rectangle)   present rend   threadDelay (5*1000000)   TTF.quit

@@ -5,13 +5,13 @@             WindowConfig(windowInitialSize), defaultWindow,             createRenderer, defaultRenderer, clear, present,             RendererConfig(rendererTargetTexture,rendererType),-            quit,($=), rendererLogicalSize,+            quit,($=), rendererLogicalSize, Texture,             RendererType(SoftwareRenderer)            ) import System.Environment (getArgs)-import SDL.Compositor.ResIndependent (translateR, fillRectangle,-                                      fromRelativeCompositor)-import SDL.Compositor (runRenderer, rgba)+import SDL.Compositor.ResIndependent (translateR, filledRectangleR,+                                      fromRelativeCompositor, ResIndependent)+import SDL.Compositor (runRenderer, rgba, CompositingNode) import Control.Concurrent (threadDelay)  main :: IO ()@@ -32,7 +32,8 @@   -- clear the window   clear renderer   -- draw a white square with length 0.99 for the edges-  let square = fillRectangle (V2 0.99 0.99) (rgba 255 255 255 255)+  let square :: ResIndependent CompositingNode Texture+      square = filledRectangleR (V2 0.99 0.99) (rgba 255 255 255 255)   -- draw everything   runRenderer     renderer@@ -43,6 +44,6 @@   -- present what we have drawn to the user   present renderer   -- wait for 5 seconds-  threadDelay (5 * 10^6)+  threadDelay (5 * 10^(6::Int))   -- quit sdl   quit

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                sdl2-compositor-version:             1.2.0.1+version:             1.2.0.3 synopsis:            image compositing with sdl2 - declarative style  description: This package provides tools for simple image composition@@ -37,12 +37,12 @@                        SDL.Data.Cache   -- other-modules:   -- other-extensions:-  build-depends:       base >=4.8 && <4.9,-                       sdl2 == 2.*,-                       transformers == 0.4.*,-                       linear == 1.19.*,+  build-depends:       base >=4.8 && < 5,+                       sdl2 >= 2.0,+                       transformers >= 0.4,+                       linear >= 1.19,                        sdl2-ttf >= 0.2.2,-                       stm,+                       stm >= 2.3,                        lrucache >= 1.2,                        text,                        QuickCheck,