From f4a96f03c4013f3d5bf30b8bdd39b7966566d778 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 20 Mar 2017 05:24:02 +0100 Subject: [PATCH] split particle update ind update and draw. Adding some concurrency --- affection.cabal | 1 + examples/example03.hs | 25 +++++++++++++------------ src/Affection.hs | 3 ++- src/Affection/Draw.hs | 21 +++++++++++++++++++++ src/Affection/Particle.hs | 27 +++++++++++++++++++++------ src/Affection/Types.hs | 3 +++ 6 files changed, 61 insertions(+), 19 deletions(-) diff --git a/affection.cabal b/affection.cabal index 46d0d1e..c1bc844 100644 --- a/affection.cabal +++ b/affection.cabal @@ -65,6 +65,7 @@ library , gegl , babl , monad-loops + , monad-parallel , containers , clock , glib diff --git a/examples/example03.hs b/examples/example03.hs index 9367bfb..75dcccd 100644 --- a/examples/example03.hs +++ b/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) - -- buf +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 diff --git a/src/Affection.hs b/src/Affection.hs index 968c1e0..b18bd48 100644 --- a/src/Affection.hs +++ b/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 diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index b016761..7618d14 100644 --- a/src/Affection/Draw.hs +++ b/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 diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 4d9649d..0623a51 100644 --- a/src/Affection/Particle.hs +++ b/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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 665237a..a0fad1d 100644 --- a/src/Affection/Types.hs +++ b/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