{-# LANGUAGE NoImplicitPrelude #-}
{- |
Fast delay based on block lists.
Blocks are arrays. They are part of Haskell 98.
In contrast to ring buffers,
block lists allow infinite look ahead.
-}
module Synthesizer.Plain.Filter.Delay.Block (
   modulated,

   -- for testing
   propDrop,
   ) where

import qualified Synthesizer.Plain.Interpolation as Interpolation
import qualified Synthesizer.Plain.Signal as Sig

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

import Data.Array((!), Array, listArray, elems, bounds, indices, rangeSize)
import Data.List(tails)

import Test.QuickCheck ((==>), Property)

import NumericPrelude.Numeric
import NumericPrelude.Base


modulatedCore :: (RealField.C a, Additive.C v) =>
   Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v
modulatedCore :: forall a v. (C a, C v) => T a v -> Int -> T a -> T v -> T v
modulatedCore T a v
ip Int
size T a
ts =
   forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
      (\a
t (Int
offset,BlockList v
bs) ->
          let (Int
ti,a
tf) = forall a b. (C a, C b) => a -> (b, a)
splitFraction (-a
t)
          in  forall t y. T t y -> t -> T y -> y
Interpolation.func T a v
ip a
tf (forall a. Int -> BlockList a -> T a
dropBlocksToList (Int
sizeforall a. C a => a -> a -> a
+Int
offsetforall a. C a => a -> a -> a
+Int
ti) BlockList v
bs))
      T a
ts forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. BlockList a -> [(Int, BlockList a)]
suffixIndexes forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   {- Using 'size' for the block size is a heuristics,
      maybe it is not a good choice in many cases. -}
   forall a. Int -> T a -> BlockList a
listToBlocks Int
size

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


type BlockList a = [Array Int a]


listToBlocks :: Int -> Sig.T a -> BlockList a
listToBlocks :: forall a. Int -> T a -> BlockList a
listToBlocks Int
blockSize =
   forall a b. (a -> b) -> [a] -> [b]
map (forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
blockSizeforall a. C a => a -> a -> a
-Int
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. (a -> a) -> a -> [a]
iterate (forall a. Int -> [a] -> [a]
drop Int
blockSize)


dropBlocksToList :: Int -> BlockList a -> Sig.T a
dropBlocksToList :: forall a. Int -> BlockList a -> T a
dropBlocksToList Int
number BlockList a
blocks =
   let dropUntil :: Int -> [Array Int e] -> (Int, Array Int e, [Array Int e])
dropUntil Int
remain (Array Int e
b:[Array Int e]
bs) =
          if Int
remain forall a. Ord a => a -> a -> Bool
<= forall a b. (a, b) -> b
snd (forall i e. Array i e -> (i, i)
bounds Array Int e
b)
            then (Int
remain, Array Int e
b, [Array Int e]
bs)
            else Int -> [Array Int e] -> (Int, Array Int e, [Array Int e])
dropUntil (Int
remain forall a. C a => a -> a -> a
- forall a. Ix a => (a, a) -> Int
rangeSize (forall i e. Array i e -> (i, i)
bounds Array Int e
b)) [Array Int e]
bs
       dropUntil Int
remain [] = (Int
remain, forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,-Int
1) [], [])
       (Int
offset, Array Int a
lead, BlockList a
suffix) = forall {e}.
Int -> [Array Int e] -> (Int, Array Int e, [Array Int e])
dropUntil Int
number BlockList a
blocks
   in  forall a b. (a -> b) -> [a] -> [b]
map (Array Int a
leadforall i e. Ix i => Array i e -> i -> e
!) [Int
offset .. (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> (i, i)
bounds Array Int a
lead)] forall a. [a] -> [a] -> [a]
++
       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall i e. Array i e -> [e]
elems BlockList a
suffix

propDrop :: Int -> Int -> [Int] -> Property
propDrop :: Int -> Int -> [Int] -> Property
propDrop Int
size Int
n [Int]
xs =
   let infXs :: [Int]
infXs = forall a. [a] -> [a]
cycle [Int]
xs
       len :: Int
len = Int
1000
   in  Int
sizeforall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& 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 [Int]
xs) forall prop. Testable prop => Bool -> prop -> Property
==>
          forall a. Int -> [a] -> [a]
take Int
len (forall a. Int -> [a] -> [a]
drop Int
n [Int]
infXs)  forall a. Eq a => a -> a -> Bool
==
          forall a. Int -> [a] -> [a]
take Int
len (forall a. Int -> BlockList a -> T a
dropBlocksToList Int
n (forall a. Int -> T a -> BlockList a
listToBlocks Int
size [Int]
infXs))

{- |
Drop elements from a blocked list.
The offset must lie in the leading block.
-}
_dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a
_dropSingleBlocksToList :: forall a. Int -> BlockList a -> T a
_dropSingleBlocksToList Int
number (Array Int a
arr:[Array Int a]
arrs) =
   forall a b. (a -> b) -> [a] -> [b]
map (Array Int a
arrforall i e. Ix i => Array i e -> i -> e
!) [Int
number .. (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> (i, i)
bounds Array Int a
arr)] forall a. [a] -> [a] -> [a]
++
   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall i e. Array i e -> [e]
elems [Array Int a]
arrs
_dropSingleBlocksToList Int
_ [] = []


suffixIndexes :: BlockList a -> [(Int, BlockList a)]
suffixIndexes :: forall a. BlockList a -> [(Int, BlockList a)]
suffixIndexes BlockList a
xs =
   do BlockList a
blockSuffix <- forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
tails BlockList a
xs
      Int
i <- forall i e. Ix i => Array i e -> [i]
indices forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head BlockList a
blockSuffix
      forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i,BlockList a
blockSuffix)