{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Synthesizer.LLVM.Filter.Allpass (
   Parameter, parameter,
   CascadeParameter, flangerParameter, flangerParameterPlain,
   causalP, cascadeP, phaserP,
   cascadePipelineP, phaserPipelineP,
   causalPackedP, cascadePackedP, phaserPackedP,
   ) where

import Synthesizer.Plain.Filter.Recursive.Allpass (Parameter(Parameter), )
import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1

import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1L

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.CausalParameterized.Functional as F
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Simple.Value as Value

import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import LLVM.Extra.Class (Undefined, undefTuple, )
import LLVM.Core (CodeGenFunction, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

import qualified Types.Data.Num as TypeNum

import Foreign.Storable (Storable, )

import qualified Control.Category as Cat
import qualified Control.Applicative as App
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import Control.Arrow ((<<<), (^<<), (<<^), (&&&), arr, first, second, )

import qualified Algebra.Transcendental as Trans
-- import qualified Algebra.Field as Field
-- import qualified Algebra.Module as Module
-- import qualified Algebra.Ring as Ring

import NumericPrelude.Numeric
import NumericPrelude.Base


instance (Phi a) => Phi (Parameter a) where
   phis = Class.phisTraversable
   addPhis = Class.addPhisFoldable

instance Undefined a => Undefined (Parameter a) where
   undefTuple = Class.undefTuplePointed

instance Class.Zero a => Class.Zero (Parameter a) where
   zeroTuple = Class.zeroTuplePointed

instance (Memory.C a) => Memory.C (Parameter a) where
   type Struct (Parameter a) = Memory.Struct a
   load = Memory.loadNewtype Parameter
   store = Memory.storeNewtype (\(Parameter k) -> k)
   decompose = Memory.decomposeNewtype Parameter
   compose = Memory.composeNewtype (\(Parameter k) -> k)


{-
instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where
   tupleDesc = Class.tupleDescFoldable
-}

instance (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where
   type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a)
   valueTupleOf = Class.valueTupleOfFunctor


instance (Value.Flatten a) => Value.Flatten (Parameter a) where
   type Registers (Parameter a) = Parameter (Value.Registers a)
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance (Vector.Simple v) => Vector.Simple (Parameter v) where
   type Element (Parameter v) = Parameter (Vector.Element v)
   type Size (Parameter v) = Vector.Size v
   shuffleMatch = Vector.shuffleMatchTraversable
   extract = Vector.extractTraversable

instance (Vector.C v) => Vector.C (Parameter v) where
   insert = Vector.insertTraversable


parameter ::
   (A.Transcendental a, A.RationalConstant a) =>
   a -> a -> CodeGenFunction r (Parameter a)
parameter phase freq =
   Value.flatten $
   Allpass.parameter
      (Value.constantValue phase) (Value.constantValue freq)


newtype CascadeParameter n a =
   CascadeParameter (Allpass.Parameter a)
      deriving
         (Phi, Undefined, Class.Zero, Storable,
          Functor, App.Applicative, Fold.Foldable, Trav.Traversable)

instance (Memory.C a) => Memory.C (CascadeParameter n a) where
   type Struct (CascadeParameter n a) = Memory.Struct a
   load = Memory.loadNewtype CascadeParameter
   store = Memory.storeNewtype (\(CascadeParameter k) -> k)
   decompose = Memory.decomposeNewtype CascadeParameter
   compose = Memory.composeNewtype (\(CascadeParameter k) -> k)


{-
instance LLVM.ValueTuple a => LLVM.ValueTuple (CascadeParameter n a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (CascadeParameter n a) where
   tupleDesc = Class.tupleDescFoldable
-}

instance (Class.MakeValueTuple a) => Class.MakeValueTuple (CascadeParameter n a) where
   type ValueTuple (CascadeParameter n a) = CascadeParameter n (Class.ValueTuple a)
   valueTupleOf = Class.valueTupleOfFunctor


instance (Value.Flatten a) => Value.Flatten (CascadeParameter n a) where
   type Registers (CascadeParameter n a) = CascadeParameter n (Value.Registers a)
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance (Vector.Simple v) => Vector.Simple (CascadeParameter n v) where
   type Element (CascadeParameter n v) = CascadeParameter n (Vector.Element v)
   type Size (CascadeParameter n v) = Vector.Size v
   shuffleMatch = Vector.shuffleMatchTraversable
   extract = Vector.extractTraversable

instance (Vector.C v) => Vector.C (CascadeParameter n v) where
   insert  = Vector.insertTraversable

type instance F.Arguments f (CascadeParameter n a) = f (CascadeParameter n a)
instance F.MakeArguments (CascadeParameter n a) where
   makeArgs = id


flangerParameter ::
   (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) =>
   n -> a ->
   CodeGenFunction r (CascadeParameter n a)
flangerParameter order freq =
   Value.flatten $
   CascadeParameter $
   Allpass.flangerParameter (TypeNum.fromIntegerT order) $
   Value.constantValue freq

flangerParameterPlain ::
   (Trans.C a, TypeNum.NaturalT n) =>
   n -> a -> CascadeParameter n a
flangerParameterPlain order freq =
   CascadeParameter $
   Allpass.flangerParameter (TypeNum.fromIntegerT order) freq


modifier ::
   (A.PseudoModule a v, A.IntegerConstant a) =>
   Modifier.Simple
      -- (Allpass.State (Value.T v))
      (Value.T v, Value.T v)
      (Parameter (Value.T a))
      (Value.T v) (Value.T v)
modifier =
   Allpass.firstOrderModifier

{-
For Allpass cascade you may use the 'CausalP.pipeline' function.
-}
causalP ::
   (A.RationalConstant a, A.PseudoModule a v, Memory.C v) =>
   CausalP.T p (Parameter a, v) v
causalP =
   CausalP.fromModifier modifier


replicateStage ::
   (TypeNum.NaturalT n) =>
   n ->
   CausalP.T p (Parameter a, b) b ->
   CausalP.T p (CascadeParameter n a, b) b
replicateStage order stg =
   CausalP.replicateControlled
      (TypeNum.fromIntegerT order)
      (stg <<< first (arr (\(CascadeParameter p) -> p)))

cascadeP ::
   (A.RationalConstant a, A.PseudoModule a v, Memory.C v,
    TypeNum.NaturalT n) =>
   CausalP.T p (CascadeParameter n a, v) v
cascadeP =
   replicateStage undefined causalP

half ::
   (A.RationalConstant a, A.PseudoModule a v) =>
   CausalP.T p (param a, v) v
half =
   let scale :: A.PseudoModule a v => param a -> a -> v -> CodeGenFunction r v
       scale _ = A.scale
   in  CausalP.mapSimple
          (\(p,x) -> scale p (A.fromRational' 0.5) x)

phaserP ::
   (A.RationalConstant a, A.RationalConstant v,
    A.PseudoModule a v, Memory.C v,
    TypeNum.NaturalT n) =>
   CausalP.T p (CascadeParameter n a, v) v
phaserP =
   CausalP.mix <<<
   cascadeP &&& arr snd <<<
   (arr fst &&& half)


{-
It shouldn't be too hard to use vector operations for the code we generate,
but LLVM-2.6 does not yet do it.
-}
stage ::
   (Vector.Canonical n a, Vector.Construct n a ~ v,
    A.PseudoModule a a, A.IntegerConstant a, Memory.C a) =>
   n ->
   CausalP.T p
      (CascadeParameter n v, v)
      (CascadeParameter n v, v)
stage _ =
   CausalP.vectorize
      (arr fst &&&
       (CausalP.fromModifier modifier <<<
        first (arr (\(CascadeParameter p) -> p))))

withSize ::
   (n -> CausalP.T p (CascadeParameter n a, b) c) ->
   CausalP.T p (CascadeParameter n a, b) c
withSize f = f undefined

{- |
Fast implementation of 'cascadeP' using vector instructions.
However, there must be at least one pipeline stage,
primitive element types
and we get a delay by the number of pipeline stages.
-}
cascadePipelineP ::
   (Vector.Canonical n a, Vector.Construct n a ~ v,
    A.PseudoModule a a, A.IntegerConstant a, Memory.C a,
    Class.Zero v, Memory.C v) =>
   CausalP.T p (CascadeParameter n a, a) a
cascadePipelineP = withSize $ \order ->
   snd ^<< CausalP.pipeline (stage order)

vectorId ::
   (Vector.Canonical n a) =>
   n -> CausalP.T p (Vector.Construct n a) (Vector.Construct n a)
vectorId _ = Cat.id

phaserPipelineP ::
   (Vector.Canonical n a, Vector.Construct n a ~ v,
    A.PseudoModule a a, A.RationalConstant a, Memory.C a,
    Class.Zero v, Memory.C v) =>
   CausalP.T p (CascadeParameter n a, a) a
phaserPipelineP = withSize $ \order ->
   CausalP.mix <<<
   cascadePipelineP &&&
   (CausalP.pipeline (vectorId order) <<^ snd) <<<
--   (CausalP.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<<
   (arr fst &&& half)


causalPackedP,
  causalNonRecursivePackedP ::
   (Serial.C v, Serial.Element v ~ a,
    Memory.C a, A.IntegerConstant a,
    A.PseudoRing v, A.PseudoRing a) =>
   CausalP.T p (Parameter a, v) v
causalPackedP =
   Filt1L.causalRecursivePackedP <<<
   (CausalP.mapSimple
       (\(Parameter k, _) ->
           fmap Filt1.Parameter $ A.neg k) &&&
    causalNonRecursivePackedP)

causalNonRecursivePackedP =
   CausalP.mapAccumSimple
      (\(Parameter k, v0) x1 -> do
         (_,v1) <- Serial.shiftUp x1 v0
         y <- A.add v1 =<< A.mul v0 =<< Serial.upsample k
         let size = fromIntegral $ Serial.size v0
         u0 <- Serial.extract (LLVM.valueOf $ size - 1) v0
         return (y, u0))
      (return A.zero)

cascadePackedP, phaserPackedP ::
   (TypeNum.NaturalT n,
    Serial.C v, Serial.Element v ~ a,
    A.PseudoRing a, A.IntegerConstant a, Memory.C a,
    A.PseudoRing v, A.RationalConstant v) =>
   CausalP.T p (CascadeParameter n a, v) v
cascadePackedP =
   replicateStage undefined causalPackedP

phaserPackedP =
   CausalP.mix <<<
   cascadePackedP &&& arr snd <<<
   second (CausalP.mapSimple (A.mul (A.fromRational' 0.5)))