{-# LANGUAGE NoImplicitPrelude #-}
{- |
An implementation of a Delay using a classical circular buffer
running in the State Thread monad.
-}
module Synthesizer.Plain.Filter.Delay.ST (modulated) where

import qualified Synthesizer.Plain.Interpolation as Interpolation

import qualified Algebra.RealField as RealField
import qualified Algebra.Additive  as Additive

import Control.Monad.ST.Lazy(runST,strictToLazyST,ST)
import Data.Array.ST

import NumericPrelude.Numeric
import NumericPrelude.Base


{-
I had no success in hiding ST in the 'modulatedST' function.
The explicit type signature is crucial.
-}
modulatedAction :: (RealField.C a, Additive.C v) =>
   Interpolation.T a v -> Int -> [a] -> [v] -> ST s [v]
modulatedAction :: forall a v s. (C a, C v) => T a v -> Int -> [a] -> [v] -> ST s [v]
modulatedAction T a v
ip Int
size [a]
ts [v]
xs =
   let ipNum :: Int
ipNum  = forall t y. T t y -> Int
Interpolation.number T a v
ip
       ipFunc :: a -> [v] -> v
ipFunc = forall t y. T t y -> t -> T y -> y
Interpolation.func   T a v
ip
   in  do STArray s Int v
arr <- forall s a. ST s a -> ST s a
strictToLazyST (forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
2forall a. C a => a -> a -> a
*Int
sizeforall a. C a => a -> a -> a
-Int
1) forall a. C a => a
zero)
                    :: Additive.C v => ST s (STArray s Int v)
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Int
n,a
t,v
x) -> forall s a. ST s a -> ST s a
strictToLazyST forall a b. (a -> b) -> a -> b
$
                  do forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int v
arr Int
n v
x
                     forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int v
arr (Int
nforall a. C a => a -> a -> a
+Int
size) v
x
                     let (Int
ti,a
tf) = forall a b. (C a, C b) => a -> (b, a)
splitFraction a
t
                     [v]
y <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int v
arr) (forall a. Int -> [a] -> [a]
take Int
ipNum [(Int
nforall a. C a => a -> a -> a
+Int
ti) ..])
                     forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
tiforall a. Ord a => a -> a -> Bool
<Int
0
                               then forall a. HasCallStack => [Char] -> a
error [Char]
"negative delay"
                               else
                                 if Int
size forall a. Ord a => a -> a -> Bool
< Int
tiforall a. C a => a -> a -> a
+Int
ipNum
                                   then forall a. HasCallStack => [Char] -> a
error [Char]
"too much delay"
                                   else a -> [v] -> v
ipFunc a
tf [v]
y))
               (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall a. [a] -> [a]
cycle [(Int
sizeforall a. C a => a -> a -> a
-Int
1),(Int
sizeforall a. C a => a -> a -> a
-Int
2)..Int
0]) [a]
ts [v]
xs)

modulated :: (RealField.C a, Additive.C v) =>
   Interpolation.T a v -> Int -> [a] -> [v] -> [v]
modulated :: forall a v. (C a, C v) => T a v -> Int -> [a] -> [v] -> [v]
modulated T a v
ip Int
maxDelay [a]
ts [v]
xs =
   let offset :: Int
offset = forall t y. T t y -> Int
Interpolation.offset T a v
ip
   in  forall a. Int -> [a] -> [a]
drop Int
offset
          (forall a. (forall s. ST s a) -> a
runST
             (forall a v s. (C a, C v) => T a v -> Int -> [a] -> [v] -> ST s [v]
modulatedAction
                T a v
ip (Int
maxDelay forall a. C a => a -> a -> a
+ forall t y. T t y -> Int
Interpolation.number T a v
ip)
                (forall a. Int -> a -> [a]
replicate Int
offset forall a. C a => a
zero forall a. [a] -> [a] -> [a]
++ [a]
ts) [v]
xs))