{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.LLVM.Filter.SecondOrderPacked (
   Parameter, bandpassParameter, State, causal, 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 Synthesizer.LLVM.Causal.Process as Causal
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 LLVM.Extra.Class (Undefined, undefTuple, )

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

import qualified Types.Data.Num as TypeNum
import Types.Data.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, Memory.Stored a ~ am, IsSized a, IsSized am,
    IsPrimitive a, IsPrimitive am,
    TypeNum.PositiveT (D4 :*: LLVM.SizeOf 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, Memory.Stored a ~ am, IsSized a, IsSized am,
    IsPrimitive a, IsPrimitive am,
    TypeNum.PositiveT (D4 :*: LLVM.SizeOf am)) =>
      Memory.C (Parameter a) where
   type Struct (Parameter a) = ParameterStruct (Memory.Stored a)
   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, SoV.TranscendentalConstant 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)

causal ::
   (Causal.C process, Vector.Arithmetic a, Memory.C (Value (State a))) =>
   process (Parameter a, Value a) (Value a)
causal =
   Causal.mapAccum next (return A.zero)

{-# DEPRECATED causalP "use causal instead" #-}
causalP ::
   (Vector.Arithmetic a, Memory.C (Value (State a))) =>
   CausalP.T p (Parameter a, Value a) (Value a)
causalP = causal