{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
module Synthesizer.LLVM.Filter.Moog
   (Parameter, parameter,
    causal, causalInit,
    causalP, causalInitP,
   ) where

import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1

import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as FirstOrder
import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog
import Synthesizer.Plain.Filter.Recursive (Pole(..))

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified Synthesizer.LLVM.Parameter as Param

import Foreign.Storable (Storable, )

import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as Class
import LLVM.Extra.Class (Undefined, undefTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

import qualified Types.Data.Num as TypeNum
import Types.Data.Num (d0, d1, )

import qualified Control.Arrow as Arrow
import qualified Control.Applicative as App
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import Control.Arrow (arr, (>>>), (&&&), )
import Control.Applicative (liftA2, )

import NumericPrelude.Numeric
import NumericPrelude.Base


newtype Parameter n a = Parameter {getParam :: Moog.Parameter a}
   deriving (Functor, App.Applicative, Fold.Foldable, Trav.Traversable)


instance (Phi a, TypeNum.NaturalT n) =>
      Phi (Parameter n a) where
   phis = Class.phisTraversable
   addPhis = Class.addPhisFoldable

instance (Undefined a, TypeNum.NaturalT n) =>
      Undefined (Parameter n a) where
   undefTuple = Class.undefTuplePointed

instance (Class.Zero a, TypeNum.NaturalT n) =>
      Class.Zero (Parameter n a) where
   zeroTuple = Class.zeroTuplePointed


type ParameterStruct a = LLVM.Struct (a, (a, ()))

parameterMemory ::
   (Memory.C a, TypeNum.NaturalT n) =>
   Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter n a)
parameterMemory =
   liftA2 (\f k -> Parameter (Moog.Parameter f k))
      (Memory.element (Moog.feedback     . getParam) d0)
      (Memory.element (Moog.lowpassParam . getParam) d1)

instance
      (Memory.C a, TypeNum.NaturalT n) =>
      Memory.C (Parameter n a) where
   type Struct (Parameter n a) = ParameterStruct (Memory.Struct a)
   load = Memory.loadRecord parameterMemory
   store = Memory.storeRecord parameterMemory
   decompose = Memory.decomposeRecord parameterMemory
   compose = Memory.composeRecord parameterMemory


instance (Value.Flatten a, TypeNum.NaturalT n) => Value.Flatten (Parameter n a) where
   type Registers (Parameter n a) = Parameter n (Value.Registers a)
   flattenCode = Value.flattenCodeTraversable
   unfoldCode = Value.unfoldCodeTraversable


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

instance (Vector.C v, TypeNum.NaturalT n) => Vector.C (Parameter n v) where
   insert = Vector.insertTraversable


parameter ::
   (A.Transcendental a, A.RationalConstant a, TypeNum.NaturalT n) =>
   n -> a -> a ->
   CodeGenFunction r (Parameter n a)
parameter order =
   Value.unlift2 $ \reson freq ->
   Parameter $ Moog.parameter (TypeNum.fromIntegerT order) (Pole reson freq)


merge ::
   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>
   (Parameter n a, v) -> v ->
   CodeGenFunction r (FirstOrder.Parameter a, v)
merge (Parameter (Moog.Parameter f k), x) y0 =
   let c :: a -> Value.T a
       c = Value.constantValue
   in  Value.flatten (fmap c k, c x - c f *> c y0)

amplify ::
   (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>
   Parameter n a ->
   v ->
   CodeGenFunction r v
amplify =
   Value.unlift2 $ \p y1 ->
      case fmap (Moog.feedback . getParam) p of
         f -> (1 + f) *> y1

causal ::
   (Causal.C process,
    Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,
    TypeNum.NaturalT n) =>
   process (Parameter n a, v) v
causal =
   causalSize
      (flip Causal.feedbackControlledZero (arr snd))
      undefined

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


causalInit, causalInitP ::
   (Storable vh, Class.MakeValueTuple vh,
    Class.ValueTuple vh ~ v, Memory.C v,
    A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,
    TypeNum.NaturalT n) =>
   Param.T p vh -> CausalP.T p (Parameter n a, v) v
causalInit = causalInitP
causalInitP initial =
   let selectOutput :: Param.T p vh -> (b, Class.ValueTuple vh) -> Class.ValueTuple vh
       selectOutput _ = snd
   in  causalSize
          (flip
             (CausalP.feedbackControlled initial)
             (arr $ selectOutput initial))
          undefined


causalSize ::
   (Causal.C process,
    Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,
    TypeNum.NaturalT n) =>
   (process ((Parameter n a, v), v) v ->
    process (Parameter n a, v) v) ->
   n ->
   process (Parameter n a, v) v
causalSize feedback n =
   let order = TypeNum.fromIntegerT n
   in  Arrow.arr fst &&&
       feedback
          (Causal.zipWith merge >>>
           Causal.replicateControlled order Filt1.lowpassCausal)
        >>> Causal.zipWith amplify

{-# DEPRECATED causalP     "use 'causal' instead" #-}
{-# DEPRECATED causalInitP "use 'causalInit' instead" #-}