Signal.hs

{-# OPTIONS_GHC -fglasgow-exts #-}
{- glasgow-exts are for the rules -}
{- |
Copyright   :  (c) Henning Thielemann 2008
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       as List

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


type T a = [a]


{- * 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 n m .
   zipWithTails (,) (iterate pred m)

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