frp.hs

import Control.Monad
import Control.Monad.Reader

-- FRP
type Time = Float
type Behavior a = (Time -> a)
type Event a = (Time, a)

inf :: Time
inf = 1/0

untilB :: Behavior a -> Event (Behavior a) -> Behavior a
b `untilB` (t', b') = \t -> if t <= t' then b t else b' t
infixr 1 `untilB`

(==>) :: Event a -> (Time -> a -> b) -> Event b
(t,x) ==> f = (t, f t x)
infixl 3 ==>

-- Platform
type ButtonPressE = Event ()

-- App
data Color = Red | Green deriving Show

wait :: Time -> Event ()
wait t = (t, ())

red :: Behavior Color
red t = Red

green :: Behavior Color
green t = Green

cycleRedGreen :: Time -> Behavior Color
cycleRedGreen = 
  \t0   -> red `untilB` wait (t0 + 1) ==> 
  \t1 _ -> green `untilB` wait (t1 + 1) ==> 
  \t2 _ -> cycleRedGreen t2
  
buttonPress :: Time -> ButtonPressE
buttonPress t = (inf, ())

buttonCycleRedGreen :: Time -> Behavior Color
buttonCycleRedGreen = 
  \t0   -> red `untilB` buttonPress t0 ==>
  \t1 _ -> green
  
main :: IO () 
main = do
  forM_ [1..10] (\t -> (putStrLn (show (buttonCycleRedGreen 0 t))))

Reactive program with structured input handling

Here's a program that cycles colors when pressing the left mouse button (LeftButton). The readInput function acts as a way of mocking IO based input, where we get the slice of allInput that corresponds to the events up to the present.

The cycling colors are represented with the function colorB :: Time -> Input -> Behavior Color, that takes the animation start and the current input to give the color behavior.

Output:

1.0	        	Red
2.0	        	Red
3.0	LeftButton	Green
4.0	        	Green
5.0	        	Green
6.0	LeftButton	Blue
7.0	        	Blue
8.0	        	Blue
9.0	        	Blue
10.0	LeftButton	Red
11.0	        	Red
12.0	        	Red

Program:

import Control.Monad
import Data.List
import Text.Printf


-- FRP Core
type Time = Float
type Behavior a = Time -> a
type Event a = (Time, a)

untilB :: Behavior a -> Event b -> (Behavior a, Event b)
b `untilB` e = (b,e)

thenB :: (Behavior a, Event b) -> Behavior a -> Behavior a
(b,(t',_)) `thenB` b' = \t -> if t < t' then b t else b' t


-- FRP utility
constB :: a -> Behavior a
constB x = \t -> x

thenMap :: (Behavior a, Event b) -> (Time -> b -> Behavior a) -> Behavior a
(b,(t',x)) `thenMap` f = (b,(t',x)) `thenB` (f t' x)


-- Platform
data Button = LeftButton deriving (Eq, Show)
type Input = [Event Button]

allInput = 
  [ (3, LeftButton)
  , (6, LeftButton) 
  , (10, LeftButton)]

readInput :: Time -> Input
readInput t = takeWhile ((<= t) . fst) allInput

inf :: Time
inf = 1/0

splitBy :: [Event a] -> Time -> ([Event a], [Event a])
splitBy xs t = span ((<= t) . fst) xs

currentPress :: Input -> Time -> Maybe Button
currentPress [] t = Nothing
currentPress input t = 
  let (t', button) = last input in
  if t == t' then Just button else Nothing

nextPress :: Input -> Button -> Time -> Event Button
nextPress input btn t = 
  let input' = filter ((== btn) . snd) input in
  let (past, present) = splitBy input' t in
  case present of
    [] -> (inf, LeftButton)
    (e:_) -> e

  
-- App
data Color = Red | Green | Blue deriving (Show)
redB = constB Red
greenB = constB Green
blueB = constB Blue

colorB :: Time -> Input -> Behavior Color
colorB = 
  \t0 input -> redB `untilB` (nextPress input LeftButton t0) `thenMap`
  \t1 _     -> greenB `untilB` (nextPress input LeftButton t1) `thenMap`
  \t2 _     -> blueB `untilB`(nextPress input LeftButton t2) `thenMap`  
  \t3 _     -> colorB t3 input

update :: Input -> Time -> String
update input t =
  let button = currentPress input t in
  let press = case button of
          Just b -> show b
          Nothing -> "" in
  let value = show (colorB 0 input t) in
  printf "%s\t%8s\t%s" (show t) press value


-- Main
main :: IO ()
main = do
  forM_ [1..12] $ \t -> do
    let input = readInput t
    let state = update input t
    putStrLn state

Animating sinusoids with delayed animation start

Trying out some non-constant behaviors by using sin and cos. The animation has a delayed start, and then gives one cycle of sin followed by one cycle of cos.

The delayed start is done with a "time transformation".

The general time transformation is given with shiftB :: Behavior Time -> Behavior a -> Behavior a which basically just applies a function on t before passing it to the behavior. This is used in delayB :: Time -> Behavior a -> Behavior a which just slides the behavior to the right along the time axis.

Time	         Value
----	         -----
0.0	           .
1.0	           .
2.0	           .
3.0	           .
4.0	           .
5.0	           .
6.0	              .
7.0	                 .
8.0	                   .
9.0	                     .
10.0	                     .
11.0	                     .
12.0	                   .
13.0	                 .
14.0	              .
15.0	           .
16.0	        .
17.0	     .
18.0	   .
19.0	 .
20.0	 .
21.0	 .
22.0	   .
23.0	     .
24.0	        .
25.0	           .
26.0	                     .
27.0	                   .
28.0	                 .
29.0	              .
30.0	           .
31.0	        .
32.0	     .
33.0	   .
34.0	 .
35.0	 .
36.0	 .
37.0	   .
38.0	     .
39.0	        .
40.0	           .
41.0	              .
42.0	                 .
43.0	                   .
44.0	                     .
45.0	                     .

import Control.Monad
import Data.List


-- FRP Core
type Time = Float
type Behavior a = Time -> a
type Event a = (Time, a)

untilB :: Behavior a -> Event b -> (Behavior a, Event b)
b `untilB` e = (b,e)

thenB :: (Behavior a, Event b) -> (Time -> b -> Behavior a) -> Behavior a
(b,(t',x)) `thenB` f =
  \t -> if t <= t' then b t else f t' x t


-- FRP utility
constB :: a -> Behavior a
constB x t = x

timeE :: Time -> Event ()
timeE t = (t, ())

shiftB :: Behavior Time -> Behavior a -> Behavior a
shiftB bt b = b . bt

delayB :: Time -> Behavior a -> Behavior a
delayB delta = shiftB (\t -> t - delta)


-- App
period :: Float
period = 20

wibble :: Time -> Float
wibble t = sin (t * 2 * pi / period)

wobble :: Time -> Float
wobble t = cos (t * 2 * pi / period)

wibbleWobble :: Time -> Time -> Float
wibbleWobble =
  \t0   -> constB 0 `untilB` timeE t0 `thenB`
  \t1 _ -> delayB t0 wibble `untilB` timeE (t1 + period) `thenB`
  \t2 _ -> delayB t0 wobble


-- Main
main :: IO ()
main = do
  let t0 = 5
  let amplitude = 10
  let padding = 1
  putStrLn "Time\t         Value"
  putStrLn "----\t         -----"
  forM_ [0..(t0 + 2 * period)] $ \t -> do
    let spaces = padding + round (amplitude * (1 + wibbleWobble t0 t))
    putStr (show t ++ "\t")
    putStrLn (replicate spaces ' ' ++ ".")