affection/src/Affection/Particle.hs

169 lines
5.1 KiB
Haskell
Raw Normal View History

{-# LANGUAGE RecordWildCards #-}
-- | This module introduces a simple particle system to Affection
module Affection.Particle
( updateParticle
, drawParticles
, updateParticleSystem
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
-- ^ 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.
2016-12-25 07:14:51 +00:00
-- -> [Maybe Particle]
2016-12-24 00:13:00 +00:00
-> Particle
-- ^ 'Particle' to be processed
2016-12-25 07:14:51 +00:00
-- -> Affection us [Maybe Particle]
-> Affection us (Maybe Particle)
2016-12-24 00:13:00 +00:00
-- ^ resulting 'Particle'
2016-12-25 07:14:51 +00:00
updateParticle time funct pa = do
now <- elapsedTime <$> get
if particleCreation pa + particleTimeToLive pa < now
2016-12-24 07:27:47 +00:00
then do
2016-12-25 07:14:51 +00:00
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 ()
2016-12-24 07:27:47 +00:00
liftIO $ G.gegl_node_drop $ particleRootNode pa
2016-12-25 07:14:51 +00:00
return $ Nothing
2016-12-24 07:27:47 +00:00
else do
2016-12-25 07:14:51 +00:00
np <- Just <$> funct time pa
return $ np
-- updateParticle time funct acc@[p] pa = do
-- now <- elapsedTime <$> get
-- if particleCreation pa + particleTimeToLive pa > now
-- then do
-- liftIO $ G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else do
-- when (not $ isNothing p) $ do
-- -- liftIO $ traceIO "linking second node in list"
-- liftIO $ G.gegl_node_link
-- (particleStackCont pa)
-- (particleStackCont $ fromJust p)
-- np <- Just <$> funct time pa
-- return $ np : acc
-- updateParticle time funct acc@(p:ps) pa = do
-- now <- elapsedTime <$> get
-- if particleCreation pa + particleTimeToLive pa > now
-- then do
-- liftIO $ G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else do
-- when (isNothing p) $ do
-- let mnl = nextLiving ps
-- maybe
-- (return ())
-- (\nl -> do
-- -- liftIO $ traceIO "linking nth node on list"
-- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))
-- mnl
-- np <- Just <$> funct time pa
-- return $ np : acc
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
ps -> Just $ head $ ps
-- if isNothing p
-- then nextLiving ps
-- else p
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
2016-12-25 07:14:51 +00:00
x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
-- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
2016-12-24 07:27:47 +00:00
when (not $ null x) $ do
-- liftIO $ traceIO "linking last node to output"
2016-12-25 07:14:51 +00:00
liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)
mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
return $ sys
2016-12-25 07:14:51 +00:00
{ 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