{-# LANGUAGE RecordWildCards #-} -- | Module for drawing primitives module Affection.Draw ( drawRect -- , clear , handleDrawRequest , invalidateDrawRequest , present , clearArea ) where import Affection.Types import Foreign.Ptr (Ptr, plusPtr) import Foreign.C.Types import Control.Monad.State (get, put) import Control.Monad (when) 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 node rect buf False) : drawStack } drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do 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) -- ad@AffectionData{..} <- get -- put $ ad -- { drawStack = (DrawRequest node rect) : drawStack -- } -- | force a blit of a specified area 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@AffectionData{..} <- get put $ ad { drawStack = (DrawRequest node rect buf pers) : drawStack } -- | 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 format stride cpp dr@DrawRequest{..} = do ad <- get liftIO $ SDL.lockSurface $ drawSurface ad liftIO $ G.gegl_node_blit requestNode 1 requestArea format (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) stride [G.GeglBlitDefault] liftIO $ SDL.unlockSurface $ drawSurface ad liftIO $ SDL.updateWindowSurface $ drawWindow ad if requestPersist then return Nothing else 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 format stride cpp dr@DrawRequest{..} = do ad <- get liftIO $ clearArea requestBuffer requestArea liftIO $ SDL.lockSurface $ drawSurface ad liftIO $ G.gegl_node_blit requestNode 1 requestArea format (pixels `plusPtr` (rectangleX requestArea * cpp + rectangleY requestArea * stride)) stride [G.GeglBlitDefault] liftIO $ SDL.unlockSurface $ drawSurface ad 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