{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Rank2Types #-}
module Test.Synthesizer.LLVM.Filter (tests) where

import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.FirstOrder as FirstOrder
import qualified Synthesizer.LLVM.Filter.SecondOrder as SecondOrder
import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as SecondOrderP
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Filter.ComplexFirstOrder as ComplexFilter
import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as ComplexFilterP
import qualified Synthesizer.LLVM.Filter.NonRecursive as FiltNR

import qualified Synthesizer.Plain.Filter.Recursive.Allpass    as AllpassCore
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrderCore
import qualified Synthesizer.Plain.Filter.Recursive.Universal  as UniFilterCore
import qualified Synthesizer.Plain.Filter.Recursive.Moog       as MoogCore
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as ComplexFilterCore

import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Simple.Signal as Sig
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), )
import Synthesizer.LLVM.Parameter (($#), )

import Synthesizer.Plain.Filter.Recursive (Pole(Pole))
-- import qualified Synthesizer.Storable.Signal as SigSt
import qualified Synthesizer.Interpolation.Module as Ip
import qualified Synthesizer.Causal.Interpolation as InterpC
import qualified Synthesizer.Causal.Filter.NonRecursive as FiltC
import qualified Synthesizer.Causal.Displacement as DispC
import qualified Synthesizer.Causal.Process as CausalS
import qualified Synthesizer.Basic.Wave as WaveCore
import qualified Synthesizer.State.Displacement as DispS
import qualified Synthesizer.State.Oscillator as OsciS
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Basic.Phase as Phase

import qualified Data.StorableVector.Lazy as SVL

import qualified Test.Synthesizer.LLVM.Generator as Gen
import Test.Synthesizer.LLVM.Generator
   (checkWithParam, arg, pair, withGenArgs, )
import Test.Synthesizer.LLVM.Utility
   (checkSimilarity, checkSimilarityState,
    CheckSimilarity, CheckSimilarityState,
    randomStorableVector, checkSimilarityPacked, )

import qualified Control.Category as Cat
import Control.Category ((<<<), )
import Control.Arrow ((&&&), (^<<), (<<^), )
import Control.Applicative (liftA2, (<$>), )

import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Memory as Memory

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, )

import qualified Type.Data.Num.Decimal as TypeNum
import Type.Data.Num.Decimal (D4, )
import Type.Base.Proxy (Proxy, )

import qualified Number.Complex as Complex
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified System.Random as Rnd
import Data.Word (Word32, )

import qualified Test.QuickCheck as QC

import NumericPrelude.Numeric
import NumericPrelude.Base


type SimFloat = CheckSimilarity Float
type SimStateFloat = CheckSimilarityState Float
type VectorValue = Serial.Value D4 Float

signalLength :: Int
signalLength = 10000


limitFloat :: SVL.Vector Float -> SVL.Vector Float
limitFloat = SVL.take signalLength

{-
limitStereoFloat :: SVL.Vector (Stereo.T Float) -> SVL.Vector (Stereo.T Float)
limitStereoFloat = SVL.take signalLength
-}


lfoSine ::
   (Memory.C a) =>
   (forall r. Value Float -> LLVM.CodeGenFunction r a) ->
   Param.T p Float ->
   SigP.T p a
lfoSine f reduct =
   SigP.interpolateConstant reduct $
   Sig.map f $
   CausalP.apply (CausalP.mapExponential 2 0.01) $
   SigP.osciSimple Wave.sine 0 (fmap (* (0.1/44100)) reduct)

allpassControl ::
   (TypeNum.Natural n) =>
   Proxy n ->
   Param.T p Float ->
   SigP.T p (Allpass.CascadeParameter n (Value Float))
allpassControl order =
   lfoSine (Allpass.flangerParameter order)

allpassPhaserCausal, allpassPhaserPipeline ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
allpassPhaserCausal reduct =
   CausalP.apply
      (Allpass.phaser
       $< allpassControl TypeNum.d16 reduct)

allpassPhaserPipeline reduct xs =
   let order = TypeNum.d16
   in  (SigP.drop $# TypeNum.integralFromProxy order) $
       (Allpass.phaserPipeline
         $< allpassControl order reduct
         $* xs)


genOsci :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)
genOsci = pair (Gen.choose (0.001, 0.01)) (Gen.choose (0, 0.99))

genOsciReduct ::
   Gen.T
      (Param.T p) ((Float, Float), Float)
      ((Param.T p Float, Param.T p Float), Param.T p Float)
genOsciReduct = pair genOsci (Gen.choose (10, 100))

genOsciReductPacked ::
   Gen.T
      (Param.T p) ((Float, Float), Float)
      ((Param.T p Float, Param.T p Float), Param.T p Float)
genOsciReductPacked = pair genOsci (arg $ (4*) <$> QC.choose (1, 25))

allpassPipeline :: Gen.Test ((Float,Float), Float) SimFloat
allpassPipeline =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
   in  checkSimilarity 1e-2 limitFloat
          (allpassPhaserCausal reduct tone)
          (allpassPhaserPipeline reduct tone)



{- |
Shrink control signal in time
since we can only handle one control parameter per vector chunk.
-}
applyPacked ::
   (Memory.C c) =>
   CausalP.T p (c, VectorValue) VectorValue ->
   SigP.T p c ->
   SigP.T p VectorValue ->
   SigP.T p VectorValue
applyPacked proc cs xs =
   proc
      $< ((SigP.interpolateConstant $#
            (recip $ TypeNum.integralFromProxy TypeNum.d4 :: Float)) cs)
      $* xs


allpassPhaserPacked ::
   Param.T p Float ->
   SigP.T p VectorValue ->
   SigP.T p VectorValue
allpassPhaserPacked reduct =
   applyPacked Allpass.phaserPacked
      (allpassControl TypeNum.d16 reduct)

allpassPacked :: Gen.Test ((Float,Float), Float) SimFloat
allpassPacked =
   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
   let tone  = SigP.osciSimple  Wave.triangle phase freq
       toneP = SigPS.osciSimple Wave.triangle phase freq
   in  checkSimilarityPacked 1e-2 limitFloat
          (allpassPhaserCausal reduct tone)
          (allpassPhaserPacked reduct toneP)


interpolateConstant :: Float -> SigS.T a -> SigS.T a
interpolateConstant reduct xs =
   CausalS.apply (InterpC.relative Ip.constant 0 xs) $
   SigS.repeat $ recip reduct


{-# INLINE lfoSineCore #-}
lfoSineCore ::
   (Float -> a) ->
   Float ->
   SigS.T a
lfoSineCore f reduct =
   interpolateConstant reduct $
   SigS.map f $
   DispS.mapExponential 2 0.01 $
   OsciS.static WaveCore.sine zero (reduct * 0.1/44100)

{-# INLINE allpassPhaserCore #-}
allpassPhaserCore ::
   Float ->
   SigS.T Float ->
   SigS.T Float
allpassPhaserCore reduct =
   let order = 16
   in  CausalS.apply $
       FiltC.amplify 0.5 <<<
       DispC.mix <<<
          ((CausalS.applyFst (AllpassCore.cascadeCausal order) $
            lfoSineCore (AllpassCore.flangerParameter order) reduct)
           &&&
           Cat.id)

allpassCore :: Gen.Test ((Float,Float), Float) SimStateFloat
allpassCore =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
       toneS p =
          OsciS.static WaveCore.triangle
             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
   in  checkSimilarityState 1e-2 limitFloat
          (allpassPhaserCausal reduct tone)
          (\p -> allpassPhaserCore (Param.get reduct p) (toneS p))



diracImpulse :: SigP.T p (Value Float)
diracImpulse =
   (CausalP.delay1 $# (one::Float)) $*
   (SigP.constant $# (zero::Float))

firstOrderConstant ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
firstOrderConstant cutOff xs =
   FirstOrder.lowpassCausal
    $< SigP.constant (FirstOrderCore.parameter ^<< cutOff)
    $* xs

firstOrderExponential :: Gen.Test Float SimFloat
firstOrderExponential =
   withGenArgs (Gen.choose (0.001, 0.01)) $ \cutOff ->
   let gain = exp(-2*pi*cutOff)
   in  checkSimilarity 1e-2 limitFloat
          (SigP.amplify (recip (1 - gain)) $
           firstOrderConstant cutOff diracImpulse)
          (SigP.exponentialCore gain $# (one :: Float))

firstOrderCausal ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
firstOrderCausal reduct xs =
   FirstOrder.lowpassCausal
    $< lfoSine FirstOrder.parameter reduct
    $* xs

{-# INLINE firstOrderCore #-}
firstOrderCore ::
   Float ->
   SigS.T Float ->
   SigS.T Float
firstOrderCore reduct =
   CausalS.apply $
      CausalS.applyFst FirstOrderCore.lowpassCausal $
      lfoSineCore FirstOrderCore.parameter reduct

firstOrder :: Gen.Test ((Float,Float), Float) SimStateFloat
firstOrder =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
       toneS p =
          OsciS.static WaveCore.triangle
             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
   in  checkSimilarityState 1e-2 limitFloat
          (firstOrderCausal reduct tone)
          (\p -> firstOrderCore (Param.get reduct p) (toneS p))

firstOrderCausalPacked ::
   Param.T p Float ->
   SigP.T p VectorValue ->
   SigP.T p VectorValue
firstOrderCausalPacked reduct =
   applyPacked
      FirstOrder.lowpassCausalPacked
      (lfoSine FirstOrder.parameter reduct)

firstOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat
firstOrderPacked =
   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
   let tone  = SigP.osciSimple  Wave.triangle phase freq
       toneP = SigPS.osciSimple Wave.triangle phase freq
   in  checkSimilarityPacked 1e-2 limitFloat
          (firstOrderCausal reduct tone)
          (firstOrderCausalPacked reduct toneP)


secondOrderCausal ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
secondOrderCausal reduct xs =
   SecondOrder.causal
    $< lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct
    $* xs

secondOrderCausalPacked ::
   Param.T p Float ->
   SigP.T p VectorValue ->
   SigP.T p VectorValue
secondOrderCausalPacked reduct =
   applyPacked SecondOrder.causalPacked
      (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct)

secondOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat
secondOrderPacked =
   withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->
   let tone  = SigP.osciSimple  Wave.triangle phase freq
       toneP = SigPS.osciSimple Wave.triangle phase freq
   in  checkSimilarityPacked 1e-2 limitFloat
          (secondOrderCausal reduct tone)
          (secondOrderCausalPacked reduct toneP)

secondOrderCausalPacked2 ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
secondOrderCausalPacked2 reduct xs =
   SecondOrderP.causal
    $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct
    $* xs

secondOrderPacked2 :: Gen.Test ((Float,Float), Float) SimFloat
secondOrderPacked2 =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple  Wave.triangle phase freq
   in  checkSimilarity 1e-2 limitFloat
          (secondOrderCausal reduct tone)
          (secondOrderCausalPacked2 reduct tone)


{-
limitUniFilter ::
   SVL.Vector (UniFilterCore.Result Float) ->
   SVL.Vector (UniFilterCore.Result Float)
limitUniFilter = SVL.take signalLength
-}

universalCausal ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (UniFilter.Result (Value Float))
universalCausal reduct xs =
   UniFilter.causal
    $< lfoSine (UniFilter.parameter (LLVM.valueOf (10::Float))) reduct
    $* xs

{-# INLINE universalCore #-}
universalCore ::
   Float ->
   SigS.T Float ->
   SigS.T (UniFilterCore.Result Float)
universalCore reduct =
   CausalS.apply $
      CausalS.applyFst UniFilterCore.causal $
      lfoSineCore (UniFilterCore.parameter . Pole 10) reduct

universal :: Gen.Test ((Float,Float), Float) SimStateFloat
universal =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
       toneS p =
          OsciS.static WaveCore.triangle
             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
   in  checkSimilarityState 1e-2 limitFloat
          (fmap UniFilter.lowpass $
             universalCausal reduct tone)
          (\p ->
             SigS.map UniFilterCore.lowpass $
             universalCore (Param.get reduct p) (toneS p))
{-
       checkSimilarityState 1e-2 limitUniFilter
          (universalCausal reduct tone)
          (\p -> universalCore (Param.get reduct p) (toneS p))
-}


moogCausal ::
   (TypeNum.Natural n) =>
   Proxy n ->
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Value Float)
moogCausal order reduct xs =
   Moog.causal
    $< lfoSine (Moog.parameter order (LLVM.valueOf (10::Float))) reduct
    $* xs

{-# INLINE moogCore #-}
moogCore ::
   Int ->
   Float ->
   SigS.T Float ->
   SigS.T Float
moogCore order reduct =
   CausalS.apply $
      CausalS.applyFst (MoogCore.lowpassCausal order) $
      lfoSineCore (MoogCore.parameter order . Pole 10) reduct

moog :: Gen.Test ((Float,Float), Float) SimStateFloat
moog =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let order = TypeNum.d6
       tone  = SigP.osciSimple Wave.triangle phase freq
       toneS p =
          OsciS.static WaveCore.triangle
             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
   in  checkSimilarityState 1e-2 limitFloat
          (moogCausal order reduct tone)
          (\p -> moogCore (TypeNum.integralFromProxy order) (Param.get reduct p) (toneS p))


complexCausal ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Stereo.T (Value Float))
complexCausal reduct =
   CausalP.apply $
      (ComplexFilter.causal
        $< lfoSine (ComplexFilter.parameter (LLVM.valueOf (10::Float))) reduct)
      <<^ (\x -> Stereo.cons x A.zero)

complexCausalPacked ::
   Param.T p Float ->
   SigP.T p (Value Float) ->
   SigP.T p (Stereo.T (Value Float))
complexCausalPacked reduct =
   CausalP.apply $
      (ComplexFilterP.causal
        $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct)
      <<^ (\x -> Stereo.cons x A.zero)

complexPacked :: Gen.Test ((Float,Float), Float) SimFloat
complexPacked =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
   in  checkSimilarity 1e-2 limitFloat
          (fmap Stereo.left $
             complexCausal reduct tone)
          (fmap Stereo.left $
             complexCausalPacked reduct tone)

{-# INLINE complexCore #-}
complexCore ::
   Float ->
   SigS.T Float ->
   SigS.T (Stereo.T Float)
complexCore reduct =
   CausalS.apply $
   (\x -> Stereo.cons (Complex.real x) (Complex.imag x)) ^<<
   CausalS.applyFst ComplexFilterCore.causal
      (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct)

complex :: Gen.Test ((Float,Float), Float) SimStateFloat
complex =
   withGenArgs genOsciReduct $ \((freq,phase), reduct) ->
   let tone = SigP.osciSimple Wave.triangle phase freq
       toneS p =
          OsciS.static WaveCore.triangle
             (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)
   in  checkSimilarityState 1e-2 limitFloat
          (fmap Stereo.left $
             complexCausal reduct tone)
          (\p ->
             SigS.map ((0.1*) . Stereo.left) $
             complexCore (Param.get reduct p) (toneS p))
{-
   in  checkSimilarityState 1e-2 limitStereoFloat
          (complexCausal reduct tone)
          (\p -> complexCore (Param.get reduct p) (toneS p))
-}


convolvePacked :: Gen.Test ((Int,Rnd.StdGen), Word32) SimFloat
convolvePacked =
   withGenArgs
      (pair
         (arg $ liftA2 (,) (QC.choose (1,20)) (Rnd.mkStdGen <$> QC.arbitrary))
         Gen.arbitrary)
   $
   \(rnd, seed) ->
   let mask = randomStorableVector (-1,1::Float) <$> rnd
       noise  = SigP.noise seed 1
       noiseP = SigPS.noise seed 1
   in  checkSimilarityPacked 1e-3 limitFloat
          (FiltNR.convolve mask $* noise)
          (FiltNR.convolvePacked mask $* noiseP)


tests :: [(String, IO ())]
tests =
   ("secondOrderPacked", checkWithParam secondOrderPacked) :
   ("secondOrderPacked2", checkWithParam secondOrderPacked2) :
   ("firstOrderExponential", checkWithParam firstOrderExponential) :
   ("firstOrder", checkWithParam firstOrder) :
   ("firstOrderPacked", checkWithParam firstOrderPacked) :
   ("universal", checkWithParam universal) :
   ("allpassPacked", checkWithParam allpassPacked) :
   ("allpassPipeline", checkWithParam allpassPipeline) :
   ("allpassCore", checkWithParam allpassCore) :
   ("moog", checkWithParam moog) :
   ("complexPacked", checkWithParam complexPacked) :
   ("complex", checkWithParam complex) :
   ("convolvePacked", checkWithParam convolvePacked) :
   []