{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Synthesizer.LLVM.Filter.SecondOrderPacked (
   Parameter, bandpassParameter, State, causalP,
   ) where

import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2L
import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2

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

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

import Data.TypeLevel.Num (D4, d0, d1, )

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


{- |
Layout:

> c0 [c1 d1 c2 d2]
-}
data Parameter a =
   Parameter (Value a) (Value (Vector D4 a))

instance (IsFirstClass a, IsPrimitive a) => Phi (Parameter a) where
   phis bb (Parameter r i) = do
      r' <- phis bb r
      i' <- phis bb i
      return (Parameter r' i')
   addPhis bb
        (Parameter r i)
        (Parameter r' i') = do
      addPhis bb r r'
      addPhis bb i i'

instance (IsFirstClass a, IsPrimitive a) => Undefined (Parameter a) where
   undefTuple = Parameter undefTuple undefTuple


type ParameterStruct a = Struct (a, (Vector D4 a, ()))

parameterMemory ::
   (Memory.FirstClass a am,
    IsSized a s, IsPrimitive a,
    IsSized am ams, IsPrimitive am) =>
   Memory.Record r (ParameterStruct am) (Parameter a)
parameterMemory =
   liftA2 Parameter
      (Memory.element (\(Parameter c0 _) -> c0) d0)
      (Memory.element (\(Parameter _ cd) -> cd) d1)

instance
   (Memory.FirstClass a am,
    IsSized a s, IsPrimitive a,
    IsSized am ms, IsPrimitive am,
    IsSized (ParameterStruct am) sms) =>
      Memory.C (Parameter a) (ParameterStruct am) where
   load = Memory.loadRecord parameterMemory
   store = Memory.storeRecord parameterMemory
   decompose = Memory.decomposeRecord parameterMemory
   compose = Memory.composeRecord parameterMemory


type State = Vector D4


{-# DEPRECATED bandpassParameter "only for testing, use Universal or Moog filter for production code" #-}
bandpassParameter ::
   (Trans.C a, IsFloating a, IsConst a, IsPrimitive a) =>
   Value a ->
   Value a ->
   CodeGenFunction r (Parameter a)
bandpassParameter reson cutoff = do
   p <- Filt2L.bandpassParameter reson cutoff
   v <- Vector.assemble [Filt2.c1 p, Filt2.d1 p, Filt2.c2 p, Filt2.d2 p]
   return $ Parameter (Filt2.c0 p) v


next ::
   (Vector.Arithmetic a) =>
   (Parameter a, Value a) ->
   Value (State a) ->
   CodeGenFunction r (Value a, Value (State a))
next (Parameter c0 k1, x0) y1 = do
   s0 <- A.mul c0 x0
   s1 <- Vector.dotProduct k1 y1
   y0 <- A.add s0 s1
   x1new <- Vector.extract (valueOf 0) y1
   y1new <- Vector.extract (valueOf 1) y1
   yv <- Vector.assemble [x0, y0, x1new, y1new]
   return (y0, yv)

causalP ::
   (Vector.Arithmetic a,
    Memory.C (Value (State a)) struct, IsSized struct size) =>
{-
   (Vector.Arithmetic a, IsPrimitive am,
    Memory.FirstClass a am,
    IsSized am ams,
    Add ams ams  ams2,
    Add ams ams2 ams3,
    Add ams ams3 ams4,
    Sets.Pos ams4) =>
-}
   CausalP.T p
      (Parameter a, Value a) (Value a)
causalP =
   CausalP.mapAccumSimple next
      (return (LLVM.value LLVM.zero))