public
Created

reactive-banana throttling events

  • Download Gist
gistfile1.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
{-----------------------------------------------------------------------------
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"
 
import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
 
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
 
data ThrottledValue a = FireStoredValue a | FireNowAndStartTimer a| HoldIt a | Stopped deriving Show
data ThrottledEvent a = TimerEvent | RealEvent a deriving Show
 
main :: IO ()
main = start $ do
f <- frame [text := "Countercesss"]
sl1 <- hslider f False 0 100 []
sl2 <- hslider f False 0 100 []
set f [ layout := column 0 [widget sl1, widget sl2] ]
t <- timer f []
set t [ enabled := False ]
let networkDescription :: forall t. NetworkDescription t ()
networkDescription = do
slEv <- event0 sl1 command
tick <- event0 t command
slB <- behavior sl1 selection
throttledEv <- throttle (slB <@ slEv) tick t 100
reactimate $ fmap (\x -> set sl2 [selection := x]) throttledEv
net <- compile networkDescription
actuate net
throttle::Event t a -> Event t () -> Timer -> Int -> NetworkDescription t (Event t a)
throttle ev tick timer dt = do
reactimate $ filterJust $ fmap stop result
reactimate $ filterJust $ fmap start result
return throttledEv
where
all = fmap RealEvent ev `union` fmap (const TimerEvent) tick
result = accumE Stopped $ fmap h all
where
h (RealEvent x) Stopped = FireNowAndStartTimer x
h TimerEvent Stopped = Stopped
h (RealEvent x) (FireNowAndStartTimer _) = HoldIt x
h TimerEvent (FireNowAndStartTimer _) = Stopped
h (RealEvent x) (HoldIt _) = HoldIt x
h (TimerEvent) (HoldIt y) = FireStoredValue y
h (RealEvent x) (FireStoredValue _) = HoldIt x
h (TimerEvent) (FireStoredValue _) = Stopped
start (FireStoredValue _) = Just $ resetTimer timer dt
start (FireNowAndStartTimer _) = Just $ resetTimer timer dt
start _ = Nothing
stop Stopped = Just $ stopTimer timer
stop _ = Nothing
filterFired (FireStoredValue a) = Just a
filterFired (FireNowAndStartTimer a) = Just a
filterFired _ = Nothing
throttledEv = filterJust $ fmap filterFired result
startTimer :: Timer -> Int -> IO ()
startTimer t dt = set t [ enabled := True, interval := dt ]
 
stopTimer :: Timer -> IO ()
stopTimer t = set t [ enabled := False ]
 
resetTimer t dt = stopTimer t >> startTimer t dt

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.