{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Synthesizer.LLVM.Filter.Universal (
   Result(Result, lowpass, highpass, bandpass, bandlimit),
   Parameter, parameter, causalP,
   ) where

import qualified Synthesizer.Plain.Filter.Recursive.Universal as Universal
import Synthesizer.Plain.Filter.Recursive.Universal
          (Parameter(Parameter),
           Result(Result, lowpass, highpass, bandpass, bandlimit))
import Synthesizer.Plain.Filter.Recursive (Pole(..))

import qualified Synthesizer.Plain.Modifier as Modifier

import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Simple.Value as Value

import qualified LLVM.Extra.Representation as Rep
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Vector as Vector

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

import Data.TypeLevel.Num (d0, d1, d2, d3, d4, d5, )

import Synthesizer.ApplicativeUtility (liftA6, )

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.Module as Module
-- import qualified Algebra.Ring as Ring


instance (Phi a) => Phi (Parameter a) where
   phis = Class.phisTraversable
   addPhis = Class.addPhisFoldable

instance Undefined a => Undefined (Parameter a) where
   undefTuple = Class.undefTuplePointed

parameterMemory ::
   (Rep.Memory a s, IsSized s ss) =>
   Rep.MemoryRecord r (Struct (s, (s, (s, (s, (s, (s, ()))))))) (Parameter a)
parameterMemory =
   liftA6 Parameter
      (Rep.memoryElement Universal.k1       d0)
      (Rep.memoryElement Universal.k2       d1)
      (Rep.memoryElement Universal.ampIn    d2)
      (Rep.memoryElement Universal.ampI1    d3)
      (Rep.memoryElement Universal.ampI2    d4)
      (Rep.memoryElement Universal.ampLimit d5)


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


instance LLVM.ValueTuple a => LLVM.ValueTuple (Result a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (Result a) where
   tupleDesc = Class.tupleDescFoldable

instance (LLVM.MakeValueTuple ah al) =>
      LLVM.MakeValueTuple (Result ah) (Result al) where
   valueTupleOf = Class.valueTupleOfFunctor

instance (Value.Flatten ah al) =>
      Value.Flatten (Result ah) (Result al) where
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance LLVM.ValueTuple a => LLVM.ValueTuple (Parameter a) where
   buildTuple f = Class.buildTupleTraversable (LLVM.buildTuple f)

instance LLVM.IsTuple a => LLVM.IsTuple (Parameter a) where
   tupleDesc = Class.tupleDescFoldable

instance (LLVM.MakeValueTuple ah al) =>
      LLVM.MakeValueTuple (Parameter ah) (Parameter al) where
   valueTupleOf = Class.valueTupleOfFunctor

instance (Value.Flatten ah al) =>
      Value.Flatten (Parameter ah) (Parameter al) where
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance (Vector.ShuffleMatch d v) =>
      Vector.ShuffleMatch d (Parameter v) where
   shuffleMatch = Vector.shuffleMatchTraversable

instance (Vector.Access d a v) =>
      Vector.Access d (Parameter a) (Parameter v) where
   insert  = Vector.insertTraversable
   extract = Vector.extractTraversable


instance (Phi a) => Phi (Result a) where
   phis = Class.phisTraversable
   addPhis = Class.addPhisFoldable

instance Undefined a => Undefined (Result a) where
   undefTuple = Class.undefTuplePointed

instance (Vector.ShuffleMatch d v) =>
      Vector.ShuffleMatch d (Result v) where
   shuffleMatch = Vector.shuffleMatchTraversable

instance (Vector.Access d a v) =>
      Vector.Access d (Result a) (Result v) where
   insert  = Vector.insertTraversable
   extract = Vector.extractTraversable


parameter ::
   (Trans.C a, IsConst a, IsFloating a) =>
   Value a -> Value a ->
   CodeGenFunction r (Parameter (Value a))
parameter reson freq =
   Value.flatten $
   Universal.parameter
      (Pole (Value.constantValue reson) (Value.constantValue freq))
--      (Pole (Value.unfold reson) (Value.unfold freq))


modifier ::
   (Module.C (Value.T a) (Value.T v), IsArithmetic a, IsConst a) =>
   Modifier.Simple
      (Universal.State (Value.T v))
      (Parameter (Value.T a))
      (Value.T v) (Result (Value.T v))
modifier =
   Universal.modifier

causalP ::
   (Field.C a, Module.C (Value.T a) (Value.T v),
    IsFirstClass a, IsSized a as, IsConst a,
    IsFirstClass v, IsSized v vs, IsConst v,
    IsArithmetic a) =>
   CausalP.T p
      (Parameter (Value a), Value v) (Result (Value v))
causalP =
   CausalP.fromModifier modifier