affection/src/Affection/Draw.hs

{-# LANGUAGE RecordWildCards #-}

-- | Module for drawing primitives
module Affection.Draw
  ( drawRect
  , clear
  , handleDrawRequest
  , invalidateDrawRequest
  , present
  , process
  , 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
    }

-- | Force update of a specific region on screen
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
    }

process
  :: G.GeglNode
  -> Affection us ()
process = liftIO . G.gegl_node_process

putToSurface
  :: Ptr a
  -> G.GeglRectangle
  -> Int
  -> Int
  -> DrawRequest
  -> Affection us ()
putToSurface pixels realRect stride cpp DrawRequest{..} = do
  ad <- get
  liftIO $ SDL.lockSurface $ drawSurface ad
  liftIO $ G.gegl_buffer_get
    requestBuffer
    (Just realRect)
    1
    (Just $ drawFormat ad)
    (pixels `plusPtr`
      (rectangleX realRect * cpp + rectangleY realRect * stride))
    stride
    G.GeglAbyssNone
  liftIO $ SDL.unlockSurface $ drawSurface ad

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)
  -- destPtr <- liftIO $ malloc :: (Ptr ByteString)
  liftIO $ G.gegl_buffer_get
    requestBuffer
    (Just realRect)
    1
    (Just $ drawFormat ad)
    destPtr
    stride
    G.GeglAbyssNone
  -- pixelData <- liftIO $ peekArray
  --   (rectangleWidth realRect * rectangleHeight realRect)
  --   destPtr
  -- SDL.updateTexture
  --   (drawTexture ad)
  --   (Just $ SDL.Rectangle
  --     (SDL.P $ SDL.V2 (rectangleX realRect) (rectangleY realRect))
  --     (SDL.V2 (rectangleWidth realRect) (rectangleHeight realRect))
  --     )
  --   pixelData
  --   (CInt $ fromIntegral stride)
  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 pixels 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 pixels 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
  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad
  let (w, h) = (fromIntegral rw, fromIntegral rh)
  liftIO $ clearArea buffer (GeglRectangle 0 0 w h)