Yampa
Quickstart
runReader (embed (yourSF “init”) [NoEvent, NoEvent, Event ()]) 1.0
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"
>>> cabal repl state # --ghci-options '+RTS --io-manager=native -RTS'
>>> 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)
>>> cabal repl animation # --ghci-options '+RTS --io-manager=native -RTS'
>>> 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"
>>> cabal repl objmove # --ghci-options '+RTS --io-manager=native -RTS'
>>> 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
>>> cabal repl spring # --ghci-options '+RTS --io-manager=native -RTS'
>>> 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 |
|
|
recurring |
|
|
parallel using broadcasting |
|
|
parallel using routing |
|
|
continuation |
|
|
switch
pSwitchB
pSwitch
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