{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{- | Utilities to run 'ClSF's at the speed of combined clocks
   when they are defined only for a constituent clock.
-}
module FRP.Rhine.ClSF.Upsample where

-- dunai
import Data.Automaton.Trans.Reader

-- rhine
import FRP.Rhine.ClSF.Core
import FRP.Rhine.Clock
import FRP.Rhine.Schedule

{- | An 'Automaton' can be given arbitrary other arguments
   that cause it to tick without doing anything
   and replicating the last output.
-}
upsampleAutomaton :: (Monad m) => b -> Automaton m a b -> Automaton m (Either arbitrary a) b
upsampleAutomaton :: forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> Automaton m a b -> Automaton m (Either arbitrary a) b
upsampleAutomaton b
b Automaton m a b
automaton = Automaton m a b
-> Automaton m (Either arbitrary a) (Either arbitrary b)
forall b c d.
Automaton m b c -> Automaton m (Either d b) (Either d c)
forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right Automaton m a b
automaton Automaton m (Either arbitrary a) (Either arbitrary b)
-> Automaton m (Either arbitrary b) b
-> Automaton m (Either arbitrary a) b
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either arbitrary b -> Either arbitrary b -> Either arbitrary b)
-> Either arbitrary b
-> Automaton m (Either arbitrary b) (Either arbitrary b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> b -> b) -> b -> Automaton m a b
accumulateWith Either arbitrary b -> Either arbitrary b -> Either arbitrary b
forall a. Semigroup a => a -> a -> a
(<>) (b -> Either arbitrary b
forall a b. b -> Either a b
Right b
b) Automaton m (Either arbitrary b) (Either arbitrary b)
-> Automaton m (Either arbitrary b) b
-> Automaton m (Either arbitrary b) b
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either arbitrary b -> b) -> Automaton m (Either arbitrary b) b
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr Either arbitrary b -> b
forall {a} {b}. Either a b -> b
fromRight
  where
    fromRight :: Either a b -> b
fromRight (Right b
b') = b
b'
    fromRight (Left a
_) = [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"fromRight: This case never occurs in upsampleAutomaton."

-- Note that the Semigroup instance of Either a arbitrary
-- updates when the first argument is Right.

{- | Upsample a 'ClSF' to a parallel clock.
   The given 'ClSF' is only called when @clR@ ticks,
   otherwise the last output is replicated
   (with the given @b@ as initialisation).
-}
upsampleR ::
  (Monad m, Time clL ~ Time clR) =>
  b ->
  ClSF m clR a b ->
  ClSF m (ParallelClock clL clR) a b
upsampleR :: forall (m :: Type -> Type) clL clR b a.
(Monad m, Time clL ~ Time clR) =>
b -> ClSF m clR a b -> ClSF m (ParallelClock clL clR) a b
upsampleR b
b ClSF m clR a b
clsf = Automaton m (TimeInfo (ParallelClock clL clR), a) b
-> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton m (r, a) b -> Automaton (ReaderT r m) a b
readerS (Automaton m (TimeInfo (ParallelClock clL clR), a) b
 -> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b)
-> Automaton m (TimeInfo (ParallelClock clL clR), a) b
-> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b
forall a b. (a -> b) -> a -> b
$ ((TimeInfo (ParallelClock clL clR), a)
 -> Either (Tag clL) (TimeInfo clR, a))
-> Automaton
     m
     (TimeInfo (ParallelClock clL clR), a)
     (Either (Tag clL) (TimeInfo clR, a))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (TimeInfo (ParallelClock clL clR), a)
-> Either (Tag clL) (TimeInfo clR, a)
forall {cl} {cl} {a} {b}.
(Time cl ~ Time cl, Tag cl ~ Either a (Tag cl)) =>
(TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap Automaton
  m
  (TimeInfo (ParallelClock clL clR), a)
  (Either (Tag clL) (TimeInfo clR, a))
-> Automaton m (Either (Tag clL) (TimeInfo clR, a)) b
-> Automaton m (TimeInfo (ParallelClock clL clR), a) b
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> b
-> Automaton m (TimeInfo clR, a) b
-> Automaton m (Either (Tag clL) (TimeInfo clR, a)) b
forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> Automaton m a b -> Automaton m (Either arbitrary a) b
upsampleAutomaton b
b (ClSF m clR a b -> Automaton m (TimeInfo clR, a) b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton (ReaderT r m) a b -> Automaton m (r, a) b
runReaderS ClSF m clR a b
clsf)
  where
    remap :: (TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Left a
tag}, b
_) = a -> Either a (TimeInfo cl, b)
forall a b. a -> Either a b
Left a
tag
    remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Right Tag cl
tag, Diff (Time cl)
Time cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
absolute :: forall cl. TimeInfo cl -> Time cl
..}, b
a) = (TimeInfo cl, b) -> Either a (TimeInfo cl, b)
forall a b. b -> Either a b
Right (TimeInfo {Diff (Time cl)
Diff (Time cl)
Time cl
Time cl
Tag cl
tag :: Tag cl
tag :: Tag cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
..}, b
a)

