content: {-# LANGUAGE Arrows #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TupleSections #-}
  
  module LiveCoding.Cell.Util where
  
  -- base
  import Control.Arrow
  import Control.Monad (guard, join)
  import Control.Monad.IO.Class
  import Data.Data (Data)
  import Data.Foldable (toList)
  import Data.Functor (void)
  import Data.Maybe
  
  -- containers
  import Data.Sequence hiding (take)
  import qualified Data.Sequence as Sequence
  
  -- time
  import Data.Time.Clock
  
  -- essence-of-live-coding
  import LiveCoding.Cell
  import LiveCoding.Cell.Feedback
  import LiveCoding.Cell.Resample (resampleMaybe)
  import LiveCoding.Cell.Util.Internal
  
  -- * State accumulation
  
  -- | Sum all past inputs, starting by the given number
  sumFrom :: (Monad m) => Integer -> Cell m Integer Integer
  sumFrom n0 = feedback n0 $ proc (n, acc) -> returnA -< (acc, acc + n)
  
  -- | Count the number of ticks, starting at 0
  count :: (Monad m) => Cell m a Integer
  count = arr (const 1) >>> sumC
  
  {- | Accumulate all incoming data,
     using the given fold function and start value.
     For example, if @'foldC' f b@ receives inputs @a0@, @a1@,...
     it will output @b@, @f a0 b@, @f a1 $ f a0 b@, and so on.
  -}
  foldC :: (Data b, Monad m) => (a -> b -> b) -> b -> Cell m a b
  foldC step cellState = Cell {..}
    where
      cellStep b a = let b' = step a b in return (b, b')
  
  -- | Like 'foldC', but does not delay the output.
  foldC' :: (Data b, Monad m) => (a -> b -> b) -> b -> Cell m a b
  foldC' step cellState = Cell {..}
    where
      cellStep b a = let b' = step a b in return (b', b')
  
  {- | Initialise with a value 'a'.
     If the input is 'Nothing', @'hold' a@ will output the stored indefinitely.
     A new value can be stored by inputting @'Just' a@.
  -}
  hold :: (Data a, Monad m) => a -> Cell m (Maybe a) a
  hold a = feedback a $ proc (ma, aOld) -> do
    let aNew = fromMaybe aOld ma
    returnA -< (aNew, aNew)
  
  {- | Outputs @'Just' a@ whenever the the value a changes and 'Nothing' otherwise.
    The first output is always 'Nothing'. The following holds:
  
    @
      delay a >>> changes >>> hold a == delay a
    @
  -}
  changes ::
    (Data a, Eq a, Monad m) =>
    Cell m a (Maybe a)
  changes = proc a -> do
    aLast <- delay Nothing -< Just a
    returnA
      -< do
        aLast' <- aLast
        guard $ a /= aLast'
        return a
  
  -- | Like 'hold', but returns 'Nothing' until it is initialised by a @'Just' a@ value.
  holdJust ::
    (Monad m, Data a) =>
    Cell m (Maybe a) (Maybe a)
  holdJust = feedback Nothing $ arr keep
    where
      keep (Nothing, Nothing) = (Nothing, Nothing)
      keep (_, Just a) = (Just a, Just a)
      keep (Just a, Nothing) = (Just a, Just a)
  
  -- | Hold the first value and output it indefinitely.
  holdFirst :: (Data a, Monad m) => Cell m a a
  holdFirst = Cell {..}
    where
      cellState = Nothing
      cellStep Nothing x = return (x, Just x)
      cellStep (Just s) _ = return (s, Just s)
  
  -- | @boundedFIFO n@ keeps the first @n@ present values.
  boundedFIFO :: (Data a, Monad m) => Int -> Cell m (Maybe a) (Seq a)
  boundedFIFO n = foldC' step empty
    where
      step Nothing as = as
      step (Just a) as = Sequence.take n $ a <| as
  
  {- | Buffers and returns the elements in First-In-First-Out order,
     returning 'Nothing' whenever the buffer is empty.
  -}
  fifo :: (Monad m, Data a) => Cell m (Seq a) (Maybe a)
  fifo = feedback empty $ proc (as, accum) -> do
    let accum' = accum >< as
    returnA
      -< case accum' of
        Empty -> (Nothing, empty)
        a :<| as -> (Just a, as)
  
  {- | Like 'fifo', but accepts lists as input.
     Each step is O(n) in the length of the list.
  -}
  fifoList :: (Monad m, Data a) => Cell m [a] (Maybe a)
  fifoList = arr fromList >>> fifo
  
  -- | Like 'fifoList', but generalised to any 'Foldable'.
  fifoFoldable :: (Monad m, Data a, Foldable f) => Cell m (f a) (Maybe a)
  fifoFoldable = arr toList >>> fifoList
  
  -- | Returns 'True' iff the current input value is 'True' and the last input value was 'False'.
  edge :: (Monad m) => Cell m Bool Bool
  edge = proc b -> do
    bLast <- delay False -< b
    returnA -< b && not bLast
  
  -- * Debugging utilities
  
  -- | Print the current UTC time, prepended with the first 8 characters of the given message.
  printTime :: (MonadIO m) => String -> m ()
  printTime msg = liftIO $ putStrLn . (take 8 msg ++) . show =<< getCurrentTime
  
  -- | Like 'printTime', but as a cell.
  printTimeC :: (MonadIO m) => String -> Cell m () ()
  printTimeC msg = constM $ printTime msg
  
  -- * Buffers
  
  -- | A command to send to 'buffer'.
  data BufferCommand a
    = -- | Add an 'a' to the buffer.
      Push a
    | -- | Remove the oldest element from the buffer.
      Pop
  
  -- | Pushes @'Just' a@ and does nothing on 'Nothing'.
  maybePush :: Maybe a -> [BufferCommand a]
  maybePush = (Push <$>) . maybeToList
  
  -- | Pops on @'Just' a@ and does nothing on 'Nothing'.
  maybePop :: Maybe a -> [BufferCommand b]
  maybePop = (const Pop <$>) . maybeToList
  
  {- | Single-consumer, multi-producer buffer.
  
  The output value is the oldest value in the buffer,
  if it exists.
  
  * Add elements by inputting @'Push' a@.
  * Remove elements by inputting 'Pop'.
  -}
  buffer :: (Monad m, Data a) => Cell m [BufferCommand a] (Maybe a)
  buffer = Cell {..}
    where
      cellState = empty
      cellStep as commands = return (currentHead as, nextBuffer as commands)
      currentHead as = case viewl as of
        EmptyL -> Nothing
        a :< as' -> Just a
      nextBuffer as [] = as
      nextBuffer as (Push a : commands) = nextBuffer (as |> a) commands
      nextBuffer as (Pop : commands) = nextBuffer (Sequence.drop 1 as) commands
  
  {- | Equip a 'Cell' with a 'buffer'.
  
  * Whenever @'Just' a@ value enters @buffered cell@,
    it is added to the buffer.
  * Whenever @cell@ emits @'Just' b@,
    the oldest value is dropped from the buffer.
  * @cell@ is always fed with 'Just' the oldest value from the buffer,
    except when the buffer is empty, then it is fed 'Nothing'.
  
  This construction guarantees that @cell@ produces exactly one output for every input value.
  -}
  buffered ::
    (Monad m, Data a) =>
    Cell m (Maybe a) (Maybe b) ->
    Cell m (Maybe a) (Maybe b)
  buffered cell = feedback Nothing $ proc (aMaybe, ticked) -> do
    aMaybe' <- buffer -< maybePop ticked ++ maybePush aMaybe
    bMaybe' <- cell -< aMaybe'
    returnA -< (bMaybe', void bMaybe')
  
  -- * Detecting change
  
  {- | Perform an action whenever the parameter @p@ changes, and the code is reloaded.
  
  Note that this does not trigger any actions when adding, or removing an 'onChange' cell.
  For this functionality, see "LiveCoding.Handle".
  Also, when moving such a cell, the action may not be triggered reliably.
  -}
  onChange ::
    (Monad m, Data p, Eq p) =>
    -- | This parameter has to change during live coding to trigger an action
    p ->
    -- | This action gets passed the old parameter and the new parameter
    (p -> p -> a -> m b) ->
    Cell m a (Maybe b)
  onChange p action = proc a -> do
    pCurrent <- arr $ const p -< ()
    pPrevious <- delay p -< pCurrent
    arrM $ whenDifferent action -< (pCurrent, pPrevious, a)
  
  -- | Like 'onChange'', but with a dynamic input.
  onChange' ::
    (Monad m, Data p, Eq p) =>
    -- | This action gets passed the old parameter and the new parameter
    (p -> p -> a -> m b) ->
    Cell m (p, a) (Maybe b)
  onChange' action = proc (pCurrent, a) -> do
    pPrevious <- delay Nothing -< Just pCurrent
    bMaybeMaybe <- resampleMaybe $ arrM $ whenDifferent action -< (,pCurrent,a) <$> pPrevious
    returnA -< join bMaybeMaybe
  