{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{- |
Interpolation buffers.
-}
module FRP.Rhine.ResamplingBuffer.Interpolation where

-- containers
import Data.Sequence

-- simple-affine-space
import Data.VectorSpace

-- rhine
import FRP.Rhine.ClSF
import FRP.Rhine.ResamplingBuffer
import FRP.Rhine.ResamplingBuffer.KeepLast
import FRP.Rhine.ResamplingBuffer.Util

-- | A simple linear interpolation based on the last calculated position and velocity.
linear ::
  ( Monad m
  , Clock m cl1
  , Clock m cl2
  , VectorSpace v s
  , Num s
  , s ~ Diff (Time cl1)
  , s ~ Diff (Time cl2)
  ) =>
  -- | The initial velocity (derivative of the signal)
  v ->
  -- | The initial position
  v ->
  ResamplingBuffer m cl1 cl2 v v
linear :: forall (m :: Type -> Type) cl1 cl2 v s.
(Monad m, Clock m cl1, Clock m cl2, VectorSpace v s, Num s,
 s ~ Diff (Time cl1), s ~ Diff (Time cl2)) =>
v -> v -> ResamplingBuffer m cl1 cl2 v v
linear v
initVelocity v
initPosition =
  (forall (m :: Type -> Type) v s td.
(Monad m, VectorSpace v s, s ~ Diff td) =>
v -> BehaviorF m td v v
derivativeFrom v
initPosition forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: Type -> Type) cl a. Monad m => ClSF m cl a a
clId) forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: Type -> Type) cl b a.
Monad m =>
(TimeInfo cl -> b) -> ClSF m cl a b
timeInfoOf forall cl. TimeInfo cl -> Diff (Time cl)
sinceInit
    forall (m :: Type -> Type) cl1 a b cl2 c.
Monad m =>
ClSF m cl1 a b
-> ResamplingBuffer m cl1 cl2 b c -> ResamplingBuffer m cl1 cl2 a c
^->> forall (m :: Type -> Type) a cl1 cl2.
Monad m =>
a -> ResamplingBuffer m cl1 cl2 a a
keepLast ((v
initVelocity, v
initPosition), s
0)
      forall (m :: Type -> Type) cl1 cl2 a b c.
Monad m =>
ResamplingBuffer m cl1 cl2 a b
-> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c
>>-^ proc ((v
velocity, v
lastPosition), s
sinceInit1) -> do
        s
sinceInit2 <- forall (m :: Type -> Type) cl b a.
Monad m =>
(TimeInfo cl -> b) -> ClSF m cl a b
timeInfoOf forall cl. TimeInfo cl -> Diff (Time cl)
sinceInit -< ()
        let diff :: s
diff = s
sinceInit2 forall a. Num a => a -> a -> a
- s
sinceInit1
        forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< v
lastPosition forall v a. VectorSpace v a => v -> v -> v
^+^ s
diff forall v a. VectorSpace v a => a -> v -> v
*^ v
velocity

{- |
sinc-Interpolation, or Whittaker-Shannon-Interpolation.

The incoming signal is strictly bandlimited
by the frequency at which @cl1@ ticks.
Each incoming value is hulled in a sinc function,
these are added and sampled at @cl2@'s ticks.
In order not to produce a space leak,
the buffer only remembers the past values within a given window,
which should be chosen much larger than the average time between @cl1@'s ticks.
-}
sinc ::
  ( Monad m
  , Clock m cl1
  , Clock m cl2
  , VectorSpace v s
  , Ord s
  , Floating s
  , s ~ Diff (Time cl1)
  , s ~ Diff (Time cl2)
  ) =>
  -- | The size of the interpolation window
  --   (for how long in the past to remember incoming values)
  s ->
  ResamplingBuffer m cl1 cl2 v v
sinc :: forall (m :: Type -> Type) cl1 cl2 v s.
(Monad m, Clock m cl1, Clock m cl2, VectorSpace v s, Ord s,
 Floating s, s ~ Diff (Time cl1), s ~ Diff (Time cl2)) =>
s -> ResamplingBuffer m cl1 cl2 v v
sinc s
windowSize =
  forall (m :: Type -> Type) cl a.
(Monad m, Ord (Diff (Time cl)), TimeDomain (Time cl)) =>
Diff (Time cl) -> ClSF m cl a (Seq (TimeInfo cl, a))
historySince s
windowSize
    forall (m :: Type -> Type) cl1 a b cl2 c.
Monad m =>
ClSF m cl1 a b
-> ResamplingBuffer m cl1 cl2 b c -> ResamplingBuffer m cl1 cl2 a c
^->> forall (m :: Type -> Type) a cl1 cl2.
Monad m =>
a -> ResamplingBuffer m cl1 cl2 a a
keepLast forall a. Seq a
empty forall (m :: Type -> Type) cl1 cl2 a b c.
Monad m =>
ResamplingBuffer m cl1 cl2 a b
-> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c
>>-^ proc Seq (TimeInfo cl1, v)
as -> do
      s
sinceInit2 <- forall (m :: Type -> Type) cl a.
Monad m =>
ClSF m cl a (Diff (Time cl))
sinceInitS -< ()
      forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< Seq v -> v
vectorSum forall a b. (a -> b) -> a -> b
$ forall {cl} {v}.
(Floating (Diff (Time cl)), VectorSpace v (Diff (Time cl))) =>
Diff (Time cl) -> (TimeInfo cl, v) -> v
mkSinc s
sinceInit2 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (TimeInfo cl1, v)
as
  where
    mkSinc :: Diff (Time cl) -> (TimeInfo cl, v) -> v
