pituicat/src/Affection/Draw.hs

{-# LANGUAGE RecordWildCards, BangPatterns #-}

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

import Affection.Types

import Data.Maybe (maybe)

import Foreign
import Foreign.C.Types

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

-- | 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
    (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))
  maybe (return()) (\realRect -> do
    liftIO $ SDL.lockSurface surf
    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 surf
    -- liftIO $ SDL.updateWindowSurface $ drawWindow ad
    ) 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
    (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))
  maybe (return()) (\realRect -> do
    let surf = drawSurface ad
    liftIO $ clearArea requestBuffer realRect
    liftIO $ SDL.lockSurface surf
    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 surf
    ) 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)