split particle update ind update and draw. Adding some concurrency

This commit is contained in:
nek0 2017-03-20 05:24:02 +01:00
parent 6eccf8ed5b
commit f4a96f03c4
6 changed files with 61 additions and 19 deletions

View file

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

View file

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

View file

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

View file

@ -72,6 +72,27 @@ process
-> Affection us () -> Affection us ()
process = liftIO . G.gegl_node_process 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 -- | function for handling 'DrawRequest's and updating the output
handleDrawRequest handleDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to :: Ptr a -- ^ Pixel buffer to blit to

View file

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

View file

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