{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Synthesizer.LLVM.Filter.Moog
   (Parameter, parameter,
    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.Simple.Value as Value
import qualified Synthesizer.LLVM.Parameter as Param

import Foreign.Storable (Storable, )

import qualified LLVM.Extra.ScalarOrVector as SoV
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 (MakeValueTuple, ValueTuple, Undefined, undefTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, IsConst, IsSized, 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 ((>>>), (&&&), )
import Control.Applicative (liftA2, )

import qualified Algebra.Additive as Additive

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)
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


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 reson freq =
   Value.flatten $
   Parameter $ Moog.parameter (TypeNum.fromIntegerT order)
      (Pole (Value.constantValue reson) (Value.constantValue freq))

{-
infixr 1 ^>>, >>^

(>>^) ::
   (Value.Flatten b bl, Value.Flatten c cl) =>
   CausalP.T p al bl -> (b -> c) -> CausalP.T p al cl
(>>^) a f =
   a >>> CausalP.mapSimple (Value.flatten . f . Value.unfold)

(^>>) ::
   (Value.Flatten a al, Value.Flatten b bl) =>
   (a -> b) -> CausalP.T p bl cl -> CausalP.T p al cl
(^>>) f b =
   CausalP.mapSimple (Value.flatten . f . Value.unfold) >>> b
-}

merge ::
   (A.PseudoModule a 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.PseudoModule a v, A.IntegerConstant a) =>
   Parameter n a ->
   v ->
   CodeGenFunction r v
amplify (Parameter (Moog.Parameter f _k)) y1 =
   Value.decons $
   (1 + Value.constantValue f) *> Value.constantValue y1

causalP ::
   (SoV.PseudoModule a v, SoV.IntegerConstant a,
    IsConst v, Additive.C v,
    Storable v,
    MakeValueTuple v, ValueTuple v ~ (Value v),
    MakeValueTuple a, ValueTuple a ~ (Value a),
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,
    Memory.FirstClass v, Memory.Stored v ~ vm, IsSized v, IsSized vm,
    TypeNum.NaturalT n) =>
   CausalP.T p (Parameter n (Value a), Value v) (Value v)
causalP =
   let withZero ::
          (Additive.C v) =>
          (Param.T p v ->
           CausalP.T p (Parameter n (Value a), Value v) (Value v)) ->
          CausalP.T p (Parameter n (Value a), Value v) (Value v)
       withZero proc = proc zero
   in  withZero causalInitP


causalInitP ::
   (A.PseudoModule a v, A.IntegerConstant a,
    Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh,
    Memory.C v,
    TypeNum.NaturalT n) =>
   Param.T p vh -> CausalP.T p (Parameter n a, v) v
causalInitP =
   causalInitPSize undefined

causalInitPSize ::
   (A.PseudoModule a v, A.IntegerConstant a,
    Storable vh, Class.MakeValueTuple vh, v ~ Class.ValueTuple vh,
    Memory.C v,
    TypeNum.NaturalT n) =>
   n -> Param.T p vh -> CausalP.T p (Parameter n a, v) v
causalInitPSize n initial =
   let order = TypeNum.fromIntegerT n
       selectOutput :: Param.T p vh -> (b, Class.ValueTuple vh) -> Class.ValueTuple vh
       selectOutput _ = snd
   in  Arrow.arr fst &&&
       CausalP.feedbackControlled
          initial
          (CausalP.zipWithSimple merge >>>
           CausalP.replicateControlled order Filt1.lowpassCausalP)
          (Arrow.arr (selectOutput initial))
        >>> CausalP.zipWithSimple amplify