Cut.hs

module Synthesizer.Storable.Cut where

import qualified Synthesizer.Storable.Signal as Sig

import qualified Data.StorableVector.Lazy      as SVL
import qualified Data.StorableVector.ST.Strict as SVST

import Control.Monad.ST.Strict (ST, runST, )

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody  as AbsEventList
import Control.Monad.Trans.State (runState, modify, gets, put, )
-- import Control.Monad (mapM, )
import Data.Tuple.HT (mapSnd, )

-- import qualified Algebra.Real     as Real
import qualified Algebra.Additive as Additive
import qualified Number.NonNegative as NonNeg

import Foreign.Storable (Storable)

import PreludeBase
import NumericPrelude


{-# INLINE arrange #-}
arrange :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrange =
   arrangeEquidist

{- |
Chunk sizes are adapted to the time differences.
Explicit ChunkSize parameter is only required for zero padding.
Since no ST monad is needed, this can be generalized to Generic.Signal.Transform class.
-}
arrangeAdaptive :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeAdaptive size =
   uncurry Sig.append .
   flip runState Sig.empty .
   fmap (Sig.concat . EventList.getTimes) .
   EventList.mapM
      (\timeNN ->
           let time = NonNeg.toNumber timeNN
           in  do (prefix,suffix) <- gets (Sig.splitAtPad size time)
                  put suffix
                  return prefix)
      (\body ->
           modify (Sig.mix body))


arrangeList :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeList size evs =
   let xs = EventList.getBodies evs
   in  case EventList.getTimes evs of
          t:ts -> Sig.replicate size (NonNeg.toNumber t) zero `Sig.append`
                  addShiftedMany size ts xs
          []   -> Sig.empty


addShiftedMany :: (Storable a, Additive.C a) =>
   Sig.ChunkSize -> [NonNeg.Int] -> [Sig.T a] -> Sig.T a
addShiftedMany size ds xss =
   foldr (uncurry (addShifted size)) Sig.empty (zip (ds++[0]) xss)


{-
It is crucial that 'mix' uses the chunk size structure of the second operand.
This way we avoid unnecessary and even infinite look-ahead.
-}
addShifted :: (Storable a, Additive.C a) =>
   Sig.ChunkSize -> NonNeg.Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted size delNN px py =
   let del = NonNeg.toNumber delNN
   in  uncurry Sig.append $
       mapSnd (flip Sig.mix py) $
       Sig.splitAtPad size del px


{- |
The result is a Lazy StorableVector with chunks of the given size.
The output is always infinite.
If the input is a finite list of finite length sounds,
then the output is padded with zeros.
Even if we try to terminate the output after the last sound,
we would not finish immediately but only at chunk boundaries.
-}
{-# INLINE arrangeEquidist #-}
arrangeEquidist :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeEquidist (SVL.ChunkSize sz) =
   let sznn = NonNeg.fromNumberMsg "arrangeEquidist" sz
       go acc evs =
          let (now,future) = EventListTM.splitAtTime sznn evs
              xs =
                 AbsEventList.toPairList $
                 EventList.toAbsoluteEventList 0 $
                 EventListTM.switchTimeR const now
              (chunk,newAcc) =
                 runST
                    (do v <- SVST.new sz zero
                        newAcc0 <- mapM (addToBuffer v 0) acc
--                        newAcc1 <- AbsEventList.mapM (addToBuffer v) xs
                        newAcc1 <-
                           mapM (\(i,s) -> addToBuffer v (NonNeg.toNumber i) s) xs
                        vf <- SVST.freeze v
                        return
                           (vf, filter (not . Sig.null) (newAcc0++newAcc1)))
          in  chunk : go newAcc future
   in  Sig.fromChunks . go []



addToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)
addToBuffer v start xs =
   let n = SVST.length v
       (now,future) = Sig.splitAt (n Additive.- start) xs
   in  Sig.foldr
          (\x continue i ->
             SVST.modify v i (x Additive.+) >>
             continue (succ i))
          (const $ return ()) now start
        >> return future


{-
Using @Sig.switchL@ in an inner loop
is slower than using @Sig.foldr@.
-}
addToBufferSwitchL :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)
addToBufferSwitchL v start =
   let n = SVST.length v
       {-# INLINE go #-}
       go i =
          if i>=n
            then return
            else
              Sig.switchL
                 (return Sig.empty)
                 (\x xs ->
                     SVST.modify v i (x Additive.+) >>
                     go (succ i) xs)
   in  go start