vulkan-tutorial/src/Affection/Draw.hs

{-# LANGUAGE RecordWildCards, BangPatterns #-}

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

import Affection.Types

import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C.Types

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

import qualified SDL

import qualified BABL as B

import qualified GEGL as G

import Debug.Trace

-- | Draw a rectangle on target buffer
drawRect
  :: G.GeglBuffer  -- ^ Target buffer
  -> G.GeglNode    -- ^ Target node
  -> G.Color       -- ^ Color to draw in
  -> DrawType      -- ^ Draw type
  -> GeglRectangle -- ^ Dimensions of Rectangle
  -> Affection us ()
drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
  liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
    (\(x, y) ->
      let col = unsafeColorize color
      in 
        G.Pixel x y col
    )
  ad@AffectionData{..} <- get
  put $ ad
    { drawStack = (DrawRequest node rect buf False) : drawStack
    }
drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
  liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
    (\(x, y) ->
      let col = unsafeColorize color
      in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
          (y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
      then
        G.Pixel x y col
      else
        G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
    )
  ad@AffectionData{..} <- get
  put $ ad
    { drawStack = (DrawRequest node rect buf False) : drawStack
    }
  -- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
  -- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
  -- drawRect buf node color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
  -- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)

-- | force a blit of a specified area. Do not use often as it slows down the program
present
  :: G.GeglNode      -- ^ Node to blit
  -> G.GeglBuffer    -- ^ BUffer to draw
  -> G.GeglRectangle -- ^ Area to blit
  -> Bool            -- ^ Shall the drawing be cleared in the next run?
  -> Affection us ()
present node buf rect pers = do
  ad <- get
  put $ ad
    { drawStack = (DrawRequest node rect buf pers) : drawStack ad
    }
  ad <- get
  format <- liftIO $ B.babl_format $ B.PixelFormat B.RGBA B.CFu8
  liftIO $ SDL.lockSurface $ drawSurface ad
  liftIO $ G.gegl_node_blit
    node
    1
    rect
    format
    nullPtr
    0
    [G.GeglBlitDefault]
  liftIO $ SDL.unlockSurface $ drawSurface ad
  liftIO $ SDL.updateWindowSurface $ drawWindow 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 format stride cpp dr@DrawRequest{..} = do
  ad <- get
  let !surf = drawSurface ad
  liftIO $ SDL.lockSurface surf
  liftIO $ G.gegl_node_blit
    requestNode
    1
    requestArea
    format
    (pixels `plusPtr`
      (rectangleX requestArea * cpp + rectangleY requestArea * stride))
    stride
    [G.GeglBlitDefault]
  liftIO $ SDL.unlockSurface surf
  liftIO $ SDL.updateWindowSurface $ drawWindow ad
  if requestPersist
  then
    return Nothing
  else
    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 format stride cpp dr@DrawRequest{..} = do
  ad <- get
  let !surf = drawSurface ad
  liftIO $ clearArea requestBuffer requestArea
  liftIO $ SDL.lockSurface surf
  liftIO $ G.gegl_node_blit
    requestNode
    1
    requestArea
    format
    (pixels `plusPtr`
      (rectangleX requestArea * cpp + rectangleY requestArea * stride))
    stride
    [G.GeglBlitDefault]
  liftIO $ SDL.unlockSurface surf
  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 all data from a buffer
-- clear
--   :: G.GeglBuffer -- ^ Target buffer
--   -> IO ()
-- clear buf = clearArea buf =<< G.gegl_rectangle_infinite_plane

-- | 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