affection/src/Affection/Particle.hs

164 lines
4.6 KiB
Haskell
Raw Normal View History

2017-02-25 16:23:28 +00:00
{-# LANGUAGE BangPatterns #-}
-- | This module introduces a simple particle system to Affection
module Affection.Particle
( updateParticle
, drawParticles
, updateParticleSystem
, drawParticleSystem
2016-12-25 07:14:51 +00:00
, insertParticle
) where
import Affection.Types
import Control.Monad
2016-12-25 07:14:51 +00:00
import Control.Monad.State (get)
import Data.Maybe
import qualified GEGL as G
2016-12-24 07:27:47 +00:00
import Debug.Trace
-- 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
2017-03-14 19:10:47 +00:00
-- ^ Elapsed time in seconds
-> (Double -> Particle -> Affection us Particle)
-- ^ Update function for each 'Particle'
-> [Particle]
-- ^ List of 'Particle's to be processed
-> Affection us [Particle]
-- ^ processed 'Particle's
updateParticle time func l =
2017-11-04 19:37:49 +00:00
catMaybes <$> mapM (\p -> do
2017-04-17 10:40:17 +00:00
now <- elapsedTime <$> get
if particleCreation p + particleTimeToLive p < now
then do
dropParticle p
return Nothing
else do
np <- func time p
return $ Just np
) l
-- updateParticle' time func l
2017-03-14 19:10:47 +00:00
where
updateParticle' _ _ [] = return []
updateParticle' dt fun [p] = do
now <- elapsedTime <$> get
if particleCreation p + particleTimeToLive p < now
then do
dropParticle p
2017-03-14 19:10:47 +00:00
return []
else
2017-03-14 21:18:39 +00:00
(: []) <$> func time p
2017-03-14 19:10:47 +00:00
updateParticle' dt fun (p:ps) = do
now <- elapsedTime <$> get
if particleCreation p + particleTimeToLive p < now
then do
dropParticle p
updateParticle' dt fun ps
else do
np <- fun dt p
2017-03-14 21:18:39 +00:00
(np :) <$> updateParticle' dt fun ps
2017-03-14 19:10:47 +00:00
dropParticle p = do
2017-02-25 16:26:00 +00:00
mproducer <- liftIO $ G.gegl_node_get_producer
2017-03-14 19:10:47 +00:00
(particleStackCont p)
2017-02-25 16:26:00 +00:00
"input"
2017-03-14 19:10:47 +00:00
maybe (return ()) (\(producer, padname) -> do
consumers <- liftIO $ G.gegl_node_get_consumers
(particleStackCont p)
"output"
2017-03-14 21:18:39 +00:00
liftIO $ mapM_ (uncurry $ G.gegl_node_connect_to
2017-03-14 19:10:47 +00:00
producer
padname
) consumers
) mproducer
liftIO $ G.gegl_node_drop $ particleRootNode p
2016-12-24 07:27:47 +00:00
-- | Get the next living particle from a list
nextLiving
:: [Maybe Particle]
-> Maybe Particle
nextLiving [] = Nothing
nextLiving acc = case catMaybes acc of
[] -> Nothing
2017-03-14 21:18:39 +00:00
ps -> Just $ head ps
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)
-> Affection us ParticleSystem
updateParticleSystem sys sec upd = do
2017-03-14 19:10:47 +00:00
!x <- updateParticle sec upd (partStorList $ partSysParts sys)
2017-03-14 21:18:39 +00:00
if not $ null x
2017-02-22 17:03:16 +00:00
then do
2017-02-25 16:23:28 +00:00
return sys
2017-02-22 17:03:16 +00:00
{ partSysParts = (partSysParts sys)
{ partStorList = x
}
}
2017-02-25 16:23:28 +00:00
else do
2017-02-22 17:03:16 +00:00
return sys
2017-02-25 16:23:28 +00:00
{ partSysParts = ParticleStorage
{ partStorList = []
, partStorLatest = Nothing
}
}
2016-12-25 07:14:51 +00:00
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)
2017-11-04 19:37:49 +00:00
mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts
else do
_ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input"
return ()
where
parts = partStorList (partSysParts sys)
2016-12-25 07:14:51 +00:00
-- | 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
2017-02-17 16:15:06 +00:00
liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList)
2017-03-14 21:18:39 +00:00
return ps
2016-12-25 07:14:51 +00:00
{ 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 =
2017-02-17 16:15:06 +00:00
if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np)
2016-12-25 07:14:51 +00:00
then p : [np]
else np : [p]
chronoInsert now l@(p:ps) np =
2017-02-17 16:15:06 +00:00
if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np)
2016-12-25 07:14:51 +00:00
then p : chronoInsert now ps np
else np : l