fixed routing

This commit is contained in:
nek0 2016-12-25 08:14:51 +01:00
parent 428ab736f8
commit 2095bb1924
4 changed files with 149 additions and 71 deletions

View file

@ -75,7 +75,7 @@ load _ = do
return $ UserData return $ UserData
{ nodeGraph = myMap { nodeGraph = myMap
, foreground = buffer , foreground = buffer
, partsys = ParticleSystem [] nop buffer , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer
} }
drawInit :: Affection UserData () drawInit :: Affection UserData ()
@ -138,29 +138,30 @@ update sec = do
liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux" liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
-- traceM $ "position is: " ++ show x ++ " " ++ show y -- traceM $ "position is: " ++ show x ++ " " ++ show y
-- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
ips <- insertParticle (partsys ud) $
Particle
{ particleTimeToLive = life
, particleCreation = elapsedTime ad
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud putAffection $ ud
{ partsys = (partsys ud) { partsys = ips
{ psParts = (Particle
{ particleLife = life
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect" , tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}) : (psParts $ partsys ud)
}
} }
when (not $ null $ psParts $ partsys ud) $ -- when (not $ null $ psParts $ partsys ud) $
liftIO $ G.gegl_node_link -- liftIO $ G.gegl_node_link
tempOver -- tempOver
(particleStackCont $ head $ psParts $ partsys ud) -- (particleStackCont $ head $ psParts $ partsys ud)
else else
return () return ()
SDL.WindowClosedEvent _ -> do SDL.WindowClosedEvent _ -> do

View file

@ -65,6 +65,7 @@ withAffection AffectionConfig{..} = do
, drawSurface = surface , drawSurface = surface
, drawFormat = format , drawFormat = format
, drawStack = [] , drawStack = []
, elapsedTime = 0
}) <$> loadState surface }) <$> loadState surface
(_, nState) <- runStateT ( A.runState $ do (_, nState) <- runStateT ( A.runState $ do
preLoop preLoop
@ -81,11 +82,14 @@ withAffection AffectionConfig{..} = do
ad <- get ad <- get
-- clean draw requests from last run -- clean draw requests from last run
mapM_ (invalidateDrawRequest pixels 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 put $ ad
{ drawStack = [] } { drawStack = []
, elapsedTime = elapsedTime ad + dt
}
-- execute user defined update loop -- execute user defined update loop
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / updateLoop dt
(fromIntegral 10 ^ 9)
-- execute user defined draw loop -- execute user defined draw loop
drawLoop drawLoop
-- handle all new draw requests -- handle all new draw requests

View file

@ -5,11 +5,13 @@ module Affection.Particle
( updateParticle ( updateParticle
, drawParticles , drawParticles
, updateParticleSystem , updateParticleSystem
, insertParticle
) where ) where
import Affection.Types import Affection.Types
import Control.Monad import Control.Monad
import Control.Monad.State (get)
import Data.Maybe import Data.Maybe
@ -27,48 +29,67 @@ updateParticle
-- ^ Update function for a single 'Particle' -- ^ Update function for a single 'Particle'
-- This Function should take the elapsed time -- This Function should take the elapsed time
-- in seconds and the initial particle as arguments. -- in seconds and the initial particle as arguments.
-> [Maybe Particle] -- -> [Maybe Particle]
-> Particle -> Particle
-- ^ 'Particle' to be processed -- ^ 'Particle' to be processed
-> Affection us [Maybe Particle] -- -> Affection us [Maybe Particle]
-> Affection us (Maybe Particle)
-- ^ resulting 'Particle' -- ^ resulting 'Particle'
updateParticle time funct acc@[] pa = updateParticle time funct pa = do
if particleLife pa - time < 0 now <- elapsedTime <$> get
if particleCreation pa + particleTimeToLive pa < now
then do 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 liftIO $ G.gegl_node_drop $ particleRootNode pa
return $ Nothing : acc return $ Nothing
else do else do
np <- Just <$> funct time pa { particleLife = particleLife pa - time } np <- Just <$> funct time pa
return $ np : acc return $ np
updateParticle time funct acc@[p] pa = -- updateParticle time funct acc@[p] pa = do
if particleLife pa - time < 0 -- now <- elapsedTime <$> get
then do -- if particleCreation pa + particleTimeToLive pa > now
liftIO $ G.gegl_node_drop $ particleRootNode pa -- then do
return $ Nothing : acc -- liftIO $ G.gegl_node_drop $ particleRootNode pa
else do -- return $ Nothing : acc
when (not $ isNothing p) $ do -- else do
-- liftIO $ traceIO "linking second node in list" -- when (not $ isNothing p) $ do
liftIO $ G.gegl_node_link -- -- liftIO $ traceIO "linking second node in list"
(particleStackCont pa) -- liftIO $ G.gegl_node_link
(particleStackCont $ fromJust p) -- (particleStackCont pa)
np <- Just <$> funct time pa { particleLife = particleLife pa - time } -- (particleStackCont $ fromJust p)
return $ np : acc -- np <- Just <$> funct time pa
updateParticle time funct acc@(p:ps) pa = -- return $ np : acc
if particleLife pa - time < 0 -- updateParticle time funct acc@(p:ps) pa = do
then do -- now <- elapsedTime <$> get
liftIO $ G.gegl_node_drop $ particleRootNode pa -- if particleCreation pa + particleTimeToLive pa > now
return $ Nothing : acc -- then do
else do -- liftIO $ G.gegl_node_drop $ particleRootNode pa
when (isNothing p) $ do -- return $ Nothing : acc
let mnl = nextLiving ps -- else do
maybe -- when (isNothing p) $ do
(return ()) -- let mnl = nextLiving ps
(\nl -> do -- maybe
-- liftIO $ traceIO "linking nth node on list" -- (return ())
liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl)) -- (\nl -> do
mnl -- -- liftIO $ traceIO "linking nth node on list"
np <- Just <$> funct time pa { particleLife = particleLife pa - time } -- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))
return $ np : acc -- mnl
-- np <- Just <$> funct time pa
-- return $ np : acc
-- | Get the next living particle from a list -- | Get the next living particle from a list
nextLiving nextLiving
@ -95,12 +116,53 @@ updateParticleSystem
-> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
-> Affection us ParticleSystem -> Affection us ParticleSystem
updateParticleSystem sys sec upd draw = do updateParticleSystem sys sec upd draw = do
-- let x = catMaybes <$> mapM (updateParticle sec upd) (psParts sys) x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
-- x <- liftIO $ catMaybes <$> foldM (updateParticle sec upd) [] (psParts sys) -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
when (not $ null x) $ do when (not $ null x) $ do
-- liftIO $ traceIO "linking last node to output" -- liftIO $ traceIO "linking last node to output"
liftIO $ G.gegl_node_link (particleStackCont $ last x) (psNode sys) liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)
mapM_ (draw (psBuffer sys) (psNode sys)) x mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
return $ sys 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

