diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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" diff --git a/reactive-banana-wx.cabal b/reactive-banana-wx.cabal --- a/reactive-banana-wx.cabal +++ b/reactive-banana-wx.cabal @@ -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 + diff --git a/src/Asteroids.hs b/src/Asteroids.hs new file mode 100644 --- /dev/null +++ b/src/Asteroids.hs @@ -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 [] diff --git a/src/CRUD.hs b/src/CRUD.hs new file mode 100644 --- /dev/null +++ b/src/CRUD.hs @@ -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 + + + + diff --git a/src/Counter.hs b/src/Counter.hs --- a/src/Counter.hs +++ b/src/Counter.hs @@ -3,8 +3,6 @@ Example: Counter ------------------------------------------------------------------------------} -module Main where - import Control.Monad import Graphics.UI.WX hiding (Event) import Reactive.Banana diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs new file mode 100644 --- /dev/null +++ b/src/CurrencyConverter.hs @@ -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 + + diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs new file mode 100644 --- /dev/null +++ b/src/NetMonitor.hs @@ -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 diff --git a/src/Reactive/Banana/WX.hs b/src/Reactive/Banana/WX.hs --- a/src/Reactive/Banana/WX.hs +++ b/src/Reactive/Banana/WX.hs @@ -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") [] + diff --git a/src/TwoCounters.hs b/src/TwoCounters.hs --- a/src/TwoCounters.hs +++ b/src/TwoCounters.hs @@ -3,8 +3,6 @@ Example: Two Counters. ------------------------------------------------------------------------------} -module Main where - import Control.Monad import Graphics.UI.WX hiding (Event) import Reactive.Banana diff --git a/src/Wave.hs b/src/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Wave.hs @@ -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 + + + +