affection/src/Affection/Draw.hs

{-# LANGUAGE RecordWildCards #-}

-- | Module for drawing primitives
module Affection.Draw
  ( drawRect
  , clear
  , handleDrawRequest
  , invalidateDrawRequest
  , process
  , present
  , render
  , clearArea
  ) where

import Affection.Types

import Data.Maybe (maybe)
import Data.ByteString (ByteString)

import Foreign
import Foreign.C.Types
import Foreign.Marshal.Alloc (malloc, free)

import Control.Monad.State (get, put)
import Control.Monad (when, unless)

import System.Glib.GObject

import qualified SDL

import qualified BABL as B

import qualified GEGL as G

import Debug.Trace

drawRect
  :: G.GeglNode      -- ^ Target Node
  -> G.Color         -- ^ Color to draw in
  -> DrawType        -- ^ Draw type
  -> G.GeglRectangle -- ^ Dimensions of Rectangle
  -> G.GeglBuffer    -- ^ Final Buffer
  -> Affection us ()
drawRect node color Fill rect@GeglRectangle{..} buf = do
  ad <- get
  tempRoot <- liftIO G.gegl_node_new
  opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
    [ G.Property "x"      $ G.PropertyDouble $ fromIntegral rectangleX
    , G.Property "y"      $ G.PropertyDouble $ fromIntegral rectangleY
    , G.Property "width"  $ G.PropertyDouble $ fromIntegral rectangleWidth
    , G.Property "height" $ G.PropertyDouble $ fromIntegral rectangleHeight
    , G.Property "color"  $ G.PropertyColor color
    ]
  diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input"
  unless diw $ error "Affection.Draw.drawRect: connect failed"
  put $ ad
    { drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad
    }

-- | Process a node graph
process
  :: G.GeglNode
  -> Affection us ()
process = liftIO . G.gegl_node_process

-- | Update of a specific region on the texture
present
  :: G.GeglRectangle -- ^ Area to be updated
  -> G.GeglBuffer    -- ^ Target buffer
  -> Bool            -- ^ Shall the 'DrawRequest' persist?
  -> Affection us ()
present rect buf kill = do
  ad <- get
  let k = if not kill then Kill Nothing else Persist
  put ad
    { drawStack = DrawRequest rect buf k : drawStack ad
    }

-- | Render the Texture or a clipping thereof. The clipping will be stretched
-- to fit the render target.
render
  :: Maybe G.GeglRectangle
    -- ^ Area of the texture to render.
    -- Pass 'Nothing' to render the whole texture.
  -> Maybe G.GeglRectangle
    -- ^ Area of render target to draw to.
    -- Pass 'Nothing' to render to the whole render target.
  -> Affection us ()
render msrc mtgt =
  do
    AffectionData{..} <- get
    SDL.copy
      windowRenderer
      drawTexture
      src
      tgt
  where
    toSdlRect (G.GeglRectangle x y w h) = SDL.Rectangle
      (SDL.P $ SDL.V2 (CInt $ fromIntegral x) (CInt $ fromIntegral y))
      (SDL.V2 (CInt $ fromIntegral w) (CInt $ fromIntegral h))
    src = maybe Nothing (Just . toSdlRect) msrc
    tgt = maybe Nothing (Just . toSdlRect) mtgt

putToTexture
  :: G.GeglRectangle
  -> Int
  -> Int
  -> DrawRequest
  -> Affection us ()
putToTexture realRect stride cpp DrawRequest{..} = do
  ad <- get
  destRect <- return $
    SDL.Rectangle
      (SDL.P $ SDL.V2
        (CInt $ fromIntegral $ rectangleX realRect)
        (CInt $ fromIntegral $ rectangleY realRect)
        )
      (SDL.V2
        (CInt $ fromIntegral $ rectangleWidth realRect)
        (CInt $ fromIntegral $ rectangleHeight realRect)
        )
  (destPtr, destStride) <- SDL.lockTexture
    (drawTexture ad)
    (Just destRect)
  liftIO $ G.gegl_buffer_get
    requestBuffer
    (Just realRect)
    1
    (Just $ drawFormat ad)
    destPtr
    stride
    G.GeglAbyssNone
  SDL.unlockTexture $ drawTexture ad

-- | function for handling 'DrawRequest's and updating the output
handleDrawRequest
  -- :: Ptr a           -- ^ Pixel buffer to blit to
  -- -> B.BablFormatPtr -- ^ format to blit in
  :: Int             -- ^ Stride
  -> Int             -- ^ Components per Pixel
  -> DrawRequest     -- ^ 'DrawRequest' to handle
  -> Affection us (Maybe DrawRequest)
handleDrawRequest stride cpp dr@DrawRequest{..} = do
  ad <- get
  -- let surf = drawSurface ad
  mrealRect <- liftIO $ G.gegl_rectangle_intersect
    requestArea
    (uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
  maybe (return()) (\realRect ->
    -- putToSurface pixels realRect stride cpp dr
    putToTexture realRect stride cpp dr
    ) mrealRect
  case requestPersist of
    Persist ->
      return Nothing
    Kill _ ->
      return $ Just dr

-- | clear a previously drawn area
invalidateDrawRequest
  -- :: Ptr a           -- ^ Pixel buffer to blit to
  -- -> B.BablFormatPtr -- ^ format to blit in
  :: Int             -- ^ Stride
  -> Int             -- ^ Components per Pixel
  -> DrawRequest  -- ^ Drawrequest to invalidate
  -> Affection us ()
invalidateDrawRequest stride cpp dr@DrawRequest{..} = do
  ad <- get
  mrealRect <- liftIO $ G.gegl_rectangle_intersect
    requestArea
    (uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
  maybe (return()) (\realRect -> do
    liftIO $ clearArea requestBuffer realRect
    -- putToSurface pixels realRect stride cpp dr
    putToTexture realRect stride cpp dr
    ) mrealRect
  case requestPersist of
    Kill (Just victim) ->
      liftIO $ G.gegl_node_drop victim
    _ ->
      return ()
  -- liftIO $ SDL.updateWindowSurface $ drawWindow ad

-- | compute color for a single pixel
colorize
  :: (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Pixel information in buffer
  -> G.Color      -- ^ Color to draw over
  -> (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Resulting colour
colorize (rr, rg, rb, ra) col =
  let (G.CVdouble (CDouble br)) = rr
      (G.CVdouble (CDouble bg)) = rg
      (G.CVdouble (CDouble bb)) = rb
      (G.CVdouble (CDouble ba)) = ra
      (cr, cg, cb) = case col of
        G.RGBA r g b _ -> (r, g, b)
        G.RGB  r g b   -> (r, g, b)
      ca = case col of
        G.RGBA _ _ _ a -> a
        G.RGB{}        -> 1
      alpha = ca
      dst_a = ba
      da = alpha + dst_a * (1 - alpha)
      a_term = dst_a * (1 - alpha)
      red = cr * alpha + br * a_term
      gre = cg * alpha + bg * a_term
      blu = cb * alpha + bb * a_term
  in
    ( G.CVdouble $ CDouble $ red / da
    , G.CVdouble $ CDouble $ gre / da
    , G.CVdouble $ CDouble $ blu / da
    , G.CVdouble $ CDouble ca
    )

unsafeColorize col =
  let
    (r, g, b) = case col of
      G.RGBA cr cg cb _ -> (cr, cg, cb)
      G.RGB  cr cg cb   -> (cr, cg, cb)
    a = case col of
      G.RGBA _ _ _ ca -> ca
      G.RGB{}         -> 1
  in
    ( G.CVdouble $ CDouble r
    , G.CVdouble $ CDouble g
    , G.CVdouble $ CDouble b
    , G.CVdouble $ CDouble a
    )

-- | Clear a specified area of a buffer from all data
clearArea
  :: G.GeglBuffer    -- ^ Target buffer
  -> G.GeglRectangle -- ^ Area to clear
  -> IO ()
clearArea = G.gegl_buffer_clear

-- | Clear the whole drawing area
clear :: G.GeglBuffer -> Affection us ()
clear buffer = do
  ad <- get 
  let (w, h) = drawDimensions ad
  liftIO $ clearArea buffer (GeglRectangle 0 0 w h)