mkSinc Diff (Time cl)
sinceInit2 (TimeInfo {Diff (Time cl)
Time cl
Tag cl
tag :: forall cl. TimeInfo cl -> Tag cl
absolute :: forall cl. TimeInfo cl -> Time cl
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
tag :: Tag cl
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
..}, v
as) =
      let t :: Diff (Time cl)
t = forall a. Floating a => a
pi forall a. Num a => a -> a -> a
* (Diff (Time cl)
sinceInit2 forall a. Num a => a -> a -> a
- Diff (Time cl)
sinceInit) forall a. Fractional a => a -> a -> a
/ Diff (Time cl)
sinceLast
       in (forall a. Floating a => a -> a
sin Diff (Time cl)
t forall a. Fractional a => a -> a -> a
/ Diff (Time cl)
t) forall v a. VectorSpace v a => a -> v -> v
*^ v
as
    vectorSum :: Seq v -> v
vectorSum = forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall v a. VectorSpace v a => v -> v -> v
(^+^) forall v a. VectorSpace v a => v
zeroVector

-- TODO Do we want to give initial values?

{- | Interpolates the signal with Hermite splines,
   using 'threePointDerivative'.

   Caution: In order to calculate the derivatives of the incoming signal,
   it has to be delayed by two ticks of @cl1@.
   In a non-realtime situation, a higher quality is achieved
   if the ticks of @cl2@ are delayed by two ticks of @cl1@.
-}
cubic ::
  ( Monad m
  , VectorSpace v s
  , Floating v
  , Eq v
  , Fractional s
  , s ~ Diff (Time cl1)
  , s ~ Diff (Time cl2)
  ) =>
  ResamplingBuffer m cl1 cl2 v v
{- FOURMOLU_DISABLE -}
cubic :: forall (m :: Type -> Type) v s cl1 cl2.
(Monad m, VectorSpace v s, Floating v, Eq v, Fractional s,
 s ~ Diff (Time cl1), s ~ Diff (Time cl2)) =>
ResamplingBuffer m cl1 cl2 v v
cubic =
  ((forall (m :: Type -> Type) a. Monad m => a -> MSF m a a
iPre forall v a. VectorSpace v a => v
zeroVector forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: Type -> Type) v s td.
(Monad m, VectorSpace v s, s ~ Diff td, Num s) =>
BehaviorF m td v v
threePointDerivative) forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall (m :: Type -> Type) cl a.
Monad m =>
ClSF m cl a (Diff (Time cl))
sinceInitS forall (cat :: Type -> Type -> Type) a b c.
Category cat =>
cat a b -> cat b c -> cat a c
>-> forall (m :: Type -> Type) a. Monad m => a -> MSF m a a
iPre s
0))
    forall (cat :: Type -> Type -> Type) a b c.
Category cat =>
cat a b -> cat b c -> cat a c
>-> (forall (m :: Type -> Type) cl a. Monad m => ClSF m cl a a
clId forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: Type -> Type) a. Monad m => a -> MSF m a a
iPre (forall v a. VectorSpace v a => v
zeroVector, s
0))
   forall (m :: Type -> Type) cl1 a b cl2 c.
Monad m =>
ClSF m cl1 a b
-> ResamplingBuffer m cl1 cl2 b c -> ResamplingBuffer m cl1 cl2 a c
^->> forall (m :: Type -> Type) a cl1 cl2.
Monad m =>
a -> ResamplingBuffer m cl1 cl2 a a
keepLast ((forall v a. VectorSpace v a => v
zeroVector, s
0), (forall v a. VectorSpace v a => v
zeroVector, s
0))
   forall (m :: Type -> Type) cl1 cl2 a b c.
Monad m =>
ResamplingBuffer m cl1 cl2 a b
-> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c
>>-^ proc (((v
dv, v
v), s
t1), ((v
dv', v
v'), s
t1')) -> do
     s
t2 <- forall (m :: Type -> Type) cl a.
Monad m =>
ClSF m cl a (Diff (Time cl))
sinceInitS -< ()
     let
       t :: s
t        = (s
t1 forall a. Num a => a -> a -> a
- s
t1') forall a. Fractional a => a -> a -> a
/ (s
t2 forall a. Num a => a -> a -> a
- s
t1')
       tsquared :: s
tsquared = s
t forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
2
       tcubed :: s
tcubed   = s
t forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
3
       vInter :: v
vInter   = ( s
2 forall a. Num a => a -> a -> a
* s
tcubed forall a. Num a => a -> a -> a
- s
3 forall a. Num a => a -> a -> a
* s
tsquared     forall a. Num a => a -> a -> a
+ s
1) forall v a. VectorSpace v a => a -> v -> v
*^  v
v'
              forall v a. VectorSpace v a => v -> v -> v
^+^ (     s
tcubed forall a. Num a => a -> a -> a
- s
2 forall a. Num a => a -> a -> a
* s
tsquared forall a. Num a => a -> a -> a
+ s
t    ) forall v a. VectorSpace v a => a -> v -> v
*^ v
dv'
              forall v a. VectorSpace v a => v -> v -> v
^+^ (-s
2 forall a. Num a => a -> a -> a
* s
tcubed forall a. Num a => a -> a -> a
+ s
3 forall a. Num a => a -> a -> a
* s
tsquared        ) forall v a. VectorSpace v a => a -> v -> v
*^  v
v
              forall v a. VectorSpace v a => v -> v -> v
^+^ (     s
tcubed forall a. Num a => a -> a -> a
-     s
tsquared        ) forall v a. VectorSpace v a => a -> v -> v
*^ v
dv
     forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< v
vInter
{- FOURMOLU_ENABLE -}