{-# LANGUAGE TypeFamilies #-}
{-# 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, )
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.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Simple.Value as Value

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Arithmetic as A
import LLVM.Extra.Class (Undefined, undefTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

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

import Synthesizer.ApplicativeUtility (liftA6, )


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

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


type ParameterStruct a = LLVM.Struct (a, (a, (a, (a, (a, (a, ()))))))

parameterMemory ::
   (Memory.C a) =>
   Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a)
parameterMemory =
   liftA6 Parameter
      (Memory.element Universal.k1       d0)
      (Memory.element Universal.k2       d1)
      (Memory.element Universal.ampIn    d2)
      (Memory.element Universal.ampI1    d3)
      (Memory.element Universal.ampI2    d4)
      (Memory.element Universal.ampLimit d5)


instance (Memory.C a) => Memory.C (Parameter a) where
   type Struct (Parameter a) = ParameterStruct (Memory.Struct a)
   load = Memory.loadRecord parameterMemory
   store = Memory.storeRecord parameterMemory
   decompose = Memory.decomposeRecord parameterMemory
   compose = Memory.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 (Class.MakeValueTuple a) => Class.MakeValueTuple (Result a) where
   type ValueTuple (Result a) = Result (Class.ValueTuple a)
   valueTupleOf = Class.valueTupleOfFunctor

instance (Value.Flatten a) => Value.Flatten (Result a) where
   type Registers (Result a) = Result (Value.Registers a)
   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 (Class.MakeValueTuple a) => Class.MakeValueTuple (Parameter a) where
   type ValueTuple (Parameter a) = Parameter (Class.ValueTuple a)
   valueTupleOf = Class.valueTupleOfFunctor

instance (Value.Flatten a) => Value.Flatten (Parameter a) where
   type Registers (Parameter a) = Parameter (Value.Registers a)
   flatten = Value.flattenTraversable
   unfold =  Value.unfoldFunctor


instance (Vector.Simple v) => Vector.Simple (Parameter v) where
   type Element (Parameter v) = Parameter (Vector.Element v)
   type Size (Parameter v) = Vector.Size v
   shuffleMatch = Vector.shuffleMatchTraversable
   extract = Vector.extractTraversable

instance (Vector.C v) => Vector.C (Parameter v) where
   insert = Vector.insertTraversable


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.Simple v) => Vector.Simple (Result v) where
   type Element (Result v) = Result (Vector.Element v)
   type Size (Result v) = Vector.Size v
   shuffleMatch = Vector.shuffleMatchTraversable
   extract = Vector.extractTraversable

instance (Vector.C v) => Vector.C (Result v) where
   insert  = Vector.insertTraversable

instance (Serial.Sized v) => Serial.Sized (Result v) where
   type Size (Result v) = Serial.Size v

instance (Serial.Read v) => Serial.Read (Result v) where
   type Element (Result v) = Result (Serial.Element v)
   type ReadIt (Result v) = Result (Serial.ReadIt v)
   extract = Serial.extractTraversable
   readStart = Serial.readStartTraversable
   readNext = Serial.readNextTraversable

instance (Serial.C v) => Serial.C (Result v) where
   type WriteIt (Result v) = Result (Serial.WriteIt v)
   insert  = Serial.insertTraversable
   writeStart = Serial.writeStartTraversable
   writeNext = Serial.writeNextTraversable
   writeStop = Serial.writeStopTraversable


parameter ::
   (A.Transcendental a, A.RationalConstant a) =>
   a -> a -> CodeGenFunction r (Parameter a)
parameter reson freq =
   Value.flatten $
   Universal.parameter
      (Pole (Value.constantValue reson) (Value.constantValue freq))
--      (Pole (Value.unfold reson) (Value.unfold freq))


modifier ::
   (A.PseudoModule a v, A.IntegerConstant a) =>
   Modifier.Simple
      (Universal.State (Value.T v))
      (Parameter (Value.T a))
      (Value.T v) (Result (Value.T v))
modifier =
   Universal.modifier

causalP ::
   (A.PseudoModule a v, A.IntegerConstant a, Memory.C v) =>
   CausalP.T p (Parameter a, v) (Result v)
causalP =
   CausalP.fromModifier modifier

{-
The state variable filter could be vectorised
by writing the integrator network as matrix recursion
and applying the doubling trick to that recursion.
However the initially sparse matrix with several 1s in it
has dense power matrices with no nice structure.
This will only payoff for large vectors.

We could write another version,
that expresses the state variable filter in terms of the general second order filter.
The general second order filter is already vectorized.
-}