-- 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/>.
module SDL.Compositor
( -- * Interface
Compositor (..)
, Blender (..)
, Manipulator (..)
, Drawer (..)
-- * Implementation
, CompositingNode
, sizedCompositingLeaf
, runRenderer
)
where
import Control.Monad.Trans.State
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)
deriving (Show,Read,Eq)
-- | Create a Graphics object with the given size.
sizedCompositingLeaf :: V2 Int -> a -> CompositingNode a
sizedCompositingLeaf = Sized
instance Manipulator (CompositingNode a) where
modulateAlphaM modulator node = AlphaMod (fromIntegral modulator) node
modulateRedM modulator node = RedMod (fromIntegral modulator) node
modulateGreenM modulator node = GreenMod (fromIntegral modulator) node
modulateBlueM modulator node = BlueMod (fromIntegral modulator) node
instance Blender (CompositingNode a) where
overrideBlendMode = OverrideBlendMode
preserveBlendMode = PreserveBlendMode
instance Compositor (CompositingNode a) where
node1 `overC` node2 = node2 `Under` node1
rotateC = Rotated
translateC = Translated
flipC = Flipped
instance Drawer (CompositingNode a) where
rectangleC = Rectangle
filledRectangleC = FilledRectangle
lineC = Line
class Compositor c where
overC :: c -> c -> c
rotateC :: Double -> c -> c
translateC :: V2 Int -> c -> c
flipC :: V2 Bool -> c -> c
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 =
evalStateT (renderNode node) (defaultState target)
renderNode :: CompositingNode SDL.Texture -> RenderEnv SDL.Renderer ()
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
let rotatedVec = (rotateV2 currentAngle (fromIntegral <$> vec))
currentTranslation <- translationVec <$> get
withTranslation (currentTranslation + rotatedVec) (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 = addFlips <$> f1 <*> f2
addFlips False b = b
addFlips b False = b
addFlips True True = False
renderNode (Rotated ang node) = do
currentAngle <- rotationAngle <$> get
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
modulations = ($env) <$> (V4 redMod greenMod blueMod alphaMod)
-- get old values
oldColors <- SDL.get (SDL.rendererDrawColor rend)
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 $= round <$> modulations * (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)
-- retrieve old values
SDL.rendererDrawColor rend $= oldColors
SDL.destroyTexture tex
renderNode (Line dims colors) = do
env <- get
let rend = renderTarget env
modulations = ($env) <$> (V4 redMod greenMod blueMod alphaMod)
-- get old values
oldColors <- SDL.get (SDL.rendererDrawColor rend)
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 $= round <$> modulations * (fromIntegral <$> colors)
SDL.drawLine rend 0 (P $ fromIntegral <$> dims)
SDL.present rend
SDL.rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode (Sized dims tex)
-- retrieve old values
SDL.rendererDrawColor rend $= oldColors
SDL.destroyTexture tex
renderNode (FilledRectangle dims colors) = do
env <- get
let rend = renderTarget env
modulations = ($env) <$> (V4 redMod greenMod blueMod alphaMod)
-- get old values
oldColors <- SDL.get (SDL.rendererDrawColor rend)
oldTarget <- SDL.get (SDL.rendererRenderTarget rend)
-- set new values
SDL.rendererDrawColor rend $= round <$> modulations * (fromIntegral <$> colors)
tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)
SDL.rendererRenderTarget rend $= Just tex
SDL.clear rend
SDL.fillRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims)))
SDL.present rend
SDL.rendererRenderTarget rend $= oldTarget
-- render created texture
renderNode (Sized dims tex)
-- retrieve old values
SDL.rendererDrawColor rend $= oldColors
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
-- liftIO $ print 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}