split particle update ind update and draw. Adding some concurrency

affection.cabal

@@ -65,6 +65,7 @@ library
                      , gegl
                      , babl
                      , monad-loops
+                     , monad-parallel
                      , containers
                      , clock
                      , glib

examples/example03.hs

@@ -194,15 +194,16 @@ partUpd sec p = do
   return np
 
 partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
-partDraw buf node Particle{..} = do
-  present
-    (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20)
-    buf
-    False
-  -- ud <- getAffection
-  -- drawRect'
-  --   particleDrawFlange
-  --   (G.RGBA 1 0 0 0.5)
-  --   (Fill)
-  --   (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
+partDraw _ _ _ = return ()
+-- partDraw buf node Particle{..} = do
+--   present
+--     (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20)
 --     buf
+--     False
+--   -- ud <- getAffection
+--   -- drawRect'
+--   --   particleDrawFlange
+--   --   (G.RGBA 1 0 0 0.5)
+--   --   (Fill)
+--   --   (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
+--   --   buf

src/Affection.hs

@@ -26,6 +26,7 @@ import Data.IORef
 import System.Clock
 
 import Control.Monad.Loops
+import qualified Control.Monad.Parallel as MP
 import Control.Monad.State
 
 import Foreign.C.Types (CInt(..))
@@ -126,7 +127,7 @@ withAffection AffectionConfig{..} = do
           }
         -- poll events
         evs <- preHandleEvents =<< liftIO SDL.pollEvents
-        forM evs $ eventLoop
+        MP.mapM_ eventLoop evs
         -- execute user defined update loop
         updateLoop
         -- execute user defined draw loop

src/Affection/Draw.hs

@@ -72,6 +72,27 @@ process
   -> Affection us ()
 process = liftIO . G.gegl_node_process
 
+putToSurface
+  :: Ptr a
+  -> G.GeglRectangle
+  -> Int
+  -> Int
+  -> DrawRequest
+  -> Affection us ()
+putToSurface pixels realRect stride cpp DrawRequest{..} = do
+  ad <- get
+  liftIO $ SDL.lockSurface $ drawSurface ad
+  liftIO $ G.gegl_buffer_get
+    requestBuffer
+    (Just realRect)
+    1
+    (Just $ drawFormat ad)
+    (pixels `plusPtr`
+      (rectangleX realRect * cpp + rectangleY realRect * stride))
+    stride
+    G.GeglAbyssNone
+  liftIO $ SDL.unlockSurface $ drawSurface ad
+
 -- | function for handling 'DrawRequest's and updating the output
 handleDrawRequest
   :: Ptr a           -- ^ Pixel buffer to blit to

src/Affection/Particle.hs

@@ -5,6 +5,7 @@ module Affection.Particle
   ( updateParticle
   , drawParticles
   , updateParticleSystem
+  , drawParticleSystem
   , insertParticle
   ) where
 
@@ -12,6 +13,7 @@ import Affection.Types
 
 import Control.Monad
 import Control.Monad.State (get)
+import qualified Control.Monad.Parallel as MP
 
 import Data.Maybe
 
@@ -38,7 +40,8 @@ updateParticle time func l =
     updateParticle' dt fun [p]    = do
       now <- elapsedTime <$> get
       if particleCreation p + particleTimeToLive p < now
-      then
+      then do
+        dropParticle p
         return []
       else
         (: []) <$> func time p
@@ -64,6 +67,7 @@ updateParticle time func l =
           padname
           ) consumers
         ) mproducer
+      liftIO $ G.gegl_node_drop $ particleRootNode p
 
 -- | Get the next living particle from a list
 nextLiving
@@ -84,21 +88,17 @@ updateParticleSystem
   :: ParticleSystem
   -> Double
   -> (Double -> Particle -> Affection us Particle)
-  -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
   -> Affection us ParticleSystem
-updateParticleSystem sys sec upd draw = do
+updateParticleSystem sys sec upd = do
   !x <- updateParticle sec upd (partStorList $ partSysParts sys)
   if not $ null x
     then do
-      liftIO $ G.gegl_node_link (particleStackCont $ head x) (partSysNode sys)
-      mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
       return sys
         { partSysParts = (partSysParts sys)
           { partStorList = x
           }
         }
     else do
-      _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input"
       return sys
         { partSysParts = ParticleStorage
           { partStorList = []
@@ -106,6 +106,21 @@ updateParticleSystem sys sec upd draw = do
           }
         }
 
+drawParticleSystem
+  :: ParticleSystem
+  -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
+  -> Affection us ()
+drawParticleSystem sys draw =
+  if not (null parts)
+    then do
+      liftIO $ G.gegl_node_link (particleStackCont $ head parts) (partSysNode sys)
+      MP.mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts
+    else do
+      _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input"
+      return ()
+  where
+    parts = partStorList (partSysParts sys)
+
 -- | Function for inserting a new 'Particle' into its 'PartileSystem'
 insertParticle
   :: ParticleSystem -- ^ 'ParticleSystem' to insert into

src/Affection/Types.hs

@@ -40,6 +40,7 @@ import qualified BABL as B
 
 import Control.Monad.IO.Class
 import Control.Monad.State
+import qualified Control.Monad.Parallel as MP
 -- import Control.Monad.Reader
 
 -- import Control.Concurrent.MVar
@@ -114,6 +115,8 @@ newtype AffectionState us m a = AffectionState
   { runState :: AffectionStateInner us m a }
   deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
 
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
+
 type Affection us a = AffectionState (AffectionData us) IO a
 
 -- -- | Inner 'StateT' monad of Affection