Merge branch 'buffer-get'

affection.cabal

@@ -49,7 +49,7 @@ library
                      , UndecidableInstances
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:       -Wall
+  ghc-options:       -Wall -debug
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && <4.10
                      , sdl2
@@ -59,7 +59,9 @@ library
                      , gegl
                      , babl
                      , monad-loops
+                     , containers
                      , clock
+                     , glib
                      -- , sdl2-image
 
 executable example00
@@ -116,7 +118,7 @@ executable example02
 executable example03
   hs-source-dirs:    examples
   main-is:           example03.hs
-  ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts
+  ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts -debug
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
   if flag(examples)
@@ -130,3 +132,21 @@ executable example03
                      , random
   else
     buildable:       False
+
+-- executable example04
+--   hs-source-dirs:    examples
+--   main-is:           example04.hs
+--   ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts
+--   default-language:  Haskell2010
+--   default-extensions: OverloadedStrings
+--   if flag(examples)
+--     build-depends:     base
+--                      , affection
+--                      , sdl2
+--                      , gegl
+--                      , babl
+--                      , containers
+--                      , mtl
+--                      , random
+--   else
+--     buildable:       False

examples/example00.hs

@@ -7,6 +7,8 @@ import qualified GEGL as G
 import qualified BABL as B
 import qualified Data.Map.Strict as M
 
+import Control.Monad (when)
+
 import Foreign.Storable (peek)
 import Foreign.C.Types  (CInt(..))
 
@@ -36,7 +38,6 @@ main = do
 
 data UserData = UserData
   { nodeGraph   :: M.Map String G.GeglNode
-  , elapsedTime :: Double
   }
 
 load :: SDL.Surface -> IO UserData
@@ -53,7 +54,7 @@ load _ = do
   traceM "over"
   text <- G.gegl_node_new_child root $ G.textOperation
     [ G.Property "string" $ G.PropertyString "Hello world!"
-    , G.Property "color"  $ G.PropertyColor $ G.RGBA 0 0 1 0.1
+    , G.Property "color"  $ G.PropertyColor $ G.RGBA 0 0 1 0.5
     , G.Property "size"   $ G.PropertyDouble 40
     ]
   traceM "text"
@@ -69,7 +70,6 @@ load _ = do
   traceM "loading complete"
   return $ UserData
     { nodeGraph = myMap
-    , elapsedTime = 0
     }
 
 draw :: Affection UserData ()
@@ -99,18 +99,10 @@ draw = do
 update :: Double -> Affection UserData ()
 update sec = do
   traceM "updating"
-  -- liftIO $ delaySec 5
+  ad <- get
-  ad@AffectionData{..} <- get
+  ud@UserData{..} <- getAffection
-  let ud@UserData{..} = userState
+  traceM $ (show $ 1 / sec) ++ " FPS"
-  traceM $ show elapsedTime
+  when (elapsedTime ad > 5) $
-  if elapsedTime < 5
-  then
-    put $ ad
-      { userState = ud
-        { elapsedTime = elapsedTime + sec
-        }
-      }
-  else
     put $ ad
       { quitEvent = True
       }

examples/example01.hs

@@ -7,6 +7,8 @@ import qualified GEGL as G
 import qualified BABL as B
 import qualified Data.Map.Strict as M
 
+import Control.Monad (when)
+
 import Foreign.Storable (peek)
 import Foreign.C.Types
 
@@ -37,7 +39,6 @@ main = do
 data UserData = UserData
   { nodeGraph   :: M.Map String G.GeglNode
   , foreground  :: G.GeglBuffer
-  , elapsedTime :: Double
   }
 
 load :: SDL.Surface -> IO UserData
@@ -54,111 +55,48 @@ load _ = do
   traceM "over"
   buffer <- 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"
-  G.gegl_node_link checkerboard over
+  nop <- G.gegl_node_new_child root $ G.Operation "gegl: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
+    ]
+  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)
     ]
   let roi = G.GeglRectangle 0 0 20 20
