{-# LANGUAGE ScopedTypeVariables #-}
-- 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 (..)
, Texture(..)
, Renderer(..)
, Renderable(..)
-- * Utility
, withZIndex
-- * Implementation
, CompositingNode
, runRenderer
-- * Colors
, Color
, rgba
)
where
import Control.Lens (over, Lens, lens, view, set)
import Control.Monad (when)
import Data.List
import Data.Maybe
import Data.StateVar (get,($=))
import Data.Word
import Linear.Affine
import Linear.V2
import Linear.V3
import Linear.V4
import qualified SDL
import SDL.Compositor.Blender
import SDL.Compositor.Drawer
import SDL.Compositor.Manipulator
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)
| 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)
| NoOP
deriving (Show,Eq)
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
-- | '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
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
}
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
}
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})
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 :: forall tex rend .
(Texture tex, Renderer rend, Renderable rend tex) =>
rend -> CompositingNode tex -> IO ()
runRenderer target node = do
currentDrawColor <- SDL.get (rendererDrawColor target)
renderNode (defaultState target) node
rendererDrawColor target SDL.$= currentDrawColor
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 (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
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 <- get $ rendererRenderTarget rend :: IO (Maybe tex)
-- set new values
tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)
rendererRenderTarget rend $= Just tex
rendererDrawColor rend $= V4 0 0 0 0
rendererDrawColor rend $= fromIntegral <$> colors
drawRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims)))
present rend
rendererRenderTarget rend $= oldTarget
renderNode env (Sized dims 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 <- get $ rendererRenderTarget rend :: IO (Maybe tex)
-- set new values
tex <- createTexture
rend
SDL.RGBA8888
SDL.TextureAccessTarget
(dims*flippingVector)
rendererRenderTarget rend $= Just tex
rendererDrawColor rend $= V4 0 0 0 0
rendererDrawColor rend $= fromIntegral <$> colors
drawLine rend 0 (P $ fromIntegral <$> dims)
rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode env (Sized dims tex)
destroyTexture tex
renderNode env (FilledRectangle dims colors) = do
let rend = view renderTarget env
-- get old values
oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)
-- set new values
rendererDrawColor rend $= fromIntegral <$> colors
tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)
rendererRenderTarget rend $= Just tex
clear rend
rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode env (Sized dims tex)
-- retrieve old values
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)