squeezing even more perfomrance out of it

examples/example01.hs

@@ -125,15 +125,15 @@ draw = do
   format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
   SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
   let (w, h) = (fromIntegral rw, fromIntegral rh)
-  liftIO $ drawRect foreground (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500)
+  drawRect foreground (nodeGraph M.! "over") (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500)
-  liftIO $ G.gegl_node_blit
+  -- liftIO $ G.gegl_node_blit
-    (nodeGraph M.! "over" :: G.GeglNode)
+  --   (nodeGraph M.! "over" :: G.GeglNode)
-    1
+  --   1
-    (G.GeglRectangle 0 0 w h)
+  --   (G.GeglRectangle 0 0 w h)
-    format
+  --   format
-    pixels
+  --   pixels
-    (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
+  --   (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
-    [G.GeglBlitDefault]
+  --   [G.GeglBlitDefault]
   liftIO $ SDL.unlockSurface drawSurface
   liftIO $ SDL.updateWindowSurface drawWindow
 

examples/example02.hs

@@ -59,7 +59,7 @@ load surface = do
     [ G.Property "buffer" $ G.PropertyBuffer buffer
     ]
   traceM "buffer-source"
-  G.gegl_node_link_many [checkerboard, over]
+  G.gegl_node_link checkerboard over
   G.gegl_node_connect_to bufsrc "output" over "aux"
   traceM "connections made"
   myMap <- return $ M.fromList
@@ -82,29 +82,34 @@ draw = do
   traceM "drawing"
   AffectionData{..} <- get
   let UserData{..} = userState
-  liftIO $ SDL.lockSurface drawSurface
+  -- liftIO $ SDL.lockSurface drawSurface
-  pixels <- liftIO $ SDL.surfacePixels drawSurface
+  -- pixels <- liftIO $ SDL.surfacePixels drawSurface
   let SDL.Surface rawSurfacePtr _ = drawSurface
   rawSurface <- liftIO $ peek rawSurfacePtr
   pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface
   format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
   SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
   let (w, h) = (fromIntegral rw, fromIntegral rh)
-  maybe (return ()) (\(x, y) -> do
+  liftIO $ clearArea foreground (GeglRectangle 0 0 w h)
-    liftIO $ drawRect foreground (G.RGB 1 0 0) (Line 2) (G.GeglRectangle (x - 10) (y - 10) 20 20)
+  maybe (return ()) (\(x, y) ->
+    drawRect
+      foreground
+      (nodeGraph M.! "over")
+      (G.RGB 1 0 0)
+      (Line 2)
+      (G.GeglRectangle (x - 10) (y - 10) 20 20)
     ) coordinates
   -- liftIO $ G.gegl_node_process $ nodeGraph M.! "display"
-  liftIO $ G.gegl_node_blit
+  -- liftIO $ G.gegl_node_blit
-    (nodeGraph M.! "over" :: G.GeglNode)
+  --   (nodeGraph M.! "over" :: G.GeglNode)
-    1
+  --   1
-    (G.GeglRectangle 0 0 w h)
+  --   (G.GeglRectangle 0 0 w h)
-    format
+  --   format
-    pixels
+  --   pixels
-    (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
+  --   (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
-    [G.GeglBlitDefault]
+  --   [G.GeglBlitDefault]
-  liftIO $ SDL.unlockSurface drawSurface
+  -- liftIO $ SDL.unlockSurface drawSurface
-  liftIO $ SDL.updateWindowSurface drawWindow
+  -- liftIO $ SDL.updateWindowSurface drawWindow
-  liftIO $ clearArea foreground (GeglRectangle 0 0 w h)
 
 update :: Double -> AffectionState (AffectionData UserData) IO ()
 update sec = do

src/Affection.hs

@@ -23,9 +23,14 @@ import Control.Monad.Loops
 import Control.Monad.State
 import Control.Concurrent.MVar
 
+import Foreign.C.Types (CInt(..))
+import Foreign.Storable (peek)
+
 import Affection.Types as A
 import Affection.Draw as A
 
+import qualified BABL as B
+
 -- | Main function which bootstraps everything else.
 withAffection
   :: AffectionConfig us -- ^ Configuration of the Game and its engine.
@@ -40,15 +45,24 @@ withAffection AffectionConfig{..} = do
   execTime <- newMVar =<< getTime Monotonic
   window <- SDL.createWindow windowTitle windowConfig
   oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window
-  surface <- (\x -> return $ SDL.Surface x Nothing) =<<
+  rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
-    Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
+  let surface = (flip SDL.Surface Nothing) rawSurfacePtr
+      bablFormat = B.PixelFormat B.RGBA B.CFu8
+  pixels <- SDL.surfacePixels surface
+  format <- B.babl_format bablFormat
+  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface
+  pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr
+  let (w, h) = (fromIntegral rw, fromIntegral rh)
+      stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
+      cpp    = B.babl_components_per_pixel bablFormat
   initContainer <- return . (\x -> AffectionData
     { quitEvent       = False
     , userState       = x
     , drawWindow      = window
     , drawSurface     = surface
+    , drawStack       = []
     }) =<< loadState surface
-  (_, nState) <- runStateT ( A.runState $
+  (_, nState) <- runStateT ( A.runState $ do
     whileM_ (do
         current <- get
         return $ not $ A.quitEvent current
@@ -57,6 +71,10 @@ withAffection AffectionConfig{..} = do
         now      <- liftIO $ getTime Monotonic
         lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
         drawLoop
+        ad <- get
+        mapM_ (handleDrawRequest pixels format stride cpp) $ drawStack ad
+        put $ ad
+          { drawStack = [] }
         liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
         updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
           (fromIntegral 10 ^ 9)

src/Affection/Draw.hs

@@ -4,13 +4,20 @@
 module Affection.Draw
   ( drawRect
   -- , clear
+  , handleDrawRequest
+  , present
   , clearArea
   ) where
 
-import Affection.Types (DrawType(..), Affection, GeglRectangle(..), liftIO)
+import Affection.Types
 
+import Foreign.Ptr (Ptr, plusPtr)
 import Foreign.C.Types
 
+import Control.Monad.State (get, put)
+
+import qualified SDL
+
 import qualified BABL as B
 
 import qualified GEGL as G
@@ -18,22 +25,61 @@ import qualified GEGL as G
 -- | 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
-  -> IO ()
+  -> Affection us ()
-drawRect buf color (Fill) rect@G.GeglRectangle{..} =
+drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
-  G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
+  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
     )
-drawRect buf color (Line size) rect@G.GeglRectangle{..} = do
+  ad@AffectionData{..} <- get
-  drawRect buf color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
+  put $ ad
-  drawRect buf color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
+    { drawStack = (DrawRequest node rect) : drawStack
-  drawRect buf color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
+    }
-  drawRect buf color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
+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)
+
+-- | force a blit of a specified area
+present
+  :: G.GeglNode      -- ^ Node to blit
+  -> G.GeglRectangle -- ^ Area to blit
+  -> Affection us ()
+present node rect = do
+  ad@AffectionData{..} <- get
+  put $ ad
+    { drawStack = (DrawRequest node rect) : 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 ()
+handleDrawRequest pixels format stride cpp 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
 
 -- | compute color for a single pixel
 colorize

src/Affection/Types.hs

@@ -12,6 +12,7 @@ module Affection.Types
   -- , Loop(..)
   , RGBA(..)
   , DrawType(..)
+  , DrawRequest(..)
   , SDL.WindowConfig(..)
   , SDL.defaultWindow
     -- | Convenience exports
@@ -57,11 +58,14 @@ data AffectionData us = AffectionData
   , userState       :: us                 -- ^ State data provided by user
   , drawWindow      :: SDL.Window         -- ^ SDL window
   , drawSurface     :: SDL.Surface        -- ^ SDL surface
+  , drawStack       :: [DrawRequest]      -- ^ Stack of 'DrawRequests's to be processed
   }
 
--- -- | Data and surfaces for drawing.
+-- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
--- data AffectionDraw dd = AffectionDraw
+data DrawRequest = DrawRequest
---   }
+  { requestNode :: G.GeglNode      -- ^ The 'G.GeglNode' to blit
+  , requestArea :: G.GeglRectangle -- ^ The area to update
+  }
 
 -- | Components to initialize in SDL.
 data InitComponents