Reactimation

Basic reactimation in BearRiver Yampa

Type signatures of reactimate

reactimate
  :: Monad m =>
     m in                              -- inputInit/senseInit
     -> (Bool -> m (DTime, Maybe in))  -- input/sense
     -> (Bool -> out -> m Bool)        -- output/actuate
     -> SF Identity in out             -- process/signal function
     -> m ()

Note that the input and output procedure also have an Bool parameter which is unused if you look at the implementation therefore we can just ignore it.

Here is a minimal implementation which just produces 1.0s time deltas independent of the real world time. So far it’s just a deterministic simulation like embed and doesn’t provide any utility until we get real time deltas.

main = do
  reactimate inputInit input output time
    where
      inputInit  = pure ()
      input  _   = pure (1.0, Just ())
      output _ o = print o >> pure False
-- > 1.0
-- > 2.0
-- > 3.0
-- > ...
-- > Interrupted.

Type signature of time:

time :: Monad m => SF m a Time

The first question that comes to mind is: How do we quit reactimate? Well in this case we don’t, so just press Control-c. On Windows there is an issue which messes up the console once you press Control-c within the app. So you probably have to restart ghci now otherwise you get garbeld output and strange error messages.

Here is a more complete example which implements a full game loop with real time deltas. Note that in a real game loop you wouldn’t write it this way because you would like to have a stable frame rate, make the delay dependent of missed time and account for skipped frames. Also I don’t know how precise Data.Time.Clock.getCurrentTime is. But let’s keep it simple for now. On Windows, make sure you run this example without the --io-manager=native option, otherwise threadDelay hangs the execution.

