reactive-banana-wx 0.4.0.0 → 0.4.1.0
raw patch · 11 files changed
+745/−18 lines, 11 filesdep +cabal-macosxdep +directorydep +randomdep ~reactive-bananabuild-type:Customsetup-changednew-component:exe:Asteroidsnew-component:exe:CRUDnew-component:exe:CurrencyConverternew-component:exe:NetMonitornew-component:exe:Wave
Dependencies added: cabal-macosx, directory, random
Dependency ranges changed: reactive-banana
Files
- Makefile +26/−9
- Setup.hs +25/−1
- reactive-banana-wx.cabal +29/−3
- src/Asteroids.hs +158/−0
- src/CRUD.hs +259/−0
- src/Counter.hs +0/−2
- src/CurrencyConverter.hs +65/−0
- src/NetMonitor.hs +56/−0
- src/Reactive/Banana/WX.hs +14/−1
- src/TwoCounters.hs +0/−2
- src/Wave.hs +113/−0
Makefile view
@@ -1,21 +1,38 @@ .PHONY: all clean open -APPS=Counter+APPS=Asteroids Counter CRUD CurrencyConverter NetMonitor TwoCounters Wave OBJ=dist/build-COMPILE=ghc --make -outputdir $(OBJ) -i$(OBJ) -L$(OBJ) -isrc -i../reactive-banana/src+COMPILE=ghc --make -i$(OBJ) -L/usr/lib -L$(OBJ) -isrc -i../reactive-banana/src -all: TwoCounters Counter+all: $(APPS) +Asteroids : src/Asteroids.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@+ Counter : src/Counter.hs src/Reactive/Banana/WX.hs- $(COMPILE) -o $@ src/Counter.hs- macosx-app $@ + $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@ +NetMonitor : src/NetMonitor.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@++CRUD : src/CRUD.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@++CurrencyConverter : src/CurrencyConverter.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@+ TwoCounters : src/TwoCounters.hs src/Reactive/Banana/WX.hs- $(COMPILE) -o $@ src/TwoCounters.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ macosx-app $@+ +Wave : src/Wave.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/+ macosx-app $@ clean: rm -rf $(APPS) $(OBJ)/*.o $(OBJ)/*.hi *.app *.exe *.manifest--open: all- open TwoCounters.app
Setup.hs view
@@ -1,2 +1,26 @@+-- Build .app bundles with the cabal-macosx package+-- Modeled after the excellent documentation on +-- https://github.com/gimbo/cabal-macosx/tree/master/examples++import Distribution.MacOSX import Distribution.Simple-main = defaultMain++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {+ postBuild = appBundleBuildHook guiApps -- no-op if not MacOS X+ }++guiApps :: [MacApp]+guiApps = [MacApp "Asteroids"+ Nothing+ Nothing -- Build a default Info.plist for the icon.+ files -- No other resources.+ [] -- No other binaries.+ DoNotChase -- Try changing to ChaseWithDefaults+ ] ++ apps++apps = map app $ words "Counter CurrencyConverter TwoCounters Wave"+app name = MacApp name Nothing Nothing [] [] DoNotChase++files = map ("data/" ++) $+ words "burning.ico rock.ico ship.ico explode.wav"
reactive-banana-wx.cabal view
@@ -1,9 +1,12 @@ Name: reactive-banana-wx-Version: 0.4.0.0+Version: 0.4.1.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library, using wxHaskell.+ .+ Note: You need to install the (platform independent)+ @cabal-macosx@ library before you can configure/build and install this library. Homepage: http://haskell.org/haskellwiki/Reactive-banana License: BSD3@@ -14,13 +17,15 @@ Cabal-version: >=1.6 -Build-type: Simple+Build-type: Custom Extra-source-files: Makefile Library hs-source-dirs: src build-depends: base >= 4.2 && < 4.4,- reactive-banana >= 0.4.0.0 && < 0.5,+ cabal-macosx == 0.1.*, random == 1.0.*,+ directory == 1.1.*,+ reactive-banana >= 0.4.1.0 && < 0.5, wx==0.12.*, wxcore==0.12.* extensions: ExistentialQuantification exposed-modules: Reactive.Banana.WX@@ -30,10 +35,31 @@ location: git://github.com/HeinrichApfelmus/Haskell-BlackBoard.git subdir: reactive-banana-wx +Executable Asteroids+ hs-source-dirs: src+ main-is: Asteroids.hs+ Executable Counter hs-source-dirs: src main-is: Counter.hs +Executable CurrencyConverter+ hs-source-dirs: src+ main-is: CurrencyConverter.hs++Executable CRUD+ hs-source-dirs: src+ main-is: CRUD.hs++Executable NetMonitor+ hs-source-dirs: src+ main-is: NetMonitor.hs+ Executable TwoCounters hs-source-dirs: src main-is: TwoCounters.hs++Executable Wave+ hs-source-dirs: src+ main-is: Wave.hs+
+ src/Asteroids.hs view
@@ -0,0 +1,158 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: Asteroids, adapted from+ http://www.haskell.org/haskellwiki/WxAsteroids+------------------------------------------------------------------------------}+import Graphics.UI.WX hiding (Event)+import Graphics.UI.WXCore as WXCore+import Reactive.Banana+import Reactive.Banana.WX+import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.Random+-- import Paths_wxAsteroids (getDataDir)++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+-- constants+height, width, diameter :: Int+height = 300+width = 300+diameter = 24++chance :: Double +chance = 0.1++rock, burning, ship :: Bitmap ()+rock = bitmap "data/rock.ico"+burning = bitmap "data/burning.ico"+ship = bitmap "data/ship.ico"++explode :: WXCore.Sound ()+explode = sound "data/explode.wav" ++getDataDir = (++ "/data") <$> getCurrentDirectory++main :: IO ()+main = + -- dataDirectory <- getDataDir+ -- setCurrentDirectory dataDirectory + start asteroids++{-----------------------------------------------------------------------------+ Game Logic +------------------------------------------------------------------------------}+-- main game function+asteroids :: IO () +asteroids = do+ f <- frame [ resizeable := False ]++ status <- statusField [text := "Welcome to asteroids"] + set f [statusBar := [status]] ++ t <- timer f [ interval := 50 ]++ game <- menuPane [ text := "&Game" ] + new <- menuItem game [ text := "&New\tCtrl+N", help := "New game" ]+ pause <- menuItem game [ text := "&Pause\tCtrl+P" + , help := "Pause game" + , checkable := True+ ] + menuLine game+ quit <- menuQuit game [help := "Quit the game"] + + set new [on command := asteroids] + set pause [on command := set t [enabled :~ not]] + set quit [on command := close f]+ + set f [menuBar := [game]]+ + set f [ text := "Asteroids" + , bgcolor := white + , layout := space width height+ , on (charKey '-') := set t [interval :~ \i -> i * 2] + , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)] + ]+ + -- event network+ network <- compile $ do+ -- timer+ etick <- event0 t command+ + -- keyboard events+ ekey <- event1 f keyboard+ let eleft = filterE ((== KeyLeft ) . keyKey) ekey+ eright = filterE ((== KeyRight) . keyKey) ekey+ + -- ship position+ let+ bship :: Behavior Int+ bship = accumB (width `div` 2) $+ (goLeft <$ eleft) `union` (goRight <$ eright)+ + goLeft x = max 0 (x - 5)+ goRight x = min width (x + 5)+ + -- rocks+ brandom <- fromPoll (randomRIO (0,1) :: IO Double)+ let+ brocks :: Behavior [Rock]+ brocks = accumB [] $+ (advanceRocks <$ etick) `union`+ (newRock <$> filterE (< chance) (brandom <@ etick))+ + -- draw the game state+ sink f [on paint :== stepperD (\_dc _ -> return ()) $+ (drawGameState <$> bship <*> brocks) <@ etick]+ reactimate $ repaint f <$ etick+ + -- status bar+ let dstatus :: Discrete String+ dstatus = stepperD "Welcome to asteroids" $+ ((\r -> "rocks: " ++ show (length r)) <$> brocks) <@ etick+ sink status [text :== dstatus]+ + actuate network+++-- rock logic+type Position = Point2 Int+type Rock = [Position] -- lazy list of future y-positions++newRock :: Double -> [Rock] -> [Rock]+newRock r rs = (track . floor $ fromIntegral width * r / chance) : rs++track :: Int -> Rock+track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]++advanceRocks :: [Rock] -> [Rock]+advanceRocks = filter (not . null) . map (drop 1)++++-- draw game state+drawGameState :: Int -> [Rock] -> DC a -> b -> IO ()+drawGameState ship rocks dc _view = do+ let+ shipLocation = point ship (height - 2 * diameter)+ positions = map head rocks+ collisions = map (collide shipLocation) positions++ drawShip dc shipLocation+ mapM (drawRock dc) (zip positions collisions) ++ when (or collisions) (play explode)++collide :: Position -> Position -> Bool+collide pos0 pos1 = + let distance = vecLength (vecBetween pos0 pos1) + in distance <= fromIntegral diameter ++drawShip :: DC a -> Point -> IO ()+drawShip dc pos = drawBitmap dc ship pos True [] ++drawRock :: DC a -> (Point, Bool) -> IO ()+drawRock dc (pos, collides) = + let rockPicture = if collides then burning else rock+ in drawBitmap dc rockPicture pos True []
+ src/CRUD.hs view
@@ -0,0 +1,259 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: ListBox with CRUD operations+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+-- import Control.Monad+import qualified Data.List+import Data.Maybe+import qualified Data.Map as Map+import Graphics.UI.WX as WX hiding (Event)+import Reactive.Banana+import Reactive.Banana.WX++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main = start $ do+ -- GUI layout+ f <- frame [ text := "CRUD Example" ]+ listBox <- singleListBox f []+ create <- button f [ text := "Create" ]+ delete <- button f [ text := "Delete" ]+ filter <- entry f [ processEnter := True ]+ + name <- entry f [ processEnter := True ]+ surname <- entry f [ processEnter := True ]+ + let dataItem = grid 10 10 [[label "Name:", widget name]+ ,[label "Surname:", widget surname]]+ set f [layout := margin 10 $+ grid 10 5+ [[row 5 [label "Filter prefix:", widget filter], glue]+ ,[minsize (sz 200 300) $ widget listBox, dataItem]+ ,[row 10 [widget create, widget delete], glue]+ ]]++ -- event network+ network <- compile $ mdo+ -- events from buttons+ eDelete <- event0 delete command+ eCreate <- event0 create command + + -- time-varying value corresponding to the filter string+ (bFilter, eFilter) <- reactimateTextEntry filter (pure "")+ let dFilter = stepperD "" $ bFilter <@ eFilter+ + -- list box with selection+ dSelectedItem <- reactimateListBox listBox database dFilter+ -- data corresponding to the selected item in the list box+ (inDataItem, changeDataItem)+ <- reactimateDataItem (name, surname) outDataItem+ + let+ -- update the database whenever+ -- a data item is created, updated or deleted+ database :: DatabaseTime DataItem+ database = accumDatabase $+ (Create Nothing ("Emil","Example") <$ eCreate)+ `union` (Update <$> dSelectedItem <@>+ (inDataItem <@ changeDataItem))+ `union` (Delete <$> dSelectedItem <@ eDelete )+ + -- display the data item whenever the selection changes+ outDataItem = stepperD ("","") $+ lookup <$> valueDB database <@> changes dSelectedItem+ where+ lookup database m = maybe ("","") id $+ readDatabase database =<< m++ -- automatically enable / disable editing+ let dDisplayItem = maybe False (const True) <$> dSelectedItem+ sink delete [ enabled :== dDisplayItem ]+ sink name [ enabled :== dDisplayItem ]+ sink surname [ enabled :== dDisplayItem ]+ + actuate network++{-----------------------------------------------------------------------------+ Database Model+------------------------------------------------------------------------------}+-- Create/Update/Delete data type for efficient updates+data CUD key a+ = Create { getKey :: key, getItem :: a }+ | Update { getKey :: key, getItem :: a }+ | Delete { getKey :: key }++instance Functor (CUD key) where+ fmap f (Delete x) = Delete x+ fmap f cud = cud { getItem = f $ getItem cud }++isDelete (Delete _) = True+isDelete _ = False++-- Database type+type DatabaseKey = Int+data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }++emptyDatabase = Database 0 Map.empty++-- Time-varying database,+-- similar to the Discrete type+data DatabaseTime a = DatabaseTime+ { valueDB :: Behavior (Database a)+ , initialDB :: Database a+ , changesDB :: Event (CUD DatabaseKey a)+ }++-- accumulate a database from CUD operations+accumDatabase :: Event (CUD (Maybe DatabaseKey) a) -> DatabaseTime a+accumDatabase e = DatabaseTime valueDB initialDB changesDB+ where+ (changesDB, valueDB) = mapAccum initialDB $ acc <$> filterE valid e+ initialDB = emptyDatabase+ + valid (Create Nothing _) = True+ valid cud = maybe False (const True) $ getKey cud+ + -- accumulation function+ acc (Create Nothing x) (Database newkey db) + = (Create newkey x, Database (newkey+1) $ Map.insert newkey x db)+ acc (Update (Just key) x) (Database newkey db)+ = (Update key x, Database newkey $ Map.insert key x db)+ acc (Delete (Just key)) (Database newkey db)+ = (Delete key , Database newkey $ Map.delete key db)++-- read a value from the database+readDatabase :: Database a -> DatabaseKey -> Maybe a+readDatabase (Database _ db) = flip Map.lookup db++{-----------------------------------------------------------------------------+ Data items that are stored in the data base+------------------------------------------------------------------------------}+type DataItem = (String, String)++-- text entry widgets in terms of discrete time-varying values+reactimateTextEntry+ :: TextCtrl a+ -> Discrete String -- set text programmatically (view)+ -> NetworkDescription+ (Behavior String -- current text (both view & controller)+ ,Event ()) -- user changes (controller)+reactimateTextEntry entry input = do+ sink entry [ text :== input ]++ -- event: Enter key+ eEnter <- event0 entry command+ -- event: text entry loses focus+ eLeave <- (() <$) . filterE not <$> event1 entry focus+ b <- behavior entry text+ return (b, eEnter `union` eLeave)++-- whole data item (consisting of two text entries)+reactimateDataItem+ :: (TextCtrl a, TextCtrl b)+ -> Discrete DataItem+ -> NetworkDescription+ (Behavior DataItem, Event ())+reactimateDataItem (name,surname) input = do+ (d1,e1) <- reactimateTextEntry name (fst <$> input)+ (d2,e2) <- reactimateTextEntry surname (snd <$> input)+ return ( (,) <$> d1 <*> d2 , e1 `union` e2 )++-- custom show function+showDataItem (name, surname) = surname ++ ", " ++ name ++{-----------------------------------------------------------------------------+ List Box View+------------------------------------------------------------------------------}+-- Display the data base in a list box (view).+-- Also keep track of the currently selected item (controller).+reactimateListBox+ :: SingleListBox b -- list box widget+ -> DatabaseTime DataItem -- database+ -> Discrete String -- filter string+ -> NetworkDescription+ (Discrete (Maybe DatabaseKey)) -- current selection as database key++reactimateListBox listBox database filter = do+ -- The list box keeps track+ -- of which data items are displayed, at which positions+ let (eListBoxUpdates, bDisplayMap)+ = mapAccum Map.empty+ $ (cudUpdate . fmap showDataItem <$> changesDB database)+ `union` (filterUpdate <$> valueDB database <@> changes filter)+ + -- "animate" changes to the list box+ reactimate $ eListBoxUpdates+ -- debug: reactimate $ fmap print $ bDisplayMap <@ eListBoxUpdates+ + -- event: item selection, maps to database key+ fixSelectionEvent listBox+ bSelection <- behavior listBox selection+ eSelect <- event0 listBox select+ let eDelete = filterE isDelete $ changesDB database+ return $ stepperD Nothing $+ -- event: item deleted + (Nothing <$ eDelete) `union`+ -- event: filter string changed+ (Nothing <$ changes filter) `union`+ -- event: user changes selection+ (lookupPositon <$> bSelection <*> bDisplayMap <@ eSelect)++ where++ -- turn CUD into a function that updates+ -- ( the graphics of the list box+ -- , the map from database keys to list positions )+ cudUpdate+ :: CUD DatabaseKey String -> DisplayMap -> (IO (), DisplayMap)++ cudUpdate (Create key str) display+ = (itemAppend listBox str, appendKey key display)+ cudUpdate (Update key str) display+ = case lookupKey key display of+ Just position -> (set listBox [ item position := str ], display)+ Nothing -> (return (), display)+ cudUpdate (Delete key) display+ = case lookupKey key display of+ Just position -> (itemDelete listBox position+ ,deleteKey key position display)+ Nothing -> (return (), display)+ + -- rebuild listBox when filter string changes+ filterUpdate database s _ = (set listBox [ items := xs ], display)+ where+ dat = Map.filter (s `Data.List.isPrefixOf`)+ . Map.map showDataItem . db $ database+ xs = Map.elems dat+ display = Map.fromList $ zip (Map.keys dat) [0..] +++-- Map between database keys and their position in the list box+type DisplayMap = Map.Map DatabaseKey Int++lookupKey = Map.lookup+lookupPositon pos = fmap fst . Data.List.find ((pos ==) . snd) . Map.toList+appendKey key display = Map.insert key (Map.size display) display+deleteKey key position display+ = Map.delete key+ -- recalculate positions of the other elements+ . Map.map (\pos -> if pos > position then pos - 1 else pos)+ $ display++{-----------------------------------------------------------------------------+ wxHaskell bug fixes+------------------------------------------------------------------------------}+-- Fix @select@ event not being fired when items are *un*selected+fixSelectionEvent listbox =+ liftIO $ set listbox [ on unclick := handler ]+ where+ handler _ = do+ propagateEvent+ s <- get listbox selection+ when (s == -1) $ (get listbox (on select)) >>= id+ +++
src/Counter.hs view
@@ -3,8 +3,6 @@ Example: Counter ------------------------------------------------------------------------------}-module Main where- import Control.Monad import Graphics.UI.WX hiding (Event) import Reactive.Banana
+ src/CurrencyConverter.hs view
@@ -0,0 +1,65 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: Currency Converter+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+import Data.Bits+import Data.Maybe+import Graphics.UI.WX hiding (Event)+import Graphics.UI.WXCore hiding (Event)+import Reactive.Banana+import Reactive.Banana.WX+import Text.Printf++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main = start $ do+ -- FIXME: Why does tab traversal not work?+ f <- frame [ text := "Currency Converter", tabTraversal := True ]+ dollar <- entry f [ processEnter := True ]+ euro <- entry f [ processEnter := True ]+ + set f [layout := margin 10 $+ column 10 [+ grid 10 10 [[label "Dollar:", widget dollar],+ [label "Euro:" , widget euro ]]+ , label "Press enter to convert"+ ]]++ network <- compile $ mdo + euroIn <- reactimateTextEntry euro euroOut+ dollarIn <- reactimateTextEntry dollar dollarOut++ let rate = 0.7 :: Double+ withString f s+ = maybe "-" (printf "%.2f") . fmap f + $ listToMaybe [x | (x,"") <- reads s] + + -- define output values in terms of input values+ dollarOut, euroOut :: Discrete String+ dollarOut = withString (/ rate) <$> stepperD "0" euroIn+ euroOut = withString (* rate) <$> stepperD "0" dollarIn++ return ()+ + actuate network+++-- text entry widget in terms of discrete time-varying values+reactimateTextEntry+ :: TextCtrl a+ -> Discrete String -- set programmatically (view)+ -> NetworkDescription (Event String) -- read from user (controller)+reactimateTextEntry entry input = do+ sink entry [ text :== input ]++ -- FIXME: How to do real-time updates?+ -- The keyboard event always lags one character behind.+ -- Where is wxEVT_COMMAND_TEXT_UPDATED in wxHaskell?+ e <- event0 entry command+ b <- behavior entry text+ return $ b <@ e++
+ src/NetMonitor.hs view
@@ -0,0 +1,56 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: Minuscule network monitor+------------------------------------------------------------------------------}+import Data.Char+import Data.List+import Data.Maybe+import Graphics.UI.WX hiding (Event)+import Reactive.Banana+import Reactive.Banana.WX+import System.Process++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main = start $ do+ f <- frame [text := "Network Monitor"]+ out1 <- staticText f []+ out2 <- staticText f []+ + set f [layout := margin 10 $+ column 10 [label "TCP network statistics",+ grid 5 5 [[label "Packets sent: ", widget out1]+ ,[label "Packets received: ", widget out2]]+ ]+ , size := sz 250 70]+ + t <- timer f [ interval := 500 ] -- timer every 500 ms++ network <- compile $ do+ etick <- event0 t command+ bnetwork <- fromPoll $ getNetworkStatistics+ + let showStat f = stepperD "" $ f <$> (bnetwork <@ etick)+ sent = maybe "parse error" show . fst+ received = maybe "parse error" show . snd+ + sink out1 [ text :== showStat sent ]+ sink out2 [ text :== showStat received ]+ + actuate network++-- obtain network statistics+type NetworkStatistics = (Maybe Int, Maybe Int)++getNetworkStatistics :: IO NetworkStatistics+getNetworkStatistics = do+ s <- readProcess "netstat" ["-s", "-p","tcp"] ""+ return (readField "packets sent" s+ ,readField "packets received" s)++readField :: String -> String -> Maybe Int+readField fieldname = id+ . fmap (read . filter isDigit) . listToMaybe+ . filter (fieldname `isSuffixOf`) . lines
src/Reactive/Banana/WX.hs view
@@ -24,6 +24,11 @@ liftIO $ WX.set widget [on e :~ \h x -> h x >> runHandlers x] fromAddHandler addHandler + -- NOTE: Some events don't work, for instance leftKey and rightKey+ -- "user error (WX.Events: the key event is write-only.)"+ -- That's because they are actually just derived from the key event+ -- Not sure what to do with this.+ -- | Event without parameters. event0 :: w -> WX.Event w (IO ()) -> NetworkDescription (Event ()) event0 widget e = event1 widget $ WX.mapEvent const (\_ e -> e ()) e@@ -42,8 +47,16 @@ sink widget props = mapM_ sink1 props where sink1 (attr :== x) = do- liftIO $ WX.set widget [attr := initial x]+ liftIOLater $ WX.set widget [attr := initial x] reactimate $ (\x -> WX.set widget [attr := x]) <$> changes x++-- Typeable instances, yikes!+-- Also, these instances are wrong, but I don't care.+instance Typeable WX.EventKey where+ typeOf _ = mkTyConApp (mkTyCon "WX.EventKey") []+instance Typeable WX.EventMouse where+ typeOf _ = mkTyConApp (mkTyCon "WX.EventMouse") []+
src/TwoCounters.hs view
@@ -3,8 +3,6 @@ Example: Two Counters. ------------------------------------------------------------------------------}-module Main where- import Control.Monad import Graphics.UI.WX hiding (Event) import Reactive.Banana
+ src/Wave.hs view
@@ -0,0 +1,113 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: Guitar chord simulation+------------------------------------------------------------------------------}+import Control.Monad+import qualified Data.List as List+import Data.Maybe+import Data.Ord+import Graphics.UI.WX hiding (Event)+import Reactive.Banana+import Reactive.Banana.WX++{-----------------------------------------------------------------------------+ 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 = start $ do+ -- create window and widgets+ f <- frame [text := "Waves of Light"]+ left <- button f [text := "Left"]+ right <- button f [text := "Right"]+ lights <- sequence $ replicate lightCount $ staticText f [text := "•"]+ + set f [layout := margin 10 $+ column 10 [row 5 [widget left, widget right],+ row 5 $ map widget lights]+ ]+ + -- we're going to need a timer+ t <- timer f []+ + network <- compile $ do+ eLeft <- event0 left command+ eRight <- event0 right command+ + -- event describing all the lights+ eWave <- scheduleQueue t $ (waveLeft <$ eLeft ) `union` + (waveRight <$ eRight)+ + -- animate the lights+ forM_ [1 .. lightCount] $ \k -> do+ let+ bulb = lights !! (k-1)+ dBulb = stepperD False $ snd <$> filterE ((== k) . fst) eWave+ + colorize True = red+ colorize False = black+ + sink bulb [ color :== colorize <$> dBulb ] ++ actuate network++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 :: Timer -> Event (Enqueue a) -> NetworkDescription (Event a)+scheduleQueue t e = do+ liftIO $ set t [ enabled := False ]+ eAlarm <- event0 t command+ 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 = set t [ enabled := True, interval := dt ]+ stop = set t [ enabled := False ]+ 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++ + +