reactive-banana-wx 0.9.0.2 → 1.0.0.0
raw patch · 15 files changed
+274/−227 lines, 15 filesdep ~filepathdep ~randomdep ~reactive-banana
Dependency ranges changed: filepath, random, reactive-banana
Files
- LICENSE +1/−1
- reactive-banana-wx.cabal +7/−7
- src/Animation.hs +20/−11
- src/Arithmetic.hs +2/−3
- src/Asteroids.hs +59/−49
- src/BarTab.hs +37/−31
- src/CRUD.hs +41/−35
- src/Counter.hs +11/−6
- src/CurrencyConverter.hs +2/−3
- src/NetMonitor.hs +1/−2
- src/Reactive/Banana/WX.hs +10/−17
- src/TicTacToe.hs +21/−13
- src/Tidings.hs +6/−6
- src/TwoCounters.hs +20/−12
- src/Wave.hs +36/−31
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, Heinrich Apfelmus+Copyright (c)20112015, Heinrich Apfelmus All rights reserved.
reactive-banana-wx.cabal view
@@ -1,5 +1,5 @@ Name: reactive-banana-wx-Version: 0.9.0.2+Version: 1.0.0.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library,@@ -13,7 +13,7 @@ . @cabal install reactive-banana-wx -fbuildExamples@ .- Stability forecast: The wrapper functions are rather provisional.+ /Stability forecast/ The wrapper functions are rather provisional. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3@@ -39,7 +39,7 @@ hs-source-dirs: src build-depends: base >= 4.2 && < 5, cabal-macosx >= 0.1 && < 0.3,- reactive-banana >= 0.8 && < 0.10,+ reactive-banana >= 1.0 && < 1.1, wxcore (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.93), wx (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.93) extensions: ExistentialQuantification@@ -54,9 +54,9 @@ if flag(buildExamples) build-depends: process >= 1.0 && < 1.4,- random == 1.0.*,+ random >= 1.0 && <= 1.1, executable-path == 0.0.*,- filepath >= 1.1 && <= 1.4,+ filepath >= 1.1 && <= 1.4.0.0, reactive-banana, wx, wxcore, base cpp-options: -DbuildExamples else@@ -76,9 +76,9 @@ Executable Asteroids if flag(buildExamples) build-depends:- random == 1.0.*,+ random >= 1.0 && <= 1.1, executable-path == 0.0.*,- filepath >= 1.1 && <= 1.4,+ filepath >= 1.1 && <= 1.4.0.0, reactive-banana, wx, wxcore, base cpp-options: -DbuildExamples else
src/Animation.hs view
@@ -3,7 +3,14 @@ Example: A simple animation. ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... import Graphics.UI.WX hiding (Event, Vector) import Reactive.Banana@@ -42,30 +49,32 @@ set ff [ layout := minsize (sz width height) $ widget pp ] -- event network- let networkDescription :: forall t. Frameworks t => Moment t ()- networkDescription = do+ let networkDescription :: MomentIO ()+ networkDescription = mdo etick <- event0 t command -- frame timer emouse <- event1 pp mouse -- mouse events - let- -- mouse pointer position- bmouse = fromPoint <$> stepper (point 0 0)+ -- mouse pointer position+ (bmouse :: Behavior Vector) <-+ fmap fromPoint <$> stepper (point 0 0) (filterJust $ justMotion <$> emouse)- ++ let -- sprite velocity- bvelocity :: Behavior t Vector+ bvelocity :: Behavior Vector bvelocity = (\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45) <$> bposition <*> bmouse where speedup v = v `vecScale` (vecLengthDouble v / 20) - -- sprite position- bposition :: Behavior t Vector- bposition = accumB (vec 0 0) $+ -- sprite position+ (bposition :: Behavior Vector)+ <- accumB (vec 0 0) $ (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos) <$> bvelocity <@ etick + let clipToFrame v = vec (clip 0 x (fromIntegral $ width - bitmapWidth )) (clip 0 y (fromIntegral $ height - bitmapHeight))
src/Arithmetic.hs view
@@ -3,7 +3,6 @@ Example: Very simple arithmetic ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Maybe @@ -25,14 +24,14 @@ [widget input1, label "+", widget input2 , label "=", minsize (sz 40 20) $ widget output]] - let networkDescription :: forall t. Frameworks t => Moment t ()+ let networkDescription :: MomentIO () networkDescription = do binput1 <- behaviorText input1 "" binput2 <- behaviorText input2 "" let- result :: Behavior t (Maybe Int)+ result :: Behavior (Maybe Int) result = f <$> binput1 <*> binput2 where f x y = liftA2 (+) (readNumber x) (readNumber y)
src/Asteroids.hs view
@@ -1,17 +1,24 @@ {----------------------------------------------------------------------------- reactive-banana-wx- + Example: Asteroids, adapted from http://wiki.haskell.org/WxAsteroids- + The original example has a few graphics issues and I didn't put much work into correcting them.- For more, see also + 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. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... import Graphics.UI.WX hiding (Event) import Graphics.UI.WXCore as WXCore@@ -30,7 +37,7 @@ width = 300 diameter = 24 -chance :: Double +chance :: Double chance = 0.1 rock, burning, ship :: Bitmap ()@@ -39,13 +46,13 @@ ship = bitmap $ getDataFile "ship.ico" explode :: WXCore.Sound ()-explode = sound $ getDataFile "explode.wav" +explode = sound $ getDataFile "explode.wav" main :: IO () main = start asteroids {------------------------------------------------------------------------------ Game Logic + Game Logic ------------------------------------------------------------------------------} -- main game function asteroids :: IO ()@@ -54,71 +61,74 @@ , bgcolor := white , resizeable := False ] - status <- statusField [text := "Welcome to asteroids"] - set ff [statusBar := [status]] + status <- statusField [text := "Welcome to asteroids"]+ set ff [statusBar := [status]] t <- timer ff [ interval := 50 ] - game <- menuPane [ text := "&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" + 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]] + 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 ff]- + set ff [menuBar := [game]]- + pp <- panel ff [] set ff [ layout := minsize (sz width height) $ widget pp ]- set pp [ on (charKey '-') := set t [interval :~ \i -> i * 2] - , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)] + set pp [ on (charKey '-') := set t [interval :~ \i -> i * 2]+ , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)] ]- + -- event network- let networkDescription :: forall t. Frameworks t => Moment t ()- networkDescription = do+ let networkDescription :: MomentIO ()+ networkDescription = mdo -- timer etick <- event0 t command- + -- keyboard events ekey <- event1 pp keyboard let eleft = filterE ((== KeyLeft ) . keyKey) ekey eright = filterE ((== KeyRight) . keyKey) ekey- + -- ship position+ (bship :: Behavior Int)+ <- accumB (width `div` 2) $ unions+ [ goLeft <$ eleft+ , goRight <$ eright+ ] 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-30) (x + 5)- + -- rocks brandom <- fromPoll (randomRIO (0,1) :: IO Double)- let- brocks :: Behavior t [Rock]- brocks = accumB [] $- (advanceRocks <$ etick) `union`- (newRock <$> filterE (< chance) (brandom <@ etick))- ++ (brocks :: Behavior [Rock])+ <- accumB [] $ unions+ [ advanceRocks <$ etick+ , newRock <$> filterE (< chance) (brandom <@ etick)+ ]+ -- draw the game state- sink pp [on paint :== stepper (\_dc _ -> return ()) $- (drawGameState <$> bship <*> brocks) <@ etick]+ bpaint <- stepper (\_dc _ -> return ()) $+ (drawGameState <$> bship <*> brocks) <@ etick+ sink pp [on paint :== bpaint] reactimate $ repaint pp <$ etick- + -- status bar- let bstatus :: Behavior t String+ let bstatus :: Behavior String bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks sink status [text :== bstatus]- - network <- compile networkDescription ++ network <- compile networkDescription actuate network @@ -146,19 +156,19 @@ collisions = map (collide shipLocation) positions drawShip dc shipLocation- mapM (drawRock dc) (zip positions collisions) + 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 +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 [] +drawShip dc pos = drawBitmap dc ship pos True [] drawRock :: DC a -> (Point, Bool) -> IO ()-drawRock dc (pos, collides) = +drawRock dc (pos, collides) = let rockPicture = if collides then burning else rock in drawBitmap dc rockPicture pos True []
src/BarTab.hs view
@@ -1,9 +1,16 @@ {----------------------------------------------------------------------------- reactive-banana-wx- + Example: Bar tab with a variable number of widgets ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} import Data.Maybe (listToMaybe)@@ -24,53 +31,52 @@ total <- staticText f [] add <- button f [text := "Add"] remove <- button f [text := "Remove"]- - let networkDescription :: forall t. Frameworks t => Moment t ()- networkDescription = do++ let networkDescription :: MomentIO ()+ networkDescription = mdo eAdd <- event0 add command eRemove <- event0 remove command- + let- newEntry :: Frameworks s- => Moment s (TextCtrl (), AnyMoment Behavior String) + newEntry :: MomentIO (TextCtrl (), Behavior String) newEntry = do wentry <- liftIO $ entry f []- bentry <- trimB =<< behaviorText wentry ""+ bentry <- behaviorText wentry "" return (wentry, bentry)- - eNewEntry <- execute $ FrameworksMoment newEntry <$ eAdd- - let- eDoRemove = whenE (not . null <$> bEntries) eRemove- - eEntries :: Event t [(TextCtrl (), AnyMoment Behavior String)]- eEntries = accumE [] $- ((\x -> (++ [x])) <$> eNewEntry) `union` (init <$ eDoRemove)- - bEntries = stepper [] eEntries- ++ eNewEntry <- execute $ newEntry <$ eAdd++ let eDoRemove = whenE (not . null <$> bEntries) eRemove++ (eEntries :: Event [(TextCtrl (), Behavior String)])+ <- accumE [] $ unions+ [ (\x -> (++ [x])) <$> eNewEntry+ , init <$ eDoRemove+ ]+ bEntries <- stepper [] eEntries+ reactimate $ ((\w -> set w [ visible := False]) . fst . last) <$> bEntries <@ eDoRemove- + let- ePrices :: Event t [AnyMoment Behavior Number]+ ePrices :: Event [Behavior Number] ePrices = map (fmap readNumber . snd) <$> eEntries- - bLayout :: Behavior t Layout++ bLayout :: Behavior Layout bLayout = mkLayout . map fst <$> bEntries- + mkLayout entries = margin 10 $ column 10 $ [row 10 [widget add, widget remove]] ++ map widget entries ++ [row 10 [widget msg, minsize (sz 40 20) $ widget total]]- - bTotal :: Behavior t Number++ bTotal :: Behavior Number bTotal = switchB (pure Nothing) $ (fmap sum . sequenceA) <$> ePrices sink total [text :== showNumber <$> bTotal] sink f [layout :== bLayout]- - network <- compile networkDescription ++ network <- compile networkDescription actuate network {-----------------------------------------------------------------------------@@ -87,7 +93,7 @@ fromInteger = pure . fromInteger readNumber :: Read a => String -> Maybe a-readNumber s = listToMaybe [x | (x,"") <- reads s] +readNumber s = listToMaybe [x | (x,"") <- reads s] showNumber :: Maybe Double -> String showNumber = maybe "--" show
src/CRUD.hs view
@@ -7,8 +7,14 @@ that the database is updated. This is perfectly fine for rapid prototyping. A more sophisticated approach would use incremental updates. ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"-{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... import Prelude hiding (lookup) import Data.List (isPrefixOf)@@ -46,15 +52,15 @@ ]] -- event network- let networkDescription :: forall t. Frameworks t => Moment t ()+ let networkDescription :: MomentIO () networkDescription = mdo -- events from buttons eCreate <- event0 createBtn command eDelete <- event0 deleteBtn command -- filter string tFilterString <- reactiveTextEntry filterEntry bFilterString- let bFilterString = stepper "" $ rumors tFilterString- tFilter = isPrefixOf <$> tFilterString+ bFilterString <- stepper "" $ rumors tFilterString+ let tFilter = isPrefixOf <$> tFilterString bFilter = facts tFilter eFilter = rumors tFilter @@ -65,42 +71,42 @@ eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname) bSelectionDataItem - let -- database- bDatabase :: Behavior t (Database DataItem)- bDatabase = accumB emptydb $ unions+ -- database+ (bDatabase :: Behavior (Database DataItem))+ <- accumB emptydb $ unions [ create ("Emil","Example") <$ eCreate , filterJust $ update' <$> bSelection <@> eDataItemIn , delete <$> filterJust (bSelection <@ eDelete) ]- where- update' mkey x = flip update x <$> mkey+ let update' mkey x = flip update x <$> mkey - -- selection- bSelection :: Behavior t (Maybe DatabaseKey)- bSelection = stepper Nothing $ unions+ -- selection+ (bSelection :: Behavior (Maybe DatabaseKey))+ <- stepper Nothing $ foldr1 (unionWith const) [ eSelection , Nothing <$ eDelete , Just . nextKey <$> bDatabase <@ eCreate , (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing) <$> bSelection <*> bShowDataItem <@> eFilter ]- - bLookup :: Behavior t (DatabaseKey -> Maybe DataItem)+ + let+ bLookup :: Behavior (DatabaseKey -> Maybe DataItem) bLookup = flip lookup <$> bDatabase - bShowDataItem :: Behavior t (DatabaseKey -> String)+ bShowDataItem :: Behavior (DatabaseKey -> String) bShowDataItem = (maybe "" showDataItem .) <$> bLookup - bListBoxItems :: Behavior t [DatabaseKey]+ bListBoxItems :: Behavior [DatabaseKey] bListBoxItems = (\p show -> filter (p. show) . keys) <$> bFilter <*> bShowDataItem <*> bDatabase - bSelectionDataItem :: Behavior t (Maybe DataItem)+ bSelectionDataItem :: Behavior (Maybe DataItem) bSelectionDataItem = (=<<) <$> bLookup <*> bSelection -- automatically enable / disable editing let- bDisplayItem :: Behavior t Bool+ bDisplayItem :: Behavior Bool bDisplayItem = isJust <$> bSelection sink deleteBtn [ enabled :== bDisplayItem ]@@ -143,10 +149,10 @@ showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname -- single text entry-reactiveTextEntry :: Frameworks t- => TextCtrl a- -> Behavior t String -- text value- -> Moment t (Tidings t String) -- user changes+reactiveTextEntry+ :: TextCtrl a+ -> Behavior String -- text value+ -> MomentIO (Tidings String) -- user changes reactiveTextEntry w btext = do eUser <- eventText w -- user changes @@ -160,10 +166,10 @@ return $ tidings btext eUser -- whole data item (consisting of two text entries)-reactiveDataItem :: Frameworks t- => (TextCtrl a, TextCtrl b)- -> Behavior t (Maybe DataItem)- -> Moment t (Tidings t DataItem)+reactiveDataItem+ :: (TextCtrl a, TextCtrl b)+ -> Behavior (Maybe DataItem)+ -> MomentIO (Tidings DataItem) reactiveDataItem (firstname,lastname) binput = do t1 <- reactiveTextEntry firstname (fst . fromMaybe ("","") <$> binput) t2 <- reactiveTextEntry lastname (snd . fromMaybe ("","") <$> binput)@@ -178,19 +184,19 @@ Changing the set may unselect the current item, but will not change it to another item. ------------------------------------------------------------------------------}-reactiveListDisplay :: forall t a b. (Ord a, Frameworks t)+reactiveListDisplay :: forall a b. Ord a => SingleListBox b -- ListBox widget to use- -> Behavior t [a] -- list of items- -> Behavior t (Maybe a) -- selected element- -> Behavior t (a -> String) -- display an item- -> Moment t- (Tidings t (Maybe a)) -- current selection as item (possibly empty)+ -> Behavior [a] -- list of items+ -> Behavior (Maybe a) -- selected element+ -> Behavior (a -> String) -- display an item+ -> MomentIO+ (Tidings (Maybe a)) -- current selection as item (possibly empty) reactiveListDisplay w bitems bsel bdisplay = do -- animate output items sink w [ items :== map <$> bdisplay <*> bitems ] -- animate output selection- let bindices :: Behavior t (Map.Map a Int)+ let bindices :: Behavior (Map.Map a Int) bindices = (Map.fromList . flip zip [0..]) <$> bitems bindex = (\m a -> fromMaybe (-1) $ flip Map.lookup m =<< a) <$> bindices <*> bsel@@ -201,7 +207,7 @@ -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] -- user selection- let bindices2 :: Behavior t (Map.Map Int a)+ let bindices2 :: Behavior (Map.Map Int a) bindices2 = Map.fromList . zip [0..] <$> bitems esel <- eventSelection w return $ tidings bsel $ flip Map.lookup <$> bindices2 <@> esel
src/Counter.hs view
@@ -3,7 +3,10 @@ Example: Counter ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ... import Graphics.UI.WX hiding (Event) import Reactive.Banana@@ -22,16 +25,18 @@ set f [layout := margin 10 $ column 5 [widget bup, widget bdown, widget output]] - let networkDescription :: forall t. Frameworks t => Moment t ()+ let networkDescription :: MomentIO () networkDescription = do eup <- event0 bup command edown <- event0 bdown command - let- counter :: Behavior t Int- counter = accumB 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown)- + (counter :: Behavior Int)+ <- accumB 0 $ unions+ [ (+1) <$ eup+ , subtract 1 <$ edown+ ]+ sink output [text :== show <$> counter] network <- compile networkDescription
src/CurrencyConverter.hs view
@@ -3,7 +3,6 @@ Example: Currency Converter ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Maybe import Text.Printf@@ -31,7 +30,7 @@ set f [layout := widget p] focusOn dollar - let networkDescription :: forall t. Frameworks t => Moment t ()+ let networkDescription :: MomentIO () networkDescription = do euroIn <- behaviorText euro "0"@@ -43,7 +42,7 @@ $ listToMaybe [x | (x,"") <- reads s] -- define output values in terms of input values- dollarOut, euroOut :: Behavior t String+ dollarOut, euroOut :: Behavior String dollarOut = withString (/ rate) <$> euroIn euroOut = withString (* rate) <$> dollarIn
src/NetMonitor.hs view
@@ -3,7 +3,6 @@ Example: Minuscule network monitor ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Char import Data.List@@ -33,7 +32,7 @@ t <- timer f [ interval := 500 ] -- timer every 500 ms - let networkDescription :: forall t. Frameworks t => Moment t ()+ let networkDescription :: MomentIO () networkDescription = do -- The network statistics are polled when and only when -- the event network handles an event.
src/Reactive/Banana/WX.hs view
@@ -32,8 +32,7 @@ General ------------------------------------------------------------------------------} -- | Event with exactly one parameter.-event1 :: Frameworks t =>- w -> WX.Event w (a -> IO ()) -> Moment t (Event t a)+event1 :: w -> WX.Event w (a -> IO ()) -> MomentIO (Event a) event1 widget e = do addHandler <- liftIO $ event1ToAddHandler widget e fromAddHandler addHandler@@ -44,28 +43,25 @@ -- Not sure what to do with this. -- | Event without parameters.-event0 :: Frameworks t =>- w -> WX.Event w (IO ()) -> Moment t (Event t ())+event0 :: w -> WX.Event w (IO ()) -> MomentIO (Event ()) event0 widget = event1 widget . event0ToEvent1 -- | Behavior from an attribute. -- Uses 'fromPoll', so may behave as you expect.-behavior :: Frameworks t =>- w -> WX.Attr w a -> Moment t (Behavior t a)+behavior :: w -> WX.Attr w a -> MomentIO (Behavior a) behavior widget attr = fromPoll $ get widget attr -- | Variant of wx properties that accept a 'Behavior'.-data Prop' t w = forall a. (WX.Attr w a) :== Behavior t a+data Prop' w = forall a. (WX.Attr w a) :== Behavior a infixr 0 :== -- | "Animate" a property with a behavior-sink :: Frameworks t =>- w -> [Prop' t w] -> Moment t ()+sink :: w -> [Prop' w] -> MomentIO () sink widget = mapM_ sink1 where sink1 (attr :== b) = do- x <- initial b+ x <- valueBLater b liftIOLater $ set widget [attr := x] e <- changes b reactimate' $ (fmap $ \x -> set widget [attr := x]) <$> e@@ -75,8 +71,7 @@ ------------------------------------------------------------------------------} -- | Event that occurs when the /user/ changed -- the text in text edit widget.-eventText :: Frameworks t =>- TextCtrl w -> Moment t (Event t String)+eventText :: TextCtrl w -> MomentIO (Event String) eventText w = do addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 onText) fromAddHandler@@ -92,14 +87,12 @@ -- keyboardUp = WX.newEvent "keyboardUp" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp -- | Behavior corresponding to user input the text field.-behaviorText :: Frameworks t =>- TextCtrl w -> String -> Moment t (Behavior t String)-behaviorText w s = stepper s <$> eventText w+behaviorText :: TextCtrl w -> String -> MomentIO (Behavior String)+behaviorText w s = stepper s =<< eventText w -- | Event that occurs when the /user/ changed -- the selection marker in a list box widget.-eventSelection :: Frameworks t =>- SingleListBox b -> Moment t (Event t Int)+eventSelection :: SingleListBox b -> MomentIO (Event Int) eventSelection w = do liftIO $ fixSelectionEvent w addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select)
src/TicTacToe.hs view
@@ -4,7 +4,14 @@ Example: A version of TicTacToe with eclectic interface elements Original Author: Gideon Sireling ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Control.Monad import Data.Array @@ -20,7 +27,7 @@ User Interface ------------------------------------------------------------------------------} -main :: IO ()+main :: IO () main = start $ do -- create the main window window <- frame [text := "OX"] @@ -35,29 +42,30 @@ [map widget btns, map widget radios, map widget checks] , floatCenter $ widget label]] - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + let networkDescription :: MomentIO () + networkDescription = mdo -- 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 t (Game -> Game) - moves = foldl1 union $ zipWith (\e s -> move s <$ e) events + moves :: Event (Game -> Game) + moves = unions $ zipWith (\e s -> move s <$ e) events [(x,y) | y <- [1..3], x <- [1..3]] - eState :: Event t Game - eState = accumE newGame moves + (eState :: Event Game) + <- accumE newGame moves - state :: Behavior t Game - state = stepper newGame eState + (state :: Behavior Game) + <- stepper newGame eState - currentPlayer :: Behavior t String + let + currentPlayer :: Behavior String currentPlayer = (show . player) <$> state - tokens :: [Behavior t String] - tokens = map (\e -> stepper "" (currentPlayer <@ e)) events + (tokens :: [Behavior String]) + <- mapM (\e -> stepper "" (currentPlayer <@ e)) events -- wire up the widget event handlers zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e])
src/Tidings.hs view
@@ -16,22 +16,22 @@ -- | Data type representing a behavior 'facts' -- and suggestions to change it 'rumors'.-data Tidings t a = T { facts :: Behavior t a, rumors :: Event t a }+data Tidings a = T { facts :: Behavior a, rumors :: Event a } -- | Smart constructor. Combine facts and rumors into 'Tidings'.-tidings :: Behavior t a -> Event t a -> Tidings t a-tidings b e = T b (calm e)+tidings :: Behavior a -> Event a -> Tidings a+tidings b e = T b e -instance Functor (Tidings t) where+instance Functor Tidings where fmap f (T b e) = T (fmap f b) (fmap f e) -- | The applicative instance combines 'rumors' -- and uses 'facts' when some of the 'rumors' are not available.-instance Applicative (Tidings t) where+instance Applicative Tidings where pure x = T (pure x) never f <*> x = uncurry ($) <$> pair f x -pair :: Tidings t a -> Tidings t b -> Tidings t (a,b)+pair :: Tidings a -> Tidings b -> Tidings (a,b) pair (T bx ex) (T by ey) = T b e where b = (,) <$> bx <*> by
src/TwoCounters.hs view
@@ -3,7 +3,14 @@ Example: Two Counters. ------------------------------------------------------------------------------}-{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... import Graphics.UI.WX hiding (Event) import Reactive.Banana@@ -26,24 +33,25 @@ grid 5 5 [[label "First Counter:" , widget out1] ,[label "Second Counter:", widget out2]]]] - let networkDescription :: forall t. Frameworks t => Moment t ()- networkDescription = do+ let networkDescription :: forall t. MomentIO ()+ networkDescription = mdo eup <- event0 bup command edown <- event0 bdown command eswitch <- event0 bswitch command let- -- do we act on the left button?- firstcounter :: Behavior t Bool- firstcounter = accumB True $ not <$ eswitch+ -- do we act on the left button?+ (firstcounter :: Behavior Bool)+ <- accumB True $ not <$ eswitch - -- joined state of the two counters- counters :: Behavior t (Int, Int)- counters = accumB (0,0) $- union ((increment <$> firstcounter) `apply` eup)- ((decrement <$> firstcounter) `apply` edown)- + -- joined state of the two counters+ (counters :: Behavior (Int, Int))+ <- accumB (0,0) $ unions+ [ increment <$> firstcounter <@> eup+ , decrement <$> firstcounter <@> edown+ ]+ let 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)
src/Wave.hs view
@@ -1,11 +1,18 @@ {----------------------------------------------------------------------------- reactive-banana-wx- + 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. Moment t"+{-# LANGUAGE ScopedTypeVariables #-}+ -- allows pattern signatures like+ -- do+ -- (b :: Behavior Int) <- stepper 0 ...+{-# LANGUAGE RecursiveDo #-}+ -- allows recursive do notation+ -- mdo+ -- ... import Control.Monad import qualified Data.List as List@@ -34,37 +41,39 @@ left <- button f [text := "Left"] right <- button f [text := "Right"] lights <- replicateM 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 []- - let networkDescription :: forall t. Frameworks t => Moment t ()++ let networkDescription :: MomentIO () networkDescription = do eLeft <- event0 left command eRight <- event0 right command- + -- event describing all the lights- eWave <- scheduleQueue t $ (waveLeft <$ eLeft ) `union` - (waveRight <$ eRight)- + eWave <- scheduleQueue t $ unionWith (++)+ (waveLeft <$ eLeft )+ (waveRight <$ eRight)+ -- animate the lights forM_ [1 .. lightCount] $ \k -> do let bulb = lights !! (k-1)- bBulb = stepper False $ snd <$> filterE ((== k) . fst) eWave- + colorize True = red colorize False = black- - sink bulb [ color :== colorize <$> bBulb ] - network <- compile networkDescription + bBulb <- stepper False $ snd <$> filterE ((== k) . fst) eWave++ sink bulb [ color :== colorize <$> bBulb ]++ network <- compile networkDescription actuate network @@ -78,7 +87,7 @@ 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]] @@ -98,34 +107,30 @@ -- Schedule events to happen after a given duration from their occurrence -- However, new events will *not* be scheduled before the old ones have finished.-scheduleQueue :: Frameworks t =>- Timer -> Event t (Enqueue a) -> Moment t (Event t a)-scheduleQueue t e = do+scheduleQueue :: Timer -> Event (Enqueue a) -> MomentIO (Event a)+scheduleQueue t e = mdo liftIO $ set t [ enabled := False ] eAlarm <- event0 t command++ -- (Queue that keeps track of events to schedule+ -- , duration of the new alarm if applicable)+ (eSetNewAlarmDuration, bQueue)+ <- mapAccum [] $ unionWith const (remove <$ eAlarm) (add <$> e)+ 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-- - -