affection/src/Affection/Draw.hs

242 lines
6.9 KiB
Haskell
Raw Normal View History

2017-03-20 04:24:30 +00:00
{-# LANGUAGE RecordWildCards #-}
2016-12-08 17:22:29 +00:00
-- | Module for drawing primitives
module Affection.Draw
( drawRect
2017-03-16 19:21:04 +00:00
, clear
, handleDrawRequest
, invalidateDrawRequest
2017-03-16 19:52:45 +00:00
, process
2017-03-23 03:34:04 +00:00
, present
, render
2016-12-11 11:24:02 +00:00
, clearArea
2016-12-08 17:22:29 +00:00
) where
import Affection.Types
2016-12-08 17:22:29 +00:00
2017-02-24 16:11:10 +00:00
import Data.Maybe (maybe)
2017-03-22 15:59:24 +00:00
import Data.ByteString (ByteString)
2017-02-24 16:11:10 +00:00
import Foreign
2016-12-08 17:22:29 +00:00
import Foreign.C.Types
2017-03-22 15:59:24 +00:00
import Foreign.Marshal.Alloc (malloc, free)
2016-12-08 17:22:29 +00:00
import Control.Monad.State (get, put)
2016-12-21 03:28:57 +00:00
import Control.Monad (when, unless)
import System.Glib.GObject
import qualified SDL
2016-12-08 17:22:29 +00:00
import qualified BABL as B
import qualified GEGL as G
import Debug.Trace
drawRect
2016-12-21 03:28:57 +00:00
:: 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
2016-12-18 18:01:18 +00:00
ad <- get
2017-03-20 04:24:30 +00:00
tempRoot <- liftIO G.gegl_node_new
opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
2016-12-21 03:28:57 +00:00
[ 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"
2016-12-29 19:15:09 +00:00
unless diw $ error "Affection.Draw.drawRect: connect failed"
put $ ad
2017-03-20 04:24:30 +00:00
{ drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad
2016-12-24 00:13:00 +00:00
}
2017-03-23 03:34:04 +00:00
-- | Process a node graph
process
:: G.GeglNode
-> Affection us ()
process = liftIO . G.gegl_node_process
-- | Update of a specific region on the texture
2016-12-24 00:13:00 +00:00
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
2017-03-05 15:39:37 +00:00
let k = if not kill then Kill Nothing else Persist
2016-12-24 00:13:00 +00:00
put ad
2017-03-20 04:24:30 +00:00
{ drawStack = DrawRequest rect buf k : drawStack ad
}
2016-12-21 03:28:57 +00:00
2017-03-23 03:34:04 +00:00
-- | 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.
2017-03-16 19:52:45 +00:00
-> Affection us ()
2017-03-23 03:34:04 +00:00
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
2017-03-16 19:52:45 +00:00
2017-03-22 15:59:24 +00:00
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
2017-03-23 03:34:04 +00:00
-- :: Ptr a -- ^ Pixel buffer to blit to
2016-12-21 03:28:57 +00:00
-- -> B.BablFormatPtr -- ^ format to blit in
2017-03-23 03:34:04 +00:00
:: Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ 'DrawRequest' to handle
-> Affection us (Maybe DrawRequest)
2017-03-23 03:34:04 +00:00
handleDrawRequest stride cpp dr@DrawRequest{..} = do
ad <- get
2017-03-23 03:34:04 +00:00
-- let surf = drawSurface ad
2017-02-24 16:11:10 +00:00
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
2017-03-20 04:24:30 +00:00
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect ->
2017-03-22 15:59:24 +00:00
-- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
2017-02-24 16:11:10 +00:00
) mrealRect
case requestPersist of
2017-03-05 15:39:37 +00:00
Persist ->
return Nothing
Kill _ ->
return $ Just dr
-- | clear a previously drawn area
invalidateDrawRequest
2017-03-23 03:34:04 +00:00
-- :: Ptr a -- ^ Pixel buffer to blit to
2016-12-21 03:28:57 +00:00
-- -> B.BablFormatPtr -- ^ format to blit in
2017-03-23 03:34:04 +00:00
:: Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ Drawrequest to invalidate
-> Affection us ()
2017-03-23 03:34:04 +00:00
invalidateDrawRequest stride cpp dr@DrawRequest{..} = do
ad <- get
2017-02-24 16:11:10 +00:00
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
2017-03-20 04:24:30 +00:00
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
2017-02-24 16:11:10 +00:00
maybe (return()) (\realRect -> do
liftIO $ clearArea requestBuffer realRect
2017-03-22 15:59:24 +00:00
-- putToSurface pixels realRect stride cpp dr
putToTexture realRect stride cpp dr
2017-02-24 16:11:10 +00:00
) mrealRect
2016-12-24 00:13:00 +00:00
case requestPersist of
Kill (Just victim) ->
liftIO $ G.gegl_node_drop victim
_ ->
return ()
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
2016-12-08 17:22:29 +00:00
-- | 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
2017-03-20 04:24:30 +00:00
G.RGB{} -> 1
2016-12-08 17:22:29 +00:00
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
2017-03-20 04:24:30 +00:00
, G.CVdouble $ CDouble ca
2016-12-08 17:22:29 +00:00
)
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
2017-03-20 04:24:30 +00:00
G.RGB{} -> 1
in
2017-03-20 04:24:30 +00:00
( G.CVdouble $ CDouble r
, G.CVdouble $ CDouble g
, G.CVdouble $ CDouble b
, G.CVdouble $ CDouble a
)
2016-12-11 11:24:02 +00:00
-- | 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
2017-03-16 19:21:04 +00:00
-- | Clear the whole drawing area
clear :: G.GeglBuffer -> Affection us ()
clear buffer = do
2017-03-23 03:34:04 +00:00
ad <- get
let (w, h) = drawDimensions ad
2017-03-16 19:21:04 +00:00
liftIO $ clearArea buffer (GeglRectangle 0 0 w h)