{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
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.Representation as Rep
import qualified LLVM.Extra.Vector as Vector

import qualified LLVM.Extra.Arithmetic as A

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

import Data.TypeLevel.Num (Add, D4, d0, d1, )
import qualified Data.TypeLevel.Num as TypeNum
import qualified Data.TypeLevel.Num.Sets as Sets

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


parameterMemory ::
   (IsPrimitive l, IsFirstClass l, IsSized l s,
    Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>
   Rep.MemoryRecord r (Struct (l, (Vector D4 l, ()))) (Parameter l)
parameterMemory =
   liftA2 Parameter
      (Rep.memoryElement (\(Parameter c0 _) -> c0) d0)
      (Rep.memoryElement (\(Parameter _ cd) -> cd) d1)

instance (IsPrimitive l, IsFirstClass l, IsSized l s,
          Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>
      Rep.Memory (Parameter l) (Struct (l, (Vector D4 l, ()))) where
   load = Rep.loadRecord parameterMemory
   store = Rep.storeRecord parameterMemory
   decompose = Rep.decomposeRecord parameterMemory
   compose = Rep.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 ::
   (Field.C a, Vector.Arithmetic a, IsSized (State a) as) =>
   CausalP.T p
      (Parameter a, Value a) (Value a)
causalP =
   CausalP.mapAccumSimple next
      (return (LLVM.value LLVM.zero))