{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Synthesizer.Interpolation.Class where
import qualified Synthesizer.State.Signal as Sig
import qualified Algebra.Module as Module
import qualified Algebra.PrincipalIdealDomain as PID
import qualified Algebra.Ring as Ring
import qualified Sound.Frame.NumericPrelude.Stereo as Stereo
import qualified Number.Ratio as Ratio
import qualified Number.Complex as Complex
import Control.Applicative (Applicative(pure, (<*>)), liftA2, )
import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, )
import NumericPrelude.Numeric hiding (zero, )
import NumericPrelude.Base
import Prelude ()
class Ring.C a => C a v where
scaleAndAccumulate :: (a,v) -> (v, v -> v)
instance C Float Float where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (Float, Float) -> (Float, Float -> Float)
scaleAndAccumulate = (Float, Float) -> (Float, Float -> Float)
forall a. C a => (a, a) -> (a, a -> a)
scaleAndAccumulateRing
instance C Double Double where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (Double, Double) -> (Double, Double -> Double)
scaleAndAccumulate = (Double, Double) -> (Double, Double -> Double)
forall a. C a => (a, a) -> (a, a -> a)
scaleAndAccumulateRing
instance (C a v) => C a (Complex.T v) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (a, T v) -> (T v, T v -> T v)
scaleAndAccumulate =
(v -> v -> T v)
-> (T v -> v) -> (T v -> v) -> (a, T v) -> (T v, T v -> T v)
forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 v -> v -> T v
forall a. a -> a -> T a
(Complex.+:) T v -> v
forall a. T a -> a
Complex.real T v -> v
forall a. T a -> a
Complex.imag
instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (T a, T a) -> (T a, T a -> T a)
scaleAndAccumulate = (T a, T a) -> (T a, T a -> T a)
forall a. C a => (a, a) -> (a, a -> a)
scaleAndAccumulateRing
instance (C a v, C a w) => C a (v, w) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (a, (v, w)) -> ((v, w), (v, w) -> (v, w))
scaleAndAccumulate = (v -> w -> (v, w))
-> ((v, w) -> v)
-> ((v, w) -> w)
-> (a, (v, w))
-> ((v, w), (v, w) -> (v, w))
forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 (,) (v, w) -> v
forall a b. (a, b) -> a
fst (v, w) -> w
forall a b. (a, b) -> b
snd
instance (C a v, C a w, C a u) => C a (v, w, u) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (a, (v, w, u)) -> ((v, w, u), (v, w, u) -> (v, w, u))
scaleAndAccumulate = (v -> w -> u -> (v, w, u))
-> ((v, w, u) -> v)
-> ((v, w, u) -> w)
-> ((v, w, u) -> u)
-> (a, (v, w, u))
-> ((v, w, u), (v, w, u) -> (v, w, u))
forall a x y z v.
(C a x, C a y, C a z) =>
(x -> y -> z -> v)
-> (v -> x) -> (v -> y) -> (v -> z) -> (a, v) -> (v, v -> v)
makeMac3 (,,) (v, w, u) -> v
forall a b c. (a, b, c) -> a
fst3 (v, w, u) -> w
forall a b c. (a, b, c) -> b
snd3 (v, w, u) -> u
forall a b c. (a, b, c) -> c
thd3
instance C a v => C a (Stereo.T v) where
{-# INLINE scaleAndAccumulate #-}
scaleAndAccumulate :: (a, T v) -> (T v, T v -> T v)
scaleAndAccumulate =
(v -> v -> T v)
-> (T v -> v) -> (T v -> v) -> (a, T v) -> (T v, T v -> T v)
forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 v -> v -> T v
forall a. a -> a -> T a
Stereo.cons T v -> v
forall a. T a -> a
Stereo.left T v -> v
forall a. T a -> a
Stereo.right
infixl 6 +.*
{-# INLINE scale #-}
scale :: C a v => (a,v) -> v
scale :: forall a v. C a v => (a, v) -> v
scale = (v, v -> v) -> v
forall a b. (a, b) -> a
fst ((v, v -> v) -> v) -> ((a, v) -> (v, v -> v)) -> (a, v) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, v) -> (v, v -> v)
forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate
{-# INLINE scaleAccumulate #-}
scaleAccumulate :: C a v => (a,v) -> v -> v
scaleAccumulate :: forall a v. C a v => (a, v) -> v -> v
scaleAccumulate = (v, v -> v) -> v -> v
forall a b. (a, b) -> b
snd ((v, v -> v) -> v -> v)
-> ((a, v) -> (v, v -> v)) -> (a, v) -> v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, v) -> (v, v -> v)
forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate
{-# INLINE (+.*) #-}
(+.*) :: C a v => v -> (a,v) -> v
+.* :: forall a v. C a v => v -> (a, v) -> v
(+.*) = ((a, v) -> v -> v) -> v -> (a, v) -> v
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a, v) -> v -> v
forall a v. C a v => (a, v) -> v -> v
scaleAccumulate
combine2 :: C a v => a -> (v, v) -> v
combine2 :: forall a v. C a v => a -> (v, v) -> v
combine2 a
a (v
x,v
y) =
(a, v) -> v -> v
forall a v. C a v => (a, v) -> v -> v
scaleAccumulate (a
forall a. C a => a
onea -> a -> a
forall a. C a => a -> a -> a
-a
a, v
x) (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
(a, v) -> v
forall a v. C a v => (a, v) -> v
scale (a
a, v
y)
combineMany :: C a v => (a, Sig.T a) -> (v, Sig.T v) -> v
combineMany :: forall a v. C a v => (a, T a) -> (v, T v) -> v
combineMany (a
a,T a
as) (v
v,T v
vs) =
(v -> (a, v) -> v) -> v -> T (a, v) -> v
forall acc x. (acc -> x -> acc) -> acc -> T x -> acc
Sig.foldL (((a, v) -> v -> v) -> v -> (a, v) -> v
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a, v) -> v -> v
forall a v. C a v => (a, v) -> v -> v
scaleAccumulate) ((a, v) -> v
forall a v. C a v => (a, v) -> v
scale (a
a,v
v)) (T (a, v) -> v) -> T (a, v) -> v
forall a b. (a -> b) -> a -> b
$
T a -> T v -> T (a, v)
forall a b. T a -> T b -> T (a, b)
Sig.zip T a
as T v
vs
{-# INLINE scaleAndAccumulateRing #-}
scaleAndAccumulateRing ::
Ring.C a =>
(a,a) -> (a, a -> a)
scaleAndAccumulateRing :: forall a. C a => (a, a) -> (a, a -> a)
scaleAndAccumulateRing (a
a,a
x) =
let ax :: a
ax = a
a a -> a -> a
forall a. C a => a -> a -> a
* a
x
in (a
ax, (a
axa -> a -> a
forall a. C a => a -> a -> a
+))
{-# INLINE scaleAndAccumulateModule #-}
scaleAndAccumulateModule ::
Module.C a v =>
(a,v) -> (v, v -> v)
scaleAndAccumulateModule :: forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulateModule (a
a,v
x) =
let ax :: v
ax = a
a a -> v -> v
forall a v. C a v => a -> v -> v
*> v
x
in (v
ax, (v
axv -> v -> v
forall a. C a => a -> a -> a
+))
{-# INLINE scaleAndAccumulateApplicative #-}
scaleAndAccumulateApplicative ::
(C a v, Applicative f) =>
(a, f v) -> (f v, f v -> f v)
scaleAndAccumulateApplicative :: forall a v (f :: * -> *).
(C a v, Applicative f) =>
(a, f v) -> (f v, f v -> f v)
scaleAndAccumulateApplicative (a
a,f v
x) =
let ax :: f (v, v -> v)
ax = (v -> (v, v -> v)) -> f v -> f (v, v -> v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, v) -> (v, v -> v)) -> a -> v -> (v, v -> v)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, v) -> (v, v -> v)
forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate a
a) f v
x
in (((v, v -> v) -> v) -> f (v, v -> v) -> f v
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, v -> v) -> v
forall a b. (a, b) -> a
fst f (v, v -> v)
ax, (((v, v -> v) -> v -> v) -> f (v, v -> v) -> f (v -> v)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, v -> v) -> v -> v
forall a b. (a, b) -> b
snd f (v, v -> v)
ax f (v -> v) -> f v -> f v
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>))
{-# INLINE scaleAndAccumulateRingApplicative #-}
scaleAndAccumulateRingApplicative ::
(Ring.C a, Applicative f) =>
(a, f a) -> (f a, f a -> f a)
scaleAndAccumulateRingApplicative :: forall a (f :: * -> *).
(C a, Applicative f) =>
(a, f a) -> (f a, f a -> f a)
scaleAndAccumulateRingApplicative (a
a,f a
x) =
let ax :: f a
ax = (a -> a) -> f a -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aa -> a -> a
forall a. C a => a -> a -> a
*) f a
x
in (f a
ax, (a -> a -> a) -> f a -> f a -> f a
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. C a => a -> a -> a
(+) f a
ax)
{-# INLINE scaleAndAccumulateModuleApplicative #-}
scaleAndAccumulateModuleApplicative ::
(Module.C a v, Applicative f) =>
(a, f v) -> (f v, f v -> f v)
scaleAndAccumulateModuleApplicative :: forall a v (f :: * -> *).
(C a v, Applicative f) =>
(a, f v) -> (f v, f v -> f v)
scaleAndAccumulateModuleApplicative (a
a,f v
x) =
let ax :: f v
ax = (v -> v) -> f v -> f v
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aa -> v -> v
forall a v. C a v => a -> v -> v
*>) f v
x
in (f v
ax, (v -> v -> v) -> f v -> f v -> f v
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 v -> v -> v
forall a. C a => a -> a -> a
(+) f v
ax)
newtype MAC a v x = MAC {forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac :: (a,v) -> (x, v -> x)}
{-# INLINE element #-}
element ::
(C a x) =>
(v -> x) -> MAC a v x
element :: forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
f =
((a, v) -> (x, v -> x)) -> MAC a v x
forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC (((a, v) -> (x, v -> x)) -> MAC a v x)
-> ((a, v) -> (x, v -> x)) -> MAC a v x
forall a b. (a -> b) -> a -> b
$ \(a
a,v
x) ->
((x -> x) -> v -> x) -> (x, x -> x) -> (x, v -> x)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ((x -> x) -> (v -> x) -> v -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
.v -> x
f) ((x, x -> x) -> (x, v -> x)) -> (x, x -> x) -> (x, v -> x)
forall a b. (a -> b) -> a -> b
$ (a, x) -> (x, x -> x)
forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate (a
a, v -> x
f v
x)
instance Functor (MAC a v) where
{-# INLINE fmap #-}
fmap :: forall a b. (a -> b) -> MAC a v a -> MAC a v b
fmap a -> b
f (MAC (a, v) -> (a, v -> a)
x) =
((a, v) -> (b, v -> b)) -> MAC a v b
forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC (((a, v) -> (b, v -> b)) -> MAC a v b)
-> ((a, v) -> (b, v -> b)) -> MAC a v b
forall a b. (a -> b) -> a -> b
$ (a -> b, (v -> a) -> v -> b) -> (a, v -> a) -> (b, v -> b)
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (a -> b
f, (a -> b
f (a -> b) -> (v -> a) -> v -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) ((a, v -> a) -> (b, v -> b))
-> ((a, v) -> (a, v -> a)) -> (a, v) -> (b, v -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, v) -> (a, v -> a)
x
instance Applicative (MAC a v) where
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
pure :: forall a. a -> MAC a v a
pure a
x = ((a, v) -> (a, v -> a)) -> MAC a v a
forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC (((a, v) -> (a, v -> a)) -> MAC a v a)
-> ((a, v) -> (a, v -> a)) -> MAC a v a
forall a b. (a -> b) -> a -> b
$ (a, v -> a) -> (a, v) -> (a, v -> a)
forall a b. a -> b -> a
const (a
x, a -> v -> a
forall a b. a -> b -> a
const a
x)
MAC (a, v) -> (a -> b, v -> a -> b)
f <*> :: forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
<*> MAC (a, v) -> (a, v -> a)
x =
((a, v) -> (b, v -> b)) -> MAC a v b
forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC (((a, v) -> (b, v -> b)) -> MAC a v b)
-> ((a, v) -> (b, v -> b)) -> MAC a v b
forall a b. (a -> b) -> a -> b
$ \(a, v)
av ->
let (a
xav,v -> a
add) = (a, v) -> (a, v -> a)
x (a, v)
av
(a -> b
g,v -> a -> b
fadd) = (a, v) -> (a -> b, v -> a -> b)
f (a, v)
av
in (a -> b
g a
xav, \v
y -> v -> a -> b
fadd v
y (v -> a
add v
y))
{-# INLINE makeMac #-}
makeMac ::
(C a x) =>
(x -> v) ->
(v -> x) ->
(a,v) -> (v, v -> v)
makeMac :: forall a x v.
C a x =>
(x -> v) -> (v -> x) -> (a, v) -> (v, v -> v)
makeMac x -> v
cons v -> x
x =
MAC a v v -> (a, v) -> (v, v -> v)
forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac (MAC a v v -> (a, v) -> (v, v -> v))
-> MAC a v v -> (a, v) -> (v, v -> v)
forall a b. (a -> b) -> a -> b
$ (x -> v) -> MAC a v (x -> v)
forall a. a -> MAC a v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> v
cons MAC a v (x -> v) -> MAC a v x -> MAC a v v
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> x) -> MAC a v x
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
x
{-# INLINE makeMac2 #-}
makeMac2 ::
(C a x, C a y) =>
(x -> y -> v) ->
(v -> x) -> (v -> y) ->
(a,v) -> (v, v -> v)
makeMac2 :: forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 x -> y -> v
cons v -> x
x v -> y
y =
MAC a v v -> (a, v) -> (v, v -> v)
forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac (MAC a v v -> (a, v) -> (v, v -> v))
-> MAC a v v -> (a, v) -> (v, v -> v)
forall a b. (a -> b) -> a -> b
$ (x -> y -> v) -> MAC a v (x -> y -> v)
forall a. a -> MAC a v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> y -> v
cons MAC a v (x -> y -> v) -> MAC a v x -> MAC a v (y -> v)
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> x) -> MAC a v x
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
x MAC a v (y -> v) -> MAC a v y -> MAC a v v
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> y) -> MAC a v y
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> y
y
{-# INLINE makeMac3 #-}
makeMac3 ::
(C a x, C a y, C a z) =>
(x -> y -> z -> v) ->
(v -> x) -> (v -> y) -> (v -> z) ->
(a,v) -> (v, v -> v)
makeMac3 :: forall a x y z v.
(C a x, C a y, C a z) =>
(x -> y -> z -> v)
-> (v -> x) -> (v -> y) -> (v -> z) -> (a, v) -> (v, v -> v)
makeMac3 x -> y -> z -> v
cons v -> x
x v -> y
y v -> z
z =
MAC a v v -> (a, v) -> (v, v -> v)
forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac (MAC a v v -> (a, v) -> (v, v -> v))
-> MAC a v v -> (a, v) -> (v, v -> v)
forall a b. (a -> b) -> a -> b
$ (x -> y -> z -> v) -> MAC a v (x -> y -> z -> v)
forall a. a -> MAC a v a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> y -> z -> v
cons MAC a v (x -> y -> z -> v) -> MAC a v x -> MAC a v (y -> z -> v)
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> x) -> MAC a v x
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
x MAC a v (y -> z -> v) -> MAC a v y -> MAC a v (z -> v)
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> y) -> MAC a v y
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> y
y MAC a v (z -> v) -> MAC a v z -> MAC a v v
forall a b. MAC a v (a -> b) -> MAC a v a -> MAC a v b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> z) -> MAC a v z
forall a x v. C a x => (v -> x) -> MAC a v x
element v -> z
z