affection/src/Affection/Particle.hs

{-# 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
  :: 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
    liftIO $ G.gegl_node_drop $ particleRootNode pa
    return $ Nothing
  else
    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
  -> (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)
  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 }