pituicat/src/Affection/Draw.hs
2016-12-21 04:29:11 +01:00

226 lines
7.2 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.Ptr (Ptr, plusPtr, nullPtr)
import Foreign.C.Types
import Control.Monad.State (get, put)
import Control.Monad (when, unless)
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
opNode <- liftIO $ G.gegl_node_new_child node $ 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 False) : 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
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 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
-- 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