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