Skip to content

Instantly share code, notes, and snippets.

@Warwolt
Last active May 26, 2024 21:48
Show Gist options
  • Save Warwolt/d83db4dada02193e657918ad102f547d to your computer and use it in GitHub Desktop.
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))))
@Warwolt
Copy link
Author

Warwolt commented May 15, 2024

Button events

Button event generation:

import Data.List
import Data.Ord

type Time = Float
type Event a = (Time, a)

type ButtonE = Event ()

inf :: Time
inf = 1/0

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

buttonPress :: [ButtonE] -> Time -> ButtonE
buttonPress xs t = let (past, present) = splitBy xs t in
  case present of
    [] -> (inf, ())
    (x:_) -> x

main :: IO ()
main = do
  let buttonEvents = [(1,()),(4,())]
  let press = buttonPress buttonEvents 0
  putStrLn . show $ press

@Warwolt
Copy link
Author

Warwolt commented May 19, 2024

Encoding state transition arrow withs untilB and thenB

Alternate formulation utilizing the fact that a behavior transition in response to an event is basically just a state transition arrow (A, e, B) , where A and B are behaviors and e is the event in response to which the transition happens.

   e
A ---> B
import Control.Monad

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

-- b1 `untilB` e `thenB` b2

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
  
  
-- FPR utility
untilTime :: Behavior a -> Time -> (Behavior a, Event ())
b `untilTime` t' = (b, (t', ()))

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


-- Application
data Color = Red | Green deriving (Show)

red :: Behavior Color
red t = Red

green :: Behavior Color
green t = Green

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

redThenGreen :: Time -> Behavior Color
redThenGreen t0 = red `untilB` (timeE (t0 + 5)) `thenB` green

cycleRedGreen :: Time -> Behavior Color
cycleRedGreen = 
  \t0   -> red `untilTime` (t0 + 1) `thenMap` 
  \t1 _ -> green `untilTime` (t1 + 1) `thenMap` 
  \t2 _ -> cycleRedGreen (t2 + 0)

main :: IO ()
main = do
  forM_ [1..10] $ \t -> (putStrLn (show (cycleRedGreen 0 t)))

@Warwolt
Copy link
Author

Warwolt commented May 19, 2024

Button press reactivity

Here's a version with user interactivity. A behavior is waiting for a button press to then switch to the next behavior. This both exhibits reacting to user input as well as composing behaviors.

(Also changed to strict inequality when checking for event reactivity, annoying when a press has a delay before the behavior reacts).

1.0		Blue
2.0		Blue
3.0		Blue
4.0		Blue
5.0	press	Red
6.0		Red
7.0		Green
8.0		Green
9.0		Red
10.0		Red
11.0	press	Blue
12.0		Blue
13.0		Blue
14.0	press	Red
15.0		Red
16.0		Green
17.0		Green
18.0		Red
19.0		Red
20.0		Green
import Control.Monad
import Data.List
import Data.Ord


-- 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
  
  
-- FPR utility
untilTime :: Behavior a -> Time -> (Behavior a, Event ())
b `untilTime` t' = (b, (t', ()))

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

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


-- Platform
type ButtonE = Event ()
data User = User { user_buttonEvents :: [ButtonE] }

inf :: Time
inf = 1/0

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

buttonPress :: User -> Time -> ButtonE
buttonPress user t = 
  let xs = user_buttonEvents user in
  let (past, present) = splitBy xs t in
  case present of
    [] -> (inf, ())
    (x:_) -> x


-- Application
data Color = Red | Green | Blue deriving (Show)
red = constB Red
green = constB Green
blue = constB Blue

cycleRedGreen :: Time -> Behavior Color
cycleRedGreen = 
  let period = 2 in
  \t0   -> red `untilTime` (t0 + period) `thenMap` 
  \t1 _ -> green `untilTime` (t1 + period) `thenMap` 
  \t2 _ -> cycleRedGreen t2
  
blueThenRedGreen :: User -> Time -> Behavior Color
blueThenRedGreen user = 
  \t0   -> blue `untilB` (buttonPress user t0) `thenMap` 
  \t1 _ -> (cycleRedGreen t1) `untilB` (buttonPress user t1) `thenMap`
  \t2 _ -> blueThenRedGreen user t2


-- Main
runBehavior :: Show a => (Time, Time) -> User -> Behavior a -> IO ()
runBehavior (start, end) user b = 
  forM_ [start..end] $ \t -> do
    let val = b t
    let buttons = user_buttonEvents user
    let press = if any ((== t) . fst) buttons then "press" else ""
    putStrLn $ (show t) ++ "\t" ++ press ++ "\t" ++ (show val) 