{- | Upsample a 'ClSF' to a parallel clock.
   The given 'ClSF' is only called when @clL@ ticks,
   otherwise the last output is replicated
   (with the given @b@ as initialisation).
-}
upsampleL ::
  (Monad m, Time clL ~ Time clR) =>
  b ->
  ClSF m clL a b ->
  ClSF m (ParallelClock clL clR) a b
upsampleL :: forall (m :: Type -> Type) clL clR b a.
(Monad m, Time clL ~ Time clR) =>
b -> ClSF m clL a b -> ClSF m (ParallelClock clL clR) a b
upsampleL b
b ClSF m clL a b
clsf = Automaton m (TimeInfo (ParallelClock clL clR), a) b
-> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton m (r, a) b -> Automaton (ReaderT r m) a b
readerS (Automaton m (TimeInfo (ParallelClock clL clR), a) b
 -> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b)
-> Automaton m (TimeInfo (ParallelClock clL clR), a) b
-> Automaton (ReaderT (TimeInfo (ParallelClock clL clR)) m) a b
forall a b. (a -> b) -> a -> b
$ ((TimeInfo (ParallelClock clL clR), a)
 -> Either (Tag clR) (TimeInfo clL, a))
-> Automaton
     m
     (TimeInfo (ParallelClock clL clR), a)
     (Either (Tag clR) (TimeInfo clL, a))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (TimeInfo (ParallelClock clL clR), a)
-> Either (Tag clR) (TimeInfo clL, a)
forall {cl} {cl} {a} {b}.
(Time cl ~ Time cl, Tag cl ~ Either (Tag cl) a) =>
(TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap Automaton
  m
  (TimeInfo (ParallelClock clL clR), a)
  (Either (Tag clR) (TimeInfo clL, a))
-> Automaton m (Either (Tag clR) (TimeInfo clL, a)) b
-> Automaton m (TimeInfo (ParallelClock clL clR), a) b
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> b
-> Automaton m (TimeInfo clL, a) b
-> Automaton m (Either (Tag clR) (TimeInfo clL, a)) b
forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> Automaton m a b -> Automaton m (Either arbitrary a) b
upsampleAutomaton b
b (ClSF m clL a b -> Automaton m (TimeInfo clL, a) b
forall (m :: Type -> Type) r a b.
Monad m =>
Automaton (ReaderT r m) a b -> Automaton m (r, a) b
runReaderS ClSF m clL a b
clsf)
  where
    remap :: (TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Right a
tag}, b
_) = a -> Either a (TimeInfo cl, b)
forall a b. a -> Either a b
Left a
tag
    remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Left Tag cl
tag, Diff (Time cl)
Time cl
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
absolute :: forall cl. TimeInfo cl -> Time cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
..}, b
a) = (TimeInfo cl, b) -> Either a (TimeInfo cl, b)
forall a b. b -> Either a b
Right (TimeInfo {Diff (Time cl)
Diff (Time cl)
Time cl
Time cl
Tag cl
tag :: Tag cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
tag :: Tag cl
sinceLast :: Diff (Time cl)
sinceInit :: Diff (Time cl)
absolute :: Time cl
..}, b
a)