Last active
May 26, 2024 21:48
-
-
Save Warwolt/d83db4dada02193e657918ad102f547d to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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)))) |
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.
import Control.Monad
import Data.List
type Time = Float
data Button = LMB deriving Show
type Input = [(Time, Button)]
fullInput =
[ (2, LMB)
, (4, LMB)
, (7, LMB) ]
update :: Input -> Time -> String
update [] t = ""
update input t =
let (t',btn) = last input in
if t == t' then "Press" else ""
main :: IO ()
main = do
forM_ [1..10] $ \t -> do
let input = takeWhile ((<= t) . fst) fullInput
let state = update input t
putStrLn ((show t) ++ "\t" ++ state)
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 ' ' ++ ".")
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Rewriting a simple FRP text animation into explicit form
Trying to apply FRP to a simple "window title animation" for my game engine project. A simple
untilTime .. thenMapchain to set up the animation frames.I did some "equational reasoning" to transform the initial version of the behavior into an explicit one, to make it easier to see what's actually going on in such a simple case.
After the substitutions:
Adding more frames
This can then easily be extended to more frames by adding another link to the
thenMapchain:Which gets rewritten to:
Deduction
This shows how the explicit form was deduced.
Definitions:
Original animation definition:
Rewrite all infix functions to prefix:
Rewrite the
t1tot2chain link:Rewrite the
t0tot1chain link: