Yampa

Let’s get back to using BearRiver.reactimate though because it already works.

Accumulating state

The point of this example is: time is entered as input, but keyboard presses are also entered as input.

{-# LANGUAGE Arrows #-}

import FRP.BearRiver
import Data.IORef
import Data.Time.Clock
import Data.Functor.Identity
import Numeric
import System.IO
import Data.Char

inputInit :: IO Char
inputInit = do
  pure '\x00'

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

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

process :: SF Identity Char (Bool, String, String)
process = proc i -> do
  t <- time -< ()

  let n = if isDigit i then digitToInt i else 0
  c <- sumS -< fromIntegral n :: Double -- required for VectorSpace
  -- c <- feedback 0 (arr feedbackAdd) -< n
  -- c <- stateful 0 statefulAdd -< n
  -- let nE = if isDigit i then Event (digitToInt i) else NoEvent
  -- c <- accumHoldBy accumAdd 0 -< nE

  returnA -< (i == 'q', showFFloat (Just 2) t "", show c)
    where
      -- feedbackAdd (accu, new) = dup (accu + new)
      -- statefulAdd accu new = accu + new
      -- accumAdd new accu = accu + new
      -- stateful :: Monad m => b -> (a -> b -> b) -> SF m a b
      -- stateful bInit f = proc a -> do
      --   b' <- feedback bInit (arr (\(a, b) -> dup $ f a b)) -< a
      --   returnA -< b'

output :: a -> (Bool, String, String) -> IO Bool
output _ (quit, timeStr, countStr) = do
  putStrLn $ "time: " ++ timeStr ++ " counter: " ++ countStr
  pure quit

main = do
  putStrLn "Enter some chars to tick, digits to add or quit with [Q]!"
  hSetBuffering stdin NoBuffering
  t <- getCurrentTime
  dtRef <- newIORef t

  reactimate inputInit (input dtRef) output process

  putStrLn "...end"

state.hs

>>> stack ghci --ghci-options '+RTS --io-manager=native -RTS'
>>> :l src/state.hs
>>> main

Stateful functions

  • constant

  • arr sin

  • time

  • count

  • integral

  • sumS

  • feedback 0 (arr feedbackAdd

  • stateful 0 statefulAdd

  • hold 0

  • accumHoldBy accumAdd 0

Animation

The point of this example is: it doesn’t matter how sophisticated the rendering will be in the end, we can define a basic animation function. It doesn’t matter if we are using an ASCII renderer, 2D pixels, 2D vectors or an 3D renderer (which is still further abstracted into OpenGL, Direct3D and Vulkan and makes everything complicated).

{-# LANGUAGE Arrows #-}

import Data.Functor.Identity
import Data.IORef
import Data.Time.Clock
import FRP.BearRiver
import System.IO
--import System.Process (system)           -- alternative Windows clearScreen
--import System.Console.ANSI (clearScreen) -- alternative Linux console controls

-- a poor mans' console controls
hideCursor    = putStr  "\ESC[?25l"
clearScreen   = putStr  "\ESC[1J"
setCursor y x = putStr ("\ESC[" ++ show (max (y + 1) 1) ++ ";" ++ show (max (x + 1) 1) ++ "H")

inputInit :: IO (Maybe Char)
inputInit = do
  pure Nothing

input :: IORef UTCTime -> UTCTime -> a -> IO (DTime, Maybe (Maybe Char))
input dtRef tInit _ = do
  hasInput <- hWaitForInput stdin 100
  mc <- if hasInput then Just <$> getChar else pure Nothing

  now <- getCurrentTime
  prev <- readIORef dtRef
  writeIORef dtRef now
  let dt = realToFrac $ diffUTCTime now prev
  pure (dt, Just mc)

process :: SF Identity (Maybe Char) (Bool, String)
process = proc a -> do
  t <- time -< ()

  frame <- arr (\t -> ball !! (floor t `mod` length ball)) -< t

  let quit = Just 'q' == a
  returnA -< (quit, frame : "")
  where
    ball = "°Oo_oO"

output :: a -> (Bool, String) -> IO Bool
output _ (quit, frame) = do
  clearScreen
  --system "cls" -- alternative Windows clearScreen
  setCursor 0 0
  putStr frame
  pure quit

main = do
  putStrLn "Watch animation and press [Q] to quit!"

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

  reactimate inputInit (input dtRef t) output process

  putStrLn "...end"

-- > °Oo_oO°Oo_oO°Oo_oO (animating one frame per 100ms)

animation.hs

>>> stack ghci --ghci-options '+RTS --io-manager=native -RTS'
>>> :l src/animation.hs
>>> main

Refinement

Now we have several options for animations:

Use arrow combinators with time and speed up the animation by 5

process = proc a -> do
  frame <- (\t -> ball !! (floor (5.0 * t) `mod` length ball)) ^<< time -< ()
  ...

Extract the animation logic into several functions which allows us to reuse it however we want:

animate :: [a] -> Double -> SF Identity () a
animate frames speed = constant speed >>> integral >>^ getFrame frames
--animate frames speed = time >>^ (* speed) >>^ getFrame frames

getFrame :: [a] -> Double -> a
getFrame frames t = let n = length frames in frames !! (floor t `mod` n)

process = proc a -> do
  frame <- animate ball 5.0 -< ()
  ...

Movement

{-# LANGUAGE Arrows #-}

import FRP.BearRiver
import Data.IORef
import Data.Time.Clock
import Data.Functor.Identity
import System.IO

ball  = "°Oo_oO"

hideCursor    = putStr  "\ESC[?25l"
clearScreen   = putStr  "\ESC[1J"
setCursor y x = putStr ("\ESC[" ++ show (max (y + 1) 1) ++ ";" ++ show (max (x + 1) 1) ++ "H")

animate :: [a] -> Double -> SF Identity () a
animate frames speed = constant speed >>> integral >>^ getFrame frames

getFrame :: [a] -> Double -> a
getFrame frames t = let n = length frames in frames !! (floor t `mod` n)

inputInit :: IO (Maybe Char)
inputInit = do
  pure Nothing

input :: IORef UTCTime -> UTCTime -> a -> IO (DTime, Maybe (Maybe Char))
input dtRef tInit _ = do
  hasInput <- hWaitForInput stdin 100
  mc <- if hasInput then Just <$> getChar else pure Nothing

  now <- getCurrentTime
  prev <- readIORef dtRef
  writeIORef dtRef now
  let dt = realToFrac $ diffUTCTime now prev
  pure (dt, Just mc)

process :: SF Identity (Maybe Char) (Bool, (Int, Int, String))
process = proc a -> do
  obj <- object -< a
  let quit = Just 'q' == a
  returnA -< (quit, obj)

object :: SF Identity (Maybe Char) (Int, Int, String)
object = proc a -> do
  x <- accumHoldBy (+) 0 -< case a of Just 'd' -> Event 1; Just 'a' -> Event (-1); _ -> NoEvent
  y <- accumHoldBy (+) 0 -< case a of Just 's' -> Event 1; Just 'w' -> Event (-1); _ -> NoEvent
  frame <- animate ball 5.0 -< ()
  returnA -< (x, y, frame : "")

output :: a -> (Bool, (Int, Int, String)) -> IO Bool
output _ (quit, (x, y, frame)) = do
  clearScreen
  setCursor y x
  putStr frame
  pure quit

main = do
  putStrLn "Press [WASD] to move around and [Q] to quit!"
  hideCursor
  hSetBuffering stdin NoBuffering
  t <- getCurrentTime
  dtRef <- newIORef t
  hasInput <- hWaitForInput stdin 5000

  reactimate inputInit (input dtRef t) output process

  clearScreen
  putStrLn "...end"

objmove.hs

>>> stack ghci --ghci-options '+RTS --io-manager=native -RTS'
>>> :l src/objmove.hs
>>> main

Refinement

If you want to add bounds to the position you could write:

object = proc a -> do
  x <- accumHoldBy (\old dir -> max 0 . min 30 $ old + dir) 0 -< case a of Just 'd' -> Event 1; Just 'a' -> Event (-1); _ -> NoEvent
  y <- accumHoldBy (\old dir -> max 0 . min 10 $ old + dir) 0 -< case a of Just 's' -> Event 1; Just 'w' -> Event (-1); _ -> NoEvent
  ...

Here are some other animations

stick = "-/|\\"
emoji = "😃😄😃😃"
clock = "🕐🕑🕒🕓🕔🕕🕖🕗🕘🕙🕚🕛"

Recursive states

{-# LANGUAGE Arrows #-}

import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.Trans.MSF.Reader
import Control.Monad.Trans.MSF.Writer
import Data.Functor.Identity
import Data.IORef
import Data.Text.Chart (plot)
import Data.Time.Clock
import FRP.BearRiver
import Numeric
import System.IO

hideCursor    = putStr  "\ESC[?25l"
clearScreen   = putStr  "\ESC[1J"
setCursor y x = putStr ("\ESC[" ++ show (max (y + 1) 1) ++ ";" ++ show (max (x + 1) 1) ++ "H")

inputInit :: IO (Maybe Char)
inputInit = do
  pure Nothing

input :: IORef UTCTime -> IORef Bool -> a -> IO (DTime, Maybe (Maybe Char))
input dtRef quitRef _ = do
  hasInput <- hWaitForInput stdin 100
  mc <- if hasInput then Just <$> getChar else pure Nothing
  when (mc == Just 'q') $ writeIORef quitRef True

  now <- getCurrentTime
  prev <- readIORef dtRef
  writeIORef dtRef now
  let dt = realToFrac $ diffUTCTime now prev
  pure (dt, Just mc)

output :: IORef Bool -> a -> Double -> IO Bool
output quitRef _ x = do
  clearScreen
  setCursor 0 0
  putStr $ replicate (round x) '~' ++ "O"
  readIORef quitRef

spring :: Monad m => Double -> Double -> Double -> SF m a Double
spring k x0 xdInit = feedback xInit $ proc (_, xt) -> do
  let xd = x0 - xt
  ft  <- integralFrom 0     -< xd
  xt' <- integralFrom xInit -< ft / k
  returnA -< (xt', xt')
  where 
    xInit = x0 + xdInit

main = do
  putStrLn "Watch an animated spring and press [Q] to quit!"
  hasInput <- hWaitForInput stdin 5000
  hSetBuffering stdin NoBuffering
  hideCursor
  t <- getCurrentTime
  dtRef <- newIORef t
  quitRef <- newIORef False

  reactimate inputInit (input dtRef quitRef) (output quitRef) (spring k x0 xdInit)

  clearScreen
  setCursor 0 0
  putStrLn "Time-distance diagram (using ASCII plot):"
  ls <- embed (runReaderS_ (spring k x0 xdInit) 0.1) (replicate 120 ())
  plot $ map round ls

  putStrLn "...end"
  where
    k      =  1.0
    x0     = 30.0
    xdInit = 20.0

-- > Watch an animated spring and press [Q] to quit!
-- > ~~~~~~~~~~~~~~~~~~~~O (bouncing back and forth)
-- > Time-distance diagram (using Unicode plot):
-- > 50.00 ┼╮                                                          ╭───╮                                                         ╭────╮
-- > 47.14 ┤╰──╮                                                    ╭──╯   ╰──╮                                                    ╭─╯    ╰──╮  
-- > 44.29 ┤   ╰──╮                                              ╭──╯         ╰─╮                                               ╭──╯         ╰─╮
-- > 41.43 ┤      ╰─╮                                          ╭─╯              ╰─╮                                           ╭─╯              ╰─╮  
-- > 38.57 ┤        ╰╮                                       ╭─╯                  ╰─╮                                       ╭─╯                  ╰─╮
-- > 35.71 ┤         ╰─╮                                    ╭╯                      ╰─╮                                    ╭╯                      ╰─╮ 
-- > 32.86 ┤           ╰╮                                 ╭─╯                         ╰╮                                 ╭─╯                         ╰╮
-- > 30.00 ┤            ╰╮                               ╭╯                            ╰╮                               ╭╯                            ╰╮  
-- > 27.14 ┤             ╰─╮                            ╭╯                              ╰─╮                            ╭╯                              ╰─╮
-- > 24.29 ┤               ╰╮                         ╭─╯                                 ╰╮                         ╭─╯                                 ╰╮  
-- > 21.43 ┤                ╰─╮                      ╭╯                                    ╰─╮                      ╭╯                                    ╰─╮
-- > 18.57 ┤                  ╰─╮                  ╭─╯                                       ╰─╮                  ╭─╯                                       ╰╮  
-- > 15.71 ┤                    ╰─╮              ╭─╯                                           ╰─╮              ╭─╯                                          ╰─╮
-- > 12.86 ┤                      ╰─╮         ╭──╯                                               ╰─╮         ╭──╯                                              ╰─
-- > 10.00 ┤                        ╰─────────╯                                                    ╰─────────╯
-- > ...end

spring.hs

>>> stack ghci --ghci-options '+RTS --io-manager=native -RTS'
>>> :l src/spring.hs
>>> main
-- | Well-formed looped connection of an output component as a future input.
feedback :: Monad m => c -> MSF m (a, c) (b, c) -> MSF m a b
feedback c sf = MSF $ \a -> do
  ((b', c'), sf') <- unMSF sf (a, c)
  return (b', feedback c' sf')

Switching behaviour

type

immediate

delayed

once

switch

dSwitch

recurring

rSwitch

drSwitch

parallel using broadcasting

pSwitchB rpSwitchB

dpSwitchB drpSwitchB

parallel using routing

pSwitch rpSwitch

dpSwitch drpSwitch

continuation

kSwitch

kdSwitch

_images/yampa_switch_.svg

switch

_images/yampa_pSwitchB_.svg

pSwitchB

_images/yampa_pSwitch_.svg

pSwithc

Reddit - How to read Yampa diagram?

These diagrams were originally designed by the author of this book. If you understand german you can read a description of switch, pSwitchB and pSwitch here: [GamArchYam10]

Todo

add english translation of switching diagrams from master thesis