{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Synthesizer.LLVM.Filter.Allpass (
   Parameter, parameter,
   CascadeParameter, flangerParameter, flangerParameterPlain,
   causal, cascade, phaser,
   cascadePipeline, phaserPipeline,
   causalPacked, cascadePacked, phaserPacked,

   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.Causal.ProcessValue as CausalV
import qualified Synthesizer.LLVM.Causal.Process as Causal
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.Util.Loop as Loop
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)
   flattenCode = Value.flattenCodeTraversable
   unfoldCode = Value.unfoldCodeTraversable


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 = Value.unlift2 Allpass.parameter


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

instance (Phi a) => Phi (CascadeParameter n a) where
   phis bb (CascadeParameter v) = fmap CascadeParameter $ Loop.phis bb v
   addPhis bb (CascadeParameter x) (CascadeParameter y) = Loop.addPhis bb x y


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)
   flattenCode = Value.flattenCodeTraversable
   unfoldCode = Value.unfoldCodeTraversable


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 =
   Value.unlift1 (flangerParameterPlain order)

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


modifier ::
   (a ~ A.Scalar v, A.PseudoModule 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 'Causal.pipeline' function.
-}
causal ::
   (Causal.C process,
    A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
   process (Parameter a, v) v
causal =
   Causal.fromModifier modifier


replicateStage ::
   (Causal.C process,
    TypeNum.NaturalT n, Phi b, Undefined b) =>
   n ->
   process (Parameter a, b) b ->
   process (CascadeParameter n a, b) b
replicateStage order stg =
   Causal.replicateControlled
      (TypeNum.fromIntegerT order)
      (stg <<< first (arr (\(CascadeParameter p) -> p)))

cascade ::
   (Causal.C process,
    A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
    TypeNum.NaturalT n) =>
   process (CascadeParameter n a, v) v
cascade =
   replicateStage undefined causal

half ::
   (Causal.C process, A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v) =>
   process v v
half = CausalV.map (Value.fromRational' 0.5 *>)

phaser ::
   (Causal.C process,
    A.RationalConstant a, A.RationalConstant v,
    a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
    TypeNum.NaturalT n) =>
   process (CascadeParameter n a, v) v
phaser =
   Causal.mix <<<
   cascade &&& arr snd <<<
   second 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 ::
   (Causal.C process,
    Vector.Canonical n a, Vector.Construct n a ~ v,
    a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a) =>
   n ->
   process
      (CascadeParameter n v, v)
      (CascadeParameter n v, v)
stage _ =
   Causal.vectorize
      (arr fst &&&
       (Causal.fromModifier modifier <<<
        first (arr (\(CascadeParameter p) -> p))))

withSize ::
   (n -> process (CascadeParameter n a, b) c) ->
   process (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.
-}
cascadePipeline ::
   (Causal.C process,
    Vector.Canonical n a, Vector.Construct n a ~ v,
    a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,
    A.Additive v, Memory.C v) =>
   process (CascadeParameter n a, a) a
cascadePipeline = withSize $ \order ->
   snd ^<< Causal.pipeline (stage order)

vectorId ::
   (Causal.C process, Vector.Canonical n a) =>
   n -> process (Vector.Construct n a) (Vector.Construct n a)
vectorId _ = Cat.id

phaserPipeline ::
   (Causal.C process,
    Vector.Canonical n a, Vector.Construct n a ~ v,
    a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,
    A.Additive v, Memory.C v) =>
   process (CascadeParameter n a, a) a
phaserPipeline = withSize $ \order ->
   Causal.mix <<<
   cascadePipeline &&&
   (Causal.pipeline (vectorId order) <<^ snd) <<<
--   (Causal.delay (const zero) (const $ TypeNum.fromIntegerT order) <<^ snd) <<<
   second half


causalPacked,
  causalNonRecursivePacked ::
   (Causal.C process,
    Serial.C v, Serial.Element v ~ a,
    Memory.C a, A.IntegerConstant a,
    A.PseudoRing v, A.PseudoRing a) =>
   process (Parameter a, v) v

causalPacked =
   Filt1L.causalRecursivePacked <<<
   (Causal.map
       (\(Parameter k, _) ->
           fmap Filt1.Parameter $ A.neg k) &&&
    causalNonRecursivePacked)

causalNonRecursivePacked =
   Causal.mapAccum
      (\(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)

cascadePacked, phaserPacked ::
   (Causal.C process,
    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) =>
   process (CascadeParameter n a, v) v
cascadePacked =
   replicateStage undefined causalPacked

phaserPacked =
   Causal.mix <<<
   cascadePacked &&& arr snd <<<
   second (Causal.map (A.mul (A.fromRational' 0.5)))





causalP ::
   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>
   CausalP.T p (Parameter a, v) v
causalP = causal

cascadeP ::
   (A.RationalConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
    TypeNum.NaturalT n) =>
   CausalP.T p (CascadeParameter n a, v) v
cascadeP = cascade

phaserP ::
   (A.RationalConstant a, A.RationalConstant v,
    a ~ A.Scalar v, A.PseudoModule v, Memory.C v,
    TypeNum.NaturalT n) =>
   CausalP.T p (CascadeParameter n a, v) v
phaserP = phaser


cascadePipelineP ::
   (Vector.Canonical n a, Vector.Construct n a ~ v,
    a ~ A.Scalar a, A.PseudoModule a, A.IntegerConstant a, Memory.C a,
    A.Additive v, Memory.C v) =>
   CausalP.T p (CascadeParameter n a, a) a
cascadePipelineP = cascadePipeline

phaserPipelineP ::
   (Vector.Canonical n a, Vector.Construct n a ~ v,
    a ~ A.Scalar a, A.PseudoModule a, A.RationalConstant a, Memory.C a,
    A.Additive v, Memory.C v) =>
   CausalP.T p (CascadeParameter n a, a) a
phaserPipelineP = phaserPipeline


causalPackedP ::
   (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 = causalPacked

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 = cascadePacked
phaserPackedP = phaserPacked

{-# DEPRECATED causalP          "use 'causal' instead" #-}
{-# DEPRECATED cascadeP         "use 'cascade' instead" #-}
{-# DEPRECATED phaserP          "use 'phaser' instead" #-}
{-# DEPRECATED cascadePipelineP "use 'cascadePipeline' instead" #-}
{-# DEPRECATED phaserPipelineP  "use 'phaserPipeline' instead" #-}
{-# DEPRECATED causalPackedP    "use 'causalPacked' instead" #-}
{-# DEPRECATED cascadePackedP   "use 'cascadePacked' instead" #-}
{-# DEPRECATED phaserPackedP    "use 'phaserPacked' instead" #-}