diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 $@ + diff --git a/reactive-banana-wx.cabal b/reactive-banana-wx.cabal --- a/reactive-banana-wx.cabal +++ b/reactive-banana-wx.cabal @@ -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 diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs --- a/src/Arithmetic.hs +++ b/src/Arithmetic.hs @@ -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 diff --git a/src/Asteroids.hs b/src/Asteroids.hs --- a/src/Asteroids.hs +++ b/src/Asteroids.hs @@ -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 [] diff --git a/src/CRUD.hs b/src/CRUD.hs --- a/src/CRUD.hs +++ b/src/CRUD.hs @@ -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 - - - - diff --git a/src/Counter.hs b/src/Counter.hs --- a/src/Counter.hs +++ b/src/Counter.hs @@ -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 diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs --- a/src/CurrencyConverter.hs +++ b/src/CurrencyConverter.hs @@ -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 diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs --- a/src/NetMonitor.hs +++ b/src/NetMonitor.hs @@ -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 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 @@ -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 diff --git a/src/TicTacToe.hs b/src/TicTacToe.hs --- a/src/TicTacToe.hs +++ b/src/TicTacToe.hs @@ -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 diff --git a/src/TwoCounters.hs b/src/TwoCounters.hs --- a/src/TwoCounters.hs +++ b/src/TwoCounters.hs @@ -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 + diff --git a/src/Wave.hs b/src/Wave.hs --- a/src/Wave.hs +++ b/src/Wave.hs @@ -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