Cut.hs

{-# LANGUAGE NoImplicitPrelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2006
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.State.Cut (
   {- * dissection -}
   takeUntilPause,
   takeUntilInterval,

   {- * glueing -}
   selectBool,
   select,
   arrange,
   arrangeList,
   ) where

import qualified Synthesizer.State.Signal as Sig

import qualified Data.EventList.Relative.TimeBody as EventList

import qualified MathObj.LaurentPolynomial as Laurent
import qualified Algebra.Real     as Real
import qualified Algebra.Additive as Additive

import qualified Data.Array as Array
import Data.Array (Array, Ix, (!), elems, )
import Control.Applicative (Applicative, )
import Data.Traversable (sequenceA, )

import Data.Tuple.HT (mapSnd, )

import qualified Number.NonNegative as NonNeg

import PreludeBase
import NumericPrelude



{- |
Take signal until it falls short of a certain amplitude for a given time.
-}
{-# INLINE takeUntilPause #-}
takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a
takeUntilPause y =
   takeUntilInterval ((<=y) . abs)

{- |
Take values until the predicate p holds for n successive values.
The list is truncated at the beginning of the interval of matching values.
-}
{-# INLINE takeUntilInterval #-}
takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a
takeUntilInterval p n xs =
   Sig.map fst $
   Sig.takeWhile ((<n) . snd) $
   Sig.zip xs $
   Sig.drop n $
   Sig.append (Sig.scanL (\acc x -> if p x then succ acc else 0) 0 xs) $
   Sig.repeat 0



{-# INLINE selectBool #-}
selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a
selectBool =
   Sig.zipWith (\(xf,xt) c -> if c then xt else xf) .
   uncurry Sig.zip


{-# INLINE select #-}
select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a
select =
   Sig.crochetL
      (\xi arr ->
           do arr0 <- sequenceArray (fmap Sig.viewL arr)
              return (fst (arr0!xi), fmap snd arr0))

{-# INLINE sequenceArray #-}
sequenceArray ::
   (Applicative f, Ix i) =>
   Array i (f a) -> f (Array i a)
sequenceArray arr =
   fmap (Array.listArray (Array.bounds arr)) $
   sequenceA (Array.elems arr)


{- |
Given a list of signals with time stamps,
mix them into one signal as they occur in time.
Ideally for composing music.

Cf. 'MathObj.LaurentPolynomial.series'
-}
{-# INLINE arrangeList #-}
arrangeList :: (Additive.C v) =>
       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 evs =
   let xs = map Sig.toList (EventList.getBodies evs)
   in  case map NonNeg.toNumber (EventList.getTimes evs) of
          t:ts -> Sig.replicate t zero `Sig.append`
                  Sig.fromList (Laurent.addShiftedMany ts xs)
          []   -> Sig.empty




{-# INLINE arrange #-}
arrange :: (Additive.C v) =>
       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 evs =
   let xs = EventList.getBodies evs
   in  case map NonNeg.toNumber (EventList.getTimes evs) of
          t:ts -> Sig.replicate t zero `Sig.append`
                  addShiftedMany ts xs
          []   -> Sig.empty


{-# INLINE addShiftedMany #-}
addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a
addShiftedMany ds xss =
   foldr (uncurry addShifted) Sig.empty (zip (ds++[zero]) xss)



{-# INLINE addShifted #-}
addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted del xs ys =
   if del < 0
     then error "State.Signal.addShifted: negative shift"
     else
       Sig.unfoldR
          (\((d,ys0),xs0) ->
              -- d<0 cannot happen
              if d==zero
                then
                  fmap
                     (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))
                     (Sig.zipStep (+) (xs0, ys0))
                else
                  Just $ mapSnd ((,) (pred d, ys0)) $
                  Sig.switchL (zero, xs0) (,) xs0)
          ((del,ys),xs)