Signal.hs

{- |
Copyright   :  (c) Henning Thielemann 2008-2011
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  portable
-}
module Synthesizer.Plain.Signal where

import qualified Number.Peano as Peano

import qualified Synthesizer.Plain.Modifier as Modifier

import qualified Data.List.Match as ListMatch
import qualified Data.List.HT    as ListHT
import qualified Data.List       as List

import Data.Tuple.HT (forcePair, mapFst, mapSnd, )


type T = []


{- * Generic routines that are useful for filters -}

type Modifier s ctrl a b = Modifier.Simple s ctrl a b

{-|
modif is a process controlled by values of type c
with an internal state of type s,
it converts an input value of type a into an output value of type b
while turning into a new state

ToDo:
Shall finite signals be padded with zeros?
-}
modifyStatic ::
   Modifier s ctrl a b -> ctrl -> T a -> T b
modifyStatic = Modifier.static

{-| Here the control may vary over the time. -}
modifyModulated ::
   Modifier s ctrl a b -> T ctrl -> T a -> T b
modifyModulated = Modifier.modulated


type ModifierInit s init ctrl a b = Modifier.Initialized s init ctrl a b


modifierInitialize ::
   ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b
modifierInitialize = Modifier.initialize

modifyStaticInit ::
   ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b
modifyStaticInit = Modifier.staticInit

{-| Here the control may vary over the time. -}
modifyModulatedInit ::
   ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b
modifyModulatedInit = Modifier.modulatedInit



unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y)
unfoldR f =
   let recourse acc0 =
          forcePair $
          maybe
             (acc0,[])
             (\(y,acc1) ->
                mapSnd (y:) $ recourse acc1)
             (f acc0)
   in  recourse

reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc
reduceL f =
   let recourse a xt =
          case xt of
             [] -> a
             (x:xs) ->
                maybe a
                   (\ a' -> seq a' (recourse a' xs))
                   (f x a)
   in  recourse

mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)
mapAccumL f =
   let recourse acc0 xt =
          forcePair $
          case xt of
             [] -> (acc0,[])
             (x:xs) ->
                 maybe
                    (acc0,[])
                    (\(y,acc1) ->
                       mapSnd (y:) $ recourse acc1 xs)
                    (f x acc0)
   in  recourse

crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
crochetL f a = snd . mapAccumL f a


{- |
Feed back signal into signal processor,
and apply a delay by one value.
'fix1' is a kind of 'Signal.generate'.
-}
fix1 :: y -> (T y -> T y) -> T y
fix1 pad f =
   let y = f (pad:y)
   in  y

{-# RULES
  "fix1/crochetL" forall f a b.
     fix1 a (crochetL f b) =
        snd $ unfoldR (\(a0,b0) ->
            do yb1@(y0,_) <- f a0 b0
               return (y0, yb1)) (a,b) ;
  #-}



{-
instance SigG.Data [] y where

instance SigG.C [] where
   add = (Additive.+)
   map = List.map
   zipWith = List.zipWith
-}


{- |
@dropMarginRem n m xs@
drops at most the first @m@ elements of @xs@
and ensures that @xs@ still contains @n@ elements.
Additionally returns the number of elements that could not be dropped
due to the margin constraint.
That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@.
Requires @length xs >= n@.
-}
dropMarginRem :: Int -> Int -> T a -> (Int, T a)
dropMarginRem n m =
   head .
   dropMargin (1+n) m .
   zip (iterate (max 0 . pred) m) .
   ListHT.tails

dropMargin :: Int -> Int -> T a -> T a
dropMargin n m xs =
   ListMatch.drop (take m (drop n xs)) xs


{- |
Test whether a list has at least @n@ elements.
-}
lengthAtLeast :: Int -> T a -> Bool
lengthAtLeast n xs =
   n<=0 || not (null (drop (n-1) xs))


{- |
Can be implemented more efficiently
than just by 'zipWith' and 'List.tails'
for other data structures.
-}
zipWithTails ::
   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
zipWithTails f xs =
   zipWith f xs . init . ListHT.tails

zipWithRest ::
   (y0 -> y0 -> y1) ->
   T y0 -> T y0 ->
   (T y1, (Bool, T y0))
zipWithRest f xs ys =
   let len = min (List.genericLength xs) (List.genericLength ys) :: Peano.T
       (prefixX,suffixX) = List.genericSplitAt len xs
       (prefixY,suffixY) = List.genericSplitAt len ys
       second = null suffixX
   in  (zipWith f prefixX prefixY,
        (second, if second then suffixY else suffixX))

zipWithRest' ::
   (y0 -> y0 -> y1) ->
   T y0 -> T y0 ->
   (T y1, (Bool, T y0))
zipWithRest' f =
   let recourse xt yt =
          forcePair $
          case (xt,yt) of
             (x:xs, y:ys) ->
                mapFst (f x y :) (recourse xs ys)
             ([], _) -> ([], (True,  yt))
             (_, []) -> ([], (False, xt))
   in  recourse
{-
Test.QuickCheck.test (\xs ys -> zipWithRest (,) xs ys == zipWithRest' (,) xs (ys::[Int]))
-}

zipWithAppend ::
   (y -> y -> y) ->
   T y -> T y -> T y
zipWithAppend f xs ys =
   uncurry (++) $ mapSnd snd $ zipWithRest f xs ys