affection/src/Affection/Draw.hs
2017-04-17 12:40:17 +02:00

241 lines
6.9 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
-- | Module for drawing primitives
module Affection.Draw
( drawRect
, clear
, handleDrawRequest
, invalidateDrawRequest
, process
, present
, render
, 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
}
-- | Process a node graph
process
:: G.GeglNode
-> Affection us ()
process = liftIO . G.gegl_node_process
-- | Update of a specific region on the texture
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
}
-- | Render the Texture or a clipping thereof. The clipping will be stretched
-- to fit the render target.
render
:: Maybe G.GeglRectangle
-- ^ Area of the texture to render.
-- Pass 'Nothing' to render the whole texture.
-> Maybe G.GeglRectangle
-- ^ Area of render target to draw to.
-- Pass 'Nothing' to render to the whole render target.
-> Affection us ()
render msrc mtgt =
do
AffectionData{..} <- get
SDL.copy
windowRenderer
drawTexture
src
tgt
where
toSdlRect (G.GeglRectangle x y w h) = SDL.Rectangle
(SDL.P $ SDL.V2 (CInt $ fromIntegral x) (CInt $ fromIntegral y))
(SDL.V2 (CInt $ fromIntegral w) (CInt $ fromIntegral h))
src = maybe Nothing (Just . toSdlRect) msrc
tgt = maybe Nothing (Just . toSdlRect) mtgt
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)
liftIO $ G.gegl_buffer_get
requestBuffer
(Just realRect)
1
(Just $ drawFormat ad)
destPtr
stride
G.GeglAbyssNone
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 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 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
let (w, h) = drawDimensions ad
liftIO $ clearArea buffer (GeglRectangle 0 0 w h)