-- Declarative image composition based on sdl2
-- Copyright (C) 2015 Sebastian Jordan
--
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- 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 (..)
, FontSupport (..)
, Alignment (..)
, Texture(..)
-- * Utility
, withZIndex
-- * Implementation
, CompositingNode
, runRenderer
-- * Colors
, Color
, rgba
)
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.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)
| Rectangle (V2 Int) (V4 Word8)
| Line (V2 Int) (V4 Word8)
| AlphaMod Double (CompositingNode a)
| RedMod Double (CompositingNode a)
| GreenMod Double (CompositingNode a)
| BlueMod Double (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,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
modulateRedM _ NoOP = NoOP
modulateRedM modulator node = RedMod (fromIntegral modulator) node
modulateGreenM _ NoOP = NoOP
modulateGreenM modulator node = GreenMod (fromIntegral modulator) node
modulateBlueM _ NoOP = NoOP
modulateBlueM modulator node = BlueMod (fromIntegral modulator) node
instance Blender (CompositingNode a) where
blendMode _ NoOP = NoOP
blendMode mode node = PreserveBlendMode mode node
instance Compositor (CompositingNode a) where
node1 `overC` NoOP = node1
NoOP `overC` node2 = node2
node1 `overC` node2 = node2 `Under` node1
rotateC = Rotated
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 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
instance Monoid (CompositingNode a) where
mempty = NoOP
mappend = flip overC
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
-- | 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
-- pair is the z-index and the second element is the composition.
-- Elements of with a higher z-index will be rendered "in front of"
-- elements with lower indices. If elements have the same index then
-- the element that comes first in the list will be drawn over all the
-- later ones.
--
-- This method can only arrange compositions that are in the "the same
-- list of arguments". That means that
--
-- > withZIndex [(1,a),(2,b)] `overC` withZIndex [(3,c)]
--
-- will always result in @b@ being rendered "in front of" @a@ and @c@,
-- no matter how large the z-index of @c@ is.
withZIndex :: (Compositor c, Monoid c) =>
[(Int,c)] -> c
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
, _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 :: r -> RendState r t
defaultState target =
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)
renderNode (defaultState target) node
SDL.rendererDrawColor target SDL.$= currentDrawColor
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
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)) $
view rotationAngle env
targetRect = round <$>
SDL.Rectangle
(P (midPoint - (fromIntegral <$> dims) / 2))
(fromIntegral <$> dims)
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
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
-- render created texture
renderNode env (Sized dims tex)
SDL.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)
-- set new values
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
SDL.rendererDrawColor rend $= fromIntegral <$> colors
SDL.drawLine rend 0 (P $ fromIntegral <$> dims)
SDL.present rend
SDL.rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode env (Sized dims tex)
SDL.destroyTexture tex
renderNode env(FilledRectangle dims colors) = do
let rend = view renderTarget env
-- get old values
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.present rend
SDL.rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode env (Sized dims tex)
-- retrieve old values
SDL.destroyTexture tex
getCurrentBlendMode :: RendState r t -> SDL.BlendMode
getCurrentBlendMode env =
fromMaybe SDL.BlendNone $
view bm env
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 . 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)