reactive-banana-wx 0.4.3.2 → 0.5.0.0
raw patch · 12 files changed
+497/−426 lines, 12 filesdep ~reactive-bananadep ~wxdep ~wxcore
Dependency ranges changed: reactive-banana, wx, wxcore
Files
- Makefile +33/−4
- reactive-banana-wx.cabal +4/−3
- src/Arithmetic.hs +13/−17
- src/Asteroids.hs +66/−51
- src/CRUD.hs +144/−195
- src/Counter.hs +12/−6
- src/CurrencyConverter.hs +17/−32
- src/NetMonitor.hs +18/−10
- src/Reactive/Banana/WX.hs +93/−30
- src/TicTacToe.hs +48/−45
- src/TwoCounters.hs +24/−17
- src/Wave.hs +25/−16
Makefile view
@@ -2,11 +2,40 @@ APPS=Asteroids Counter CRUD CurrencyConverter NetMonitor TicTacToe TwoCounters Wave OBJ=dist/build-COMPILE=ghc --make -i$(OBJ) -L/usr/lib -L$(OBJ) -isrc -i../reactive-banana/src -idist/build/autogen+COMPILE= \+ ghc --make -i$(OBJ) -L/usr/lib -L$(OBJ) \+ -isrc -i../reactive-banana/src -idist/build/autogen +# Compile all programs with cabal all: cabal configure && cabal build --ghc-options=-L/usr/lib -test : src/Asteroids.hs src/Reactive/Banana/WX.hs- $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/- macosx-app $@++# Compile individual programs for testing+Arithmetic : src/Arithmetic.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@++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 $@ $< -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 $@++NetMonitor : src/NetMonitor.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@++TicTacToe : src/TicTacToe.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@++TwoCounters : src/TwoCounters.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@++Wave : src/Wave.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@+
reactive-banana-wx.cabal view
@@ -1,5 +1,5 @@ Name: reactive-banana-wx-Version: 0.4.3.2+Version: 0.5.0.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library,@@ -13,6 +13,7 @@ . @cabal install reactive-banana-wx -fbuildExamples@ .+ Stability forecast: The wrapper functions are rather provisional. Homepage: http://haskell.org/haskellwiki/Reactive-banana License: BSD3@@ -37,8 +38,8 @@ hs-source-dirs: src build-depends: base >= 4.2 && < 5, cabal-macosx >= 0.1 && < 0.3,- reactive-banana >= 0.4.3.0 && < 0.5,- wx >= 0.12.1.6 && < 0.12.2, wxcore >= 0.12.1.7 && < 0.12.2+ reactive-banana >= 0.5.0.0 && < 0.6,+ wx==0.12.1.6, wxcore==0.12.1.7 extensions: ExistentialQuantification exposed-modules: Reactive.Banana.WX
src/Arithmetic.hs view
@@ -3,7 +3,10 @@ Example: Very simple arithmetic ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Data.Maybe+ import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX@@ -13,37 +16,30 @@ ------------------------------------------------------------------------------} main = start $ do f <- frame [text := "Arithmetic"]- calculate <- button f [text := "="] input1 <- entry f [processEnter := True] input2 <- entry f [processEnter := True] output <- staticText f [ size := sz 40 20 ] set f [layout := margin 10 $ row 10 $ [widget input1, label "+", widget input2- , widget calculate, widget output]]+ , label "=", widget output]] - network <- compile $ do- -- TODO: Maybe include real-time updates? (see CurrencyConverter.hs)- eenter1 <- event0 input1 command- eenter2 <- event0 input2 command- ebutton <- event0 calculate command+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do - binput1 <- behavior input1 text- binput2 <- behavior input2 text+ binput1 <- behaviorText input1 ""+ binput2 <- behaviorText input2 "" let- ecalculate :: Event ()- ecalculate = ebutton `union` eenter1 `union` eenter2- - result :: Discrete (Maybe Int)- result = stepperD Nothing $- (f <$> binput1 <*> binput2) <@ ecalculate+ result :: Behavior t (Maybe Int)+ result = f <$> binput1 <*> binput2 where f x y = liftA2 (+) (readNumber x) (readNumber y) readNumber s = listToMaybe [x | (x,"") <- reads s] showNumber = maybe "--" show - sink output [text :== showNumber <$> result]- + sink output [text :== showNumber <$> result] ++ network <- compile networkDescription actuate network
src/Asteroids.hs view
@@ -1,9 +1,18 @@ {----------------------------------------------------------------------------- reactive-banana-wx - Example: Asteroids, adapted from- http://www.haskell.org/haskellwiki/WxAsteroids+ Example:+ Asteroids, adapted from+ http://www.haskell.org/haskellwiki/WxAsteroids+ + The original example has a few graphics issues+ and I didn't put much work into correcting them.+ For more, see also + https://github.com/killerswan/wxAsteroids/issues/1+ http://comments.gmane.org/gmane.comp.lang.haskell.wxhaskell.general/1086 ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Graphics.UI.WX hiding (Event) import Graphics.UI.WXCore as WXCore import Reactive.Banana@@ -50,75 +59,81 @@ Game Logic ------------------------------------------------------------------------------} -- main game function-asteroids :: IO () +asteroids :: IO () asteroids = do- f <- frame [ resizeable := False ]+ ff <- frame [ text := "Asteroids"+ , bgcolor := white+ , clientSize := sz width height+ , resizeable := False ] status <- statusField [text := "Welcome to asteroids"] - set f [statusBar := [status]] + set ff [statusBar := [status]] - t <- timer f [ interval := 50 ]+ t <- timer ff [ interval := 50 ] - game <- menuPane [ text := "&Game" ] - new <- menuItem game [ text := "&New\tCtrl+N", help := "New game" ]+ 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"] + 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 quit [on command := close ff] - set f [menuBar := [game]]+ set ff [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)] - ]+ pp <- panel ff [ clientSize := sz width height+ , position := point 1 1+ ]+ set ff [ layout := widget pp+ ]+ set pp [ 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+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do+ -- timer+ etick <- event0 t command - -- keyboard events- ekey <- event1 f keyboard- let eleft = filterE ((== KeyLeft ) . keyKey) ekey- eright = filterE ((== KeyRight) . keyKey) ekey+ -- keyboard events+ ekey <- event1 pp 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)+ -- ship position+ let+ bship :: Behavior t Int+ bship = accumB (width `div` 2) $+ (goLeft <$ eleft) `union` (goRight <$ eright) - goLeft x = max 0 (x - 5)- goRight x = min width (x + 5)+ goLeft x = max 0 (x - 5)+ goRight x = min (width-30) (x + 5) - -- rocks- brandom <- fromPoll (randomRIO (0,1) :: IO Double)- let- brocks :: Behavior [Rock]- brocks = accumB [] $- (advanceRocks <$ etick) `union`- (newRock <$> filterE (< chance) (brandom <@ etick))+ -- rocks+ brandom <- fromPoll (randomRIO (0,1) :: IO Double)+ let+ brocks :: Behavior t [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+ -- draw the game state+ sink pp [on paint :== stepper (\_dc _ -> return ()) $+ (drawGameState <$> bship <*> brocks) <@ etick]+ reactimate $ repaint pp <$ etick - -- status bar- let dstatus :: Discrete String- dstatus = stepperD "Welcome to asteroids" $- ((\r -> "rocks: " ++ show (length r)) <$> brocks) <@ etick- sink status [text :== dstatus]+ -- status bar+ let bstatus :: Behavior t String+ bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks+ sink status [text :== bstatus] + network <- compile networkDescription actuate network @@ -152,13 +167,13 @@ collide :: Position -> Position -> Bool collide pos0 pos1 = - let distance = vecLength (vecBetween pos0 pos1) - in distance <= fromIntegral diameter + 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 []+ let rockPicture = if collides then burning else rock+ in drawBitmap dc rockPicture pos True []
src/CRUD.hs view
@@ -1,14 +1,24 @@ {----------------------------------------------------------------------------- reactive-banana-wx - Example: ListBox with CRUD operations+ Example:+ Small database with CRUD operations and filtering.+ To keep things simple, the list box is rebuild every time+ that the database is updated. This is perfectly fine for rapid prototyping.+ A more sophisticated approach would use incremental updates. ------------------------------------------------------------------------------}-{-# LANGUAGE RecursiveDo #-}--- import Control.Monad-import qualified Data.List+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-}++import Prelude hiding (lookup)+import Data.List (isPrefixOf) import Data.Maybe+import Data.Monoid import qualified Data.Map as Map-import Graphics.UI.WX as WX hiding (Event)+import qualified Data.Set as Set++import qualified Graphics.UI.WX as WX+import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX @@ -17,235 +27,178 @@ ------------------------------------------------------------------------------} 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 ]+ f <- frame [ text := "CRUD Example (Simple)" ]+ listBox <- singleListBox f []+ createBtn <- button f [ text := "Create" ]+ deleteBtn <- button f [ text := "Delete" ]+ filterEntry <- entry f [ processEnter := True ] - name <- entry f [ processEnter := True ]- surname <- entry f [ processEnter := True ]+ firstname <- entry f [ processEnter := True ]+ lastname <- entry f [ processEnter := True ] - let dataItem = grid 10 10 [[label "Name:", widget name]- ,[label "Surname:", widget surname]]+ let dataItem = grid 10 10 [[label "First Name:", widget firstname]+ ,[label "Last Name:" , widget lastname]] set f [layout := margin 10 $ grid 10 5- [[row 5 [label "Filter prefix:", widget filter], glue]+ [[row 5 [label "Filter prefix:", widget filterEntry], glue] ,[minsize (sz 200 300) $ widget listBox, dataItem]- ,[row 10 [widget create, widget delete], glue]+ ,[row 10 [widget createBtn, widget deleteBtn], 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 )+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = mdo+ -- events from buttons+ eCreate <- event0 createBtn command + eDelete <- event0 deleteBtn command+ -- filter string+ bFilterString <- behaviorText filterEntry ""+ let bFilter :: Behavior t (String -> Bool)+ bFilter = isPrefixOf <$> bFilterString++ -- list box with selection+ bSelection <- reactiveListDisplay listBox bListItems bShowDataItem++ -- data item display+ (_,eDataItemIn) <- reactiveDataItem (firstname,lastname) bDataItemOut - -- display the data item whenever the selection changes- outDataItem = stepperD ("","") $- lookup <$> valueDB database <@> changes dSelectedItem- where- lookup database m = maybe ("","") id $- readDatabase database =<< m+ let -- database+ bDatabase :: Behavior t (Database DataItem)+ bDatabase = accumB emptydb $ mconcat+ [ create ("Emil","Example") <$ eCreate+ , filterJust $ update' <$> bSelection <@> eDataItemIn+ , delete <$> filterJust (bSelection <@ eDelete)+ ]+ where+ update' mkey x = flip update x <$> mkey+ + bLookup :: Behavior t (DatabaseKey -> Maybe DataItem)+ bLookup = flip lookup <$> bDatabase+ + bShowDataItem :: Behavior t (DatabaseKey -> String)+ bShowDataItem = (maybe "" showDataItem .) <$> bLookup+ + bListItems :: Behavior t [DatabaseKey]+ bListItems = (\p show -> filter (p. show) . keys)+ <$> bFilter <*> bShowDataItem <*> bDatabase - -- automatically enable / disable editing- let dDisplayItem = maybe False (const True) <$> dSelectedItem- sink delete [ enabled :== dDisplayItem ]- sink name [ enabled :== dDisplayItem ]- sink surname [ enabled :== dDisplayItem ]+ bDataItemOut :: Behavior t (Maybe DataItem)+ bDataItemOut = (=<<) <$> bLookup <*> bSelection++ -- TODO: Delete event must change selection!++ -- automatically enable / disable editing+ let+ bDisplayItem :: Behavior t Bool+ bDisplayItem = maybe False (const True) <$> bSelection+ sink deleteBtn [ enabled :== bDisplayItem ]+ sink firstname [ enabled :== bDisplayItem ]+ sink lastname [ enabled :== bDisplayItem ] + network <- compile networkDescription 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)+emptydb = Database 0 Map.empty+keys = Map.keys . db --- read a value from the database-readDatabase :: Database a -> DatabaseKey -> Maybe a-readDatabase (Database _ db) = flip Map.lookup db+create x (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db+update key x (Database newkey db) = Database newkey $ Map.insert key x db+delete key (Database newkey db) = Database newkey $ Map.delete key db+lookup key (Database _ db) = Map.lookup key db {----------------------------------------------------------------------------- Data items that are stored in the data base ------------------------------------------------------------------------------} type DataItem = (String, String)+showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname +{- Note: On breaking feedback loops.++The right abstraction for this is a behavior + notifications .+The point is that the notifications do *not* represent every single change+in the behavior. Instead, they represent selected changes.+That's why the applicative instance for this data type is a bit different+than usual.++-}+ -- text entry widgets in terms of discrete time-varying values-reactimateTextEntry+reactiveTextEntry :: 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 ]+ -> Behavior t String -- set text programmatically (view)+ -> NetworkDescription t+ (Behavior t String -- current text (both view & controller)+ ,Event t String) -- user changes (controller)+reactiveTextEntry entry input = do+ sink entry [ text :== input ] -- display value - -- 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)+ eUser <- changes =<< behaviorText entry "" -- user changes+ eIn <- changes input -- input changes+ x <- initial input+ -- programmatic changes will affect the text box *after* user changes.+ return (stepper x (eUser `union` eIn), eUser) -- whole data item (consisting of two text entries)-reactimateDataItem+reactiveDataItem :: (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 )+ -> Behavior t (Maybe DataItem)+ -> NetworkDescription t+ (Behavior t DataItem, Event t DataItem)+reactiveDataItem (firstname,lastname) input = do+ (b1,e1) <- reactiveTextEntry firstname (fst . maybe ("","") id <$> input)+ (b2,e2) <- reactiveTextEntry lastname (snd . maybe ("","") id <$> input)+ return ( (,) <$> b1 <*> b2 ,+ ((,) <$> b1 <@> e2) `union` (flip (,) <$> b2 <@> e1)) --- custom show function-showDataItem (name, surname) = surname ++ ", " ++ name {------------------------------------------------------------------------------ List Box View+ reactive list display+ + Display a list of (distinct) items in a list box.+ The current selection contains one or no items.+ Changing the set may unselect the current item,+ but will not change it to another item. ------------------------------------------------------------------------------}--- 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+reactiveListDisplay :: forall t a b. Ord a+ => SingleListBox b -- ListBox widget to use+ -> Behavior t [a] -- list of items+ -> Behavior t (a -> String) -- display an item+ -> NetworkDescription t+ (Behavior t (Maybe a)) -- current selection as item (possibly empty)+reactiveListDisplay listBox elements display = do+ -- retrieve selection index+ bSelection <- behaviorListBoxSelection listBox -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)+ -- display items+ sink listBox [ items :== map <$> display <*> elements ]+ -- changing the display won't change the current selection+ eDisplay <- changes display+ sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] - where+ -- return current selection as element+ let bIndexed :: Behavior t (Map.Map Int a)+ bIndexed = Map.fromList . zip [0..] <$> elements+ return $ Map.lookup <$> bSelection <*> bIndexed - -- 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+ wxHaskell convenience wrappers and bug fixes ------------------------------------------------------------------------------}--- Fix @select@ event not being fired when items are *un*selected+-- | Return *user* changes to the list box selection.+behaviorListBoxSelection :: SingleListBox b -> NetworkDescription t (Behavior t Int)+behaviorListBoxSelection listBox = do+ liftIO $ fixSelectionEvent listBox+ a <- liftIO $ event1ToAddHandler listBox (event0ToEvent1 select)+ fromChanges (-1) $ mapIO (const $ get listBox selection) a++-- Fix @select@ event not being fired when items are *un*selected. fixSelectionEvent listbox = liftIO $ set listbox [ on unclick := handler ] where@@ -253,7 +206,3 @@ propagateEvent s <- get listbox selection when (s == -1) $ (get listbox (on select)) >>= id- ---
src/Counter.hs view
@@ -3,7 +3,10 @@ Example: Counter ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Control.Monad+ import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX@@ -19,15 +22,18 @@ set f [layout := margin 10 $ column 5 [widget bup, widget bdown, widget output]]- - network <- compile $ do++ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do+ eup <- event0 bup command edown <- event0 bdown command let- counter :: Discrete Int- counter = accumD 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown)- - sink output [text :== show <$> counter]+ counter :: Behavior t Int+ counter = accumB 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown) + sink output [text :== show <$> counter] ++ network <- compile networkDescription actuate network
src/CurrencyConverter.hs view
@@ -3,15 +3,16 @@ Example: Currency Converter ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" {-# LANGUAGE RecursiveDo #-}+ import Data.Bits import Data.Maybe+import Text.Printf+ import Graphics.UI.WX hiding (Event)-import qualified Graphics.UI.WX.Events-import Graphics.UI.WXCore hiding (Event) import Reactive.Banana import Reactive.Banana.WX-import Text.Printf {----------------------------------------------------------------------------- Main@@ -29,41 +30,25 @@ , label "Amounts update while typing." ]] - network <- compile $ mdo - euroIn <- reactimateTextEntry euro euroOut- dollarIn <- reactimateTextEntry dollar dollarOut-+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do+ + euroIn <- behaviorText euro "0"+ dollarIn <- behaviorText dollar "0"+ 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 ()+ dollarOut, euroOut :: Behavior t String+ dollarOut = withString (/ rate) <$> euroIn+ euroOut = withString (* rate) <$> dollarIn - 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 ]-- -- Real-time text updates.- -- Should be wxEVT_COMMAND_TEXT_UPDATED , but that's misisng from wxHaskell.- e <- event1 entry keyboardUp- b <- behavior entry text- return $ b <@ e+ sink euro [text :== euroOut ]+ sink dollar [text :== dollarOut] --- observe "key up" events (many thanks to Abu Alam)--- this should probably be in the wxHaskell library-keyboardUp :: Graphics.UI.WX.Events.Event (Window a) (EventKey -> IO ())-keyboardUp = newEvent "keyboardUp" windowGetOnKeyUp (windowOnKeyUp)+ network <- compile networkDescription + actuate network
src/NetMonitor.hs view
@@ -3,13 +3,17 @@ Example: Minuscule network monitor ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Data.Char import Data.List import Data.Maybe++import System.Process+ import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX-import System.Process {----------------------------------------------------------------------------- Main@@ -28,20 +32,24 @@ t <- timer f [ interval := 500 ] -- timer every 500 ms - network <- compile $ do- etick <- event0 t command- bnetwork <- fromPoll $ getNetworkStatistics+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do+ -- The network statistics are polled when and only when+ -- the event network handles an event.+ bnetwork <- fromPoll getNetworkStatistics+ -- That's why we need a timer that generates regular events to handle.+ etick <- event0 t command - let showStat f = stepperD "" $ f <$> (bnetwork <@ etick)- sent = maybe "parse error" show . fst- received = maybe "parse error" show . snd+ let showSent = maybe "parse error" show . fst+ showReceived = maybe "parse error" show . snd - sink out1 [ text :== showStat sent ]- sink out2 [ text :== showStat received ]+ sink out1 [ text :== showSent <$> bnetwork ]+ sink out2 [ text :== showReceived <$> bnetwork ] + network <- compile networkDescription actuate network --- obtain network statistics+-- Obtain network statistics from the netstat utility type NetworkStatistics = (Maybe Int, Maybe Int) getNetworkStatistics :: IO NetworkStatistics
src/Reactive/Banana/WX.hs view
@@ -1,27 +1,38 @@-{-# LANGUAGE ExistentialQuantification #-} {----------------------------------------------------------------------------- reactive-banana-wx- - Utility functions for interfacing with wxHaskell ------------------------------------------------------------------------------}+{-# LANGUAGE ExistentialQuantification #-} -module Reactive.Banana.WX where+module Reactive.Banana.WX (+ -- * Synopsis+ -- | Utility functions for interfacing with wxHaskell.+ -- Note: Useful, but I haven't done any serious design work on these.+ + -- * General+ event1, event0, behavior,+ Prop'(..), sink,+ + -- * Specialized for widgets+ behaviorText, sinkText, keyboardUp,+ + -- * Utilities+ event1ToAddHandler, event0ToEvent1,+ mapIO,+ ) where import Reactive.Banana import qualified Graphics.UI.WX as WX-import Graphics.UI.WX (on, Prop(..))+import Graphics.UI.WX hiding (Event, Attr)+import Graphics.UI.WXCore hiding (Event)+-- import Graphics.UI.WX (on, Prop(..)) {------------------------------------------------------------------------------ Wx- - Utilities for representing stuff from Wx as events and behaviors+ Connection with events and behaviors ------------------------------------------------------------------------------}- -- | Event with exactly one parameter.-event1 :: Typeable a => w -> WX.Event w (a -> IO ()) -> NetworkDescription (Event a)+event1 :: w -> WX.Event w (a -> IO ()) -> NetworkDescription t (Event t a) event1 widget e = do- (addHandler, runHandlers) <- liftIO $ newAddHandler- liftIO $ WX.set widget [on e :~ \h x -> h x >> runHandlers x]+ addHandler <- liftIO $ event1ToAddHandler widget e fromAddHandler addHandler -- NOTE: Some events don't work, for instance leftKey and rightKey@@ -30,33 +41,85 @@ -- 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---- | Behavior form an attribute-behavior :: w -> WX.Attr w a -> NetworkDescription (Behavior a)-behavior widget attr = fromPoll . liftIO $ WX.get widget attr+event0 :: w -> WX.Event w (IO ()) -> NetworkDescription t (Event t ())+event0 widget = event1 widget . event0ToEvent1 +-- | Behavior from an attribute.+-- Uses 'fromPoll', so may behave as you expect.+behavior :: w -> WX.Attr w a -> NetworkDescription t (Behavior t a)+behavior widget attr = fromPoll . liftIO $ get widget attr -data Prop' w = forall a. (WX.Attr w a) :== Discrete a+-- | Variant of wx properties that accept a 'Behavior'.+data Prop' t w = forall a. (WX.Attr w a) :== Behavior t a infixr 0 :== --- | "Animate" a property with a stream of events-sink :: w -> [Prop' w] -> NetworkDescription ()+-- | "Animate" a property with a behavior+sink :: w -> [Prop' t w] -> NetworkDescription t () sink widget props = mapM_ sink1 props where- sink1 (attr :== x) = do- liftIOLater $ WX.set widget [attr := initial x]- reactimate $ (\x -> WX.set widget [attr := x]) <$> changes x+ sink1 (attr :== b) = do+ x <- initial b+ liftIOLater $ set widget [attr := x]+ e <- changes b+ reactimate $ (\x -> set widget [attr := x]) <$> e --- 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") []+{-----------------------------------------------------------------------------+ Connection with events and behaviors+------------------------------------------------------------------------------}+-- | Behavior of the user-entered 'text' of a 'TextCtrl' widget.+--+-- To avoid feedback loops, *only* the user-entered text will+-- update the behavior.+-- This is probably not what you want, though.+behaviorText+ :: WX.TextCtrl w+ -> String+ -- ^ Initial value supplied "by the user". Not set programmaticaly.+ -> NetworkDescription t (Behavior t String)+behaviorText textCtrl initial = do+ -- Should probably be wxEVT_COMMAND_TEXT_UPDATED ,+ -- but that's missing from wxHaskell.+ -- Note: Observing keyUp events does create a small lag+ addHandler <- liftIO $ event1ToAddHandler textCtrl keyboardUp+ e <- fromAddHandler $ mapIO (const $ get textCtrl text) addHandler+ return $ stepper initial e +-- observe "key up" events (many thanks to Abu Alam)+-- this should probably be in the wxHaskell library+keyboardUp :: WX.Event (Window a) (EventKey -> IO ())+keyboardUp = WX.newEvent "keyboardUp" windowGetOnKeyUp windowOnKeyUp +-- | Reactimate the 'text' of a 'TextCtrl' widget.+--+-- To avoid feedback loops, the text will not be updated while+-- the widget has the focus.+sinkText :: WX.TextCtrl w -> Behavior t String -> NetworkDescription t ()+sinkText textCtrl b = do+ e <- changes b+ x <- initial b++ bHasFocus <- stepper False <$> event1 textCtrl focus+ + let b' = stepper x $ whenE (not <$> bHasFocus) e+ sink textCtrl [ text :== b' ]++{-----------------------------------------------------------------------------+ Utilities+------------------------------------------------------------------------------}+-- | Obtain an 'AddHandler' from a 'WX.Event'.+event1ToAddHandler :: w -> WX.Event w (a -> IO ()) -> IO (AddHandler a)+event1ToAddHandler widget e = do+ (addHandler, runHandlers) <- newAddHandler+ set widget [on e :~ \h x -> h x >> runHandlers x]+ return addHandler++-- | Obtain an 'AddHandler' from a 'WX.Event'.+event0ToEvent1 :: WX.Event w (IO ()) -> WX.Event w (() -> IO ())+event0ToEvent1 = mapEvent const (\_ e -> e ())++-- | Apply a function with side effects to an 'AddHandler'+mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b+mapIO f addHandler = \h -> addHandler $ \x -> f x >>= h
src/TicTacToe.hs view
@@ -2,8 +2,10 @@ reactive-banana-wx Example: A version of TicTacToe with eclectic interface elements - Author: Gideon Sireling + Original Author: Gideon Sireling ------------------------------------------------------------------------------} +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" + import Control.Monad import Data.Array import Data.List hiding (union) @@ -22,10 +24,10 @@ main = start $ do -- create the main window window <- frame [text := "OX"] - label <- staticText window [text := "Move: X"] + label <- staticText window [text := "Move: X"] -- overwritten by FRP, here to ensure correct positioning - btns <- replicateM 3 $ button window [size := sz 40 40] - radios <- replicateM 3 $ radioBox window Vertical ["", "?"] [] + btns <- replicateM 3 $ button window [size := sz 40 40] + radios <- replicateM 3 $ radioBox window Vertical ["", " "] [] checks <- replicateM 3 $ checkBox window [text := " "] -- reserve space for X/O in label @@ -33,55 +35,56 @@ [map widget btns, map widget radios, map widget checks] , floatCenter $ widget label]] - network <- compile $ do - -- convert WxHaskell events to FRP events - let event0s widgets event = forM widgets $ \x -> event0 x event - events <- liftM concat $ sequence - [event0s btns command, event0s radios select, event0s checks command] + let networkDescription :: forall t. NetworkDescription t () + networkDescription = do + -- convert WxHaskell events to FRP events + let event0s widgets event = forM widgets $ \x -> event0 x event + events <- liftM concat $ sequence + [event0s btns command, event0s radios select, event0s checks command] - let - moves :: Event (State -> State) - moves = foldl1 union $ zipWith (\e s -> play s <$ e) events - [(x,y) | y <- [1..3], x <- [1..3]] - where play square (game, _) = move game square + let + moves :: Event t (Game -> Game) + moves = foldl1 union $ zipWith (\e s -> move s <$ e) events + [(x,y) | y <- [1..3], x <- [1..3]] - state :: Discrete State - state = accumD (newGame, Nothing) moves + state :: Behavior t Game + state = accumB newGame moves - player :: Discrete String - player = (\(Game player _, _) -> show player) <$> state + currentPlayer :: Behavior t String + currentPlayer = (show . player) <$> state - tokens :: [Discrete String] - tokens = map (\e -> stepperD "" (player <@ e)) events - - -- wire up the widget event handlers - zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e]) - (map objectCast btns - ++ map objectCast radios - ++ map objectCast checks :: [Control ()]) - tokens + tokens :: [Behavior t String] + tokens = map (\e -> stepper "" (currentPlayer <@ e)) events - sink label [text :== ("Move: " ++) <$> player] + -- wire up the widget event handlers + zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e]) + (map objectCast btns + ++ map objectCast radios + ++ map objectCast checks :: [Control ()]) + tokens - -- end game event handler - reactimate $ (end window . fromJust) <$> - filterE isJust (changes $ snd <$> state) + sink label [text :== ("Move: " ++) <$> currentPlayer] + + -- end game event handler + eState <- changes state + reactimate $ end window <$> filterJust (isGameEnd . board <$> eState) + network <- compile networkDescription actuate network + end :: Frame () -> Token -> IO () end window result = do - infoDialog window "" $ case result of - X -> "X won!" - O -> "O won!" - None -> "Draw!" + infoDialog window "" $ + case result of + X -> "X won!" + O -> "O won!" + None -> "Draw!" close window {----------------------------------------------------------------------------- Game Logic ------------------------------------------------------------------------------} -type State = (Game, Maybe Token) - data Token = None | X | O deriving Eq @@ -105,8 +108,8 @@ -- |Determine if the 'Board' is in an end state. -- Returns 'Just' 'Token' if the game has been won, -- 'Just' 'None' for a draw, otherwise 'Nothing'. -endGame :: Board -> Maybe Token -endGame board +isGameEnd :: Board -> Maybe Token +isGameEnd board | Just X `elem` maybeWins = Just X | Just O `elem` maybeWins = Just O | None `notElem` elems board = Just None @@ -131,7 +134,7 @@ maybeWins = map isWin rows2tokens -- |The state of a game, i.e. the player who's turn it is, and the current board. -data Game = Game Token Board +data Game = Game { player :: Token, board :: Board } newGame :: Game newGame = Game X newBoard @@ -139,11 +142,11 @@ -- |Puts the player's token on the specified square. -- Returns 'Just' 'Token' if the game has been won, -- 'Just' 'None' for a draw, otherwise 'Nothing'. -move :: Game -> Square -> (Game, Maybe Token) -move (Game player board) square = - let board' = setSquare board square player - player' = case player of {X -> O; O -> X} - in (Game player' board', endGame board') +move :: Square -> Game -> Game +move square (Game player board) = Game player' board' + where + board' = setSquare board square player + player' = case player of {X -> O; O -> X} {----------------------------------------------------------------------------- Show instances
src/TwoCounters.hs view
@@ -3,7 +3,10 @@ Example: Two Counters. ------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"+ import Control.Monad+ import Graphics.UI.WX hiding (Event) import Reactive.Banana import Reactive.Banana.WX@@ -24,26 +27,30 @@ grid 5 5 [[label "First Counter:" , widget out1] ,[label "Second Counter:", widget out2]]]] - network <- compile $ do- eup <- event0 bup command- edown <- event0 bdown command- eswitch <- event0 bswitch command+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do++ eup <- event0 bup command+ edown <- event0 bdown command+ eswitch <- event0 bswitch command - let- -- do we act on the left button?- firstcounter :: Behavior Bool- firstcounter = accumB True $ not <$ eswitch+ let+ -- do we act on the left button?+ firstcounter :: Behavior t Bool+ firstcounter = accumB True $ not <$ eswitch - -- joined state of the two counters- counters :: Discrete (Int, Int)- counters = accumD (0,0) $- union ((increment <$> firstcounter) `apply` eup)- ((decrement <$> firstcounter) `apply` edown)+ -- joined state of the two counters+ counters :: Behavior t (Int, Int)+ counters = accumB (0,0) $+ union ((increment <$> firstcounter) `apply` eup)+ ((decrement <$> firstcounter) `apply` edown) - increment left _ (x,y) = if left then (x+1,y) else (x,y+1)- decrement left _ (x,y) = if left then (x-1,y) else (x,y-1)+ increment left _ (x,y) = if left then (x+1,y) else (x,y+1)+ decrement left _ (x,y) = if left then (x-1,y) else (x,y-1) - sink out1 [text :== show . fst <$> counters]- sink out2 [text :== show . snd <$> counters]+ sink out1 [text :== show . fst <$> counters]+ sink out2 [text :== show . snd <$> counters] + network <- compile networkDescription actuate network+
src/Wave.hs view
@@ -1,12 +1,17 @@ {----------------------------------------------------------------------------- reactive-banana-wx - Example: Guitar chord simulation+ Example: Emit a wave of lights.+ 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. NetworkDescription t"+ 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@@ -33,27 +38,31 @@ -- we're going to need a timer t <- timer f [] - network <- compile $ do- eLeft <- event0 left command- eRight <- event0 right command+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do++ eLeft <- event0 left command+ eRight <- event0 right command - -- event describing all the lights- eWave <- scheduleQueue t $ (waveLeft <$ eLeft ) `union` - (waveRight <$ eRight)+ -- 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+ -- 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+ colorize True = red+ colorize False = black - sink bulb [ color :== colorize <$> dBulb ] + sink bulb [ color :== colorize <$> bBulb ] + network <- compile networkDescription actuate network + type Index = Int type Action = (Index, Bool) @@ -81,7 +90,7 @@ -- 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 :: Timer -> Event t (Enqueue a) -> NetworkDescription t (Event t a) scheduleQueue t e = do liftIO $ set t [ enabled := False ] eAlarm <- event0 t command