{-----------------------------------------------------------------------------
reactive-banana-threepenny
Example: Emit a wave of light.
Demonstrates that reactive-banana is capable of emitting timed events,
even though it has no built-in notion of time.
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"
import Control.Monad
import qualified Data.List as List
import Data.Maybe
import Data.Ord
import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core hiding (Event)
import Reactive.Banana
import Reactive.Banana.Threepenny
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
lightCount = 15 -- number of lights that comprise the wave
waveLength = 4 -- number of lights that are lit at once
dt = 70 -- half the cycle duration
main :: IO ()
main = do
startGUI Config
{ tpPort = 10000
, tpCustomHTML = Nothing
, tpStatic = ""
} setup
setup :: Window -> IO ()
setup window = do
return window # set title "Waves of Light"
left <- UI.button #+ [string "Left" ]
right <- UI.button #+ [string "Right"]
lights <- sequence $ replicate lightCount $ UI.span # set text "•"
getBody window #+ [column
[row [element left, element right]
,row $ map element lights
]]
timer <- UI.timer
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
eLeft <- event UI.click left
eRight <- event UI.click right
-- event describing all the lights
eWave <- scheduleQueue timer $ (waveLeft <$ eLeft ) `union`
(waveRight <$ eRight)
-- animate the lights
forM_ [1 .. lightCount] $ \k -> do
let
bulb = lights !! (k-1)
bBulb = stepper False $ snd <$> filterE ((== k) . fst) eWave
colorize True = "red"
colorize False = "black"
return bulb # sink color (colorize <$> bBulb)
network <- compile networkDescription
actuate network
color = mkWriteAttr $ \i -> set' style [("color",i)]
type Index = Int
type Action = (Index, Bool)
-- describe wave pattern as a list
wave :: (Index -> Index) -> [(Duration, Action)]
wave f = deltas $ merge ons offs
where
merge xs ys = List.sortBy (comparing fst) $ xs ++ ys
deltas xs = zipWith relativize (0 : map fst xs) xs
where relativize dt1 (dt2,x) = (dt2-dt1, x)
ons = [(k*2*dt, (f k, True)) | k <- [1..lightCount]]
offs = [(dt+(waveLength+k)*2*dt, (f k, False)) | k <- [1..lightCount]]
waveLeft = wave id
waveRight = wave (\k -> lightCount - k + 1)
{-----------------------------------------------------------------------------
Timer magic
------------------------------------------------------------------------------}
type Duration = Int -- in milliseconds
type Queue a = [(Duration, a)] -- [(time to wait, occurrence to happen)]
type Enqueue a = Queue a
-- Schedule events to happen after a given duration from their occurrence
-- However, new events will *not* be scheduled before the old ones have finished.
scheduleQueue :: Frameworks t =>
UI.Timer -> Event t (Enqueue a) -> Moment t (Event t a)
scheduleQueue t e = do
liftIO $ UI.stop t
eAlarm <- event UI.tick t
let
-- (Queue that keeps track of events to schedule
-- , duration of the new alarm if applicable)
(eSetNewAlarmDuration, bQueue) =
mapAccum [] $ (remove <$ eAlarm) `union` (add <$> e)
-- change queue and change timer
remove (_:[]) = (stop, [])
remove (_:xs) = (wait (fst $ head xs), xs)
add ys [] = (wait (fst $ head ys), ys)
add ys xs = (idle, xs ++ ys)
wait dt = do { return t # set UI.interval dt; UI.start t }
stop = UI.stop t
idle = return ()
-- Return topmost value from the queue whenever the alarm rings.
-- The queue is never empty when the alarm rings.
eout = fmap (snd . head) $ bQueue <@ eAlarm
reactimate $ eSetNewAlarmDuration
return eout