affection/src/Affection/Particle.hs

{-# LANGUAGE BangPatterns #-}

-- | This module introduces a simple particle system to Affection
module Affection.Particle
  ( updateParticle
  , drawParticles
  , updateParticleSystem
  , drawParticleSystem
  , insertParticle
  ) where

import Affection.Types

import Control.Monad
import Control.Monad.State (get)
import qualified Control.Monad.Parallel as MP

import Data.Maybe

import qualified GEGL as G

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
  :: Double
        -- ^ 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 =
  catMaybes <$> MP.mapM (\p -> do
    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
  where
    updateParticle' _  _   []     = return []
    updateParticle' dt fun [p]    = do
      now <- elapsedTime <$> get
      if particleCreation p + particleTimeToLive p < now
      then do
        dropParticle p
        return []
      else
        (: []) <$> func time p
    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
        (np :) <$> updateParticle' dt fun ps
    dropParticle p = do
      mproducer <- liftIO $ G.gegl_node_get_producer
        (particleStackCont p)
        "input"
      maybe (return ()) (\(producer, padname) -> do
        consumers <- liftIO $ G.gegl_node_get_consumers
          (particleStackCont p)
          "output"
        liftIO $ mapM_ (uncurry $ G.gegl_node_connect_to
          producer
          padname
          ) consumers
        ) mproducer
      liftIO $ G.gegl_node_drop $ particleRootNode p

-- | 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

drawParticles
  :: (Particle -> Affection us ())
  -> [Particle]
  -> Affection us ()
drawParticles = mapM_

updateParticleSystem
  :: ParticleSystem
  -> Double
  -> (Double -> Particle -> Affection us Particle)
  -> Affection us ParticleSystem
updateParticleSystem sys sec upd = do
  !x <- updateParticle sec upd (partStorList $ partSysParts sys)
  if not $ null x
    then do
      return sys
        { partSysParts = (partSysParts sys)
          { partStorList = x
          }
        }
    else do
      return sys
        { partSysParts = ParticleStorage
          { partStorList = []
          , partStorLatest = Nothing
          }
        }

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)
      MP.mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts
    else do
      _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input"
      return ()
  where
    parts = partStorList (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
  liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList)
  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 + particleTimeToLive np)
  then p : [np]
  else np : [p]
chronoInsert now l@(p:ps) np =
  if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np)
  then p : chronoInsert now ps np
  else np : l