-
-
Save Warwolt/d83db4dada02193e657918ad102f547d to your computer and use it in GitHub Desktop.
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 ' ' ++ ".")
Detour: simulating realistic input handling
Some very simple code that prepares a list of input events, but only passes the past and present into the program itself, not allowing the program to rely on future events.