{- |
Implements pure clocks ticking at
every multiple of a fixed number of steps,
and a deterministic schedule for such clocks.
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module FRP.Rhine.Clock.FixedStep where


-- base
import Data.Maybe (fromMaybe)
import GHC.TypeLits

-- vector-sized
import Data.Vector.Sized (Vector, fromList)

-- dunai
import Data.MonadicStreamFunction.Async (concatS)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.ResamplingBuffer
import FRP.Rhine.ResamplingBuffer.Collect
import FRP.Rhine.ResamplingBuffer.Util
import FRP.Rhine.Schedule

-- | A pure (side effect free) clock with fixed step size,
--   i.e. ticking at multiples of 'n'.
--   The tick rate is in the type signature,
--   which prevents composition of signals at different rates.
data FixedStep (n :: Nat) where
  FixedStep :: KnownNat n => FixedStep n -- TODO Does the constraint bring any benefit?

-- | Extract the type-level natural number as an integer.
stepsize :: FixedStep n -> Integer
stepsize :: FixedStep n -> Integer
stepsize fixedStep :: FixedStep n
fixedStep@FixedStep n
FixedStep = FixedStep n -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal FixedStep n
fixedStep

instance Monad m => Clock m (FixedStep n) where
  type Time (FixedStep n) = Integer
  type Tag  (FixedStep n) = ()
  initClock :: FixedStep n
-> RunningClockInit m (Time (FixedStep n)) (Tag (FixedStep n))
initClock FixedStep n
cl = (MSF m () (Integer, ()), Integer)
-> m (MSF m () (Integer, ()), Integer)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ( MSF m () Integer
forall n (m :: Type -> Type) a. (Num n, Monad m) => MSF m a n
count MSF m () Integer
-> MSF m Integer (Integer, ()) -> MSF m () (Integer, ())
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Integer -> Integer) -> MSF m Integer Integer
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* FixedStep n -> Integer
forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl)
      MSF m Integer Integer
-> MSF m Integer () -> MSF m Integer (Integer, ())
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Integer -> ()) -> MSF m Integer ()
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> Integer -> ()
forall a b. a -> b -> a
const ())
    , Integer
0
    )

instance GetClockProxy (FixedStep n)

-- | A singleton clock that counts the ticks.
type Count = FixedStep 1

-- | Two 'FixedStep' clocks can always be scheduled without side effects.
scheduleFixedStep
  :: Monad m
  => Schedule m (FixedStep n1) (FixedStep n2)
scheduleFixedStep :: Schedule m (FixedStep n1) (FixedStep n2)
scheduleFixedStep = (FixedStep n1
 -> FixedStep n2
 -> RunningClockInit
      m
      (Time (FixedStep n1))
      (Either (Tag (FixedStep n1)) (Tag (FixedStep n2))))
-> Schedule m (FixedStep n1) (FixedStep n2)
forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
 -> cl2
 -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule FixedStep n1
-> FixedStep n2
-> RunningClockInit
     m
     (Time (FixedStep n1))
     (Either (Tag (FixedStep n1)) (Tag (FixedStep n2)))
forall (m :: Type -> Type) (m :: Type -> Type) b (n :: Nat)
       (n :: Nat).
(Monad m, Monad m, Num b) =>
FixedStep n
-> FixedStep n -> m (MStream m (Integer, Either () ()), b)
f where
  f :: FixedStep n
-> FixedStep n -> m (MStream m (Integer, Either () ()), b)
f FixedStep n
cl1 FixedStep n
cl2 = (MStream m (Integer, Either () ()), b)
-> m (MStream m (Integer, Either () ()), b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MStream m (Integer, Either () ())
msf, b
0)
    where
      n1 :: Integer
n1 = FixedStep n -> Integer
forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl1
      n2 :: Integer
n2 = FixedStep n -> Integer
forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl2
      msf :: MStream m (Integer, Either () ())
msf = MStream m [(Integer, Either () ())]
-> MStream m (Integer, Either () ())
forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS (MStream m [(Integer, Either () ())]
 -> MStream m (Integer, Either () ()))
-> MStream m [(Integer, Either () ())]
-> MStream m (Integer, Either () ())
forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
        Integer
k <- (Integer -> Integer) -> MSF m Integer Integer
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) MSF m Integer Integer -> MSF m () Integer -> MSF m () Integer
forall k (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< MSF m () Integer
forall n (m :: Type -> Type) a. (Num n, Monad m) => MSF m a n
count -< ()
        MSF m [(Integer, Either () ())] [(Integer, Either () ())]
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA                 -< [ (Integer
k, () -> Either () ()
forall a b. a -> Either a b
Left  ()) | Integer
k Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
n1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 ]
                                [(Integer, Either () ())]
-> [(Integer, Either () ())] -> [(Integer, Either () ())]
forall a. [a] -> [a] -> [a]
++ [ (Integer
k, () -> Either () ()
forall a b. b -> Either a b
Right ()) | Integer
k Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
n2 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 ]

-- TODO The problem is that the schedule doesn't give a guarantee where in the n ticks of the first clock the second clock will tick.
-- For this to work, it has to be the last.
-- With scheduleFixedStep, this works,
-- but the user might implement an incorrect schedule.
downsampleFixedStep
  :: (KnownNat n, Monad m)
  => ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a)
downsampleFixedStep :: ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a)
downsampleFixedStep = ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a [a]
forall (m :: Type -> Type) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a [a]
-> ClSF m (FixedStep (n * k)) [a] (Vector n a)
-> ResamplingBuffer
     m (FixedStep k) (FixedStep (n * k)) a (Vector n a)
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
>>-^ ([a] -> Vector n a) -> ClSF m (FixedStep (n * k)) [a] (Vector n a)
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ([a] -> Maybe (Vector n a)
forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList ([a] -> Maybe (Vector n a))
-> (Maybe (Vector n a) -> Vector n a) -> [a] -> Vector n a
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe (Vector n a) -> Vector n a
forall a. Maybe a -> a
assumeSize)
  where
    assumeSize :: Maybe a -> a
assumeSize = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (a -> Maybe a -> a) -> a -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"You are using an incorrectly implemented schedule"
      , [Char]
"for two FixedStep clocks."
      , [Char]
"Use a correct schedule like downsampleFixedStep."
      ]