{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Filter.ComplexFirstOrderPacked (
   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 LLVM.Extra.Vector as Vector

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,
    IsPrimitive, IsConst, IsFloating, IsSized,
    Undefined, undefTuple,
    Vector, insertelement,
    neg, CodeGenFunction, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

import Data.TypeLevel.Num (Add, D4, d0, d1, )
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.Ring as Ring
-- import qualified Algebra.Additive as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base


-- the pair should also be replaced by a Vector
data Parameter a =
   Parameter (Value (Vector D4 a)) (Value (Vector D4 a))

instance 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 IsPrimitive a => Undefined (Parameter a) where
   undefTuple = Parameter undefTuple undefTuple


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

{-
The complicated Add constraints are caused by the IsType superclass of Memory.

instance (IsPrimitive l, IsSized (Vector D4 l) ss) =>
      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where

Mul constraint seems to be not enough, GHC urges to give constraints in terms of Add
instance (IsPrimitive l, IsSized l s, Mul D4 s ss, Sets.Pos ss) =>
      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where
-}
instance (IsPrimitive l, IsSized l s, Add s s s2, Add s2 s s3, Add s3 s s4, Sets.Pos s4) =>
      Rep.Memory (Parameter l) (Struct (Vector D4 l, (Vector D4 l, ()))) where
   load = Rep.loadRecord parameterMemory
   store = Rep.storeRecord parameterMemory
   decompose = Rep.decomposeRecord parameterMemory
   compose = Rep.composeRecord parameterMemory

parameter ::
   (Trans.C a,
    IsPrimitive a, IsConst a, IsFloating a) =>
   Value a -> Value a -> CodeGenFunction r (Parameter 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

   kin <- neg ki
   kvr <- Vector.assemble [kr,kin,amp, value LLVM.zero]
   kvi <- Vector.assemble [ki,kr, amp, value LLVM.zero]
   return (Parameter kvr kvi)

{-
The handling of Vector D2 Float in LLVM-2.5 and LLVM-2.6 is at least unexpected.
Because of compatibility reasons, LLVM chooses MMX registers
which requires to call EMMS occasionally.
Thus I choose Vector D4 for Float computations.
Actually, I have now rearranged the data
such that we can make use of SSE4's dot product operation.
This would even require a vector of size 3.
-}
next ::
   (Vector.Arithmetic a, IsConst a) =>
   (Parameter a, Stereo.T (Value a)) ->
   (Value (Vector D4 a)) ->
   CodeGenFunction r (Stereo.T (Value a), (Value (Vector D4 a)))
next (Parameter kr ki, x) s = do
   sr <- insertelement s (Stereo.left  x) (valueOf 2)
   yr <- Vector.dotProduct kr sr

   si <- insertelement s (Stereo.right x) (valueOf 2)
   yi <- Vector.dotProduct ki si

   sv <- Vector.assemble [yr,yi]
   return (Stereo.cons yr yi, sv)

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

causal ::
   (IsConst a, Vector.Arithmetic a,
    IsSized (Vector D4 a) as) =>
   Causal.T
      (Parameter a, Stereo.T (Value a))
      (Stereo.T (Value a))
causal =
   Causal.mapAccum next start

causalP ::
   (IsConst a, Vector.Arithmetic a,
    IsSized (Vector D4 a) as) =>
   CausalP.T p
      (Parameter a, Stereo.T (Value a))
      (Stereo.T (Value a))
causalP =
   CausalP.mapAccumSimple next start