{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Synthesizer.LLVM.Filter.Moog
   (Parameter, parameter,
    causalP,
   ) 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 Foreign.Storable (Storable, )

import qualified LLVM.Extra.Representation as Rep
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Vector as Vector

import qualified LLVM.Core as LLVM
import LLVM.Core
   (valueOf, Value, Struct,
    IsFirstClass, IsConst, IsArithmetic, IsFloating, IsSized,
    Undefined, undefTuple,
    CodeGenFunction, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

import qualified Data.TypeLevel.Num as TypeNum
import Data.TypeLevel.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 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


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


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

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

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

parameterMemory ::
   (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>
   Rep.MemoryRecord r (Struct (s, (s, ()))) (Parameter n a)
parameterMemory =
   liftA2 (\f k -> Parameter (Moog.Parameter f k))
      (Rep.memoryElement (Moog.feedback     . getParam) d0)
      (Rep.memoryElement (Moog.lowpassParam . getParam) d1)

instance
      (Rep.Memory a s, IsSized s ss, TypeNum.Nat n) =>
      Rep.Memory (Parameter n a) (Struct (s, (s, ()))) where
   load = Rep.loadRecord parameterMemory
   store = Rep.storeRecord parameterMemory
   decompose = Rep.decomposeRecord parameterMemory
   compose = Rep.composeRecord parameterMemory


instance (Value.Flatten ah al, TypeNum.Nat n) =>
      Value.Flatten (Parameter n ah) (Parameter n al) where
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance (Vector.ShuffleMatch m v, TypeNum.Nat n) =>
      Vector.ShuffleMatch m (Parameter n v) where
   shuffleMatch = Vector.shuffleMatchTraversable

instance (Vector.Access m a v, TypeNum.Nat n) =>
      Vector.Access m (Parameter n a) (Parameter n v) where
   insert  = Vector.insertTraversable
   extract = Vector.extractTraversable


parameter ::
   (Trans.C a, IsConst a, IsFloating a, TypeNum.Nat n) =>
   n -> Value a -> Value a ->
   CodeGenFunction r (Parameter n (Value a))
parameter order reson freq =
   Value.flatten $
   Parameter $ Moog.parameter (TypeNum.toInt 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 ::
   (Module.C (Value.T a) (Value.T v),
    LLVM.MakeValueTuple v (Value v), IsConst v,
    LLVM.MakeValueTuple a (Value a), IsConst a) =>
   (Parameter n (Value a), Value v) -> Value v ->
   CodeGenFunction r (FirstOrder.Parameter (Value a), Value v)
merge (Parameter (Moog.Parameter f k), x) y0 =
   let c :: (LLVM.MakeValueTuple a (Value a)) => Value a -> Value.T a
       c = Value.constantValue
   in  Value.flatten (fmap c k, c x - c f *> c y0)

amplify ::
   (Module.C (Value.T a) (Value.T v)) =>
   Parameter n (Value a) ->
   Value v ->
   CodeGenFunction r (Value v)
amplify (Parameter (Moog.Parameter f _k)) y1 =
   Value.decons $
   (1 + Value.constantValue f) *> Value.constantValue y1

causalP ::
   (Module.C (Value.T a) (Value.T v),
    Module.C a v, Storable v,
    LLVM.MakeValueTuple v (Value v),
    LLVM.MakeValueTuple a (Value a),
    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,
    IsFirstClass v, IsSized v vs, IsConst v,
    TypeNum.Nat n) =>
   CausalP.T p
      (Parameter n (Value a), Value v) (Value v)
causalP =
   causalPSize undefined

causalPSize ::
   (Module.C (Value.T a) (Value.T v),
    Module.C a v, Storable v,
    LLVM.MakeValueTuple v (Value v),
    LLVM.MakeValueTuple a (Value a),
    IsFirstClass a, IsSized a as, IsConst a, IsArithmetic a,
    IsFirstClass v, IsSized v vs, IsConst v,
    TypeNum.Nat n) =>
   n ->
   CausalP.T p
      (Parameter n (Value a), Value v) (Value v)
causalPSize n =
   let order = TypeNum.toInt n
       feedZero = zero
       selectOutput = snd `asTypeOf` const (valueOf feedZero)
   in  Arrow.arr fst &&&
       CausalP.feedbackControlled
          (return feedZero)
          (CausalP.mapSimple (uncurry merge) >>>
           CausalP.replicateControlled order Filt1.lowpassCausalP)
          (Arrow.arr selectOutput)
        >>> CausalP.mapSimple (uncurry amplify)