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

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.Inference.Reader.Filter (
   {- * Non-recursive -}

   {- ** Amplification -}
   amplify,
   negate,
   envelope,
   {- ** Filter operators from calculus -}
   differentiate,

{-
   {- ** Smooth -}
   mean,

   {- ** Delay -}
   delay,
   phaseModulation,
   phaser,
   phaserStereo,


   {- * Recursive -}

   {- ** Without resonance -}
   firstOrderLowpass,
   firstOrderHighpass,
   butterworthLowpass,
   butterworthHighpass,
   chebyshevALowpass,
   chebyshevAHighpass,
   chebyshevBLowpass,
   chebyshevBHighpass,
   {- ** With resonance -}
   universal,
   moogLowpass,
   {- ** Allpass -}
   allpassCascade,
-}
   {- ** Reverb -}
   comb,

   {- ** Filter operators from calculus -}
   integrate,
) where


import qualified Synthesizer.SampleRateContext.Filter as FiltC

import qualified Synthesizer.Inference.Reader.Signal as SigR
import qualified Synthesizer.Inference.Reader.Process as Proc

{-
import Synthesizer.Inference.Reader.Signal
   (toTimeScalar, toFrequencyScalar)

import qualified Synthesizer.Physical.Signal as SigP
import qualified Synthesizer.Plain.Displacement as Syn
import qualified Synthesizer.Plain.Interpolation as Interpolation
import qualified Synthesizer.Plain.Filter.Delay.Block as Delay
import qualified Synthesizer.Plain.Filter.NonRecursive as Filt
import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI
import qualified Synthesizer.Inference.Monad.Signal.Cut         as CutI
-}

import qualified Algebra.OccasionallyScalar as OccScalar
-- import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealField      as RealField
import qualified Algebra.Field          as Field
-- import qualified Algebra.Real           as Real
import qualified Algebra.Ring           as Ring
import qualified Algebra.Additive       as Additive
import qualified Algebra.Module         as Module
-- import qualified Algebra.VectorSpace    as VectorSpace

{-
import Data.Ord.HT (limit)

import Control.Monad(liftM2)

import NumericPrelude hiding (negate)
import PreludeBase as P
-}


