particle system now works as a cascade of nodes

affection.cabal

@@ -59,7 +59,9 @@ library
                      , gegl
                      , babl
                      , monad-loops
+                     , containers
                      , clock
+                     , glib
                      -- , sdl2-image
 
 executable example00
@@ -79,22 +81,22 @@ executable example00
   else
     buildable:       False
 
-executable example01
+-- executable example01
-  hs-source-dirs:    examples
+--   hs-source-dirs:    examples
-  main-is:           example01.hs
+--   main-is:           example01.hs
-  ghc-options:       -threaded -Wall
+--   ghc-options:       -threaded -Wall
-  default-language:  Haskell2010
+--   default-language:  Haskell2010
-  default-extensions: OverloadedStrings
+--   default-extensions: OverloadedStrings
-  if flag(examples)
+--   if flag(examples)
-    build-depends:     base
+--     build-depends:     base
-                     , affection
+--                      , affection
-                     , sdl2
+--                      , sdl2
-                     , gegl
+--                      , gegl
-                     , babl
+--                      , babl
-                     , containers
+--                      , containers
-                     , mtl
+--                      , mtl
-  else
+--   else
-    buildable:       False
+--     buildable:       False
 
 executable example02
   hs-source-dirs:    examples

examples/example02.hs

@@ -48,13 +48,17 @@ load _ = do
   buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
     B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
   bufPtr <- new b
-  sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
+  sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
-    [ G.Property "buffer" $ G.PropertyPointer $ castPtr bufPtr
+    [ G.Property "buffer" $ G.PropertyBuffer buffer
     ]
   traceM "buffer-sink"
   nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
   traceM "nop"
-  G.gegl_node_link_many [checkerboard, over, sink]
+  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
+    [ G.Property "width" $ G.PropertyDouble 800
+    , G.Property "height" $ G.PropertyDouble 600
+    ]
+  G.gegl_node_link_many [checkerboard, over, crop, sink]
   G.gegl_node_connect_to nop "output" over "aux"
   traceM "connections made"
   myMap <- return $ M.fromList
@@ -63,6 +67,7 @@ load _ = do
     , ("background"  , checkerboard)
     , ("sink"        , sink)
     , ("nop"         , nop)
+    , ("crop"        , crop)
     ]
   traceM "loading complete"
   return $ UserData
@@ -92,6 +97,7 @@ draw = do
       (G.GeglRectangle (x - 10) (y - 10) 20 20)
       foreground
     ) coordinates
+  liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
 
 update :: Double -> AffectionState (AffectionData UserData) IO ()
 update sec = do

examples/example03.hs

@@ -29,7 +29,6 @@ main = do
 data UserData = UserData
   { nodeGraph   :: M.Map String G.GeglNode
   , foreground  :: G.GeglBuffer
-  , coordinates :: Maybe (Int, Int)
   , partsys     :: ParticleSystem
   }
 
@@ -45,37 +44,47 @@ load _ = do
   traceM "checkerboard"
   over <- G.gegl_node_new_child root G.defaultOverOperation
   traceM "over"
-  buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
+  buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
     B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
-  bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
+  sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
     [G.Property "buffer" $ G.PropertyBuffer buffer
     ]
-  traceM "buffer-source"
+  traceM "buffer-sink"
-  G.gegl_node_link checkerboard over
+  nop <- G.gegl_node_new_child root $ G.Operation "nop" []
-  G.gegl_node_connect_to bufsrc "output" over "aux"
+  traceM "nop"
+  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
+    [ G.Property "width" $ G.PropertyDouble 800
+    , G.Property "height" $ G.PropertyDouble 600
+    ]
+  traceM "crop"
+  G.gegl_node_link_many [checkerboard, over, crop, sink]
+  G.gegl_node_connect_to nop "output" over "aux"
   traceM "connections made"
   myMap <- return $ M.fromList
     [ ("root"        , root)
     , ("over"        , over)
     , ("background"  , checkerboard)
-    , ("foreground"  , bufsrc)
+    , ("sink"        , sink)
+    , ("nop"         , nop)
+    , ("crop"        , crop)
     ]
   traceM "loading complete"
   return $ UserData
     { nodeGraph = myMap
     , foreground = buffer
-    , coordinates = Nothing
+    , partsys = ParticleSystem [] nop buffer
-    , partsys = ParticleSystem [] over buffer
     }
 
 drawInit :: Affection UserData ()
