{-# 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 LLVM.DSL.Parameter as Param

import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Marshal as Marshal
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Tuple as Tuple

import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction)

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

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 (Tuple.Phi a, TypeNum.Natural n) =>
      Tuple.Phi (Parameter n a) where
   phi = Tuple.phiTraversable
   addPhi = Tuple.addPhiFoldable

instance (Tuple.Undefined a, TypeNum.Natural n) =>
      Tuple.Undefined (Parameter n a) where
   undef = Tuple.undefPointed

instance (Tuple.Zero a, TypeNum.Natural n) =>
      Tuple.Zero (Parameter n a) where
   zero = Tuple.zeroPointed


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

parameterMemory ::
   (Memory.C a, TypeNum.Natural 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.Natural 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.Natural 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.Natural 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.Natural n) => Vector.C (Parameter n v) where
   insert = Vector.insertTraversable


parameter ::
   (A.Transcendental a, A.RationalConstant a, TypeNum.Natural n) =>
   Proxy n -> a -> a ->
   CodeGenFunction r (Parameter n a)
parameter order =
   Value.unlift2 $ \reson freq ->
   Parameter $ Moog.parameter (TypeNum.integralFromProxy 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.Natural n) =>
   process (Parameter n a, v) v
causal =
   causalSize
      (flip Causal.feedbackControlledZero (arr snd))
      Proxy

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


causalInit, causalInitP ::
   (Marshal.C vh, Tuple.ValueOf vh ~ v,
    A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,
    TypeNum.Natural n) =>
   Param.T p vh -> CausalP.T p (Parameter n a, v) v
causalInit = causalInitP
causalInitP initial =
   let selectOutput :: Param.T p vh -> (b, Tuple.ValueOf vh) -> Tuple.ValueOf vh
       selectOutput _ = snd
   in  causalSize
          (flip
             (CausalP.feedbackControlled initial)
             (arr $ selectOutput initial))
          Proxy


causalSize ::
   (Causal.C process,
    Memory.C v, A.PseudoModule v, A.Scalar v ~ a, A.IntegerConstant a,
    TypeNum.Natural n) =>
   (process ((Parameter n a, v), v) v ->
    process (Parameter n a, v) v) ->
   Proxy n ->
   process (Parameter n a, v) v
causalSize feedback n =
   let order = TypeNum.integralFromProxy 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" #-}