{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Filter.ComplexFirstOrder (
   Parameter, parameter,
   causal, causalP,
   ) where

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified LLVM.Extra.Representation as Rep
import qualified Synthesizer.LLVM.Simple.Value as Value

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified LLVM.Extra.Arithmetic as A

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

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

import Control.Applicative (liftA3, )

import qualified Algebra.Transcendental as Trans

import NumericPrelude.Numeric
import NumericPrelude.Base


data Parameter a =
   Parameter a (a,a)

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

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


parameterMemory ::
   (Rep.Memory l s, IsSized s ss) =>
   Rep.MemoryRecord r (Struct (s, (s, (s, ())))) (Parameter l)
parameterMemory =
   liftA3 (\amp kr ki -> Parameter amp (kr,ki))
      (Rep.memoryElement (\(Parameter  amp (_kr,_ki)) -> amp) d0)
      (Rep.memoryElement (\(Parameter _amp ( kr,_ki)) -> kr) d1)
      (Rep.memoryElement (\(Parameter _amp (_kr, ki)) -> ki) d2)

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

parameter ::
   (Trans.C a,
    IsConst a, IsFloating a) =>
   Value a -> Value a -> CodeGenFunction r (Parameter (Value a))
parameter reson freq = do
   amp <- A.fdiv (valueOf 1) reson
   k   <- A.sub  (valueOf 1) amp
   w  <- A.mul freq =<< Value.decons Value.twoPi
   kr <- A.mul k =<< A.cos w
   ki <- A.mul k =<< A.sin w
   return (Parameter amp (kr,ki))


next ::
   (IsArithmetic a, IsConst a) =>
   (Parameter (Value a), Stereo.T (Value a)) ->
   (Value a, Value a) ->
   CodeGenFunction r (Stereo.T (Value a), (Value a, Value a))
next (Parameter amp (kr,ki), x) (sr,si) = do
   yr <- Value.decons $
      Value.Cons (A.mul (Stereo.left x) amp) +
      Value.Cons (A.mul kr sr) - Value.Cons (A.mul ki si)
   yi <- Value.decons $
      Value.Cons (A.mul (Stereo.right x) amp) +
      Value.Cons (A.mul kr si) + Value.Cons (A.mul ki sr)
   return (Stereo.cons yr yi, (yr, yi))

start ::
   (LLVM.IsType a, IsConst a) =>
   CodeGenFunction r (Value a, Value a)
start =
   return (value LLVM.zero, value LLVM.zero)

causal ::
   (IsFirstClass a, IsSized a sa, IsConst a,
    IsFloating a) =>
   Causal.T
      (Parameter (Value a), Stereo.T (Value a))
      (Stereo.T (Value a))
causal =
   Causal.mapAccum next start

causalP ::
   (IsFirstClass a, IsSized a sa, IsConst a,
    IsFloating a) =>
   CausalP.T p
      (Parameter (Value a), Stereo.T (Value a))
      (Stereo.T (Value a))
causalP =
   CausalP.mapAccumSimple next start