affection/src/Affection/Particle.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}

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

import Affection.Types

import Control.Monad
import Control.Monad.State (get)

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 a single 'Particle'
    -- This Function should take the elapsed time
    -- in seconds and the initial particle as arguments.
  -- -> [Maybe Particle]
  -> Particle
    -- ^ 'Particle' to be processed
  -- -> Affection us [Maybe Particle]
  -> Affection us (Maybe Particle)
    -- ^ resulting 'Particle'
updateParticle time funct pa =
  do
    now <- elapsedTime <$> get
    if particleCreation pa + particleTimeToLive pa < now
    then do
      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 ()
      liftIO $ G.gegl_node_drop $ particleRootNode pa
      return $ Nothing
    else do
      np <- Just <$> funct time pa
      return $ np

-- | 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
  -> (Double -> Particle -> Affection us Particle)
  -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
  -> Affection us ParticleSystem
updateParticleSystem sys sec upd draw = do
  !x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
  -- liftIO $ traceIO $ show $ length x
  -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
  if (not $ null x)
    then do
      -- liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys)
      -- liftIO $ traceIO "linking last node to output"
      liftIO $ G.gegl_node_link (particleStackCont $ head x) (partSysNode sys)
      mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
      return sys
        { partSysParts = (partSysParts sys)
          { partStorList = x
          }
        }
    else do
      _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input"
      return sys
        { partSysParts = ParticleStorage
          { partStorList = []
          , partStorLatest = Nothing
          }
        }

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