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
, babl
, monad-loops
, monad-parallel
, containers
, clock
, glib

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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