affection/src/Affection/Draw.hs
2017-03-22 16:59:24 +01:00

249 lines
7.1 KiB
Haskell

{-# 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)