247 lines
7.8 KiB
Haskell
247 lines
7.8 KiB
Haskell
{-# LANGUAGE RecordWildCards, BangPatterns #-}
|
|
|
|
-- | Module for drawing primitives
|
|
module Affection.Draw
|
|
(
|
|
-- drawRect
|
|
drawRect'
|
|
-- , clear
|
|
, handleDrawRequest
|
|
, invalidateDrawRequest
|
|
, present
|
|
, clearArea
|
|
) where
|
|
|
|
import Affection.Types
|
|
|
|
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
|
|
|
|
-- | 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 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 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)
|
|
|
|
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 Yes
|
|
put ad
|
|
{ drawStack = (DrawRequest rect buf k) : drawStack ad
|
|
}
|
|
|
|
-- -- | 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 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
|
|
-- 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 stride cpp dr@DrawRequest{..} = do
|
|
ad <- get
|
|
let surf = drawSurface ad
|
|
liftIO $ SDL.lockSurface surf
|
|
liftIO $ G.gegl_buffer_get
|
|
requestBuffer
|
|
(Just requestArea)
|
|
1
|
|
(Just $ drawFormat ad)
|
|
(pixels `plusPtr`
|
|
(rectangleX requestArea * cpp + rectangleY requestArea * stride))
|
|
stride
|
|
G.GeglAbyssNone
|
|
liftIO $ SDL.unlockSurface surf
|
|
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
|
|
case requestPersist of
|
|
Yes ->
|
|
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
|
|
let surf = drawSurface ad
|
|
liftIO $ clearArea requestBuffer requestArea
|
|
liftIO $ SDL.lockSurface surf
|
|
liftIO $ G.gegl_buffer_get
|
|
requestBuffer
|
|
(Just requestArea)
|
|
1
|
|
(Just $ drawFormat ad)
|
|
(pixels `plusPtr`
|
|
(rectangleX requestArea * cpp + rectangleY requestArea * stride))
|
|
stride
|
|
G.GeglAbyssNone
|
|
liftIO $ SDL.unlockSurface surf
|
|
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 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
|