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