{- |
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 :: forall s ctrl a b. Modifier s ctrl a b -> ctrl -> T a -> T b
modifyStatic = forall s ctrl a b. Modifier s ctrl a b -> ctrl -> T a -> T b
Modifier.static

{-| Here the control may vary over the time. -}
modifyModulated ::
   Modifier s ctrl a b -> T ctrl -> T a -> T b
modifyModulated :: forall s ctrl a b. Modifier s ctrl a b -> T ctrl -> T a -> T b
modifyModulated = forall s ctrl a b. Modifier s ctrl a b -> T ctrl -> T a -> T b
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 :: forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b
modifierInitialize = forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b
Modifier.initialize

modifyStaticInit ::
   ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b
modifyStaticInit :: forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b
modifyStaticInit = forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b
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 :: forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b
modifyModulatedInit = forall s init ctrl a b.
ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b
Modifier.modulatedInit



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

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

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

crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
crochetL :: forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
crochetL x -> acc -> Maybe (y, acc)
f acc
a = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x acc y.
(x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)
mapAccumL x -> acc -> Maybe (y, acc)
f acc
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 :: forall y. y -> (T y -> T y) -> T y
fix1 y
pad T y -> T y
f =
   let y :: T y
y = T y -> T y
f (y
padforall a. a -> [a] -> [a]
:T y
y)
   in  T y
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 :: forall a. Int -> Int -> T a -> (Int, T a)
dropMarginRem Int
n Int
m =
   forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. Int -> Int -> T a -> T a
dropMargin (Int
1forall a. Num a => a -> a -> a
+Int
n) Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. (a -> a) -> a -> [a]
iterate (forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred) Int
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. [a] -> [[a]]
ListHT.tails

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


{- |
Test whether a list has at least @n@ elements.
-}
lengthAtLeast :: Int -> T a -> Bool
lengthAtLeast :: forall a. Int -> T a -> Bool
lengthAtLeast Int
n T a
xs =
   Int
nforall a. Ord a => a -> a -> Bool
<=Int
0 Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> [a] -> [a]
drop (Int
nforall a. Num a => a -> a -> a
-Int
1) T a
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 :: forall y0 y1 y2. (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
zipWithTails y0 -> T y1 -> y2
f T y0
xs =
   forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith y0 -> T y1 -> y2
f T y0
xs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
ListHT.tails

zipWithRest ::
   (y0 -> y0 -> y1) ->
   T y0 -> T y0 ->
   (T y1, (Bool, T y0))
zipWithRest :: forall y0 y1.
(y0 -> y0 -> y1) -> T y0 -> T y0 -> (T y1, (Bool, T y0))
zipWithRest y0 -> y0 -> y1
f T y0
xs T y0
ys =
   let len :: T
len = forall a. Ord a => a -> a -> a
min (forall i a. Num i => [a] -> i
List.genericLength T y0
xs) (forall i a. Num i => [a] -> i
List.genericLength T y0
ys) :: Peano.T
       (T y0
prefixX,T y0
suffixX) = forall i a. Integral i => i -> [a] -> ([a], [a])
List.genericSplitAt T
len T y0
xs
       (T y0
prefixY,T y0
suffixY) = forall i a. Integral i => i -> [a] -> ([a], [a])
List.genericSplitAt T
len T y0
ys
       second :: Bool
second = forall (t :: * -> *) a. Foldable t => t a -> Bool
null T y0
suffixX
   in  (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith y0 -> y0 -> y1
f T y0
prefixX T y0
prefixY,
        (Bool
second, if Bool
second then T y0
suffixY else T y0
suffixX))

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

zipWithAppend ::
   (y -> y -> y) ->
   T y -> T y -> T y
zipWithAppend :: forall y. (y -> y -> y) -> T y -> T y -> T y
zipWithAppend y -> y -> y
f T y
xs T y
ys =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall y0 y1.
(y0 -> y0 -> y1) -> T y0 -> T y0 -> (T y1, (Bool, T y0))
zipWithRest y -> y -> y
f T y
xs T y
ys