sdl2-compositor 1.1 → 1.2
raw patch · 8 files changed
+285/−238 lines, 8 filesdep +QuickCheckdep +StateVardep +lensdep ~basedep ~lineardep ~sdl2new-component:exe:sdl2-comp-examplenew-component:exe:sdl2-comp-res-independent
Dependencies added: QuickCheck, StateVar, lens, lrucache, sdl2-ttf, stm, text
Dependency ranges changed: base, linear, sdl2, transformers
Files
- SDL/Compositor.hs +190/−208
- SDL/Compositor/Blender.hs +1/−6
- SDL/Compositor/Drawer.hs +15/−3
- SDL/Compositor/ResIndependent.hs +4/−7
- example.hs +7/−8
- font-test.hs +33/−0
- resolution-independent.hs +2/−3
- sdl2-compositor.cabal +33/−3
SDL/Compositor.hs view
@@ -32,30 +32,44 @@ , Manipulator (..) , Drawer (..) , AbsoluteSize (..)+ , FontSupport (..)+ , Alignment (..)+ , Texture(..) -- * Utility , withZIndex -- * Implementation , CompositingNode- , sizedCompositingLeaf , runRenderer+ -- * Colors+ , Color+ , rgba ) where -import Control.Monad.Trans.State+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.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 SDL.Compositor.Blender import SDL.Compositor.Drawer import SDL.Compositor.Manipulator+import SDL.Compositor.TTF+import SDL.Data.Cache+import SDL.Data.Texture (Texture(..)) data CompositingNode a = Sized (V2 Int) a | FilledRectangle (V2 Int) (V4 Word8)@@ -65,19 +79,18 @@ | RedMod Double (CompositingNode a) | GreenMod Double (CompositingNode a) | BlueMod Double (CompositingNode a)- | OverrideBlendMode SDL.BlendMode (CompositingNode a) | PreserveBlendMode SDL.BlendMode (CompositingNode a) | (CompositingNode a) `Under` (CompositingNode a) | 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,Read,Eq)+ deriving (Show,Eq) --- | Create a Graphics object with the given size on the rendering--- surface.-sizedCompositingLeaf :: V2 Int -> a -> CompositingNode a-sizedCompositingLeaf = Sized+newtype CompositingNodeKey a = CompositingNodeKey (CompositingNode a)+ deriving (Eq,Show) instance Manipulator (CompositingNode a) where modulateAlphaM _ NoOP = NoOP@@ -90,10 +103,8 @@ modulateBlueM modulator node = BlueMod (fromIntegral modulator) node instance Blender (CompositingNode a) where- overrideBlendMode _ NoOP = NoOP- overrideBlendMode mode node = OverrideBlendMode mode node- preserveBlendMode _ NoOP = NoOP- preserveBlendMode mode node = PreserveBlendMode mode node+ blendMode _ NoOP = NoOP+ blendMode mode node = PreserveBlendMode mode node instance Compositor (CompositingNode a) where node1 `overC` NoOP = node1@@ -109,10 +120,14 @@ sizedA = Sized instance Drawer (CompositingNode a) where- rectangleC = Rectangle- filledRectangleC = FilledRectangle- lineC = Line+ rectangleC dims = Rectangle dims . colorToVector+ 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@@ -120,23 +135,6 @@ 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` -- | A Compositor is a thing that can overlap, rotate and mirror@@ -176,106 +174,156 @@ withZIndex :: (Compositor c, Monoid c) => [(Int,c)] -> c withZIndex = go.map snd.sortOn (negate.fst) where- go cs = foldl overC mempty cs+ go = foldl overC mempty -type RenderEnv t a = StateT (RendState t) IO a-data RendState t = RendState { alphaMod :: Double- , redMod :: Double- , greenMod :: Double- , blueMod :: Double- , renderTarget :: t- , translationVec :: V2 Double- , rotationAngle :: Double- , blendOverride :: Maybe SDL.BlendMode- , blendMode :: Maybe SDL.BlendMode- , flipping :: V2 Bool- }+type RenderEnv t a = IO a+data RendState rend tex = RendState { _alphaMod :: Double+ , _redMod :: Double+ , _greenMod :: Double+ , _blueMod :: Double+ , _renderTarget :: rend+ , _translationVec :: V2 Double+ , _rotationAngle :: Double+ , _blendMode :: Maybe SDL.BlendMode+ , _flipping :: V2 Bool+ , _fontkey :: Maybe FontKey+ , _fontcache :: Maybe (Cache FontKey tex)+ } -defaultState :: t -> RendState t+defaultState :: r -> RendState r t defaultState target =- RendState { alphaMod = 255- , redMod = 255- , greenMod = 255- , blueMod = 255- , renderTarget = target- , translationVec = 0- , rotationAngle = 0- , blendOverride = Nothing- , blendMode = Nothing- , flipping = V2 False False+ RendState { _alphaMod = 255+ , _redMod = 255+ , _greenMod = 255+ , _blueMod = 255+ , _renderTarget = target+ , _translationVec = 0+ , _rotationAngle = 0+ , _blendMode = Nothing+ , _flipping = V2 False False+ , _fontkey = Nothing+ , _fontcache = Nothing } +alphaMod,redMod,greenMod,blueMod,rotationAngle+ :: Lens (RendState r t) (RendState r t) Double Double+alphaMod = lens _alphaMod (\st a -> st{_alphaMod = a})+redMod = lens _redMod (\st r -> st{_redMod=r})+greenMod = lens _greenMod (\st g -> st{_greenMod=g})+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})++flipping :: Lens (RendState r t) (RendState r t) (V2 Bool) (V2 Bool)+flipping = lens _flipping (\st f -> st{_flipping=f})++translationVec :: Lens (RendState r t) (RendState r t) (V2 Double) (V2 Double)+translationVec = lens _translationVec (\st tv -> st{_translationVec=tv})++bm :: Lens (RendState r t) (RendState r t) (Maybe SDL.BlendMode) (Maybe SDL.BlendMode)+bm = lens _blendMode (\st b -> st{_blendMode=b})+ -- | Render a composed image. runRenderer :: SDL.Renderer -> CompositingNode SDL.Texture -> IO () runRenderer target node = do currentDrawColor <- SDL.get (SDL.rendererDrawColor target)- evalStateT (renderNode node) (defaultState target)+ renderNode (defaultState target) node SDL.rendererDrawColor target SDL.$= currentDrawColor -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)-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))+renderNode :: RendState SDL.Renderer SDL.Texture+ -> CompositingNode SDL.Texture+ -> RenderEnv SDL.Renderer ()+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+ 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 + transVec) (renderNode node)-renderNode (node1 `Under` node2) = do- renderNode node1- renderNode node2-renderNode (OverrideBlendMode mode node) = do- oldOverride <- blendOverride <$> get- case oldOverride of- Nothing -> do setBlendOverride (Just mode)- renderNode node- setBlendOverride (Nothing)- Just _ -> return ()- where setBlendOverride m = modify $ \st -> st {blendOverride = m}-renderNode (Flipped f node) = do- oldFlipping <- flipping <$> get- setFlip (combineFlip oldFlipping f)- renderNode node- setFlip oldFlipping- where setFlip x = modify $ \st -> st {flipping = x}- combineFlip f1 f2 = (/=) <$> f1 <*> f2-renderNode (Rotated ang node) = do- currentAngle <- rotationAngle <$> get- 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}-renderNode (PreserveBlendMode mode node) = do- currentMode <- blendMode <$> get- setBlendMode (Just mode)- renderNode node- setBlendMode currentMode- where setBlendMode m = modify $ \st -> st {blendMode = m}-renderNode (Sized dims tex) = do- env <- get- let renderer = renderTarget env- midPoint = translationVec env+ in renderNode (over translationVec (+ transVec) env) node+renderNode env (node1 `Under` node2) =+ renderNode env node1 >> renderNode env node2+renderNode env (Flipped f node) =+ renderNode (over flipping ((/=) <$> f <*>) env) node+renderNode env (Rotated ang node) =+ renderNode (set rotationAngle newAngle env) node+ where currentAngle = view rotationAngle env+ V2 horFlip verFlip = view flipping env+ newAngle = if horFlip /= verFlip+ then currentAngle - ang+ else currentAngle + ang+renderNode env (PreserveBlendMode mode node) =+ renderNode (set bm (Just mode) env) node+renderNode _ (Sized (V2 0 _) _) = return ()+renderNode _ (Sized (V2 _ 0) _) = return ()+renderNode env (Sized dims tex) = do+ let renderer = view renderTarget env+ midPoint = view translationVec env ang = (negate.(/pi).(*180)) $- rotationAngle env- targetRect = fmap round $+ view rotationAngle env+ targetRect = round <$> SDL.Rectangle (P (midPoint - (fromIntegral <$> dims) / 2)) (fromIntegral <$> dims)- setColorsAndBlend tex- ( SDL.copyEx- renderer tex Nothing (Just targetRect) (CDouble ang)- Nothing (flipping env)- )-renderNode (Rectangle dims colors) = do- env <- get- let rend = renderTarget env+ setColorsAndBlend env tex+ SDL.copyEx renderer tex Nothing (Just targetRect) (CDouble 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) -- set new values@@ -288,12 +336,11 @@ SDL.present rend SDL.rendererRenderTarget rend $= oldTarget -- render created texture- renderNode (Sized dims tex)+ renderNode env (Sized dims tex) SDL.destroyTexture tex-renderNode (Line dims colors) = do- env <- get- let rend = renderTarget env- flippingVector = (\b -> if b then (-1) else 1) <$> flipping env+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) -- set new values@@ -310,11 +357,10 @@ SDL.present rend SDL.rendererRenderTarget rend $= oldTarget -- render created texture- renderNode (Sized dims tex)+ renderNode env (Sized dims tex) SDL.destroyTexture tex-renderNode (FilledRectangle dims colors) = do- env <- get- let rend = renderTarget env+renderNode env(FilledRectangle dims colors) = do+ let rend = view renderTarget env -- get old values oldTarget <- SDL.get (SDL.rendererRenderTarget rend) -- set new values@@ -325,99 +371,35 @@ SDL.present rend SDL.rendererRenderTarget rend $= oldTarget -- render created texture- renderNode (Sized dims tex)+ renderNode env (Sized dims tex) -- retrieve old values SDL.destroyTexture tex -getCurrentBlendMode :: RenderEnv t SDL.BlendMode-getCurrentBlendMode =- (\env -> fromMaybe SDL.BlendNone $- case blendOverride env of- Nothing -> blendMode env- Just _ -> blendOverride env) <$> get-+getCurrentBlendMode :: RendState r t -> SDL.BlendMode+getCurrentBlendMode env =+ fromMaybe SDL.BlendNone $+ view bm env -setColorsAndBlend :: SDL.Texture -> RenderEnv t a -> RenderEnv t a-setColorsAndBlend tex action = do- env <- get- blend <- getCurrentBlendMode+setColorsAndBlend :: (Texture a) => RendState t a -> a -> IO ()+setColorsAndBlend env tex = do let safeToWord8 :: Int -> Word8 safeToWord8 n | n > 255 = 255 | n < 0 = 0 | otherwise = fromIntegral n- alpha = (safeToWord8 . round . alphaMod) env- red = (safeToWord8 . round . redMod) env- green = (safeToWord8 . round . greenMod) env- blue = (safeToWord8 . round . blueMod ) env- oldAlpha <- SDL.get (SDL.textureAlphaMod tex)- oldRGB <- SDL.get (SDL.textureColorMod tex)- oldBlend <- SDL.get (SDL.textureBlendMode tex)- SDL.textureAlphaMod tex $= alpha- SDL.textureColorMod tex $= V3 red green blue- SDL.textureBlendMode tex $= blend- result <- action- SDL.textureAlphaMod tex $= oldAlpha- SDL.textureColorMod tex $= oldRGB- SDL.textureBlendMode tex $= oldBlend- return result+ alpha = (safeToWord8 . round . view alphaMod) env+ red = (safeToWord8 . round . view redMod) env+ green = (safeToWord8 . round . view greenMod) env+ blue = (safeToWord8 . round . view blueMod ) env+ blend = getCurrentBlendMode env+ rgb = V3 red green blue+ oldAlpha <- SDL.get (textureAlphaMod tex)+ oldRGB <- SDL.get (textureColorMod tex)+ oldBlend <- SDL.get (textureBlendMode tex)+ when (oldAlpha /= alpha) $ textureAlphaMod tex $= alpha+ when (oldRGB /= rgb) $ textureColorMod tex $= rgb+ when (oldBlend /= blend) $ textureBlendMode tex $= blend rotateV2 :: Double -> V2 Double -> V2 Double rotateV2 ang (V2 x y) = V2 (x * cos ang - y * sin ang) (x * sin ang + y * cos ang)--withTranslation :: V2 Double -> RenderEnv t a -> RenderEnv t a-withTranslation vec action = do- oldVec <- translationVec <$> get- modify $ \st -> st {translationVec = vec}- res <- action- modify $ \st -> st {translationVec = oldVec}- return res--withAlphaMod :: Double -> RenderEnv t a -> RenderEnv t a-withAlphaMod m action = do- oldMod <- getAlphaMod- setAlphaMod (oldMod * (m/255))- res <- action- setAlphaMod oldMod- return res- where getAlphaMod :: RenderEnv t Double- getAlphaMod = alphaMod <$> get- setAlphaMod :: Double -> RenderEnv t ()- setAlphaMod x = modify $ \st -> st {alphaMod = x}--withRedMod :: Double -> RenderEnv t a -> RenderEnv t a-withRedMod m action = do- oldMod <- getRedMod- setRedMod (oldMod * (m/255))- res <- action- setRedMod oldMod- return res- where getRedMod :: RenderEnv t Double- getRedMod = redMod <$> get- setRedMod :: Double -> RenderEnv t ()- setRedMod x = modify $ \st -> st {redMod = x}--withGreenMod :: Double -> RenderEnv t a -> RenderEnv t a-withGreenMod m action = do- oldMod <- getGreenMod- setGreenMod (oldMod * (m/255))- res <- action- setGreenMod oldMod- return res- where getGreenMod :: RenderEnv t Double- getGreenMod = greenMod <$> get- setGreenMod :: Double -> RenderEnv t ()- setGreenMod x = modify $ \st -> st {greenMod = x}--withBlueMod :: Double -> RenderEnv t a -> RenderEnv t a-withBlueMod m action = do- oldMod <- getBlueMod- setBlueMod (oldMod * (m/255))- res <- action- setBlueMod oldMod- return res- where getBlueMod :: RenderEnv t Double- getBlueMod = blueMod <$> get- setBlueMod :: Double -> RenderEnv t ()- setBlueMod x = modify $ \st -> st {blueMod = x}
SDL/Compositor/Blender.hs view
@@ -5,11 +5,6 @@ -- | This class modells a graphics object that supports switching of -- `BlendMode`. class Blender b where- -- | This method overrides the the blend mode settings for an- -- object. If the object contains children/multiple objects, their- -- `BlendMode` property will also be overidden.- overrideBlendMode :: BlendMode -> b -> b -- | This method sets the `BlendMode` of an object. If the object -- has children, their `BlendMode` property will be preserved.- preserveBlendMode :: BlendMode -> b -> b-+ blendMode :: BlendMode -> b -> b
SDL/Compositor/Drawer.hs view
@@ -5,6 +5,18 @@ import Linear.V4 class Drawer d where- rectangleC :: V2 Int -> V4 Word8 -> d- lineC :: V2 Int -> V4 Word8 -> d- filledRectangleC :: V2 Int -> V4 Word8 -> d+ rectangleC :: V2 Int -> Color -> d+ lineC :: V2 Int -> Color -> d+ filledRectangleC :: V2 Int -> Color -> d++-- | Represents the value of color.+newtype Color = Color {unColor :: V4 Word8}++-- | construct a color value from red green blue and alpha values.+rgba :: Word8 -> Word8 -> Word8 -> Word8 -> Color+rgba r g b a = Color $ V4 r g b a++-- | Convert a color value to vector of numbers that represent the+-- color.+colorToVector :: Color -> V4 Word8+colorToVector = unColor
SDL/Compositor/ResIndependent.hs view
@@ -27,9 +27,7 @@ ) where -import Data.Word import Linear.V2-import Linear.V4 import SDL.Compositor @@ -64,8 +62,7 @@ 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)+ blendMode mode (ResIndependent fun) = ResIndependent $ \dims -> blendMode mode (fun dims) scaleToFormat :: V2 Int -> V2 Float -> V2 Int scaleToFormat (V2 w h) coords =@@ -86,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 -> V4 Word8 -> ResIndependent c a+drawRectangle :: (Drawer (c a)) => V2 Float -> Color -> 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 :: (Drawer (c a)) => V2 Float -> Color -> 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 :: (Drawer (c a)) => V2 Float -> Color -> ResIndependent c a drawLine lineCoords colors = ResIndependent $ \dims -> lineC (scaleToFormat dims lineCoords) colors
example.hs view
@@ -2,13 +2,12 @@ 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,+ createRenderer, RendererConfig(rendererTargetTexture),+ defaultRenderer, rendererLogicalSize, ($=), present, clear, quit, BlendMode(BlendAlphaBlend)) import SDL.Compositor (filledRectangleC, translateA, runRenderer, overC,- modulateAlphaM, preserveBlendMode)+ modulateAlphaM, blendMode, rgba) main :: IO () main = do@@ -25,15 +24,15 @@ 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)+ 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) -- translate an image by (250,300) pixels translateToCenter = translateA (V2 250 300) -- draw everything runRenderer rend ( ( -- enable alpha blending for the whole subtree- preserveBlendMode BlendAlphaBlend .+ blendMode BlendAlphaBlend . -- make all the images slightly transparent modulateAlphaM 150 . -- align the images in the center
+ font-test.hs view
@@ -0,0 +1,33 @@+import Control.Concurrent+import Control.Monad+import Data.Text hiding (head)+import qualified Graphics.UI.SDL.TTF as TTF+import Linear.V2+import Linear.V4+import SDL+import SDL.Compositor+import SDL.Raw (Color(..))+import System.Environment++main = do+ void TTF.init+ initializeAll+ args <- getArgs+ let fontPath = head args+ font <- TTF.openFont fontPath 36+ window <- createWindow (pack "Testwindow") defaultWindow+ 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)+ clear rend+ runRenderer rend (translateA (V2 400 300) $+ preserveBlendMode BlendAlphaBlend $+ (hello `overC` rectangle))+ present rend+ threadDelay (5*1000000)+ TTF.quit+ quit+ + +
resolution-independent.hs view
@@ -9,10 +9,9 @@ RendererType(SoftwareRenderer) ) import System.Environment (getArgs)-import Linear.V4 (V4(..)) import SDL.Compositor.ResIndependent (translateR, fillRectangle, fromRelativeCompositor)-import SDL.Compositor (runRenderer)+import SDL.Compositor (runRenderer, rgba) import Control.Concurrent (threadDelay) main :: IO ()@@ -33,7 +32,7 @@ -- 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)+ let square = fillRectangle (V2 0.99 0.99) (rgba 255 255 255 255) -- draw everything runRenderer renderer
sdl2-compositor.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor-version: 1.1+version: 1.2 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition@@ -18,9 +18,14 @@ category: Graphics build-type: Simple extra-source-files: example.hs,- resolution-independent.hs+ resolution-independent.hs,+ font-test.hs cabal-version: >=1.10 +flag BuildExamples+ Description: Enable examples+ Default: False+ library exposed-modules: SDL.Compositor, SDL.Compositor.Manipulator,@@ -32,9 +37,34 @@ build-depends: base >=4.8 && <4.9, sdl2 == 2.*, transformers == 0.4.*,- linear == 1.19.*+ linear == 1.19.*,+ sdl2-ttf >= 0.2.2,+ stm,+ lrucache >= 1.2,+ text,+ QuickCheck,+ lens,+ StateVar -- hs-source-dirs: default-language: Haskell2010++executable sdl2-comp-example+ if flag(BuildExamples)+ build-depends: base, sdl2, stm, lrucache, sdl2-ttf, linear, text,+ transformers, lens, StateVar+ else+ buildable: False+ main-is: example.hs+ default-language: Haskell2010++executable sdl2-comp-res-independent+ if flag(BuildExamples)+ build-depends: base, sdl2, stm, lrucache, sdl2-ttf, linear, text,+ transformers, lens, StateVar+ else+ buildable: False+ main-is: resolution-independent.hs+ default-language: Haskell2010 source-repository head type: darcs