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

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