{- |
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 :: forall (n :: Nat). FixedStep n -> Integer
stepsize fixedStep :: FixedStep n
fixedStep@FixedStep n
FixedStep = 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 = forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ( forall n (m :: Type -> Type) a. (Num n, Monad m) => MSF m a n
count forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall a. Num a => a -> a -> a
* forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl)
      forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (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 :: forall (m :: Type -> Type) (n1 :: Nat) (n2 :: Nat).
Monad m =>
Schedule m (FixedStep n1) (FixedStep n2)
scheduleFixedStep = 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 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 = forall (m :: Type -> Type) a. Monad m => a -> m a
return (MStream m (Integer, Either () ())
msf, b
0)
    where
      n1 :: Integer
n1 = forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl1
      n2 :: Integer
n2 = forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl2
      msf :: MStream m (Integer, Either () ())
msf = forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS forall a b. (a -> b) -> a -> b
$ proc ()
_ -> do
        Integer
k <- forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall a. Num a => a -> a -> a
+Integer
1) forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< forall n (m :: Type -> Type) a. (Num n, Monad m) => MSF m a n
count -< ()
        forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA                 -< [ (Integer
k, forall a b. a -> Either a b
Left  ()) | Integer
k forall a. Integral a => a -> a -> a
`mod` Integer
n1 forall a. Eq a => a -> a -> Bool
== Integer
0 ]
                                forall a. [a] -> [a] -> [a]
++ [ (Integer
k, forall a b. b -> Either a b
Right ()) | Integer
k forall a. Integral a => a -> a -> a
`mod` Integer
n2 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 :: forall (n :: Nat) (m :: Type -> Type) (k :: Nat) a.
(KnownNat n, Monad m) =>
ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a)
downsampleFixedStep = forall (m :: Type -> Type) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect 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
>>-^ forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall {a}. Maybe a -> a
assumeSize)
  where
    assumeSize :: Maybe a -> a
assumeSize = forall a. a -> Maybe a -> a
fromMaybe forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error 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."
      ]