{-# LANGUAGE RecordWildCards, BangPatterns #-} -- | Module for drawing primitives module Affection.Draw ( -- drawRect drawRect' -- , clear , handleDrawRequest , invalidateDrawRequest -- , present , clearArea ) where import Affection.Types import Foreign import Foreign.C.Types 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 -- | 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 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 tempRoot)) : 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 case requestPersist of Yes -> 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 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 let Kill victim = requestPersist liftIO $ G.gegl_node_drop victim -- 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