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