affection/src/Affection/Particle.hs

74 lines
2.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE RecordWildCards #-}
-- | This module introduces a simple particle system to Affection
module Affection.Particle
( updateParticle
, drawParticles
, updateParticleSystem
) where
import Affection.Types
import Control.Monad
import Data.Maybe
import qualified GEGL as G
-- This function updates particles through a specified function. Particle ageing
-- and death is being handled by 'updateParticles' itself and does not need to
-- bother you.
updateParticle
2016-12-24 00:13:00 +00:00
:: Double
-- ^ Elapsed time in seconds
-> (Double -> Particle -> Affection us Particle)
-- ^ Update function for a single 'Particle'
-- This Function should take the elapsed time
-- in seconds and the initial particle as arguments.
-> Particle
-- ^ 'Particle' to be processed
-> Affection us (Maybe Particle)
-- ^ resulting 'Particle'
updateParticle time funct pa =
if particleLife pa - time < 0
then do
2016-12-24 00:13:00 +00:00
liftIO $ G.gegl_node_drop $ particleRootNode pa
return $ Nothing
else
2016-12-24 00:13:00 +00:00
Just <$> funct time pa { particleLife = particleLife pa - time }
-- updateParticle time funct acc@[p] pa =
-- if particleLife pa - time < 0
-- then do
-- G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else
-- return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
-- updateParticle time funct acc@(p:ps) pa =
-- if particleLife pa - time < 0
-- then do
-- G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else
-- return $ (Just $ funct time $ pa { particleLife = particleLife pa - time }) : acc
drawParticles
:: (Particle -> Affection us ())
-> [Particle]
-> Affection us ()
drawParticles = mapM_
updateParticleSystem
:: ParticleSystem
-> Double
2016-12-24 00:13:00 +00:00
-> (Double -> Particle -> Affection us Particle)
-> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
-> Affection us ParticleSystem
updateParticleSystem sys sec upd draw = do
-- let x = catMaybes <$> mapM (updateParticle sec upd) (psParts sys)
-- x <- liftIO $ catMaybes <$> foldM (updateParticle sec upd) [] (psParts sys)
2016-12-24 00:13:00 +00:00
x <- catMaybes <$> mapM (updateParticle sec upd) (psParts sys)
liftIO $ G.gegl_node_link_many $ map particleStackCont x ++ [psNode sys]
mapM_ (draw (psBuffer sys) (psNode sys)) x
return $ sys
{ psParts = x }