{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{- |
Copyright   :  (c) Henning Thielemann 2008
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes

Comb filters, useful for emphasis of tones with harmonics
and for repeated echos.
-}
module Synthesizer.Generic.Filter.Recursive.Comb (
   karplusStrong,
   run,
   runMulti,
   runProc,
   ) where

import qualified Synthesizer.Generic.Filter.NonRecursive as Filt
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1

import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Cut as CutG

import qualified Algebra.Module                as Module
import qualified Algebra.Ring                  as Ring
import qualified Algebra.Additive              as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base


{- |
The most simple version of the Karplus-Strong algorithm
which is suitable to simulate a plucked string.
It is similar to the 'runProc' function.
-}
{-# INLINE karplusStrong #-}
karplusStrong ::
   (Ring.C t, Module.C t y, SigG.Write sig y) =>
   Filt1.Parameter t -> sig y -> sig y
karplusStrong :: forall t y (sig :: * -> *).
(C t, C t y, Write sig y) =>
Parameter t -> sig y -> sig y
karplusStrong Parameter t
c sig y
wave =
   (sig y -> sig y) -> sig y -> sig y
forall (sig :: * -> *) y.
Transform sig y =>
(sig y -> sig y) -> sig y -> sig y
SigG.delayLoop (Simple y (Parameter t) y y -> Parameter t -> sig y -> sig y
forall (sig :: * -> *) a s ctrl.
Transform sig a =>
Simple s ctrl a a -> ctrl -> sig a -> sig a
SigG.modifyStatic Simple y (Parameter t) y y
forall a v. (C a, C a v) => Simple v (Parameter a) v v
Filt1.lowpassModifier Parameter t
c) sig y
wave


{- |
Infinitely many equi-delayed exponentially decaying echos.
The echos are clipped to the input length.
We think it is easier (and simpler to do efficiently)
to pad the input with zeros or whatever
instead of cutting the result according to the input length.
-}
{-# INLINE run #-}
run :: (Module.C t y, SigG.Write sig y) =>
   Int -> t -> sig y -> sig y
run :: forall t y (sig :: * -> *).
(C t y, Write sig y) =>
Int -> t -> sig y -> sig y
run Int
time t
gain =
   Int -> (sig y -> sig y) -> sig y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> (sig y -> sig y) -> sig y -> sig y
runProc Int
time (t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector t
gain)

{- |
Echos of different delays.
Chunk size must be smaller than all of the delay times.
-}
{-# INLINE runMulti #-}
runMulti :: (Module.C t y, SigG.Write sig y) =>
   [Int] -> t -> sig y -> sig y
runMulti :: forall t y (sig :: * -> *).
(C t y, Write sig y) =>
[Int] -> t -> sig y -> sig y
runMulti [Int]
times t
gain sig y
x =
    let y :: sig y
y = (sig y -> sig y -> sig y) -> sig y -> [sig y] -> sig y
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
               ((y -> y -> y) -> sig y -> sig y -> sig y
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.zipWith y -> y -> y
forall a. C a => a -> a -> a
(+)) sig y
x
               ((Int -> sig y) -> [Int] -> [sig y]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> sig y -> sig y) -> sig y -> Int -> sig y
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> sig y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> sig y -> sig y
Filt.delay (t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector t
gain sig y
y)) [Int]
times)
--               (map (flip Delay.staticPos (gain *> y)) times)
    in  sig y
y

{- | Echos can be piped through an arbitrary signal processor. -}
{-# INLINE runProc #-}
runProc :: (Additive.C y, SigG.Write sig y) =>
   Int -> (sig y -> sig y) -> sig y -> sig y
runProc :: forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> (sig y -> sig y) -> sig y -> sig y
runProc = Int -> (sig y -> sig y) -> sig y -> sig y
forall y (sig :: * -> *).
(C y, Write sig y) =>
Int -> (sig y -> sig y) -> sig y -> sig y
SigG.delayLoopOverlap


{- |
Alternative to 'run' that uses 'CutG.splitAt' at the beginning
instead of adding a zero signal.
-}
_run :: (Module.C t y, SigG.Transform sig y) => t -> Int -> sig y -> sig y
_run :: forall t y (sig :: * -> *).
(C t y, Transform sig y) =>
t -> Int -> sig y -> sig y
_run t
gain Int
delay sig y
xs =
   let (sig y
xs0,sig y
xs1) = Int -> sig y -> (sig y, sig y)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
delay (sig y -> (sig y, sig y)) -> sig y -> (sig y, sig y)
forall a b. (a -> b) -> a -> b
$ t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector (t
1t -> t -> t
forall a. C a => a -> a -> a
-t
gain) sig y
xs
       ys :: sig y
ys = sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
CutG.append sig y
xs0 (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ (y -> y -> y) -> sig y -> sig y -> sig y
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.zipWith y -> y -> y
forall a. C a => a -> a -> a
(+) sig y
xs1 (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector t
gain sig y
ys
   in  sig y
ys

_runInf :: (Module.C t y, SigG.Write sig y) => t -> Int -> sig y -> sig y
_runInf :: forall t y (sig :: * -> *).
(C t y, Write sig y) =>
t -> Int -> sig y -> sig y
_runInf t
gain Int
delay sig y
xs =
   let (sig y
xs0,sig y
xs1) =
          Int -> sig y -> (sig y, sig y)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
delay (sig y -> (sig y, sig y)) -> sig y -> (sig y, sig y)
forall a b. (a -> b) -> a -> b
$
          t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector (t
1t -> t -> t
forall a. C a => a -> a -> a
-t
gain) sig y
xs sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
`CutG.append`
             LazySize -> y -> sig y
forall y. Storage (sig y) => LazySize -> y -> sig y
forall (sig :: * -> *) y.
(Write0 sig, Storage (sig y)) =>
LazySize -> y -> sig y
SigG.repeat (Int -> LazySize
SigG.LazySize Int
delay) y
forall a. C a => a
zero
       ys :: sig y
ys = sig y -> sig y -> sig y
forall sig. Monoid sig => sig -> sig -> sig
CutG.append sig y
xs0 (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ (y -> y -> y) -> sig y -> sig y -> sig y
forall (sig :: * -> *) a b c.
(Read sig a, Transform sig b, Transform sig c) =>
(a -> b -> c) -> sig a -> sig b -> sig c
SigG.zipWith y -> y -> y
forall a. C a => a -> a -> a
(+) sig y
xs1 (sig y -> sig y) -> sig y -> sig y
forall a b. (a -> b) -> a -> b
$ t -> sig y -> sig y
forall a v (sig :: * -> *).
(C a v, Transform sig v) =>
a -> sig v -> sig v
Filt.amplifyVector t
gain sig y
ys
   in  sig y
ys