module SDL.Compositor
(
Compositor (..)
, Blender (..)
, Manipulator (..)
, Drawer (..)
, AbsoluteSize (..)
, Texture(..)
, Renderer(..)
, Renderable(..)
, withZIndex
, CompositingNode
, runRenderer
, 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(..))
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
instance Monoid (CompositingNode a) where
mempty = NoOP
mappend = flip overC
infixr 5 `overC`
class Compositor c where
overC :: c -> c -> c
rotateC :: Double -> c -> c
flipC :: V2 Bool -> c -> c
class AbsoluteSize c where
translateA :: V2 Int -> c a -> c a
sizedA :: V2 Int -> a -> c a
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})
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
oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)
tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)
rendererRenderTarget rend $= Just tex
rendererDrawColor rend $= V4 0 0 0 0
clear rend
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
oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)
tex <- createTexture
rend
SDL.RGBA8888
SDL.TextureAccessTarget
(dims*flippingVector)
rendererRenderTarget rend $= Just tex
rendererDrawColor rend $= V4 0 0 0 0
clear rend
rendererDrawColor rend $= fromIntegral <$> colors
drawLine rend 0 (P $ fromIntegral <$> dims)
present rend
rendererRenderTarget rend $= oldTarget
renderNode env (Sized dims tex)
destroyTexture tex
renderNode env(FilledRectangle dims colors) = do
let rend = view renderTarget env
oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex)
rendererDrawColor rend $= fromIntegral <$> colors
tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims)
rendererRenderTarget rend $= Just tex
clear rend
present rend
rendererRenderTarget rend $= oldTarget
renderNode env (Sized dims tex)
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)