{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.Interpolation (
   T(Cons, margin, func),
   Margin(marginOffset, marginNumber),
   cons,
   number,
   offset,
   PrefixReader,
   getNode,
   fromPrefixReader,
   constant,
   ) where

import qualified Synthesizer.State.Signal  as Sig

import Control.Monad.Trans.State (StateT(StateT), evalStateT, )
import Control.Monad.Trans.Writer (Writer, writer, runWriter, )
import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )
import Data.Monoid (Sum(Sum), )

import qualified Test.QuickCheck as QC

import NumericPrelude.Numeric
import NumericPrelude.Base




{- | interpolation as needed for resampling -}
data T t y =
  Cons {
    forall t y. T t y -> Margin
margin :: !Margin,
    forall t y. T t y -> t -> T y -> y
func   :: !(t -> Sig.T y -> y)
  }

data Margin =
    Margin {
       Margin -> Int
marginNumber :: !Int,
          -- ^ interpolation requires a total number of 'number'
       Margin -> Int
marginOffset :: !Int
          -- ^ interpolation requires 'offset' values before the current
    }
   deriving (Int -> Margin -> ShowS
[Margin] -> ShowS
Margin -> String
(Int -> Margin -> ShowS)
-> (Margin -> String) -> ([Margin] -> ShowS) -> Show Margin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Margin -> ShowS
showsPrec :: Int -> Margin -> ShowS
$cshow :: Margin -> String
show :: Margin -> String
$cshowList :: [Margin] -> ShowS
showList :: [Margin] -> ShowS
Show, Margin -> Margin -> Bool
(Margin -> Margin -> Bool)
-> (Margin -> Margin -> Bool) -> Eq Margin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Margin -> Margin -> Bool
== :: Margin -> Margin -> Bool
$c/= :: Margin -> Margin -> Bool
/= :: Margin -> Margin -> Bool
Eq)

instance QC.Arbitrary Margin where
   arbitrary :: Gen Margin
arbitrary = (Int -> Int -> Margin) -> Gen Int -> Gen Int -> Gen Margin
forall a b c. (a -> b -> c) -> Gen a -> Gen b -> Gen c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Margin
Margin (Int -> Int
forall a. C a => a -> a
abs (Int -> Int) -> Gen Int -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary) (Int -> Int
forall a. C a => a -> a
abs (Int -> Int) -> Gen Int -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary)


cons :: Int -> Int -> (t -> Sig.T y -> y) -> T t y
cons :: forall t y. Int -> Int -> (t -> T y -> y) -> T t y
cons Int
num Int
off =
   Margin -> (t -> T y -> y) -> T t y
forall t y. Margin -> (t -> T y -> y) -> T t y
Cons (Int -> Int -> Margin
Margin Int
num Int
off)

number :: T t y -> Int
number :: forall t y. T t y -> Int
number = Margin -> Int
marginNumber (Margin -> Int) -> (T t y -> Margin) -> T t y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T t y -> Margin
forall t y. T t y -> Margin
margin

offset :: T t y -> Int
offset :: forall t y. T t y -> Int
offset = Margin -> Int
marginOffset (Margin -> Int) -> (T t y -> Margin) -> T t y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T t y -> Margin
forall t y. T t y -> Margin
margin



{-* Different kinds of interpolation -}

{-** Hard-wired interpolations -}

{-
Applicative composition of two applicative functors,
namely @Writer@ and @StateT Maybe@.
We could also use (.:) from TypeCompose.
-}
newtype PrefixReader y a =
   PrefixReader (Writer (Sum Int) (StateT (Sig.T y) Maybe a))