-  -- G.iterateOver
-  --   buffer
-  --   roi
-  --   (B.PixelFormat B.RGBA B.CFfloat)
-  --   G.GeglAccessReadWrite
-  --   G.GeglAbyssNone
-  --   (\(G.Pixel px py pc) ->
-  --     let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2))
-  --         (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc
-  --         dist = (sqrt (fromIntegral dsqr :: Float))
-  --     in if dsqr < 100
-  --       then
-  --         if dist < fromIntegral 9
-  --           then
-  --             G.Pixel px py
-  --               ( G.CVfloat $ CFloat 0
-  --               , G.CVfloat $ CFloat 0
-  --               , G.CVfloat $ CFloat 0
-  --               , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa
-  --               )
-  --           else
-  --             let alpha = fromIntegral 10 - dist
-  --                 dst_a = pa
-  --                 a = alpha + dst_a * (1 - alpha)
-  --                 a_term = dst_a * (1 - alpha)
-  --                 red = 0 * alpha + pr * a_term
-  --                 gre = 0 * alpha + pg * a_term
-  --                 blu = 0 * alpha + pb * a_term
-  --             in
-  --               G.Pixel px py
-  --                 ( G.CVfloat $ CFloat $ red / a
-  --                 , G.CVfloat $ CFloat $ gre / a
-  --                 , G.CVfloat $ CFloat $ blu / a
-  --                 , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa
-  --                 )
-  --     else
-  --       G.Pixel px py pc
-  --   )
   traceM "loading complete"
   return $ UserData
     { nodeGraph = myMap
     , foreground = buffer
-    , elapsedTime = 0
     }
 
 draw :: Affection UserData ()
 draw = do
   traceM "drawing"
   UserData{..} <- getAffection
-  -- AffectionData{..} <- get
+  drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground
-  -- let UserData{..} = userState
+  liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
-  -- -- liftIO $ SDL.lockSurface 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)
-  drawRect foreground (nodeGraph M.! "over") (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500)
-  -- liftIO $ G.gegl_node_blit
-  --   (nodeGraph M.! "over" :: G.GeglNode)
-  --   1
-  --   (G.GeglRectangle 0 0 w h)
-  --   format
-  --   pixels
-  --   (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
-  --   [G.GeglBlitDefault]
-  -- liftIO $ SDL.unlockSurface drawSurface
-  -- liftIO $ SDL.updateWindowSurface drawWindow
 
 update :: Double -> AffectionState (AffectionData UserData) IO ()
 update sec = do
   traceM "updating"
   -- liftIO $ delaySec 5
-  ad@AffectionData{..} <- get
+  ad <- get
-  let ud@UserData{..} = userState
+  ud@UserData{..} <- getAffection
   traceM $ (show $ 1 / sec) ++ " FPS"
-  if elapsedTime < 20
+  when (elapsedTime ad > 20) $
-  then do
-    fg <- liftIO $ G.gegl_buffer_get_extent foreground
-    _ <- liftIO $ G.gegl_buffer_set_extent foreground $ fg
-      { G.rectangleX = G.rectangleX fg + 1
-      , G.rectangleY = G.rectangleY fg + 1
-      }
-    put $ ad
-      { userState = ud
-        { elapsedTime = elapsedTime + sec
-        }
-      }
-  else
     put $ ad
       { quitEvent = True
       }

examples/example02.hs

@@ -3,10 +3,13 @@
 import Affection
 import qualified SDL
 import qualified GEGL as G
+import qualified GEGL.FFI.Buffer as G
 import qualified BABL as B
 import qualified Data.Map.Strict as M
 
 import Foreign.C.Types
+import Foreign.Marshal.Utils (new)
+import Foreign.Ptr (castPtr)
 
 import Debug.Trace
 
@@ -16,7 +19,7 @@ main = do
     { initComponents = All
     , windowTitle    = "Affection: example00"
     , windowConfig   = SDL.defaultWindow
-    , preLoop        = drawInit
+    , preLoop        = return ()
     , drawLoop       = draw
     , updateLoop     = update
     , loadState      = load
@@ -42,20 +45,29 @@ 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
+  bufPtr <- new b
+  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 "gegl: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
+    ]
+  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
@@ -64,10 +76,10 @@ load _ = do
     , coordinates = Nothing
     }
 
