-- 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 (..)
-- * Utility
, withZIndex
-- * Implementation
, CompositingNode
, sizedCompositingLeaf
, runRenderer
)
where
import Control.Monad.Trans.State
import Data.List
import Data.Maybe
import Data.Word
import Foreign.C.Types
import Linear.Affine
import Linear.V2
import Linear.V3
import Linear.V4
import SDL (($=))
import qualified SDL as SDL
import SDL.Compositor.Blender
import SDL.Compositor.Drawer
import SDL.Compositor.Manipulator
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)
| 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)
| NoOP
deriving (Show,Read,Eq)
-- | Create a Graphics object with the given size on the rendering
-- surface.
sizedCompositingLeaf :: V2 Int -> a -> CompositingNode a
sizedCompositingLeaf = Sized
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
overrideBlendMode _ NoOP = NoOP
overrideBlendMode mode node = OverrideBlendMode mode node
preserveBlendMode _ NoOP = NoOP
preserveBlendMode 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 = Rectangle
filledRectangleC = FilledRectangle
lineC = Line
-- | 'mempty' represents no painting at all. Also
--
-- prop> mappend a b == overC a b
instance Monoid (CompositingNode a) where
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
-- 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 cs = foldl overC mempty cs
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
}
defaultState :: t -> RendState 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
}
-- | 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)
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))
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
ang = (negate.(/pi).(*180)) $
rotationAngle env
targetRect = fmap 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
-- 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 (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
-- 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 (Sized dims tex)
SDL.destroyTexture tex
renderNode (FilledRectangle dims colors) = do
env <- get
let rend = 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 (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
setColorsAndBlend :: SDL.Texture -> RenderEnv t a -> RenderEnv t a
setColorsAndBlend tex action = do
env <- get
blend <- getCurrentBlendMode
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
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}