{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Synthesizer.LLVM.Filter.ComplexFirstOrder (
Parameter(Parameter), parameter, causal,
parameterCode, causalExp,
) where
import qualified Synthesizer.LLVM.Causal.Process as CausalExp
import qualified Synthesizer.LLVM.Causal.Private as Causal
import qualified Synthesizer.LLVM.Value as Value
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Complex as Complex
import qualified LLVM.DSL.Expression as Expr
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Tuple as Tuple
import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction)
import Type.Data.Num.Decimal (d0, d1, d2)
import qualified Control.Applicative as App
import Control.Applicative (liftA2, liftA3, (<*>))
import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Ring as Ring
import NumericPrelude.Numeric
import NumericPrelude.Base
data Parameter a =
Parameter a (Complex.T a)
instance Functor Parameter where
{-# INLINE fmap #-}
fmap f (Parameter k c) =
Parameter (f k) (fmap f c)
instance App.Applicative Parameter where
{-# INLINE pure #-}
pure x = Parameter x (x Complex.+: x)
{-# INLINE (<*>) #-}
Parameter fk fc <*> Parameter pk pc =
Parameter (fk pk) $
(Complex.real fc $ Complex.real pc)
Complex.+:
(Complex.imag fc $ Complex.imag pc)
instance Fold.Foldable Parameter where
{-# INLINE foldMap #-}
foldMap = Trav.foldMapDefault
instance Trav.Traversable Parameter where
{-# INLINE sequenceA #-}
sequenceA (Parameter k c) =
liftA2 Parameter k $
liftA2 (Complex.+:) (Complex.real c) (Complex.imag c)
instance (Tuple.Phi a) => Tuple.Phi (Parameter a) where
phi = Tuple.phiTraversable
addPhi = Tuple.addPhiFoldable
instance Tuple.Undefined a => Tuple.Undefined (Parameter a) where
undef = Tuple.undefPointed
type ParameterStruct a = LLVM.Struct (a, (a, (a, ())))
parameterMemory ::
(Memory.C a) =>
Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a)
parameterMemory =
liftA3 (\amp kr ki -> Parameter amp (kr Complex.+: ki))
(Memory.element (\(Parameter amp _) -> amp) d0)
(Memory.element (\(Parameter _amp k) -> Complex.real k) d1)
(Memory.element (\(Parameter _amp k) -> Complex.imag k) d2)
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 (Value.Flatten a) => Value.Flatten (Parameter a) where
type Registers (Parameter a) = Parameter (Value.Registers a)
flattenCode = Value.flattenCodeTraversable
unfoldCode = Value.unfoldCodeTraversable
instance
(Expr.Aggregate e mv) =>
Expr.Aggregate (Parameter e) (Parameter mv) where
type MultiValuesOf (Parameter e) = Parameter (Expr.MultiValuesOf e)
type ExpressionsOf (Parameter mv) = Parameter (Expr.ExpressionsOf mv)
bundle = Trav.traverse Expr.bundle
dissect = fmap Expr.dissect
parameterCode, _parameterCode ::
(A.Transcendental a, A.RationalConstant a) =>
a -> a -> CodeGenFunction r (Parameter a)
parameterCode reson freq =
let amp = recip $ Value.unfold reson
in Value.flatten $ Parameter amp $
Complex.scale (1-amp) $ Complex.cis $
Value.unfold freq * Value.tau
_parameterCode reson freq = do
amp <- A.fdiv A.one reson
k <- A.sub A.one amp
w <- A.mul freq =<< Value.decons Value.tau
kr <- A.mul k =<< A.cos w
ki <- A.mul k =<< A.sin w
return (Parameter amp (kr Complex.+: ki))
parameter :: (Trans.C a) => a -> a -> Parameter a
parameter reson freq =
let amp = recip reson
in Parameter amp $
Complex.scale (1-amp) $ Complex.cis $ freq * 2*pi
next, _next ::
(A.PseudoRing a, A.IntegerConstant a) =>
(Parameter a, Stereo.T a) ->
Complex.T a ->
CodeGenFunction r (Stereo.T a, Complex.T a)
next inp state =
let stereoFromComplexVal :: Complex.T (Value.T a) -> Stereo.T (Value.T a)
stereoFromComplexVal = stereoFromComplex
(Parameter amp k, x) = Value.unfold inp
xc = Stereo.left x Complex.+: Stereo.right x
y = Complex.scale amp xc + k * Value.unfold state
in Value.flatten (stereoFromComplexVal y, y)
_next (Parameter amp k, x) s = do
let kr = Complex.real k
ki = Complex.imag k
sr = Complex.real s
si = Complex.imag s
yr <- Value.decons $
Value.lift0 (A.mul (Stereo.left x) amp) +
Value.lift0 (A.mul kr sr) - Value.lift0 (A.mul ki si)
yi <- Value.decons $
Value.lift0 (A.mul (Stereo.right x) amp) +
Value.lift0 (A.mul kr si) + Value.lift0 (A.mul ki sr)
return (Stereo.cons yr yi, yr Complex.+: yi)
start ::
(A.Additive a) =>
CodeGenFunction r (Complex.T a)
start =
return (A.zero Complex.+: A.zero)
causal ::
(A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>
Causal.T
(Parameter a, Stereo.T a)
(Stereo.T a)
causal =
Causal.mapAccum next start
stereoFromComplex :: Complex.T a -> Stereo.T a
stereoFromComplex c = Stereo.cons (Complex.real c) (Complex.imag c)
nextPlain ::
(Ring.C a) =>
(Parameter a, Stereo.T a) -> Complex.T a -> (Stereo.T a, Complex.T a)
nextPlain (Parameter amp k, x) state =
let xc = Stereo.left x Complex.+: Stereo.right x
y = Complex.scale amp xc + k * state
in (stereoFromComplex y, y)
causalExp ::
(Ring.C ae, Expr.Aggregate ae a, Memory.C a) =>
CausalExp.T (Parameter a, Stereo.T a) (Stereo.T a)
causalExp =
CausalExp.mapAccum nextPlain zero