-drawInit :: Affection UserData ()
+-- drawInit :: Affection UserData ()
-drawInit = do
+-- drawInit = do
-  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
@@ -79,12 +91,13 @@ draw = do
   liftIO $ clearArea foreground (GeglRectangle 0 0 w h)
   maybe (return ()) (\(x, y) ->
     drawRect
-      foreground
+      (nodeGraph M.! "nop")
-      (nodeGraph M.! "over")
       (G.RGBA 1 0 0 0.5)
-      (Line 7)
+      (Fill)
       (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

@@ -4,8 +4,11 @@ import Affection
 import qualified SDL
 import qualified GEGL as G
 import qualified BABL as B
+
 import qualified Data.Map.Strict as M
 
+import Control.Monad (when)
+
 import Foreign.C.Types
 
 import System.Random (randomRIO)
@@ -29,7 +32,6 @@ main = do
 data UserData = UserData
   { nodeGraph   :: M.Map String G.GeglNode
   , foreground  :: G.GeglBuffer
-  , coordinates :: Maybe (Int, Int)
   , partsys     :: ParticleSystem
   }
 
@@ -45,37 +47,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
+    [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 "gegl: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 (ParticleStorage Nothing []) nop buffer
-    , partsys = ParticleSystem [] over buffer
     }
 
 drawInit :: Affection UserData ()
 drawInit = do
   UserData{..} <- getAffection
-  present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
+  present (GeglRectangle 0 0 800 600) foreground 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,20 +121,47 @@ update sec = do
           vx <- liftIO $ randomRIO (-20, 20)
           vy <- liftIO $ randomRIO (-20, 20)
           life <- liftIO $ randomRIO (1, 5)
+          r <- liftIO $ randomRIO (0,1)
+          g <- liftIO $ randomRIO (0,1)
+          b <- liftIO $ randomRIO (0,1)
+          tempRoot <- liftIO $ G.gegl_node_new
+          tempOver <- liftIO $ G.gegl_node_new_child tempRoot
+            G.defaultOverOperation
+          tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
+            "gegl:rectangle"
+            [ G.Property "x"      $ G.PropertyDouble $ fromIntegral x - 10
+            , G.Property "y"      $ G.PropertyDouble $ fromIntegral y - 10
+            , G.Property "width"  $ G.PropertyDouble 20
+            , G.Property "height" $ G.PropertyDouble 20
+            , G.Property "color"  $ G.PropertyColor  $ (G.RGBA r g b 0.5)
+            ]
+          liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
           -- traceM $ "position is: " ++ show x ++ " " ++ show y
           -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
-          putAffection $ ud
+          ips <- insertParticle (partsys ud) $
-            { coordinates = Just (fromIntegral x, fromIntegral y)
+            Particle
-            , partsys     = (partsys ud)
+              { particleTimeToLive = life
-                { psParts = (Particle
+              , particleCreation   = elapsedTime ad
-                    { particleLife = life
               , particlePosition   = (fromIntegral x, fromIntegral y)
               , particleRotation   = Rad 0
               , particleVelocity   = (vx, vy)
               , particlePitchRate  = Rad 0
-                    }) : (psParts $ partsys ud)
+              , particleRootNode   = tempRoot
+              , particleNodeGraph  = M.fromList
+                [ ("root", tempRoot)
+                , ("over", tempOver)
+                , ("rect", tempRect)
+                ]
+              , particleStackCont  = tempOver
+              , particleDrawFlange = tempOver
               }
+          putAffection $ ud
+            { partsys = ips
             }
+          -- when (not $ null $ psParts $ partsys ud) $
+          --   liftIO $ G.gegl_node_link
+          --     tempOver
+          --     (particleStackCont $ head $ psParts $ partsys ud)
         else
           return ()
       SDL.WindowClosedEvent _ -> do
@@ -140,22 +179,28 @@ update sec = do
 clean :: UserData -> IO ()
 clean _ = return ()
 
-partUpd :: Double -> Particle -> Particle
+partUpd :: Double -> Particle -> Affection UserData Particle
-partUpd sec p@Particle{..} =
+partUpd sec p@Particle{..} = do
-  p
+  let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
-    { particlePosition = (newX, newY)
-    , particleLife = particleLife - sec
-    }
-  where
-    newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
       newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
+  liftIO $ G.gegl_node_set (particleNodeGraph M.! "rect") $ G.Operation "gegl:rectangle"
+    [ G.Property "x" $ G.PropertyDouble $ newX - 10
+    , G.Property "y" $ G.PropertyDouble $ newY - 10
+    ]
+  return p
+    { particlePosition = (newX, newY)
+    }
 
 partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
 partDraw buf node Particle{..} = do
-  ud <- getAffection
+  present
-  drawRect
+    (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20)
     buf
-    node
+    False
-    (G.RGBA 1 0 0 0.5)
+  -- ud <- getAffection
-    (Line 5)
+  -- drawRect'
-    (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
+  --   particleDrawFlange
+  --   (G.RGBA 1 0 0 0.5)
+  --   (Fill)
+  --   (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
+  --   buf

examples/example04.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE RecordWildCards #-}
+
+import Affection
+import qualified SDL
+import qualified GEGL as G
+import qualified BABL as B
+import qualified BABL.FFI.Format as B
+import qualified Data.Map.Strict as M
+
+import Foreign.C.Types
+import Foreign.Ptr (castPtr, nullPtr)
+import Foreign.Marshal.Utils (new)
+
+import System.Random (randomRIO)
+
+import Control.Monad (unless)
+
+import Debug.Trace
+
+main :: IO ()
+main = do
+  conf <- return $ AffectionConfig
+    { initComponents = All
+    , windowTitle    = "Affection: example00"
+    , windowConfig   = SDL.defaultWindow
+    , preLoop        = return ()
+    , drawLoop       = draw
+    , updateLoop     = update
+    , loadState      = load
+    , cleanUp        = clean
+    }
+  withAffection conf
+
+data UserData = UserData
+  { nodeGraph   :: M.Map String G.GeglNode
+  , coordinates :: Maybe (Int, Int)
+  }
+
+load :: SDL.Surface -> IO UserData
+load surface = do
+  traceM "loading"
+  root <- G.gegl_node_new
+  traceM "new root node"
+  checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation
+    [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1
+    , G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1
+    ]
+  traceM "checkerboard"
+  over <- G.gegl_node_new_child root G.defaultOverOperation
+  traceM "over"
+  nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
+  traceM "nop"
+  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
+    [ G.Property "x" $ G.PropertyDouble 0
+    , G.Property "y" $ G.PropertyDouble 0
+    , G.Property "width" $ G.PropertyDouble 800
+    , G.Property "height" $ G.PropertyDouble 600
+    ]
+  traceM "crop"
+  format <- B.babl_format $ B.PixelFormat B.RGBA B.CFu8
+  pixels <- liftIO $ new =<< SDL.surfacePixels surface
+  sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
+    [ G.Property "buffer" $ G.PropertyPointer $ castPtr $ pixels
+    , G.Property "format" $ G.PropertyPointer $ nullPtr
+    ]
+  traceM "sink"
+  G.gegl_node_link_many [checkerboard, over, crop, sink]
+  diw <- G.gegl_node_connect_to nop "output" over "aux"
+  unless diw (error "connect failed")
+  traceM "connections made"
+  myMap <- return $ M.fromList
+    [ ("root"        , root)
+    , ("over"        , over)
+    , ("background"  , checkerboard)
+    , ("nop"         , nop)
+    , ("crop"        , crop)
+    , ("sink"        , sink)
+    ]
+  traceM "loading complete"
+  return $ UserData
+    { nodeGraph = myMap
+    , coordinates = Nothing
+    }
+
+update :: Double -> AffectionState (AffectionData UserData) IO ()
+update sec = do
+  traceM "updating"
+  ad <- get
+  ud <- getAffection
+  traceM $ (show $ 1 / sec) ++ " FPS"
+  ev <- liftIO $ SDL.pollEvents
+  mapM_ (\e ->
+    case SDL.eventPayload e of
+      SDL.MouseButtonEvent dat -> do
+        let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat
+        drawRect
+          (nodeGraph ud M.! "nop")
+          (G.RGBA 1 0 0 0.5)
+          Fill
+          (G.GeglRectangle (fromIntegral x - 10) (fromIntegral y - 10) 20 20)
+        traceM $ "drewn a rectangle at " ++ show x ++ " " ++ show y
+      SDL.WindowClosedEvent _ -> do
+        traceM "seeya!"
+        put $ ad
+          { quitEvent = True
+          }
+      _ ->
+        return ()
+    ) ev
+
+draw :: Affection UserData ()
+draw = do
+  ad <- get
+  ud <- getAffection
+  liftIO $ SDL.lockSurface $ drawSurface ad
+  liftIO $ G.gegl_node_process (nodeGraph ud M.! "sink")
+  liftIO $ SDL.unlockSurface $ drawSurface ad
+
+clean :: UserData -> IO ()
+clean _ = return ()

src/Affection.hs

@@ -63,7 +63,9 @@ withAffection AffectionConfig{..} = do
     , userState       = x
     , drawWindow      = window
     , drawSurface     = surface
+    , drawFormat      = format
     , drawStack       = []
+    , elapsedTime     = 0
     }) <$> loadState surface
   (_, nState) <- runStateT ( A.runState $ do
     preLoop
@@ -79,17 +81,20 @@ withAffection AffectionConfig{..} = do
         -- get state
         ad <- get
         -- clean draw requests from last run
-        mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad
+        mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
+        -- compute dt and update elapsedTime
+        let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
         put $ ad
-          { drawStack = [] }
+          { drawStack = []
+          , elapsedTime = elapsedTime ad + dt
+          }
+        -- execute user defined update loop
+        updateLoop dt
         -- execute user defined draw loop
         drawLoop
-        -- execute user defined update loop
-        updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
-          (fromIntegral 10 ^ 9)
         -- handle all new draw requests
         ad2 <- get
-        clear <- catMaybes <$> mapM (handleDrawRequest pixels format stride cpp) (drawStack ad2)
+        clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)
         -- save all draw requests to clear in next run
         put $ ad2
           { drawStack = clear }

src/Affection/Draw.hs

@@ -12,11 +12,13 @@ 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)
+import Control.Monad (when, unless)
+
+import System.Glib.GObject
 
 import qualified SDL
 
@@ -26,123 +28,99 @@ import qualified GEGL as G
 
 import Debug.Trace
 
--- | Draw a rectangle on target buffer
 drawRect
-  :: G.GeglBuffer  -- ^ Target buffer
+  :: G.GeglNode      -- ^ Target Node
-  -> G.GeglNode    -- ^ Target node
   -> G.Color         -- ^ Color to draw in
   -> DrawType        -- ^ Draw type
-  -> GeglRectangle -- ^ Dimensions of Rectangle
+  -> G.GeglRectangle -- ^ Dimensions of Rectangle
+  -> G.GeglBuffer    -- ^ Final Buffer
   -> Affection us ()
-drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
+drawRect node color Fill rect@GeglRectangle{..} buf = do
-  liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
+  ad <- get
-    (\(x, y) ->
+  tempRoot <- liftIO $ G.gegl_node_new
-      let col = unsafeColorize color
+  opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
-      in 
+    [ G.Property "x"      $ G.PropertyDouble $ fromIntegral rectangleX
-        G.Pixel x y col
+    , G.Property "y"      $ G.PropertyDouble $ fromIntegral rectangleY
-    )
+    , G.Property "width"  $ G.PropertyDouble $ fromIntegral rectangleWidth
-  ad@AffectionData{..} <- get
+    , 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 node rect buf False) : drawStack
+    { drawStack = (DrawRequest rect buf (Kill (Just tempRoot))) : drawStack ad
     }
-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 node 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)
 
--- | force a blit of a specified area. Do not use often as it slows down the program
+-- | Force update of a specific region on screen
 present
-  :: G.GeglNode      -- ^ Node to blit
+  :: G.GeglRectangle -- ^ Area to be updated
-  -> G.GeglBuffer    -- ^ BUffer to draw
+  -> G.GeglBuffer    -- ^ Target buffer
-  -> G.GeglRectangle -- ^ Area to blit
+  -> Bool            -- ^ Shall the 'DrawRequest' persist?
-  -> Bool            -- ^ Shall the drawing be cleared in the next run?
   -> Affection us ()
-present node buf rect pers = do
+present rect buf kill = do
   ad <- get
-  put $ ad
+  let k = if not kill then Kill Nothing else Yes
-    { drawStack = (DrawRequest node rect buf pers) : drawStack ad
+  put ad
+    { drawStack = (DrawRequest rect buf k) : 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
-    node
-    1
-    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
+  -- -> 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
+handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
   ad <- get
   let surf = drawSurface ad
   liftIO $ SDL.lockSurface surf
-  liftIO $ G.gegl_node_blit
+  liftIO $ G.gegl_buffer_get
-    requestNode
+    requestBuffer
+    (Just requestArea)
     1
-    requestArea
+    (Just $ drawFormat ad)
-    format
     (pixels `plusPtr`
       (rectangleX requestArea * cpp + rectangleY requestArea * stride))
     stride
-    [G.GeglBlitDefault]
+    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
 invalidateDrawRequest
   :: Ptr a           -- ^ Pixel buffer to blit to
-  -> B.BablFormatPtr -- ^ format to blit in
+  -- -> 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
+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_node_blit
+  liftIO $ G.gegl_buffer_get
-    requestNode
+    requestBuffer
+    (Just requestArea)
     1
-    requestArea
+    (Just $ drawFormat ad)
-    format
     (pixels `plusPtr`
       (rectangleX requestArea * cpp + rectangleY requestArea * stride))
     stride
-    [G.GeglBlitDefault]
+    G.GeglAbyssNone
   liftIO $ SDL.unlockSurface surf
+  case requestPersist of
+    Kill (Just victim) ->
+      liftIO $ G.gegl_node_drop victim
+    _ ->
+      return ()
   -- liftIO $ SDL.updateWindowSurface $ drawWindow ad
 
 -- | compute color for a single pixel
@@ -190,12 +168,6 @@ unsafeColorize col =
     , 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

src/Affection/Particle.hs

@@ -5,30 +5,103 @@ module Affection.Particle
   ( updateParticle
   , drawParticles
   , updateParticleSystem
+  , insertParticle
   ) where
 
 import Affection.Types
 
-import Data.Maybe (catMaybes)
+import Control.Monad
+import Control.Monad.State (get)
+
+import Data.Maybe
 
 import qualified GEGL as G
 
+import Debug.Trace
+
 -- This function updates particles through a specified function. Particle ageing
 -- and death is being handled by 'updateParticles' itself and does not need to
 -- bother you.
 updateParticle
-  :: Double                           -- ^ Elapsed time in seconds
+  :: Double
-  -> (Double -> Particle -> Particle) -- ^ Update function for a single 'Particle'
+    -- ^ Elapsed time in seconds
+  -> (Double -> Particle -> Affection us Particle) 
+    -- ^ Update function for a single 'Particle'
     -- This Function should take the elapsed time
     -- in seconds and the initial particle as arguments.
-  -> Particle                         -- ^ 'Particle' to be processed
+  -- -> [Maybe Particle]
-  -> Maybe Particle                   -- ^ resulting 'Particle'
+  -> Particle
-updateParticle time funct p@Particle{..} =
+    -- ^ 'Particle' to be processed
-  if particleLife - time < 0
+  -- -> Affection us [Maybe Particle]
-  then
+  -> Affection us (Maybe Particle)
-    Nothing
+    -- ^ resulting 'Particle'
-  else
+updateParticle time funct pa = do
-    Just $ funct time $ p { particleLife = particleLife - time }
+  now <- elapsedTime <$> get
+  if particleCreation pa + particleTimeToLive pa < now
+  then do
+    mproducer <- liftIO $ G.gegl_node_get_producer
+      (particleStackCont pa)
+      "input"
+    case mproducer of
+      Just (producer, padname) -> do
+        consumers <- liftIO $ G.gegl_node_get_consumers
+          (particleStackCont pa)
+          "output"
+        liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
+          producer
+          padname
+          node
+          inpad
+          ) consumers
+      Nothing -> return ()
+    liftIO $ G.gegl_node_drop $ particleRootNode pa
+    return $ Nothing
+  else do
+    np <- Just <$> funct time pa
+    return $ np
+-- updateParticle time funct acc@[p] pa = do
+--   now <- elapsedTime <$> get
+--   if particleCreation pa + particleTimeToLive pa > now
+--   then do
+--     liftIO $ G.gegl_node_drop $ particleRootNode pa
+--     return $ Nothing : acc
+--   else do
+--     when (not $ isNothing p) $ do
+--       -- liftIO $ traceIO "linking second node in list"
+--       liftIO $ G.gegl_node_link
+--         (particleStackCont pa)
+--         (particleStackCont $ fromJust p)
+--     np <- Just <$> funct time pa
+--     return $ np : acc
+-- updateParticle time funct acc@(p:ps) pa = do
+--   now <- elapsedTime <$> get
+--   if particleCreation pa + particleTimeToLive pa > now
+--   then do
+--     liftIO $ G.gegl_node_drop $ particleRootNode pa
+--     return $ Nothing : acc
+--   else do
+--     when (isNothing p) $ do
+--       let mnl = nextLiving ps
+--       maybe
+--         (return ())
+--         (\nl -> do
+--           -- liftIO $ traceIO "linking nth node on list"
+--           liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))
+--         mnl
+--     np <- Just <$> funct time pa
+--     return $ np : acc
+
+-- | Get the next living particle from a list
+nextLiving
+  :: [Maybe Particle]
+  -> Maybe Particle
+nextLiving [] = Nothing
+nextLiving acc = case catMaybes acc of
+  [] -> Nothing
+  ps -> Just $ head $ ps
+  -- if isNothing p
+  -- then nextLiving ps
+  -- else p
 
 drawParticles
   :: (Particle -> Affection us ())
@@ -39,11 +112,57 @@ drawParticles = mapM_
 updateParticleSystem
   :: ParticleSystem
   -> Double
-  -> (Double -> Particle -> Particle)
+  -> (Double -> Particle -> Affection us Particle)
   -> (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)
+  x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
-  mapM_ (draw (psBuffer sys) (psNode sys)) x
+  -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
+  when (not $ null x) $ do
+    -- liftIO $ traceIO "linking last node to output"
+    liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)
+  mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
   return $ sys
-    { psParts = x }
+    { partSysParts = (partSysParts sys)
+      { partStorList = x
+      , partStorLatest =
+          if null x
+          then Nothing
+          else partStorLatest (partSysParts sys)
+      }
+    }
+
+-- | Function for inserting a new 'Particle' into its 'PartileSystem'
+insertParticle
+  :: ParticleSystem -- ^ 'ParticleSystem' to insert into
+  -> Particle       -- ^ 'Particle' to insert
+  -> Affection us ParticleSystem -- ^ resulting new 'ParticleSystem'
+insertParticle ps p = do
+  now <- elapsedTime <$> get
+  let newList = chronoInsert now (partStorList $ partSysParts ps) p
+  when (not $ isNothing $ partStorLatest $ partSysParts ps) $ 
+    liftIO $ G.gegl_node_link
+      (particleStackCont p)
+      (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)
+  return $ ps
+    { partSysParts = (partSysParts ps)
+      { partStorLatest = Just p
+      , partStorList   = newList
+      }
+    }
+
+-- | Insert a 'Particle' into its chronologically ordered list
+chronoInsert
+  :: Double     -- ^ Time in seconds from beginning of program execution
+  -> [Particle] -- ^ List to insert to
+  -> Particle   -- ^ 'Particle' to insert
+  -> [Particle] -- ^ Resulting list
+chronoInsert now []       np = [np]
+chronoInsert now [p]      np =
+  if now + particleTimeToLive p < particleCreation np
+  then p : [np]
+  else np : [p]
+chronoInsert now l@(p:ps) np =
+  if now + particleTimeToLive p < particleCreation np
+  then p : chronoInsert now ps np
+  else np : l

src/Affection/Types.hs

@@ -13,11 +13,13 @@ module Affection.Types
   , RGBA(..)
   , DrawType(..)
   , DrawRequest(..)
+  , RequestPersist(..)
   , Angle(..)
   , ConvertAngle(..)
     -- | Particle system
   , Particle(..)
   , ParticleSystem(..)
+  , ParticleStorage(..)
     -- | Convenience exports
   , liftIO
   , SDL.WindowConfig(..)
@@ -30,7 +32,10 @@ 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
 
 import Control.Monad.IO.Class
 import Control.Monad.State
@@ -58,6 +63,11 @@ data AffectionConfig us = AffectionConfig
       -- ^ Provide your own finisher function to clean your data.
   }
 