-drawInit = do
+drawInit = return ()
-  UserData{..} <- getAffection
+  -- UserData{..} <- getAffection
-  present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
+  -- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
 
 draw :: Affection UserData ()
 draw = do
   traceM "drawing"
+  UserData{..} <- getAffection
+  liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
   -- ad <- get
   -- ud <- getAffection
   -- drawParticles partDraw $ particles ud
@@ -109,17 +118,30 @@ update sec = do
           vx <- liftIO $ randomRIO (-20, 20)
           vy <- liftIO $ randomRIO (-20, 20)
           life <- liftIO $ randomRIO (1, 5)
+          tempRoot <- liftIO $ G.gegl_node_new
+          tempOver <- liftIO $ G.gegl_node_new_child tempRoot
+            G.defaultOverOperation
+          tempNop  <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
+            "gegl:nop" []
+          liftIO $ G.gegl_node_connect_to tempNop "output" tempOver "aux"
           -- traceM $ "position is: " ++ show x ++ " " ++ show y
           -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
           putAffection $ ud
-            { coordinates = Just (fromIntegral x, fromIntegral y)
+            { partsys     = (partsys ud)
-            , partsys     = (partsys ud)
                 { psParts = (Particle
                     { particleLife = life
                     , particlePosition = (fromIntegral x, fromIntegral y)
                     , particleRotation = Rad 0
                     , particleVelocity = (vx, vy)
                     , particlePitchRate = Rad 0
+                    , particleRootNode = tempRoot
+                    , particleNodeGraph = M.fromList
+                      [ ("root", tempRoot)
+                      , ("over", tempOver)
+                      , ("nop" , tempNop)
+                      ]
+                    , particleStackCont = tempOver
+                    , particleDrawFlange = tempNop
                     }) : (psParts $ partsys ud)
                 }
             }
@@ -144,7 +166,6 @@ partUpd :: Double -> Particle -> Particle
 partUpd sec p@Particle{..} =
   p
     { particlePosition = (newX, newY)
-    , particleLife = particleLife - sec
     }
   where
     newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
@@ -153,9 +174,9 @@ partUpd sec p@Particle{..} =
 partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
 partDraw buf node Particle{..} = do
   ud <- getAffection
-  drawRect
+  drawRect'
-    buf
+    particleDrawFlange
-    node
     (G.RGBA 1 0 0 0.5)
-    (Line 5)
+    (Fill)
     (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
+    buf

src/Affection.hs

@@ -83,11 +83,11 @@ withAffection AffectionConfig{..} = do
         mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
         put $ ad
           { drawStack = [] }
-        -- execute user defined draw loop
-        drawLoop
         -- execute user defined update loop
         updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
           (fromIntegral 10 ^ 9)
+        -- execute user defined draw loop
+        drawLoop
         -- handle all new draw requests
         ad2 <- get
         clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)

src/Affection/Draw.hs

@@ -2,8 +2,9 @@
 
 -- | Module for drawing primitives
 module Affection.Draw
-  ( drawRect
+  (
-  , drawRect'
+  -- drawRect
+    drawRect'
   -- , clear
   , handleDrawRequest
   , invalidateDrawRequest
@@ -13,12 +14,14 @@ module Affection.Draw
 
 import Affection.Types
 
-import Foreign.Ptr (Ptr, plusPtr, nullPtr)
+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
@@ -28,43 +31,43 @@ import qualified GEGL as G
 import Debug.Trace
 
 -- | Draw a rectangle on target buffer
-drawRect
+-- drawRect
-  :: G.GeglBuffer  -- ^ Target buffer
+--   :: G.GeglBuffer  -- ^ Target buffer
-  -> G.GeglNode    -- ^ Target node
+--   -> G.GeglNode    -- ^ Target node
-  -> G.Color       -- ^ Color to draw in
+--   -> G.Color       -- ^ Color to draw in
-  -> DrawType      -- ^ Draw type
+--   -> DrawType      -- ^ Draw type
-  -> GeglRectangle -- ^ Dimensions of Rectangle
+--   -> GeglRectangle -- ^ Dimensions of Rectangle
-  -> Affection us ()
+--   -> Affection us ()
-drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
+-- drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
-  liftIO $ 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) ->
+--     (\(x, y) ->
-      let col = unsafeColorize color
+--       let col = unsafeColorize color
-      in 
+--       in 
-        G.Pixel x y col
+--         G.Pixel x y col
-    )
+--     )
-  ad@AffectionData{..} <- get
+--   ad@AffectionData{..} <- get
-  put $ ad
+--   put $ ad
-    { drawStack = (DrawRequest rect buf False) : drawStack
+--     { drawStack = (DrawRequest rect buf False) : drawStack
-    }
+--     }
-drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
+-- 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 $
+--   liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
-    (\(x, y) ->
+--     (\(x, y) ->
-      let col = unsafeColorize color
+--       let col = unsafeColorize color
-      in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
+--       in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
-          (y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
+--           (y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
-      then
+--       then
-        G.Pixel x y col
+--         G.Pixel x y col
-      else
+--       else
-        G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
+--         G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
-    )
+--     )
-  ad@AffectionData{..} <- get
+--   ad@AffectionData{..} <- get
-  put $ ad
+--   put $ ad
-    { drawStack = (DrawRequest rect buf False) : drawStack
+--     { 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 rectangleWidth size)
-  -- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
+--   -- 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 + rectangleWidth - size) rectangleY size rectangleHeight)
-  -- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
+--   -- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
 
 drawRect'
   :: G.GeglNode      -- ^ Target Node
@@ -75,7 +78,8 @@ drawRect'
   -> Affection us ()
 drawRect' node color Fill rect@GeglRectangle{..} buf = do
   ad <- get
-  opNode <- liftIO $ G.gegl_node_new_child node $ G.Operation "gegl:rectangle"
+  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
@@ -85,7 +89,7 @@ drawRect' node color Fill rect@GeglRectangle{..} buf = do
   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 False) : drawStack 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
@@ -135,10 +139,10 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
     G.GeglAbyssNone
   liftIO $ SDL.unlockSurface surf
   -- liftIO $ SDL.updateWindowSurface $ drawWindow ad
-  if requestPersist
+  case requestPersist of
-  then
+    Yes ->
       return Nothing
-  else
+    Kill _ ->
       return $ Just dr
 
 -- | clear a previously drawn area
@@ -151,7 +155,7 @@ invalidateDrawRequest
   -> Affection us ()
 invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
   ad <- get
-  let !surf = drawSurface ad
+  let surf = drawSurface ad
   liftIO $ clearArea requestBuffer requestArea
   liftIO $ SDL.lockSurface surf
   liftIO $ G.gegl_buffer_get
@@ -164,6 +168,8 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
     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

src/Affection/Particle.hs

@@ -9,7 +9,9 @@ module Affection.Particle
 
 import Affection.Types
 
-import Data.Maybe (catMaybes)
+import Control.Monad
+
+import Data.Maybe
 
 import qualified GEGL as G
 
@@ -22,13 +24,28 @@ updateParticle
                                       -- This Function should take the elapsed time
                                       -- in seconds and the initial particle as arguments.
   -> Particle                         -- ^ 'Particle' to be processed
-  -> Maybe Particle                   -- ^ resulting 'Particle'
+  -> IO (Maybe Particle)              -- ^ resulting 'Particle'
-updateParticle time funct p@Particle{..} =
+updateParticle time funct pa =
-  if particleLife - time < 0
+  if particleLife pa - time < 0
-  then
+  then do
-    Nothing
+    G.gegl_node_drop $ particleRootNode pa
+    return $ Nothing
   else
-    Just $ funct time $ p { particleLife = particleLife - time }
+    return $ Just $ funct time $ pa { particleLife = particleLife pa - time }
+-- updateParticle time funct acc@[p] pa =
+--   if particleLife pa - time < 0
+--   then do
+--     G.gegl_node_drop $ particleRootNode pa
+--     return $ Nothing : acc
+--   else
+--     return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
+-- updateParticle time funct acc@(p:ps) pa =
+--   if particleLife pa - time < 0
+--   then do
+--     G.gegl_node_drop $ particleRootNode pa
+--     return $ Nothing : acc
+--   else
+--     return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
 
 drawParticles
   :: (Particle -> Affection us ())
@@ -43,7 +60,10 @@ updateParticleSystem
   -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
   -> Affection us ParticleSystem
 updateParticleSystem sys sec upd draw = do
-  let x = catMaybes $ map (updateParticle sec upd) (psParts sys)
+  -- let x = catMaybes <$> mapM (updateParticle sec upd) (psParts sys)
+  -- x <- liftIO $ catMaybes <$> foldM (updateParticle sec upd) [] (psParts sys)
+  x <- liftIO $ catMaybes <$> mapM (updateParticle sec upd) (psParts sys)
+  liftIO $ G.gegl_node_link_many $ map particleStackCont x ++ [psNode sys]
   mapM_ (draw (psBuffer sys) (psNode sys)) x
   return $ sys
     { psParts = x }

src/Affection/Types.hs

@@ -13,6 +13,7 @@ module Affection.Types
   , RGBA(..)
   , DrawType(..)
   , DrawRequest(..)
+  , RequestPersist(..)
   , Angle(..)
   , ConvertAngle(..)
     -- | Particle system
@@ -30,6 +31,7 @@ module Affection.Types
 import qualified SDL.Init as SDL
 import qualified SDL.Video as SDL
 import qualified Data.Text as T
+import Data.Map
 
 import qualified GEGL as G
 import qualified BABL as B
@@ -81,9 +83,13 @@ data AffectionData us = AffectionData
 data DrawRequest = DrawRequest
   { requestArea     :: G.GeglRectangle -- ^ The area to update
   , requestBuffer   :: G.GeglBuffer    -- ^ Buffer to draw
-  , requestPersist  :: Bool            -- ^ Shall the drawRequest persist
+  , requestPersist  :: RequestPersist  -- ^ Shall the drawRequest persist
   }
 
+data RequestPersist
+  = Yes
+  | Kill G.GeglNode
+
 -- | A type for storing 'DrawRequest' results to be executed frequently. TODO
 data DrawAsset = DrawAsset
 
@@ -169,7 +175,15 @@ data Particle = Particle
       -- ^ particle velocity as vector of pixels per second
   , particlePitchRate  :: Angle
       -- ^ Rotational velocity of particle in angle per second
-  } deriving (Show, Eq)
+  , particleRootNode   :: G.GeglNode
+      -- ^ Root 'G.GeglNode' of 'Particle'
+  , particleNodeGraph  :: Map String G.GeglNode
+      -- ^ Node Graph of 'G.GeglNodes' per particle
+  , particleStackCont  :: G.GeglNode
+      -- ^ 'G.GeglNode' to connect other 'Particle's to
+  , particleDrawFlange :: G.GeglNode
+      -- ^ 'G.GeglNode' to connect draw actions to
+  }
 
 data ParticleSystem = ParticleSystem
   { psParts  :: [Particle]