{- | The amplification factor must be positive. -}
amplify :: (Field.C y') =>
      y'
   -> Proc.T t t'
        (SigR.T y y' yv
      -> SigR.T y y' yv)
amplify volume = SigR.lift (FiltC.amplify volume)

negate :: (Additive.C yv) =>
   Proc.T t t'
       (SigR.T y y' yv
     -> SigR.T y y' yv)
negate = SigR.lift FiltC.negate


envelope :: (Module.C y yv, Field.C y') =>
   Proc.T t t' (
      SigR.T y y' y   {-  the envelope -}
   -> SigR.T y y' yv  {-  the signal to be enveloped -}
   -> SigR.T y y' yv)
envelope = SigR.lift FiltC.envelope


differentiate :: (Additive.C v, Field.C q') =>
   Proc.T q q' (
        SigR.T q q' v
     -> SigR.T q q' v)
differentiate = SigR.lift FiltC.differentiate


{-
{- | needs a good handling of boundaries, yet -}
mean :: (Additive.C yv, Field.C y', RealField.C a,
         Module.C a v, OccScalar.C a q) =>
      q            {- ^ time length of the window -}
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
mean time x =
   do t <- toTimeScalar x (Expr.constant time)
      let tInt  = round ((t-1)/2)
      let width = tInt*2+1
      returnModified []
         ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .
          Filt.sums width . FiltNR.delay tInt) x


delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
      q
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
delay time x =
   do t <- toTimeScalar x (Expr.constant time)
      returnModified [] (FiltNR.delay (round t)) x


phaseModulation ::
         (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
      Interpolation.T a v
   -> q   {- ^ minDelay, minimal delay, may be negative -}
   -> q   {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
               and the modulation must always be
               in the range [minDelay,maxDelay]. -}
   -> SigI.T a q a
          {- ^ delay control, positive numbers mean delay,
               negative numbers mean prefetch -}
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
phaseModulation ip minDelay maxDelay delays x =
   do t0 <- toTimeScalar x (Expr.constant minDelay)
      t1 <- toTimeScalar x (Expr.constant maxDelay)
      let tInt0 = floor   t0
      let tInt1 = ceiling t1
      let tInt0Neg = Additive.negate tInt0
      ds <- SigI.scalarSamples (toTimeScalar delays) delays
      returnModified [SigP.sampleRate delays]
         (FiltNR.delay tInt0 .
             Delay.modulated ip (tInt1-tInt0+1)
               (FiltNR.delay tInt0Neg
                  (Syn.raise (fromIntegral tInt0Neg)
                     (map (limit (t0,t1)) ds)))) x


{- | symmetric phaser -}
phaser :: (Additive.C yv, Field.C y', RealField.C a,
           Module.C a v, OccScalar.C a q) =>
      Interpolation.T a v
   -> q   {- ^ maxDelay, must be positive -}
   -> SigI.T a q a
          {- ^ delay control -}
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
phaser ip maxDelay delays x =
   amplify (asTypeOf 0.5 maxDelay) =<<
      uncurry SynI.mix =<< phaserCore ip maxDelay delays x

phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,
                 Module.C a v, OccScalar.C a q) =>
      Interpolation.T a v
   -> q   {- ^ maxDelay, must be positive -}
   -> SigI.T a q a
          {- ^ delay control -}
   -> SigR.T y y' yv
   -> SigI.Process a q (v,v)
phaserStereo ip maxDelay delays x =
   uncurry CutI.zip =<< phaserCore ip maxDelay delays x

phaserCore :: (Additive.C yv, Field.C y', RealField.C a,
               Module.C a v, OccScalar.C a q) =>
      Interpolation.T a v
   -> q   {- ^ maxDelay, must be positive -}
   -> SigI.T a q a
          {- ^ delay control -}
   -> SigR.T y y' yv
   -> Process.T q (SigR.T y y' yv, SigR.T y y' yv)
phaserCore ip maxDelay delays x =
   do let minDelay = Additive.negate maxDelay
      negDelays <- Inference.Signal.Filter.negate delays
      liftM2 (,)
         (phaseModulation ip minDelay maxDelay delays x)
         (phaseModulation ip minDelay maxDelay negDelays x)



firstOrderLowpass, firstOrderHighpass ::
   (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
      SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
   -> SigR.T y y' yv {- ^ Input signal -}
   -> Proc.T t t' (SigR.T y y' yv)
firstOrderLowpass  = firstOrderGen Syn.lowpass1stOrder
firstOrderHighpass = firstOrderGen Syn.highpass1stOrder

firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
      ([a] -> [v] -> [v])
   -> SigI.T a q a
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
firstOrderGen filt freq x =
   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
      returnModified [SigP.sampleRate freq]
         (filt (map Syn.lowpass1stOrderParam freqs)) x


butterworthLowpass, butterworthHighpass,
   chebyshevALowpass, chebyshevAHighpass,
   chebyshevBLowpass, chebyshevBHighpass ::
      (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
      Int          {- ^ Order of the filter, must be even,
                        the higher the order, the sharper is the separation of frequencies. -}
   -> a            {- ^ The attenuation at the cut-off frequency.
                        Should be between 0 and 1. -}
   -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
   -> SigR.T y y' yv {- ^ Input signal -}
   -> Proc.T t t' (SigR.T y y' yv)

butterworthLowpass  = higherOrderNoResoGen Syn.butterworthLowpass
butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass
chebyshevALowpass   = higherOrderNoResoGen Syn.chebyshevALowpass
chebyshevAHighpass  = higherOrderNoResoGen Syn.chebyshevAHighpass
chebyshevBLowpass   = higherOrderNoResoGen Syn.chebyshevBLowpass
chebyshevBHighpass  = higherOrderNoResoGen Syn.chebyshevBHighpass

higherOrderNoResoGen ::
   (Field.C y', Ring.C a, OccScalar.C a q) =>
      (Int -> a -> [a] -> [v] -> [v])
   -> Int
   -> a
   -> SigI.T a q a
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
higherOrderNoResoGen filt order ratio freq x =
   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
      returnModified [SigP.sampleRate freq]
         (filt order ratio freqs) x



universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
      SigI.T a q a {- ^ signal for resonance,
                        i.e. factor of amplification at the resonance frequency
                        relatively to the transition band. -}
   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
   -> SigR.T y y' yv {- ^ input signal -}
   -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}
universal reso freq x =
   do resos <- SigI.scalarSamples (Process.exprToScalar) reso
      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
      let params =
             map UniFilter.parameter
                 (zipWith Syn.Pole resos freqs)
      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
         (UniFilter.run params) x

moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
      Int
   -> SigI.T a q a {- ^ signal for resonance,
                        i.e. factor of amplification at the resonance frequency
                        relatively to the transition band. -}
   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
moogLowpass order reso freq x =
   do resos <- SigI.scalarSamples (Process.exprToScalar) reso
      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
      let params =
             map (Moog.parameter order)
                 (zipWith Syn.Pole resos freqs)
      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
         (Moog.lowpass order params) x

allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
      Int          {- ^ order, number of filters in the cascade -}
   -> a            {- ^ the phase shift to be achieved for the given frequency -}
   -> SigI.T a q a {- ^ lowest comb frequency -}
   -> SigR.T y y' yv
   -> Proc.T t t' (SigR.T y y' yv)
allpassCascade order phase freq x =
   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
      let params = map (Syn.allpassCascadeParam order phase) freqs
      returnModified [SigP.sampleRate freq]
         (Syn.allpassCascade order params) x
-}



{- | Infinitely many equi-delayed exponentially decaying echos. -}
comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>
   t' -> y -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)
comb time gain = SigR.lift (FiltC.comb time gain)


integrate :: (Additive.C v, Field.C q') =>
   Proc.T q q'
       (SigR.T q q' v
     -> SigR.T q q' v)
integrate = SigR.lift FiltC.integrate


{-
returnModified :: (Eq q) =>
   [Process.Value q] -> ([v] -> [w]) -> SigR.T y y' yv -> SigI.Process a q w
returnModified sampleRates proc x =
   do let sampleRate = SigP.sampleRate x
      mapM_ (Process.equalValue sampleRate) sampleRates
      SigI.returnCons
         sampleRate (SigP.amplitude x)
         (proc (SigP.samples x))
-}