{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Margin] -> ShowS
$cshowList :: [Margin] -> ShowS
show :: Margin -> String
$cshow :: Margin -> String
showsPrec :: Int -> Margin -> ShowS
$cshowsPrec :: Int -> Margin -> ShowS
Show, Margin -> Margin -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Margin -> Margin -> Bool
$c/= :: Margin -> Margin -> Bool
== :: Margin -> Margin -> Bool
$c== :: Margin -> Margin -> Bool
Eq)

instance QC.Arbitrary Margin where
   arbitrary :: Gen Margin
arbitrary = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Int -> Int -> Margin
Margin (forall a. C a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary) (forall a. C a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =
   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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
      forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
       forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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 =
   forall y a.
Writer (Sum Int) (StateT (T y) Maybe a) -> PrefixReader y a
PrefixReader forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer (forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a. T a -> Maybe (a, T a)
Sig.viewL, 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) = forall w a. Writer w a -> (a, w)
runWriter Writer (Sum Int) (StateT (T y) Maybe (t -> y))
pr
   in  forall t y. Int -> Int -> (t -> T y -> y) -> T t y
cons Int
count Int
off
          (\t
t T y
xs ->
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                 (forall a. HasCallStack => String -> a
error (String
name forall a. [a] -> [a] -> [a]
++ String
" interpolation: not enough nodes"))
                 (forall a b. (a -> b) -> a -> b
$t
t)
                 (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 =
   forall y t. String -> Int -> PrefixReader y (t -> y) -> T t y
fromPrefixReader String
"constant" Int
0 (forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall y. PrefixReader y y
getNode)