main :: IO ()
main = do
  let user = User { user_buttonEvents = [(5,()), (11,()), (14, ())] }
  runBehavior (1,20) user $ blueThenRedGreen user 0

@Warwolt
Copy link
Author

Warwolt commented May 20, 2024

Time transforms

A version utilizing time transforms to slow down or speed up an animation. The first click animates at normal speed, next click turns off, click after animates at half speed, and next animation is at double speed

1.0		Blue
2.0	press	Red
3.0		Red
4.0		Green
5.0		Green
6.0	press	Blue
7.0		Blue
8.0		Blue
9.0		Blue
10.0	press	Red
11.0		Red
12.0		Red
13.0		Red
14.0		Green
15.0		Green
16.0		Green
17.0		Green
18.0		Red
19.0		Red
20.0	press	Blue
21.0		Blue
22.0	press	Red
23.0		Green
24.0		Red
25.0		Green
26.0	press	Blue
27.0		Blue
28.0		Blue
29.0		Blue
30.0		Blue
import Control.Monad
import Data.List
import Data.Ord
import Debug.Trace

-- 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
  
  
-- FPR utility
untilTime :: Behavior a -> Time -> (Behavior a, Event ())
b `untilTime` t' = (b, (t', ()))

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

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

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

-- Platform
type ButtonE = Event ()
data User = User { user_buttonEvents :: [ButtonE] }

inf :: Time
inf = 1/0

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

buttonPress :: User -> Time -> ButtonE
buttonPress user t = 
  let xs = user_buttonEvents user in
  let (past, present) = splitBy xs t in
  case present of
    [] -> (inf, ())
    (x:_) -> x


-- Application
data Color = Red | Green | Blue deriving (Show)
red = constB Red
green = constB Green
blue = constB Blue

cycleRedGreen :: Time -> Behavior Color
cycleRedGreen = 
  let period = 2 in
  \t0   -> red `untilTime` (t0 + period) `thenMap` 
  \t1 _ -> green `untilTime` (t1 + period) `thenMap` 
  \t2 _ -> cycleRedGreen t2
  
slowmo :: Time -> Behavior Time 
slowmo t0 = \t -> 
  if t <= t0 then t else t0 + (t - t0) / 2

turbo :: Time -> Behavior Time 
turbo t0 = \t -> 
  if t <= t0 then t else t0 + (t - t0) * 2
  
slowCycleRedGreen :: Time -> Behavior Color
slowCycleRedGreen t0 = timeTransform (cycleRedGreen t0) (slowmo t0)

fastCycleRedGreen :: Time -> Behavior Color
fastCycleRedGreen t0 = timeTransform (cycleRedGreen t0) (turbo t0)

variousSpeedsBlueRedGreen :: User -> Time -> Behavior Color
variousSpeedsBlueRedGreen user = 
  -- normal
  \t0   -> blue `untilB` (buttonPress user t0) `thenMap` 
  \t1 _ -> (cycleRedGreen t1) `untilB` (buttonPress user t1) `thenMap`
  -- slow
  \t2 _ -> blue `untilB` (buttonPress user t2) `thenMap` 
  \t3 _ -> (slowCycleRedGreen t3) `untilB` (buttonPress user t3) `thenMap`
  -- fast
  \t4 _ -> blue `untilB` (buttonPress user t4) `thenMap` 
  \t5 _ -> (fastCycleRedGreen t5) `untilB` (buttonPress user t5) `thenMap`
  -- repeat
  \t6 _ -> variousSpeedsBlueRedGreen user t6

  
-- Main
runBehavior :: Show a => (Time, Time) -> User -> Behavior a -> IO ()
runBehavior (start, end) user b = 
  forM_ [start..end] $ \t -> do
    let val = b t
    let buttons = user_buttonEvents user
    let press = if any ((== t) . fst) buttons then "press" else ""
    putStrLn $ (show t) ++ "\t" ++ press ++ "\t" ++ (show val) 

main :: IO ()
main = do
  let buttonEvents = [
          (2,()), (6,()), (10,()), (20,()), (22,()), (26, ())
        ]
  let user = User { user_buttonEvents = buttonEvents}
  runBehavior (1,30) user $ variousSpeedsBlueRedGreen user 0

@Warwolt
Copy link
Author

Warwolt commented May 21, 2024

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 .. thenMap chain to set up the animation frames.

