diff --git a/SDL/Compositor.hs b/SDL/Compositor.hs --- a/SDL/Compositor.hs +++ b/SDL/Compositor.hs @@ -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} diff --git a/SDL/Compositor/Blender.hs b/SDL/Compositor/Blender.hs --- a/SDL/Compositor/Blender.hs +++ b/SDL/Compositor/Blender.hs @@ -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 diff --git a/SDL/Compositor/Drawer.hs b/SDL/Compositor/Drawer.hs --- a/SDL/Compositor/Drawer.hs +++ b/SDL/Compositor/Drawer.hs @@ -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 diff --git a/SDL/Compositor/ResIndependent.hs b/SDL/Compositor/ResIndependent.hs --- a/SDL/Compositor/ResIndependent.hs +++ b/SDL/Compositor/ResIndependent.hs @@ -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 diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -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 diff --git a/font-test.hs b/font-test.hs new file mode 100644 --- /dev/null +++ b/font-test.hs @@ -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 + + + diff --git a/resolution-independent.hs b/resolution-independent.hs --- a/resolution-independent.hs +++ b/resolution-independent.hs @@ -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 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.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