{-# 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  = T a v -> Int
forall t y. T t y -> Int
Interpolation.number T a v
ip
       ipFunc :: a -> [v] -> v
ipFunc = T a v -> a -> [v] -> v
forall t y. T t y -> t -> T y -> y
Interpolation.func   T a v
ip
   in  do STArray s Int v
arr <- ST s (STArray s Int v) -> ST s (STArray s Int v)
forall s a. ST s a -> ST s a
strictToLazyST ((Int, Int) -> v -> ST s (STArray s Int v)
forall i. Ix i => (i, i) -> v -> ST s (STArray s i v)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0,Int
2Int -> Int -> Int
forall a. C a => a -> a -> a
*Int
sizeInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1) v
forall a. C a => a
zero)
                    :: Additive.C v => ST s (STArray s Int v)
          ((Int, a, v) -> ST s v) -> [(Int, a, v)] -> ST s [v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Int
n,a
t,v
x) -> ST s v -> ST s v
forall s a. ST s a -> ST s a
strictToLazyST (ST s v -> ST s v) -> ST s v -> ST s v
forall a b. (a -> b) -> a -> b
$
                  do STArray s Int v -> Int -> v -> ST s ()
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
                     STArray s Int v -> Int -> v -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int v
arr (Int
nInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
size) v
x
                     let (Int
ti,a
tf) = a -> (Int, a)
forall b. C b => a -> (b, a)
forall a b. (C a, C b) => a -> (b, a)
splitFraction a
t
                     [v]
y <- (Int -> ST s v) -> [Int] -> ST s [v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (STArray s Int v -> Int -> ST s v
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Int v
arr) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
ipNum [(Int
nInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
ti) ..])
                     v -> ST s v
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
tiInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0
                               then [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"negative delay"
                               else
                                 if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tiInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
ipNum
                                   then [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"too much delay"
                                   else a -> [v] -> v
ipFunc a
tf [v]
y))
               ([Int] -> [a] -> [v] -> [(Int, a, v)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [(Int
sizeInt -> Int -> Int
forall a. C a => a -> a -> a
-Int
1),(Int
sizeInt -> Int -> Int
forall 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 = T a v -> Int
forall t y. T t y -> Int
Interpolation.offset T a v
ip
   in  Int -> [v] -> [v]
forall a. Int -> [a] -> [a]
drop Int
offset
          ((forall s. ST s [v]) -> [v]
forall a. (forall s. ST s a) -> a
runST
             (T a v -> Int -> [a] -> [v] -> ST s [v]
forall a v s. (C a, C v) => T a v -> Int -> [a] -> [v] -> ST s [v]
modulatedAction
                T a v
ip (Int
maxDelay Int -> Int -> Int
forall a. C a => a -> a -> a
+ T a v -> Int
forall t y. T t y -> Int
Interpolation.number T a v
ip)
                (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
offset a
forall a. C a => a
zero [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ts) [v]
xs))