-- 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 (..)
    -- * 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
  translateC _ NoOP = NoOP
  translateC v node = Translated v node
  flipC _ NoOP = NoOP
  flipC f node = Flipped f node

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`

class Compositor c where
  overC :: c -> c -> c
  rotateC :: Double -> c -> c
  translateC :: V2 Int -> c -> c
  flipC :: V2 Bool -> c -> c

-- | 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 =
  evalStateT (renderNode node) (defaultState target)

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
  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
  -- 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 $= 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
  -- 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 $= 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
  -- get old values
  oldColors <- SDL.get (SDL.rendererDrawColor rend)
  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.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
  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}