instance Functor (PrefixReader y) where
   {-# INLINE fmap #-}
   fmap :: forall a b. (a -> b) -> PrefixReader y a -> PrefixReader y b
fmap a -> b
f (PrefixReader Writer (Sum Int) (StateT (T y) Maybe a)
m) =
      Writer (Sum Int) (StateT (T y) Maybe b) -> PrefixReader y b
forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader ((StateT (T y) Maybe a -> StateT (T y) Maybe b)
-> Writer (Sum Int) (StateT (T y) Maybe a)
-> Writer (Sum Int) (StateT (T y) Maybe b)
forall a b.
(a -> b)
-> WriterT (Sum Int) Identity a -> WriterT (Sum Int) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> StateT (T y) Maybe a -> StateT (T y) Maybe b
forall a b.
(a -> b) -> StateT (T y) Maybe a -> StateT (T y) Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Writer (Sum Int) (StateT (T y) Maybe a)
m)

instance Applicative (PrefixReader y) where
   {-# INLINE pure #-}
   {-# INLINE (<*>) #-}
   pure :: forall a. a -> PrefixReader y a
pure = Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader (Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a)
-> (a -> Writer (Sum Int) (StateT (T y) Maybe a))
-> a
-> PrefixReader y a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (T y) Maybe a -> Writer (Sum Int) (StateT (T y) Maybe a)
forall a. a -> WriterT (Sum Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateT (T y) Maybe a -> Writer (Sum Int) (StateT (T y) Maybe a))
-> (a -> StateT (T y) Maybe a)
-> a
-> Writer (Sum Int) (StateT (T y) Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT (T y) Maybe a
forall a. a -> StateT (T y) Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   (PrefixReader Writer (Sum Int) (StateT (T y) Maybe (a -> b))
f) <*> :: forall a b.
PrefixReader y (a -> b) -> PrefixReader y a -> PrefixReader y b
<*> (PrefixReader Writer (Sum Int) (StateT (T y) Maybe a)
x) =
       Writer (Sum Int) (StateT (T y) Maybe b) -> PrefixReader y b
forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader ((StateT (T y) Maybe (a -> b)
 -> StateT (T y) Maybe a -> StateT (T y) Maybe b)
-> Writer (Sum Int) (StateT (T y) Maybe (a -> b))
-> Writer (Sum Int) (StateT (T y) Maybe a)
-> Writer (Sum Int) (StateT (T y) Maybe b)
forall a b c.
(a -> b -> c)
-> WriterT (Sum Int) Identity a
-> WriterT (Sum Int) Identity b
-> WriterT (Sum Int) Identity c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 StateT (T y) Maybe (a -> b)
-> StateT (T y) Maybe a -> StateT (T y) Maybe b
forall a b.
StateT (T y) Maybe (a -> b)
-> StateT (T y) Maybe a -> StateT (T y) Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) Writer (Sum Int) (StateT (T y) Maybe (a -> b))
f Writer (Sum Int) (StateT (T y) Maybe a)
x)


{-# INLINE getNode #-}
getNode :: PrefixReader y y
getNode :: forall y. PrefixReader y y
getNode =
   Writer (Sum Int) (StateT (T y) Maybe y) -> PrefixReader y y
forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader (Writer (Sum Int) (StateT (T y) Maybe y) -> PrefixReader y y)
-> Writer (Sum Int) (StateT (T y) Maybe y) -> PrefixReader y y
forall a b. (a -> b) -> a -> b
$ (StateT (T y) Maybe y, Sum Int)
-> Writer (Sum Int) (StateT (T y) Maybe y)
forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer ((T y -> Maybe (y, T y)) -> StateT (T y) Maybe y
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT T y -> Maybe (y, T y)
forall a. T a -> Maybe (a, T a)
Sig.viewL, Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)

{-# INLINE fromPrefixReader #-}
fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y
fromPrefixReader :: forall y t. String -> Int -> PrefixReader y (t -> y) -> T t y
fromPrefixReader String
name Int
off (PrefixReader Writer (Sum Int) (StateT (T y) Maybe (t -> y))
pr) =
   let (StateT (T y) Maybe (t -> y)
parser, Sum Int
count) = Writer (Sum Int) (StateT (T y) Maybe (t -> y))
-> (StateT (T y) Maybe (t -> y), Sum Int)
forall w a. Writer w a -> (a, w)
runWriter Writer (Sum Int) (StateT (T y) Maybe (t -> y))
pr
   in  Int -> Int -> (t -> T y -> y) -> T t y
forall t y. Int -> Int -> (t -> T y -> y) -> T t y
cons Int
count Int
off
          (\t
t T y
xs ->
              y -> ((t -> y) -> y) -> Maybe (t -> y) -> y
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                 (String -> y
forall a. HasCallStack => String -> a
error (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" interpolation: not enough nodes"))
                 ((t -> y) -> t -> y
forall a b. (a -> b) -> a -> b
$t
t)
                 (StateT (T y) Maybe (t -> y) -> T y -> Maybe (t -> y)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (T y) Maybe (t -> y)
parser T y
xs))

{-|
Consider the signal to be piecewise constant,
where the leading value is used for filling the interval [0,1).
-}
{-# INLINE constant #-}
constant :: T t y
constant :: forall t y. T t y
constant =
   String -> Int -> PrefixReader y (t -> y) -> T t y
forall y t. String -> Int -> PrefixReader y (t -> y) -> T t y
fromPrefixReader String
"constant" Int
0 (y -> t -> y
forall a b. a -> b -> a
const (y -> t -> y) -> PrefixReader y y -> PrefixReader y (t -> y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrefixReader y y
forall y. PrefixReader y y
getNode)