{-# 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 Control.Arrow
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
import GHC.TypeLits

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

-- monad-schedule
import Control.Monad.Schedule.Class
import Control.Monad.Schedule.Trans (ScheduleT, wait)

-- automaton
import Data.Automaton (accumulateWith, arrM)

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

{- | 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 = FixedStep n -> Integer
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal FixedStep n
fixedStep

instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n) where
  type Time (FixedStep n) = Integer
  type Tag (FixedStep n) = ()
  initClock :: FixedStep n
-> RunningClockInit
     (ScheduleT Integer m) (Time (FixedStep n)) (Tag (FixedStep n))
initClock FixedStep n
cl =
    let step :: Integer
step = FixedStep n -> Integer
forall (n :: Nat). FixedStep n -> Integer
stepsize FixedStep n
cl
     in (Automaton (ScheduleT Integer m) () (Integer, ()), Integer)
-> FreeT
     (Wait Integer)
     m
     (Automaton (ScheduleT Integer m) () (Integer, ()), Integer)
forall a. a -> FreeT (Wait Integer) m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
          ( (() -> Integer) -> Automaton (ScheduleT Integer m) () Integer
forall b c. (b -> c) -> Automaton (ScheduleT Integer m) b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (Integer -> () -> Integer
forall a b. a -> b -> a
const Integer
step)
              Automaton (ScheduleT Integer m) () Integer
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
-> Automaton (ScheduleT Integer 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 -> Integer)
-> Integer -> Automaton (ScheduleT Integer m) Integer Integer
forall (m :: Type -> Type) a b.
Monad m =>
(a -> b -> b) -> b -> Automaton m a b
accumulateWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
0
              Automaton (ScheduleT Integer m) Integer Integer
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
-> Automaton (ScheduleT Integer m) Integer (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 -> FreeT (Wait Integer) m (Integer, ()))
-> Automaton (ScheduleT Integer m) Integer (Integer, ())
forall (m :: Type -> Type) a b.
Functor m =>
(a -> m b) -> Automaton m a b
arrM (\Integer
time -> Integer -> ScheduleT Integer m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait Integer
step ScheduleT Integer m ()
-> (Integer, ()) -> FreeT (Wait Integer) m (Integer, ())
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> (Integer
time, ()))
          , Integer
0
          )

instance GetClockProxy (FixedStep n)

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

{- | Resample into a 'FixedStep' clock that ticks @n@ times slower,
  by collecting all values into a vector.
-}
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 = 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 b c.
(b -> c)
-> Automaton (ReaderT (TimeInfo (FixedStep (n * k))) m) b c
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]
"downsampleFixedStep: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"