+-- | Components to initialize in SDL.
+data InitComponents
+  = All
+  | Only [SDL.InitFlag]
+
 -- | Main type for defining the look, feel and action of the whole application.
 data AffectionData us = AffectionData
   -- { affectionConfig :: AffectionConfig us -- ^ Application configuration.
@@ -65,22 +75,25 @@ data AffectionData us = AffectionData
   , userState       :: us                 -- ^ State data provided by user
   , drawWindow      :: SDL.Window         -- ^ SDL window
   , drawSurface     :: SDL.Surface        -- ^ SDL surface
+  , drawFormat      :: B.BablFormatPtr    -- ^ Target format
   , drawStack       :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be processed
   , clearStack      :: [DrawRequest]      -- ^ Stack of 'DrawRequest's to be invalidated
+  , elapsedTime     :: Double             -- ^ Elapsed time in seconds
   }
 
 -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
 data DrawRequest = DrawRequest
-  { requestNode     :: G.GeglNode      -- ^ The 'G.GeglNode' to blit
+  { requestArea     :: G.GeglRectangle -- ^ The area to update
-  , 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
   }
 
--- | Components to initialize in SDL.
+data RequestPersist
-data InitComponents
+  = Yes
-  = All
+  | Kill (Maybe G.GeglNode)
-  | Only [SDL.InitFlag]
+
+-- | A type for storing 'DrawRequest' results to be executed frequently. TODO
+data DrawAsset = DrawAsset
 
 -- | Inner 'StateT' monad for the update state
 -- type AffectionStateInner us m a = StateT (AffectionData us) m a
@@ -154,8 +167,10 @@ instance Eq Angle where
 
 -- | A single particle
 data Particle = Particle
-  { particleLife      :: Double
+  { particleTimeToLive :: Double
       -- ^ Time to live in seconds
+  , particleCreation   :: Double
+      -- ^ Creation time of particle in seconds form program start
   , particlePosition   :: (Double, Double)
       -- ^ Position of particle on canvas
   , particleRotation   :: Angle
@@ -164,10 +179,25 @@ 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'
-data ParticleSystem = ParticleSystem
+  , particleNodeGraph  :: Map String G.GeglNode
-  { psParts  :: [Particle]
+      -- ^ Node Graph of 'G.GeglNodes' per particle
-  , psNode   :: G.GeglNode
+  , particleStackCont  :: G.GeglNode
-  , psBuffer :: G.GeglBuffer
+      -- ^ 'G.GeglNode' to connect other 'Particle's to
+  , particleDrawFlange :: G.GeglNode
+      -- ^ 'G.GeglNode' to connect draw actions to
+  }
+
+-- | The particle system
+data ParticleSystem = ParticleSystem
+  { partSysParts  :: ParticleStorage
+  , partSysNode   :: G.GeglNode
+  , partSysBuffer :: G.GeglBuffer
+  }
+
+-- | The particle storage datatype
+data ParticleStorage = ParticleStorage
+  { partStorLatest :: Maybe Particle -- ^ The particle stored last
+  , partStorList   :: [Particle]     -- ^ List of particles in ascending order of remaining lifetime
   }