0.0	"Engine 2024 (rebuilding)"
1.0	"Engine 2024 (rebuilding)"
2.0	"Engine 2024 (rebuilding)"
3.0	"Engine 2024 (rebuilding..)"
4.0	"Engine 2024 (rebuilding..)"
5.0	"Engine 2024 (rebuilding..)"
6.0	"Engine 2024 (rebuilding)"
7.0	"Engine 2024 (rebuilding)"
8.0	"Engine 2024 (rebuilding)"
9.0	"Engine 2024 (rebuilding..)"
10.0	"Engine 2024 (rebuilding..)"
11.0	"Engine 2024 (rebuilding..)"
12.0	"Engine 2024 (rebuilding)"
13.0	"Engine 2024 (rebuilding)"
14.0	"Engine 2024 (rebuilding)"
15.0	"Engine 2024 (rebuilding..)"
16.0	"Engine 2024 (rebuilding..)"
17.0	"Engine 2024 (rebuilding..)"
18.0	"Engine 2024 (rebuilding)"
19.0	"Engine 2024 (rebuilding)"
20.0	"Engine 2024 (rebuilding)"

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.

windowTitle :: Time -> Behavior String
windowTitle = 
  let period = 3 in
  \t0   -> constB "Engine 2024 (rebuilding)"  `untilTime` (t0 + period) `thenMap`
  \t1 _ -> constB "Engine 2024 (rebuilding..)" `untilTime` (t1 + period) `thenMap`
  \t2 _ -> windowTitle t2

After the substitutions:

windowTitle :: Time -> Behavior String
windowTitle t0 = 
  let period = 3 in
    \t -> 
      if t < (t0 + period) then 
        "Engine 2024 (rebuilding)" 
      else if t < (t0 + period + period) then 
        "Engine 2024 (rebuilding..)" 
      else 
        windowTitle (t0 + period + period) t

Adding more frames

This can then easily be extended to more frames by adding another link to the thenMap chain:

windowTitle :: Time -> Behavior String
windowTitle = 
  let period = 3 in
  \t0   -> constB "Engine 2024 (rebuilding)"  `untilTime` (t0 + period) `thenMap`
  \t1 _ -> constB "Engine 2024 (rebuilding.)" `untilTime` (t1 + period) `thenMap`
  \t2 _ -> constB "Engine 2024 (rebuilding..)" `untilTime` (t2 + period) `thenMap`
  \t3 _ -> windowTitle t3

Which gets rewritten to:

windowTitle :: Time -> Behavior String
windowTitle t0 = 
  let period = 3 in
    \t -> 
      if t < (t0 + period) then 
        "Engine 2024 (rebuilding)" 
      else if t < (t0 + period + period) then 
        "Engine 2024 (rebuilding.)" 
      else if t < (t0 + period + period + period) then 
        "Engine 2024 (rebuilding..)" 
      else 
        windowTitle (t0 + period + period + period) t

Deduction

This shows how the explicit form was deduced.

Definitions:

-- Definitions
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

untilTime :: Behavior a -> Time -> (Behavior a, Event ())
b `untilTime` t' = b `untilB` (t',())

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

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

Original animation definition:

-- REWRITE 0
windowTitle :: Time -> Behavior String
windowTitle = 
  let period = 3 in
  \t0   -> constB "Engine 2024 (rebuilding)"  `untilTime` (t0 + period) `thenMap`
  \t1 _ -> constB "Engine 2024 (rebuilding..)" `untilTime` (t1 + period) `thenMap`
  \t2 _ -> windowTitle t2

Rewrite all infix functions to prefix:

-- REWRITE 1
windowTitle = 
  let period = 3 in
  \t0   -> thenMap (untilTime (constB "Engine 2024 (rebuilding)")  (t0 + period))
    (\t1 _ -> thenMap (untilTime (constB "Engine 2024 (rebuilding..)")  (t1 + period))
      (\t2 _ -> windowTitle t2))

Rewrite the t1 to t2 chain link:

-- REWRITE 2
windowTitle = 
  let period = 3 in
  \t0 -> 
    thenMap 
    ((\t -> "Engine 2024 (rebuilding)", (t0 + period, ())))
    (\t1 _ -> \t -> if t < (t1 + period) then "Engine 2024 (rebuilding..)" else windowTitle (t1 + period) t)

Rewrite the t0 to t1 chain link:

-- REWRITE 3
windowTitle :: Time -> Behavior String
windowTitle t0 = 
  let period = 3 in
    \t -> 
      if t < (t0 + period) then 
        "Engine 2024 (rebuilding)" 
      else if t < (t0 + period + period) then 
        "Engine 2024 (rebuilding..)" 
      else 
        windowTitle (t0 + period + period) t

@Warwolt
Copy link
Author

Warwolt commented May 23, 2024

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)

@Warwolt
Copy link
Author

Warwolt commented May 23, 2024

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

@Warwolt
Copy link
Author

Warwolt commented May 26, 2024

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