{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
See NumericPrelude.AffineSpace for design discussion.
-}
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 ()

{- |
Given that @scale zero v == Additive.zero@
this type class is equivalent to Module in the following way:

> scaleAndAccumulate (a,x) =
>    let ax = a *> x
>    in  (ax, (ax+))

(see implementation of 'scaleAndAccumulateModule')
and

> x+y = scaleAccumulate one y $ scale one x
> zero = scale zero x
> s*>x = scale s x

But this redundancy is only because of a lack of the type system
or lack of my imagination how to solve it better.
Use this type class for all kinds of interpolation,
that is where addition and scaling alone make no sense.

I intended to name this class AffineSpace,
because all interpolations should be affine combinations.
This property is equivalent to interpolations that preserve constant functions.
However, I cannot easily assert this property
and I'm not entirely sure
that all reasonable interpolations are actually affine.

Early versions had a @zero@ method,
but this is against the idea of interpolation.
For implementing @zero@ we needed a @Maybe@ wrapper
for interpolation of @StorableVector@s.
Btw. having @zero@ instead of @scale@ is also inefficient,
since every sum must include a zero summand,
which works well only when the optimizer
simplifies addition with a constant.

We use only one class method
that contains actually two methods:
@scale@ and @scaleAccumulate@.
We expect that instances are always defined on record types
lifting interpolations from scalars to records.
This should be done using 'makeMac' and friends
or the 'MAC' type and the 'Applicative' interface
for records with many elements.
-}
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 = forall a. C a => (a, a) -> (a, a -> a)
scaleAndAccumulateRing

instance C Double Double where
   {-# INLINE scaleAndAccumulate #-}
   scaleAndAccumulate :: (Double, Double) -> (Double, Double -> Double)
scaleAndAccumulate = 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 =
      forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 forall a. a -> a -> T a
(Complex.+:) forall a. T a -> a
Complex.real 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 = 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 = forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 (,) forall a b. (a, b) -> a
fst 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 = 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 (,,) forall a b c. (a, b, c) -> a
fst3 forall a b c. (a, b, c) -> b
snd3 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 =
      forall a x y v.
(C a x, C a y) =>
(x -> y -> v) -> (v -> x) -> (v -> y) -> (a, v) -> (v, v -> v)
makeMac2 forall a. a -> a -> T a
Stereo.cons forall a. T a -> a
Stereo.left 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 = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate

{- |
Infix variant of 'scaleAccumulate'.
-}
{-# INLINE (+.*) #-}
(+.*) :: C a v => v -> (a,v) -> v
+.* :: forall a v. C a v => v -> (a, v) -> v
(+.*) = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) =
   forall a v. C a v => (a, v) -> v -> v
scaleAccumulate (forall a. C a => a
oneforall a. C a => a -> a -> a
-a
a, v
x) forall a b. (a -> b) -> a -> b
$
   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) =
   forall acc x. (acc -> x -> acc) -> acc -> T x -> acc
Sig.foldL (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a v. C a v => (a, v) -> v -> v
scaleAccumulate) (forall a v. C a v => (a, v) -> v
scale (a
a,v
v)) forall a b. (a -> b) -> a -> b
$
   forall a b. T a -> T b -> T (a, b)
Sig.zip T a
as T v
vs


-- * convenience functions for defining scaleAndAccumulate

{-# 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 forall a. C a => a -> a -> a
* a
x
   in  (a
ax, (a
axforall 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 forall a v. C a v => a -> v -> v
*> v
x
   in  (v
ax, (v
axforall 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a v. C a v => (a, v) -> (v, v -> v)
scaleAndAccumulate a
a) f v
x
   in  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst f (v, v -> v)
ax, (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd f (v, v -> v)
ax 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aforall a. C a => a -> a -> a
*) f a
x
   in  (f a
ax, forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aforall a v. C a v => a -> v -> v
*>) f v
x
   in  (f v
ax, forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. C a => a -> a -> a
(+) f v
ax)


{- |
A special reader monad.
-}
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 =
   forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC forall a b. (a -> b) -> a -> b
$ \(a
a,v
x) ->
      forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (forall b c a. (b -> c) -> (a -> b) -> a -> c
.v -> x
f) forall a b. (a -> b) -> a -> b
$ 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) =
      forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC forall a b. (a -> b) -> a -> b
$ forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (a -> b
f, (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.)) 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 = forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (a
x, 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 =
      forall a v x. ((a, v) -> (x, v -> x)) -> MAC a v x
MAC 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 =
   forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> v
cons forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 =
   forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> y -> v
cons forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 =
   forall a v x. MAC a v x -> (a, v) -> (x, v -> x)
runMac forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure x -> y -> z -> v
cons forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a x v. C a x => (v -> x) -> MAC a v x
element v -> x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a x v. C a x => (v -> x) -> MAC a v x
element v -> y
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a x v. C a x => (v -> x) -> MAC a v x
element v -> z
z