{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

{- |
Implements pure clocks ticking at
every multiple of a fixed number of steps,
and a deterministic schedule for such clocks.
-}
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."
            ]