{- |
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 = Simple s ctrl a b -> ctrl -> T a -> T b
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 = Simple s ctrl a b -> T ctrl -> T a -> T b
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 = Initialized s init ctrl a b -> init -> Simple s ctrl a b
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 = Initialized s init ctrl a b -> init -> ctrl -> T a -> T b
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 = Initialized s init ctrl a b -> init -> T ctrl -> T a -> T b
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 =
          (acc, [y]) -> (acc, [y])
forall a b. (a, b) -> (a, b)
forcePair ((acc, [y]) -> (acc, [y])) -> (acc, [y]) -> (acc, [y])
forall a b. (a -> b) -> a -> b
$
          (acc, [y])
-> ((y, acc) -> (acc, [y])) -> Maybe (y, acc) -> (acc, [y])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
             (acc
acc0,[])
             (\(y
y,acc
acc1) ->
                ([y] -> [y]) -> (acc, [y]) -> (acc, [y])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:) ((acc, [y]) -> (acc, [y])) -> (acc, [y]) -> (acc, [y])
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) ->
                acc -> (acc -> acc) -> Maybe acc -> acc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe acc
a
                   (\ acc
a' -> acc -> acc -> acc
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 =
          (acc, [y]) -> (acc, [y])
forall a b. (a, b) -> (a, b)
forcePair ((acc, [y]) -> (acc, [y])) -> (acc, [y]) -> (acc, [y])
forall a b. (a -> b) -> a -> b
$
          case [x]
xt of
             [] -> (acc
acc0,[])
             (x
x:[x]
xs) ->
                 (acc, [y])
-> ((y, acc) -> (acc, [y])) -> Maybe (y, acc) -> (acc, [y])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    (acc
acc0,[])
                    (\(y
y,acc
acc1) ->
                       ([y] -> [y]) -> (acc, [y]) -> (acc, [y])
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:) ((acc, [y]) -> (acc, [y])) -> (acc, [y]) -> (acc, [y])
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 = (acc, T y) -> T y
forall a b. (a, b) -> b
snd ((acc, T y) -> T y) -> (T x -> (acc, T y)) -> T x -> T y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)
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
pady -> T y -> T y
forall 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 =
   [(Int, T a)] -> (Int, T a)
forall a. HasCallStack => [a] -> a
head ([(Int, T a)] -> (Int, T a))
-> (T a -> [(Int, T a)]) -> T a -> (Int, T a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Int -> Int -> [(Int, T a)] -> [(Int, T a)]
forall a. Int -> Int -> T a -> T a
dropMargin (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) Int
m ([(Int, T a)] -> [(Int, T a)])
-> (T a -> [(Int, T a)]) -> T a -> [(Int, T a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   [Int] -> [T a] -> [(Int, T a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred) Int
m) ([T a] -> [(Int, T a)]) -> (T a -> [T a]) -> T a -> [(Int, T a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   T a -> [T a]
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 =
   T a -> T a -> T a
forall b a. [b] -> [a] -> [a]
ListMatch.drop (Int -> T a -> T a
forall a. Int -> [a] -> [a]
take Int
m (Int -> T a -> T a
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
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
0 Bool -> Bool -> Bool
|| Bool -> Bool
not (T a -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> T a -> T a
forall a. Int -> [a] -> [a]
drop (Int
nInt -> Int -> Int
forall 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 =
   (y0 -> T y1 -> y2) -> T y0 -> [T y1] -> [y2]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith y0 -> T y1 -> y2
f T y0
xs ([T y1] -> [y2]) -> (T y1 -> [T y1]) -> T y1 -> [y2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [T y1] -> [T y1]
forall a. HasCallStack => [a] -> [a]
init ([T y1] -> [T y1]) -> (T y1 -> [T y1]) -> T y1 -> [T y1]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T y1 -> [T y1]
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 = T -> T -> T
forall a. Ord a => a -> a -> a
min (T y0 -> T
forall i a. Num i => [a] -> i
List.genericLength T y0
xs) (T y0 -> T
forall i a. Num i => [a] -> i
List.genericLength T y0
ys) :: Peano.T
       (T y0
prefixX,T y0
suffixX) = T -> T y0 -> (T y0, T y0)
forall i a. Integral i => i -> [a] -> ([a], [a])
List.genericSplitAt T
len T y0
xs
       (T y0
prefixY,T y0
suffixY) = T -> T y0 -> (T y0, T y0)
forall i a. Integral i => i -> [a] -> ([a], [a])
List.genericSplitAt T
len T y0
ys
       second :: Bool
second = T y0 -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null T y0
suffixX
   in  ((y0 -> y0 -> y1) -> T y0 -> T y0 -> [y1]
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 =
          ([y1], (Bool, [y0])) -> ([y1], (Bool, [y0]))
forall a b. (a, b) -> (a, b)
forcePair (([y1], (Bool, [y0])) -> ([y1], (Bool, [y0])))
-> ([y1], (Bool, [y0])) -> ([y1], (Bool, [y0]))
forall a b. (a -> b) -> a -> b
$
          case ([y0]
xt,[y0]
yt) of
             (y0
x:[y0]
xs, y0
y:[y0]
ys) -> ([y1] -> [y1]) -> ([y1], (Bool, [y0])) -> ([y1], (Bool, [y0]))
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (y0 -> y0 -> y1
f y0
x y0
y y1 -> [y1] -> [y1]
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 =
   (T y -> T y -> T y) -> (T y, T y) -> T y
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry T y -> T y -> T y
forall a. [a] -> [a] -> [a]
(++) ((T y, T y) -> T y) -> (T y, T y) -> T y
forall a b. (a -> b) -> a -> b
$ ((Bool, T y) -> T y) -> (T y, (Bool, T y)) -> (T y, T y)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (Bool, T y) -> T y
forall a b. (a, b) -> b
snd ((T y, (Bool, T y)) -> (T y, T y))
-> (T y, (Bool, T y)) -> (T y, T y)
forall a b. (a -> b) -> a -> b
$ (y -> y -> y) -> T y -> T y -> (T y, (Bool, T y))
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