{-# LANGUAGE Arrows #-}

import Control.Concurrent (threadDelay)
import Data.Functor.Identity
import Data.IORef
import Data.Time.Clock
import FRP.BearRiver

inputInit :: IO String
inputInit = do
  pure "inputInit" -- use this if input doesn't produce anything

input :: IORef UTCTime -> UTCTime -> Bool -> IO (DTime, Maybe String)
input dtRef tInit _ = do
  now <- getCurrentTime
  prev <- readIORef dtRef
  writeIORef dtRef now
  let dt = realToFrac $ diffUTCTime now prev  -- delta time
  let at = realToFrac $ diffUTCTime now tInit -- absolute time
  return (dt, Just (show now)) -- usually you would want to use device inputs or resource media here but let's produce some input strings from time

sf :: Monad m => SF m String String
sf = proc nowStr -> do
  t <- integral -< 1.0 :: Double
  returnA -< " integral: " ++ show t ++ " now: " ++ nowStr

output :: Bool -> String -> IO Bool
output _ out = do
  putStrLn out
  threadDelay secs -- DON'T USE IT LIKE THIS IN A REAL GAME LOOP
  return False
  where secs = 1000 * 1000 -- pico seconds

main = do
  putStrLn "Warning: On Windows threadDelay only works without io-manager=native options!"
  putStrLn "Time progress in about 1sec (+ some processor time) steps. Interrupt with [Control-C]!"
  t <- getCurrentTime
  dtRef <- newIORef t

  reactimate inputInit (input dtRef t) output sf

  putStrLn "...end"

-- > start...
-- > now: 2021-09-12 09:42:57.1321897 UTC integral: 0.0
-- > now: 2021-09-12 09:42:58.1421375 UTC integral: 1.0099473
-- > now: 2021-09-12 09:42:59.1492352 UTC integral: 2.0170455
-- > Interrupted.

reactimate.hs

>>> cabal repl reactimate # DON'T USE io-manager=native HERE!
>>> main

Press Control-c again to quit. On Windows you need to restart GHCI one more time.

Note that inputInit is only used as fallback here if input never produces anything. You can see that if you end input with:

input dtRef tInit _ = do
  ...
  pure (dt, if at < 3 then Nothing else Just (show now))

-- > start...
-- > now: inputInit integral: 0.0
-- > now: inputInit integral: 1.0099473
-- > now: inputInit integral: 2.0170455
-- > now: 2021-09-12 09:42:59.1492352 UTC integral: 3.0270455
-- > Interrupted.

On Windows make sure you use GHC 9 and start with --io-manager=native -RTS option, otherwise NoBuffering and getChar wont work:

>>> cabal repl reactimate --ghci-options '+RTS --io-manager=native -RTS'

In this example we use a poor man’s input handling with getChar which just reads one character from the console. Depending on how long the user waits we get the corrsponding time delta. Once you press Q the app quits.

{-# LANGUAGE Arrows #-}

import Data.Functor.Identity
import Data.IORef
import Data.Time.Clock
import FRP.BearRiver
import Numeric
import System.IO ( stdin, hSetBuffering, BufferMode(NoBuffering) )

inputInit :: IO (Char, String)
inputInit = do
  pure ('\x00', "inputInit")

input :: IORef UTCTime -> UTCTime -> a -> IO (DTime, Maybe (Char, String))
input dtRef tInit _ = do
  c <- getChar

  now <- getCurrentTime
  prev <- readIORef dtRef
  writeIORef dtRef now
  let dt = realToFrac $ diffUTCTime now prev  -- delta time
  let at = realToFrac $ diffUTCTime now tInit -- absolute time
  pure (dt, Just (c, show now))

sf :: SF Identity (Char, String) (Bool, String)
sf = proc (input, nowStr) -> do
  t <- integral -< 1.0 :: Double
  let out = "integral: " ++ showFFloat (Just 2) t "" ++ " now: " ++ nowStr
  returnA -< (input == 'q', out)

output :: a -> (Bool, String) -> IO Bool
output _ (quit, out) = do
  putStrLn out
  pure quit

main = do
  putStrLn "Repeatedly press any key or [Q] to quit!"

  hSetBuffering stdin NoBuffering
  t <- getCurrentTime
  dtRef <- newIORef t

  reactimate inputInit (input dtRef t) output sf

  putStrLn "...end"

-- > start...
-- > Repeatedly press any key or [Q] to quit!
-- > integral: 0.64 now: 2021-09-12 10:09:21.9324477 UTC
-- > integral: 1.80 now: 2021-09-12 10:09:23.0927901 UTC
-- > integral: 2.73 now: 2021-09-12 10:09:24.0177477 UTC
-- > ...end

input.hs

>>> cabal repl input #--ghci-options '+RTS --io-manager=native -RTS'
>>> main

Reactimate in Dunai

type signatures of reactimate

-- BearRiver
reactimate
  :: Monad m =>
     m in                              -- inputInit/senseInit
     -> (Bool -> m (DTime, Maybe in))  -- input/sense
     -> (Bool -> out -> m Bool)        -- output/actuate
     -> SF Identity in out             -- process/signal function
     -> m ()

-- Dunai
reactimate :: Monad m => MSF m () () -> m ()

main = do
  hSetBuffering stdin LineBuffering -- important if you work on Windows
  putStrLn "Enter some words: "
  Dunai.reactimate (arrM (const getLine) >>> arr reverse >>> arrM putStrLn)
-- > Enter some words:
-- > hello
-- > olleh
-- > world
-- > dlorw

Note that the functions arrM_ and liftS mentioned on https://github.com/ivanperez-keera/dunai don’t really exist.

From the paper:

liftLM :: (Monad m, Monad n) => (forall a . m a -> n a) -> MSF m a b -> MSF n a b

liftST = liftLM . lift

From source:

-- | Lifts a monadic computation into a Stream.
constM :: Monad m => m b -> MSF m a b
constM = arrM . const

-- | Apply a monadic transformation to every element of the input stream.
-- Generalisation of 'arr' from 'Arrow' to monadic functions.
arrM :: Monad m => (a -> m b) -> MSF m a b
arrM = ...

-- | Apply trans-monadic actions (in an arbitrary way).
-- This is just a convenience function when you have a function to move across
-- monads, because the signature of 'morphGS' is a bit complex.
morphS :: (Monad m1, Monad m2)
      => (forall c . m1 c -> m2 c)
      -> MSF m1 a b
      -> MSF m2 a b
morphS = ...

-- | Lift inner monadic actions in monad stacks.
liftTransS :: (MonadTrans t, Monad m, Monad (t m))
           => MSF m a b
           -> MSF (t m) a b
liftTransS = morphS lift

Therefore:

arrM_  => constM
liftS  => arrM
liftLM => morphS
liftST => liftTransS

MyReactimate

Let’s implement our own myreactimate

{-# LANGUAGE Arrows #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}

import Control.Monad.Trans.MSF.Reader
import Data.Functor.Identity
import Data.MonadicStreamFunction
import System.IO

type SF m = MSF (ReaderT Double m)

input :: IO (Double, Char)
input = do
  i <- getChar
  pure (dt, i)
  where dt = 1.0

process :: SF Identity Char String
process = proc i -> do                -- input is inserted as an arrow input
  tStr <- constM (show <$> ask) -< () -- whereas the time deltas are provided from the reader monad
  returnA -< tStr

output :: String -> IO ()
output o = putStrLn o

myreactimate :: forall a b. IO (Double, a) -> (b -> IO ()) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimate $ senseSF sense >>> sfIO sf >>> actuateSF actuate
  where
    senseSF :: forall (m :: * -> *) a. Monad m => m a -> MSF m () a
    senseSF s = constM s
    actuateSF :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
    actuateSF a = arrM a
    sfIO :: forall (m2 :: * -> *) r a b. Monad m2 => MSF (ReaderT r Identity) a b -> MSF m2 (r, a) b
    sfIO s = morphS (pure . runIdentity) (runReaderS s)

main :: IO ()
main = do
  putStrLn "Press any key to get fake delta times and [Control-C] to interrupt!"
  hSetBuffering stdin NoBuffering
  myreactimate input output process

myreactimate0.hs

>>> cabal repl myreactimate0 --ghci-options '+RTS --io-manager=native -RTS'
>>> main

Now if want to make the type signatures explicit

myreactimate :: IO (Double, a) -> (b -> IO ()) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimate $ senseSF >>> sfIO >>> actuateSF
  where
    senseSF :: MSF IO () (Double, a)
    senseSF = constM sense
    actuateSF :: MSF IO b ()
    actuateSF = arrM actuate
    sfIO :: MSF IO (Double, a) b
    sfIO = morphS (pure . runIdentity) (runReaderS sf)

-- Couldn't match type ‘b1’ with ‘b’
-- Expected: MSF IO b1 ()
-- Actual: MSF IO b ()
-- ‘b1’ is a rigid type variable bound by
-- the type signature for: actuateSF :: forall b1. MSF IO b1 ()

Thats because the variable b mentioned in the signature is different from the b mentioned in the signature of actuateSF (which is renamed to b1). We would have to use ScopedTypeVariables and forall, which says something like: “for the following block assume the variables to be the same.”

{-# LANGUAGE ScopedTypeVariables #-}

myreactimate :: forall a b. IO (Double, a) -> (b -> IO ()) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimate $ senseSF >>> sfIO >>> actuateSF
  where
    senseSF :: MSF IO () (Double, a)
    senseSF = constM sense
    actuateSF :: MSF IO b ()
    actuateSF = arrM actuate
    sfIO :: MSF IO (Double, a) b
    sfIO = morphS (pure . runIdentity) (runReaderS sf)

Here is the version that Haskell Language Server suggested

{-# LANGUAGE RankNTypes, KindSignatures #-}

myreactimate :: forall a b. IO (Double, a) -> (b -> IO ()) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimate $ senseSF sense >>> sfIO sf >>> actuateSF actuate
  where
    senseSF :: forall (m :: * -> *) a. Monad m => m a -> MSF m () a
    senseSF s = constM s
    actuateSF :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
    actuateSF a = arrM a
    sfIO :: forall (m2 :: * -> *) r a b. Monad m2 => MSF (ReaderT r Identity) a b -> MSF m2 (r, a) b
    sfIO s = morphS (pure . runIdentity) (runReaderS s)

Can we use Yampa functions within? Turns out: yes

Yampa definitions:

type SF m = MSF (ClockInfo m)
type ClockInfo m = ReaderT DTime m
type DTime = Double

SF :: Monad m => MSF (ReaderT Double m) a b

{-# LANGUAGE Arrows, ScopedTypeVariables #-}

import Control.Monad.Trans.MSF.Reader
import Data.Functor.Identity
import Data.MonadicStreamFunction
import FRP.BearRiver hiding (reactimate)
import System.IO

input :: IO (Double, Char)
input = do
  i <- getChar
  pure (dt, i)
  where dt = 1.0

process :: SF Identity Char String -- this is an BearRiver.SF now, not a Dunai.MSF
process = proc i -> do
  t <- sumS -< 1.0 :: Double -- using BearRiver.sumS here!
  returnA -< show t

output :: String -> IO ()
output o = putStrLn o

myreactimate :: forall a b. IO (Double, a) -> (b -> IO ()) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimate $ senseSF >>> sfIO >>> actuateSF
  where
    senseSF :: MSF IO () (Double, a)
    senseSF = constM sense
    actuateSF :: MSF IO b ()
    actuateSF = arrM actuate
    sfIO :: MSF IO (Double, a) b
    sfIO = morphS (pure . runIdentity) (runReaderS sf)

main :: IO ()
main = do
  putStrLn "Press any key to get custom process counts and [Control-C] to interrupt!"
  hSetBuffering stdin NoBuffering
  myreactimate input output process

myreactimate1.hs

>>> cabal repl myreactimate1 #--ghci-options '+RTS --io-manager=native -RTS'
>>> main

So if you disagree on how Yampa’s reactimate is implemented, this is your chance. Let’s get back to using BearRiver.reactimate though because it already works.

Terminating myreactimate

[FrpRefac16] 4.3 Exceptions and Control Flow - MSFs can use different monads to define control structures. One common construct is switching, that is, applying a transformation until a certain time, and then applying a different transformation. We can implement an equivalent construct using monads like Either or Maybe. We could define a potentially-terminating MSF as an MSF in a MaybeT m monad. Following the same pattern as before, the associated running function would have type: runMaybeS :: Monad m => MSF (MaybeT m) a b -> MSF m a (Maybe b). Our evaluation function step, for this monad, would have type MSF Maybe a b -> a -> Maybe (b, MSF Maybe a b) indicating that it may produce no continuation. runMaybeS outputs Nothing continuously once the internal MSF produces no result.

Well, that doesn’t help us much. Fortunately Dunai provides a reactimateB function which uses the ExceptT internally and allows us to quit using a Bool.

{-# LANGUAGE Arrows #-}

import Control.Monad.Trans.MSF.Except (reactimateB)
import Control.Monad.Trans.MSF.Reader
import Data.Functor.Identity
import Data.MonadicStreamFunction
import System.IO

type SF m = MSF (ReaderT Double m)

input :: IO (Double, Char)
input = do
  i <- getChar
  pure (dt, i)
  where dt = 1.0

process :: SF Identity Char (Bool, String)
process = proc i -> do                -- input is inserted as an arrow input
  tStr <- constM (show <$> ask) -< () -- whereas the time deltas are provided from the reader monad
  returnA -< (i == 'q', tStr)

output :: (Bool, String) -> IO Bool
output (quit, o) = do
  putStrLn o
  pure quit
  -- we could also move the quit logic from process to output directly

myreactimate :: IO (Double, a) -> (b -> IO Bool) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimateB $ senseSF sense >>> sfIO sf >>> actuateSF actuate
  where
    senseSF :: Monad m => m a -> MSF m () a
    senseSF s = constM s
    actuateSF :: Monad m => (a -> m b) -> MSF m a b
    actuateSF a = arrM a
    sfIO :: Monad m2 => MSF (ReaderT r Identity) a b -> MSF m2 (r, a) b
    sfIO s = morphS (pure . runIdentity) (runReaderS s)

main = do
  putStrLn "Press any key to get fake delta times and [Q] to quit!"
  hSetBuffering stdin NoBuffering
  myreactimate input output process

myreactimateB.hs

>>> cabal repl myreactimateB # --ghci-options '+RTS --io-manager=native -RTS'
>>> main

{-# LANGUAGE Arrows #-}

import Control.Monad
import Control.Monad.Trans.MSF.Except (reactimateB)
import Control.Monad.Trans.MSF.Reader
import Data.Functor.Identity
import Data.IORef
import Data.MonadicStreamFunction
import System.IO

type SF m = MSF (ReaderT Double m)

input :: IORef Bool -> IO (Double, Char)
input quitRef = do
  i <- getChar
  when (i == 'q') $ writeIORef quitRef True
  pure (dt, i)
  where dt = 1.0

process :: SF Identity Char String
process = proc i -> do                -- input is inserted as an arrow input
  tStr <- constM (show <$> ask) -< () -- whereas the time deltas are provided from the reader monad
  returnA -< tStr

output :: IORef Bool -> String -> IO Bool
output quitRef o = do
  putStrLn o
  readIORef quitRef

myreactimate :: IO (Double, a) -> (b -> IO Bool) -> SF Identity a b -> IO ()
myreactimate sense actuate sf = reactimateB $ senseSF sense >>> sfIO sf >>> actuateSF actuate
  where
    senseSF :: Monad m => m a -> MSF m () a
    senseSF s = constM s
    actuateSF :: Monad m => (a -> m b) -> MSF m a b
    actuateSF a = arrM a
    sfIO :: Monad m2 => MSF (ReaderT r Identity) a b -> MSF m2 (r, a) b
    sfIO s = morphS (pure . runIdentity) (runReaderS s)

main = do
  putStrLn "Press any key to get fake delta times and [Q] to quit!"
  hSetBuffering stdin NoBuffering
  quitRef <- newIORef False
  myreactimate (input quitRef) (output quitRef) process

myreactimateB1.hs

[FrpExt17] 6.4 Experience - Personally, I have found that using monad stacks with multiple transformers makes MSFs hard to work with, in spite of the multiple benefits of being able to describe switching in terms of EitherT or parallelism in terms of ListT. With this in mind, it is perhaps still convenient to add layers of abstraction on top of MSFs to describe Functional Reactive Programming or other mathematical constructs, as opposed to expressing programs directly in terms of Monadic Stream Functions (even if they are still implemented that way). Note, however, that programmers with a more mathematical background may find working with monad stacks more straightforward.

Okay…