View file

@ -19,6 +19,7 @@ module Affection.Types
-- | Particle system -- | Particle system
, Particle(..) , Particle(..)
, ParticleSystem(..) , ParticleSystem(..)
, ParticleStorage(..)
-- | Convenience exports -- | Convenience exports
, liftIO , liftIO
, SDL.WindowConfig(..) , SDL.WindowConfig(..)
@ -77,6 +78,7 @@ data AffectionData us = AffectionData
, drawFormat :: B.BablFormatPtr -- ^ Target format , drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated , 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 -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
@ -165,8 +167,10 @@ instance Eq Angle where
-- | A single particle -- | A single particle
data Particle = Particle data Particle = Particle
{ particleLife :: Double { particleTimeToLive :: Double
-- ^ Time to live in seconds -- ^ Time to live in seconds
, particleCreation :: Double
-- ^ Creation time of particle in seconds form program start
, particlePosition :: (Double, Double) , particlePosition :: (Double, Double)
-- ^ Position of particle on canvas -- ^ Position of particle on canvas
, particleRotation :: Angle , particleRotation :: Angle
@ -185,8 +189,15 @@ data Particle = Particle
-- ^ 'G.GeglNode' to connect draw actions to -- ^ 'G.GeglNode' to connect draw actions to
} }
-- | The particle system
data ParticleSystem = ParticleSystem data ParticleSystem = ParticleSystem
{ psParts :: [Particle] { partSysParts :: ParticleStorage
, psNode :: G.GeglNode , partSysNode :: G.GeglNode
, psBuffer :: G.GeglBuffer , 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
} }