reactive-banana-threepenny (empty) → 0.7.1.3
raw patch · 25 files changed
+1647/−0 lines, 25 filesdep +arraydep +basedep +containerssetup-changedbinary-added
Dependencies added: array, base, containers, filepath, process, random, reactive-banana, threepenny-gui
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- data/banana.png binary
- data/burning.png binary
- data/circle.png binary
- data/cross.png binary
- data/empty.png binary
- data/explode.wav binary
- data/rock.png binary
- data/ship.png binary
- reactive-banana-threepenny.cabal +151/−0
- src/Animation.hs +125/−0
- src/Arithmetic.hs +58/−0
- src/Asteroids.hs +218/−0
- src/BarTab.hs +106/−0
- src/CRUD.hs +252/−0
- src/Counter.hs +48/−0
- src/CurrencyConverter.hs +64/−0
- src/NetMonitor.hs +76/−0
- src/Paths.hs +24/−0
- src/Reactive/Banana/Threepenny.hs +66/−0
- src/TicTacToe.hs +187/−0
- src/Tidings.hs +40/−0
- src/TwoCounters.hs +68/−0
- src/Wave.hs +132/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Heinrich Apfelmus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Heinrich Apfelmus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/banana.png view
binary file changed (absent → 2013 bytes)
+ data/burning.png view
binary file changed (absent → 5939 bytes)
+ data/circle.png view
binary file changed (absent → 239 bytes)
+ data/cross.png view
binary file changed (absent → 289 bytes)
+ data/empty.png view
binary file changed (absent → 857 bytes)
+ data/explode.wav view
binary file changed (absent → 23788 bytes)
+ data/rock.png view
binary file changed (absent → 3401 bytes)
+ data/ship.png view
binary file changed (absent → 1617 bytes)
+ reactive-banana-threepenny.cabal view
@@ -0,0 +1,151 @@+Name: reactive-banana-threepenny+Version: 0.7.1.3+Synopsis: Examples for the reactive-banana library, using threepenny-gui.+Description:+ This library provides some GUI examples for the @reactive-banana@ library,+ using @threepenny-gui@.+ .+ .+ Note: This library contains examples, but they are not built by default.+ To build and install the example, use the @buildExamples@ flag like this+ .+ @cabal install reactive-banana-threepenny -fbuildExamples@+ .+ Stability forecast: The wrapper functions are rather provisional.++Homepage: http://haskell.org/haskellwiki/Reactive-banana+License: BSD3+License-file: LICENSE+Author: Heinrich Apfelmus+Maintainer: Heinrich Apfelmus <apfelmus quantentunnel de>+Category: FRP, GUI+Cabal-version: >=1.8+++Build-type: Simple++data-dir: data+data-files: *.wav, *.png++flag buildExamples+ description: Build example executables+ default: False++Library+ hs-source-dirs: src+ build-depends: base >= 4.2 && < 5,+ reactive-banana >= 0.7.1.0 && < 0.8,+ threepenny-gui == 0.2.*+ extensions: ExistentialQuantification+ exposed-modules: Reactive.Banana.Threepenny++Source-repository head+ type: git+ location: git://github.com/HeinrichApfelmus/reactive-banana.git+ subdir: reactive-banana-threepenny++Executable reactiva-banana-threepenny-Animation+ if flag(buildExamples)+ build-depends:+ process >= 1.0 && < 1.2,+ random == 1.0.*,+ filepath >= 1.1 && <= 1.4,+ base, reactive-banana, threepenny-gui+ cpp-options: -DbuildExamples+ else+ buildable: False+ hs-source-dirs: src+ other-modules: Paths_reactive_banana_threepenny, Paths+ main-is: Animation.hs++Executable reactiva-banana-threepenny-Arithmetic+ if flag(buildExamples)+ build-depends: base, reactive-banana, threepenny-gui+ else+ buildable: False+ hs-source-dirs: src+ main-is: Arithmetic.hs++Executable reactiva-banana-threepenny-Asteroids+ if flag(buildExamples)+ build-depends:+ random == 1.0.*,+ filepath >= 1.1 && <= 1.4,+ reactive-banana, threepenny-gui, base+ cpp-options: -DbuildExamples+ else+ buildable: False+ hs-source-dirs: src+ other-modules: Paths_reactive_banana_threepenny, Paths+ main-is: Asteroids.hs++Executable reactiva-banana-threepenny-BarTab+ if flag(buildExamples)+ build-depends: reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: BarTab.hs++Executable reactiva-banana-threepenny-Counter+ if flag(buildExamples)+ build-depends: reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: Counter.hs++Executable reactiva-banana-threepenny-CurrencyConverter+ if flag(buildExamples)+ build-depends: reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: CurrencyConverter.hs++Executable reactiva-banana-threepenny-CRUD+ if flag(buildExamples)+ build-depends: containers >= 0.4 && < 0.6,+ reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: CRUD.hs+ other-modules: Tidings++Executable reactiva-banana-threepenny-NetMonitor+ if flag(buildExamples)+ build-depends: process >= 1.0 && < 1.2,+ reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: NetMonitor.hs++Executable reactiva-banana-threepenny-TicTacToe+ if flag(buildExamples)+ build-depends: array >= 0.3 && < 0.5,+ filepath >= 1.1 && <= 1.4,+ reactive-banana, threepenny-gui, base+ cpp-options: -DbuildExamples+ else+ buildable: False+ hs-source-dirs: src+ other-modules: Paths_reactive_banana_threepenny, Paths+ main-is: TicTacToe.hs++Executable reactiva-banana-threepenny-TwoCounters+ if flag(buildExamples)+ build-depends: reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: TwoCounters.hs++Executable reactiva-banana-threepenny-Wave+ if flag(buildExamples)+ build-depends: reactive-banana, threepenny-gui, base+ else+ buildable: False+ hs-source-dirs: src+ main-is: Wave.hs
+ src/Animation.hs view
@@ -0,0 +1,125 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: An animated picture follows the mouse pointer.+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"++-- import System.Random++import Paths (getDataFile)++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Constants+------------------------------------------------------------------------------}+height, width :: Double+height = 500+width = 500++dt :: Double+dt = 20 * ms where ms = 1e-3++spriteFile :: IO FilePath+spriteFile = getDataFile "banana.png"++bitmapWidth, bitmapHeight :: Double+bitmapWidth = 128+bitmapHeight = 128++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "It's functional programming time!"++ spriteURL <- loadFile window "image/png" =<< spriteFile+ sprite <- UI.img # set UI.src spriteURL+ wrap <- UI.div #. "wrap"+ # set style [("width",double2px width),("height",double2px height)+ ,("border","solid black 1px")]+ #+ [element sprite]+ getBody window #+ [element wrap]++ timer <- UI.timer # set UI.interval (ceiling $ dt * 1e3)++ -- event network+ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ etick <- event UI.tick timer -- frame timer+ emouse <- event UI.mousemove wrap -- mouse events+ + let+ -- mouse pointer position+ bmouse = stepper (vec 0 0) (readMouse <$> emouse)+ + -- sprite velocity+ bvelocity :: Behavior t Vector+ bvelocity =+ (\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45)+ <$> bposition <*> bmouse+ where+ speedup v = v `vecScale` (vecLength v / 20)+ + -- sprite position+ bposition :: Behavior t Vector+ bposition = accumB (vec 0 0) $+ (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos)+ <$> bvelocity <@ etick+ + clipToFrame v = vec+ (clip 0 x (width - bitmapWidth ))+ (clip 0 y (height - bitmapHeight))+ where+ x = vecX v; y = vecY v+ clip a x b = max a (min x b)++ -- animate the sprite+ return sprite # sink position bposition+ + network <- compile networkDescription + actuate network+ UI.start timer+++{-----------------------------------------------------------------------------+ 2D Geometry+------------------------------------------------------------------------------}+data Vector = Vec !Double !Double deriving (Show)++vecX (Vec x _) = x+vecY (Vec _ y) = y+vec x y = Vec x y+vecScale (Vec x y) s = Vec (s*x) (s*y)+vecAdd (Vec x1 y1) (Vec x2 y2) = Vec (x1+x2) (y1+y2)+vecSub (Vec x1 y1) (Vec x2 y2) = Vec (x1-x2) (y1-y2)+vecLength :: Vector -> Double+vecLength (Vec x y) = sqrt (x*x + y*y)++{-----------------------------------------------------------------------------+ Threepenny stuff+------------------------------------------------------------------------------}+position :: WriteAttr Element Vector+position = mkWriteAttr $ \(Vec x y) el ->+ set' style [("position","absolute")+ ,("left", double2px x) ,("top", double2px y)] el++double2px x = show (ceiling x) ++ "px" ++readMouse :: (Int,Int) -> Vector+readMouse (x,y) = vec (fromIntegral x) (fromIntegral y)+
+ src/Arithmetic.hs view
@@ -0,0 +1,58 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Very simple arithmetic+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"++import Data.Maybe++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Arithmetic"+ + input1 <- UI.input+ input2 <- UI.input+ output <- UI.span+ + getBody window #+ [row+ [ element input1, UI.string " + ", element input2+ , UI.string " = ", element output]]+++ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ + binput1 <- behaviorValue input1 ""+ binput2 <- behaviorValue input2 ""+ + let+ 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+ + return output # sink text (showNumber <$> result)++ network <- compile networkDescription + actuate network
+ src/Asteroids.hs view
@@ -0,0 +1,218 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + 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. Moment t"+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++import Control.Monad+import System.Random++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny+++import Paths (getDataFile)+import System.FilePath++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+-- constants+height, width, diameter :: Int+height = 300+width = 300+diameter = 24++chance :: Double +chance = 0.1++-- explode :: WXCore.Sound ()+-- explode = sound $ getDataFile "explode.wav" ++{-----------------------------------------------------------------------------+ Game Logic +------------------------------------------------------------------------------}+-- main game function+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } asteroids++asteroids :: Window -> IO ()+asteroids window = do+ return window # set title "Asteroids"+ + -- user interface+ canvas <- UI.canvas+ # set UI.height height+ # set UI.width width+ # set style [("border","solid black 1px")]+ # set (attr "tabindex") "1" -- allow keyboard events here+ status <- UI.span # set text "Welcome to asteroids"+ + -- resources: images and audio+ let+ loadImage name = do+ url <- loadFile window "image/png" =<< getDataFile (name <.> "png")+ img <- UI.img # set UI.src url+ return $ \(Point x y) -> UI.drawImage img (x,y) canvas++ [drawShip, drawRock, drawBurning] <- mapM loadImage (words "ship rock burning")+ audio <- do+ url <- loadFile window "audio/wav" =<< getDataFile "explode.wav"+ UI.audio # set UI.src url+ let+ clearCanvas = UI.clearCanvas canvas+ playExplosion = UI.audioPlay audio+ resources = Resources {..} + + getBody window #+ [column+ [element canvas, element status+ ,string "Click on the canvas and use the arrow keys to move."]+ ,element audio]++{-+ game <- menuPane [ text := "&Game" ] + new <- menuItem game [ text := "&New\tCtrl+N", help := "New game" ]+ pause <- menuItem game [ text := "&Pause\tCtrl+P" + , help := "Pause game" + , checkable := True+ ] + menuLine game+ quit <- menuQuit game [help := "Quit the game"] + + set new [on command := asteroids] + set pause [on command := set t [enabled :~ not]] + set quit [on command := close 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)] + ]+-}+++ timer <- UI.timer # set UI.interval 50++ -- event network+ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ -- timer+ etick <- event UI.tick timer+ + -- keyboard events+ ekey <- event UI.keydown canvas+ let eleft = filterE (== 37) ekey+ eright = filterE (== 39) ekey+ + -- 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-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))+ + -- draw the game state+ reactimate $ (drawGameState resources <$> bship <*> brocks) <@ etick+ + -- status bar+ let bstatus :: Behavior t String+ bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks+ return status # sink UI.text bstatus+ + network <- compile networkDescription + actuate network+ UI.start timer+++-- rock logic+type Position = Point+type Rock = [Position] -- lazy list of future y-positions++newRock :: Double -> [Rock] -> [Rock]+newRock r rs = (track . floor $ fromIntegral width * r / chance) : rs++track :: Int -> Rock+track x = [point x (y - diameter) | y <- [0, 6 .. height + 2 * diameter]]++advanceRocks :: [Rock] -> [Rock]+advanceRocks = filter (not . null) . map (drop 1)++collide :: Position -> Position -> Bool+collide pos0 pos1 = + let distance = vecLength (vecBetween pos0 pos1) + in distance <= fromIntegral diameter++-- draw game state+data Resources = Resources+ { drawShip :: Position -> IO ()+ , drawRock :: Position -> IO ()+ , drawBurning :: Position -> IO ()+ , clearCanvas :: IO ()+ , playExplosion :: IO ()+ }++drawGameState :: Resources -> Int -> [Rock] -> IO ()+drawGameState r@(Resources{..}) ship rocks = do+ let+ shipLocation = point ship (height - 2 * diameter)+ positions = map head rocks+ collisions = map (collide shipLocation) positions++ clearCanvas+ drawShip shipLocation+ mapM_ (drawEnemyRock r) (zip positions collisions) ++ when (or collisions) playExplosion++drawEnemyRock :: Resources -> (Position, Bool) -> IO ()+drawEnemyRock (Resources{..}) (pos, collides) = draw pos+ where draw = if collides then drawBurning else drawRock+++{-----------------------------------------------------------------------------+ 2D Geometry+------------------------------------------------------------------------------}+data Point = Point !Int !Int deriving (Show)+data Vector = Vec !Int !Int deriving (Show)++point = Point++vecX (Vec x _) = x+vecY (Vec _ y) = y+vec x y = Vec x y+-- vecScale (Vec x y) s = Vec (s*x) (s*y)+vecAdd (Vec x1 y1) (Vec x2 y2) = Vec (x1+x2) (y1+y2)+vecSub (Vec x1 y1) (Vec x2 y2) = Vec (x1-x2) (y1-y2)+vecLength :: Vector -> Double+vecLength (Vec x y) = sqrt $ fromIntegral $ x*x + y*y+vecBetween (Point x1 y1) (Point x2 y2) = Vec (x2-x1) (y2-y1)
+ src/BarTab.hs view
@@ -0,0 +1,106 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Bar tab with a variable number of widgets+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++import Control.Monad (void)+import Data.Maybe (listToMaybe)+import Data.Traversable (sequenceA)++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Bar Tab"++ msg <- UI.span # set text "Sum:"+ total <- UI.span+ add <- UI.button #+ [string "Add"]+ remove <- UI.button #+ [string "Remove"]+ body <- UI.getBody window+ + let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ eAdd <- event UI.click add+ eRemove <- event UI.click remove+ + let+ newEntry :: Frameworks s+ => Moment s (Element, AnyMoment Behavior String) + newEntry = do+ wentry <- liftIO $ UI.input # set value "0"+ bentry <- trimB =<< behaviorValue wentry "0"+ return (wentry, bentry)+ + eNewEntry <- execute $ (FrameworksMoment newEntry <$ eAdd)+ + let+ eDoRemove = whenE (not . null <$> bEntries) eRemove+ + eEntries :: Event t [(Element, AnyMoment Behavior String)]+ eEntries = accumE [] $+ ((\x -> (++ [x])) <$> eNewEntry) `union` (init <$ eDoRemove)+ + bEntries = stepper [] eEntries+ + let hideElement e = void $ element e # set style [("hidden","true")]+ reactimate $ (hideElement . fst . last)+ <$> bEntries <@ eDoRemove+ + let+ ePrices :: Event t [AnyMoment Behavior Number]+ ePrices = map (fmap readNumber . snd) <$> eEntries+ + bLayout :: Behavior t [IO Element]+ bLayout = mkLayout . map fst <$> bEntries+ + mkLayout entries = [column $+ [row [element add, element remove]] ++ map element entries+ ++ [row [element msg, element total]]]+ + bTotal :: Behavior t Number+ bTotal = switchB (pure Nothing) $+ (fmap sum . sequenceA) <$> ePrices++ return total # sink text (showNumber <$> bTotal)+ return body # sink layout bLayout + + network <- compile networkDescription + actuate network++layout :: WriteAttr Element [IO Element]+layout = mkWriteAttr $ \i x -> void $ element x # set children [] #+ i++{-----------------------------------------------------------------------------+ Utilities+------------------------------------------------------------------------------}+type Number = Maybe Double++instance Num Number where+ (+) = liftA2 (+)+ (-) = liftA2 (-)+ (*) = liftA2 (*)+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++readNumber s = listToMaybe [x | (x,"") <- reads s] +showNumber = maybe "--" show
+ src/CRUD.hs view
@@ -0,0 +1,252 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + 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 ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-}++import Prelude hiding (lookup)+import Control.Monad (void)+import Data.List (isPrefixOf)+import Data.Maybe+import Data.Monoid+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event, filterJust, delete)++import Reactive.Banana+import Reactive.Banana.Threepenny++import Tidings++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "CRUD Example (Simple)"++ -- GUI layout+ listBox <- UI.select # set (attr "size") "10" # set style [("width","200px")]+ createBtn <- UI.button #+ [string "Create"]+ deleteBtn <- UI.button #+ [string "Delete"]+ filterEntry <- UI.input+ firstname <- UI.input+ lastname <- UI.input+ + let dataItem = grid [[string "First Name:", element firstname]+ ,[string "Last Name:" , element lastname]]+ let glue = string " "+ getBody window #+ [grid+ [[row [string "Filter prefix:", element filterEntry], glue]+ ,[element listBox, dataItem]+ ,[row [element createBtn, element deleteBtn], glue]+ ]]++ -- event network+ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = mdo+ -- events from buttons+ eCreate <- event UI.click createBtn+ eDelete <- event UI.click deleteBtn+ -- filter string+ tFilterString <- reactiveTextEntry filterEntry bFilterString+ let bFilterString = stepper "" $ rumors tFilterString+ tFilter = isPrefixOf <$> tFilterString+ bFilter = facts tFilter+ eFilter = rumors tFilter++ -- list box with selection+ eSelection <- rumors <$> reactiveListDisplay listBox+ bListBoxItems bSelection bShowDataItem+ -- data item display+ eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname)+ bSelectionDataItem++ let -- database+ bDatabase :: Behavior t (Database DataItem)+ bDatabase = accumB emptydb $ unions+ [ create ("Emil","Example") <$ eCreate+ , filterJust $ update' <$> bSelection <@> eDataItemIn+ , delete <$> filterJust (bSelection <@ eDelete)+ ]+ where+ update' mkey x = flip update x <$> mkey+ + -- selection+ bSelection :: Behavior t (Maybe DatabaseKey)+ bSelection = stepper Nothing $ unions+ [ 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)+ bLookup = flip lookup <$> bDatabase+ + bShowDataItem :: Behavior t (DatabaseKey -> String)+ bShowDataItem = (maybe "" showDataItem .) <$> bLookup+ + bListBoxItems :: Behavior t [DatabaseKey]+ bListBoxItems = (\p show -> filter (p. show) . keys)+ <$> bFilter <*> bShowDataItem <*> bDatabase++ bSelectionDataItem :: Behavior t (Maybe DataItem)+ bSelectionDataItem = (=<<) <$> bLookup <*> bSelection++ -- automatically enable / disable editing+ let+ bDisplayItem :: Behavior t Bool+ bDisplayItem = maybe False (const True) <$> bSelection+ + return deleteBtn # sink UI.enabled bDisplayItem+ return firstname # sink UI.enabled bDisplayItem+ return lastname # sink UI.enabled bDisplayItem+ + network <- compile networkDescription + actuate network++{-----------------------------------------------------------------------------+ Database Model+------------------------------------------------------------------------------}+type DatabaseKey = Int+data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }++emptydb = Database 0 Map.empty+keys = Map.keys . 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++-- single text entry+reactiveTextEntry :: Frameworks t+ => Element+ -> Behavior t String -- text value+ -> Moment t (Tidings t String) -- user changes+reactiveTextEntry w btext = do+ eUser <- eventValue w -- user changes++ -- filter text setting that are simultaneous with user events+ itext <- initial btext+ etext <- changes btext+ let etext2 = fst $ split $ unionWith (curry snd) (Left <$> etext) (Right <$> eUser)+ btext2 = stepper itext etext2++ return w # sink value btext2 -- display value+ return $ tidings btext eUser++-- whole data item (consisting of two text entries)+reactiveDataItem :: Frameworks t+ => (Element, Element)+ -> Behavior t (Maybe DataItem)+ -> Moment t (Tidings t DataItem)+reactiveDataItem (firstname,lastname) binput = do+ t1 <- reactiveTextEntry firstname (fst . maybe ("","") id <$> binput)+ t2 <- reactiveTextEntry lastname (snd . maybe ("","") id <$> binput)+ return $ (,) <$> t1 <*> t2+++{-----------------------------------------------------------------------------+ 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.+------------------------------------------------------------------------------}+reactiveListDisplay :: forall t a b. (Ord a, Frameworks t)+ => Element -- 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)+reactiveListDisplay w bitems bsel bdisplay = do+ -- animate output items+ liftIO $ putStrLn "test"+ return w # sink items (map <$> bdisplay <*> bitems)+ + -- animate output selection+ let bindices :: Behavior t (Map.Map a Int)+ bindices = (Map.fromList . flip zip [0..]) <$> bitems+ bindex = lookupIndex <$> bindices <*> bsel++ lookupIndex indices Nothing = Nothing+ lookupIndex indices (Just sel) = Map.lookup sel indices++ return w # sink UI.selection bindex++ -- changing the display won't change the current selection+ -- eDisplay <- changes display+ -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]++ -- user selection+ let bindices2 :: Behavior t (Map.Map Int a)+ bindices2 = Map.fromList . zip [0..] <$> bitems+ esel <- eventSelection w+ return $ tidings bsel $ lookupIndex <$> bindices2 <@> esel+++items = mkWriteAttr $ \i x -> void $ do+ return x # set children [] #+ map (\i -> UI.option # set text i) i++{-----------------------------------------------------------------------------+ wxHaskell convenience wrappers and bug fixes+------------------------------------------------------------------------------}+{- Currently exported from Reactive.Banana.WX++-- user input event - text for text entries+eventText :: TextCtrl w -> Moment t (Event t String)+eventText w = 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 w keyboardUp+ fromAddHandler $ mapIO (const $ get w text) addHandler++-- 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" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp++-- user input event - selection marker for list events+eventSelection :: SingleListBox b -> Moment t (Event t Int)+eventSelection w = do+ liftIO $ fixSelectionEvent w+ addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select)+ fromAddHandler $ mapIO (const $ get w selection) addHandler++-- Fix @select@ event not being fired when items are *un*selected.+fixSelectionEvent listbox =+ liftIO $ set listbox [ on unclick := handler ]+ where+ handler _ = do+ propagateEvent+ s <- get listbox selection+ when (s == -1) $ (get listbox (on select)) >>= id+-}
+ src/Counter.hs view
@@ -0,0 +1,48 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Counter+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Counter"+ + bup <- UI.button #+ [UI.string "Up" ]+ bdown <- UI.button #+ [UI.string "Down"]+ output <- UI.span+ + getBody window #+ [column [element bup, element bdown, element output]]++ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ + eup <- event UI.click bup+ edown <- event UI.click bdown+ + let+ counter :: Behavior t Int+ counter = accumB 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown)+ + return output # sink text (show <$> counter)++ network <- compile networkDescription + actuate network
+ src/CurrencyConverter.hs view
@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: Currency Converter+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"+{-# LANGUAGE RecursiveDo #-}++import Data.Maybe+import Text.Printf++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Currency Converter"++ dollar <- UI.input+ euro <- UI.input+ + getBody window #+ [+ column [+ grid [[string "Dollar:", element dollar]+ ,[string "Euro:" , element euro ]]+ , string "Amounts update while typing."+ ]]++ let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do+ + euroIn <- behaviorValue euro "0"+ dollarIn <- behaviorValue 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 :: Behavior t String+ dollarOut = withString (/ rate) <$> euroIn+ euroOut = withString (* rate) <$> dollarIn+ + return euro # sink value euroOut+ return dollar # sink value dollarOut++ network <- compile networkDescription + actuate network+
+ src/NetMonitor.hs view
@@ -0,0 +1,76 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Minuscule network monitor+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"++import Data.Char+import Data.List+import Data.Maybe++import System.Process++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Network Monitor"++ out1 <- UI.span+ out2 <- UI.span+ + getBody window #++ [column [string "TCP network statistics",+ grid [[string "Packets sent: ", element out1]+ ,[string "Packets received: ", element out2]]+ ]]+ + timer <- UI.timer # set UI.interval 500 -- timer every 500 ms++ let networkDescription :: forall t. Frameworks t => Moment 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 <- event UI.tick timer+ + let showSent = maybe "parse error" show . fst+ showReceived = maybe "parse error" show . snd+ + return out1 # sink text (showSent <$> bnetwork)+ return out2 # sink text (showReceived <$> bnetwork)+ + network <- compile networkDescription+ actuate network+ UI.start timer++-- Obtain network statistics from the netstat utility+type NetworkStatistics = (Maybe Int, Maybe Int)++getNetworkStatistics :: IO NetworkStatistics+getNetworkStatistics = do+ s <- readProcess "netstat" ["-s", "-p","tcp"] ""+ return (readField "packets sent" s+ ,readField "packets received" s)++readField :: String -> String -> Maybe Int+readField fieldname = id+ . fmap (read . filter isDigit) . listToMaybe+ . filter (fieldname `isSuffixOf`) . lines
+ src/Paths.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP#-}+module Paths (getDataFile) where++import System.FilePath+import System.IO.Unsafe++#if buildExamples+-- using cabal+-- import System.Environment.Executable+-- import System.Info+import qualified Paths_reactive_banana_threepenny (getDataDir)++getDataDir :: IO FilePath+getDataDir = Paths_reactive_banana_threepenny.getDataDir++#else+-- using GHCi++getDataDir :: IO FilePath+getDataDir = return "../data/"++#endif++getDataFile x = fmap (</> x) getDataDir
+ src/Reactive/Banana/Threepenny.hs view
@@ -0,0 +1,66 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+------------------------------------------------------------------------------}+{-# LANGUAGE ExistentialQuantification #-}++module Reactive.Banana.Threepenny (+ -- * Synopsis+ -- | Utility functions for interfacing with "Graphics.UI.Threepenny".+ -- Note: Useful, but I haven't done any serious design work on these.+ + -- * General+ event, behavior, sink,+ module Reactive.Banana.Frameworks,+ + -- * Specific widgets+ eventValue, behaviorValue, eventSelection,+ ) where++import Control.Monad (void)++import Reactive.Banana+import Reactive.Banana.Frameworks++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++{-----------------------------------------------------------------------------+ General+------------------------------------------------------------------------------}+-- | Obtain an event for an element.+event :: Frameworks t => (x -> UI.Event a) -> x -> Moment t (Event t a)+event e widget = fromAddHandler . register $ e widget++-- | Behavior from an attribute.+-- Uses 'fromPoll', so may behave as you expect.+behavior :: Frameworks t => UI.ReadWriteAttr x i o -> x -> Moment t (Behavior t o)+behavior widget attr = fromPoll $ get widget attr++-- | "Animate" an attribute with a behavior.+sink :: Frameworks t+ => UI.ReadWriteAttr x i o -> Behavior t i -> Moment t x -> Moment t ()+sink attr b mx = do+ x <- mx+ i <- initial b+ liftIOLater $ void $ return x # set attr i+ e <- changes b+ reactimate $ (\i -> void $ return x # set attr i) <$> e ++{-----------------------------------------------------------------------------+ Specific widgets+------------------------------------------------------------------------------}+-- | Event that occurs when the /user/ changes the value of the input element.+eventValue :: Frameworks t => UI.Element -> Moment t (Event t String)+eventValue = event $ \widget ->+ UI.mapIO (const $ get value widget) (domEvent "keydown" widget)++-- | Behavior corresponding to user input in the element.+behaviorValue :: Frameworks t => UI.Element -> String -> Moment t (Behavior t String)+behaviorValue w s = stepper s <$> eventValue w++-- | Event that occurs when the /user/ changes the selection of a @<select>@ element.+eventSelection :: Frameworks t => UI.Element -> Moment t (Event t (Maybe Int))+eventSelection = event $ \widget ->+ UI.mapIO (const $ get UI.selection widget) (UI.click widget)++
+ src/TicTacToe.hs view
@@ -0,0 +1,187 @@+{----------------------------------------------------------------------------- + reactive-banana-threepenny + + Example: TicTacToe. + Original Author: Gideon Sireling +------------------------------------------------------------------------------} +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" + +import Control.Monad +import Data.Array +import Data.List hiding (union) +import Data.Maybe + +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core hiding (Event, filterJust) + +import Reactive.Banana +import Reactive.Banana.Threepenny + +import Paths + +{----------------------------------------------------------------------------- + User Interface +------------------------------------------------------------------------------} +main :: IO () +main = do + startGUI Config + { tpPort = 10000 + , tpCustomHTML = Nothing + , tpStatic = "" + } setup + +-- | Load images corresponding to tokens. +loadToken2URL :: Window -> IO (Token -> String) +loadToken2URL window = do + let loadPng name = loadFile window "image/png" =<< getDataFile (name ++ ".png") + [none, x, o] <- mapM loadPng ["empty","cross","circle"] + return $ \token -> case token of { None -> none; X -> x; O -> o; } + +-- | Set up user interface. +setup :: Window -> IO () +setup window = do + return window # set title "Tic Tac Toe" + + token2url <- loadToken2URL window + + status <- UI.div # set text "Player: X" + let repeat n = sequence . replicate n + fields <- repeat 3 $ repeat 3 $ + UI.img # set UI.src (token2url None) # set style [("border","1px solid black")] + + getBody window #+ [grid $ map (map element) fields, element status] + + + let networkDescription :: forall t. Frameworks t => Moment t () + networkDescription = do + events <- concat <$> mapM (mapM (event UI.click)) fields + + 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 :: Behavior t Game + state = accumB newGame moves + + currentPlayer :: Behavior t Token + currentPlayer = player <$> state + + tokens :: [Behavior t Token] + tokens = map (\e -> stepper None (currentPlayer <@ e)) events + + zipWithM_ + (\field token -> return field # sink UI.src (token2url <$> token)) + (concat fields) + tokens + + return status # sink text (("Player: " ++) . show <$> currentPlayer) + + -- end game event handler + eState <- changes state + reactimate $ end window <$> filterJust (isGameEnd . board <$> eState) + + network <- compile networkDescription + actuate network + + +end :: Window -> Token -> IO () +end window result = do + alert window $ + case result of + X -> "X won!" + O -> "O won!" + None -> "Draw!" + clear window + +alert w s = runFunction w (ffi "alert(%1)" s) + +{----------------------------------------------------------------------------- + Game Logic +------------------------------------------------------------------------------} +data Token = None | X | O + deriving Eq + +-- |The coordinates of a square. +type Square = (Int,Int) + +-- |A noughts and crosses board. +type Board = Array Square Token + +-- |Returns an empty 'Board'. +newBoard :: Board +newBoard = listArray ((1,1),(3,3)) (repeat None) + +-- |Puts a 'Token' in a 'Square'. +setSquare :: Board -> Square -> Token -> Board +setSquare board square token = + if (board ! square) /= None + then error $ "square " ++ show square ++ " is not empty" + else board // [(square, token)] + +-- |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'. +isGameEnd :: Board -> Maybe Token +isGameEnd board + | Just X `elem` maybeWins = Just X + | Just O `elem` maybeWins = Just O + | None `notElem` elems board = Just None + | otherwise = Nothing + + where rows :: [[Square]] + rows = let i = [1..3] + in [[(x,y) | y <- i] | x <- i] ++ -- rows + [[(y,x) | y <- i] | x <- i] ++ -- coloumns + [[(x,x) | x <- i], [(x,4-x) | x <- i]] -- diagonals + + rows2tokens :: [[Token]] + rows2tokens = map (map (board !)) rows + + isWin :: [Token] -> Maybe Token + isWin tokens + | all (==X) tokens = Just X + | all (==O) tokens = Just O + | otherwise = Nothing + + maybeWins :: [Maybe Token] + 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 { player :: Token, board :: Board } + +newGame :: Game +newGame = Game X newBoard + +-- |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 :: 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 +------------------------------------------------------------------------------} +outersperse :: a -> [a] -> [a] +outersperse x ys = x : intersperse x ys ++ [x] + +instance Show Token where + show X = "X" + show O = "O" + show None = " " + showList tokens = showString $ outersperse '|' $ concatMap show tokens + +-- Board cannot be declared an instance of Show, +-- as this would overlap with the existing instance for Array. +showBoard :: Board -> String +showBoard board = + let border = " +-+-+-+" + i = [1..3] + showRow x = show x ++ show [board ! (y,x) | y <- i] + in intercalate "\n" $ " 1 2 3" : outersperse border (map showRow i) + +instance Show Game where + show (Game player board) = showBoard board ++ "\n\nTurn: " ++ show player
+ src/Tidings.hs view
@@ -0,0 +1,40 @@+{-----------------------------------------------------------------------------+ reactive-banana+------------------------------------------------------------------------------}+module Tidings (+ -- * Synopsis+ -- The 'Tidings' data type for composing user events.+ --+ -- See <http://apfelmus.nfshost.com/blog/2012/03/29-frp-three-principles-bidirectional-gui.html>+ -- for more information.+ + -- * Documentation+ Tidings, tidings, facts, rumors,+ ) where++import Reactive.Banana.Combinators++-- | 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 }++-- | 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)++instance Functor (Tidings t) 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+ pure x = T (pure x) never+ f <*> x = uncurry ($) <$> pair f x++pair :: Tidings t a -> Tidings t b -> Tidings t (a,b)+pair (T bx ex) (T by ey) = T b e+ where+ b = (,) <$> bx <*> by+ x = flip (,) <$> by <@> ex+ y = (,) <$> bx <@> ey+ e = unionWith (\(x,_) (_,y) -> (x,y)) x y
+ src/TwoCounters.hs view
@@ -0,0 +1,68 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Two Counters.+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Two Counters"+ + bup <- UI.button #+ [string "Up" ]+ bdown <- UI.button #+ [string "Down"]+ bswitch <- UI.button #+ [string "Switch Counters"]++ out1 <- UI.span+ out2 <- UI.span+ + getBody window #+ [+ column [row [element bup, element bdown, element bswitch]+ ,grid [[string "First Counter:", element out1]+ ,[string "Second Counter:", element out2]]]]++ + let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do++ eup <- event UI.click bup+ edown <- event UI.click bdown+ eswitch <- event UI.click bswitch+ + let+ -- do we act on the left button?+ firstcounter :: Behavior t Bool+ firstcounter = 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)+ + 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)+ + return out1 # sink text (show . fst <$> counters)+ return out2 # sink text (show . snd <$> counters)+ + network <- compile networkDescription + actuate network+
+ src/Wave.hs view
@@ -0,0 +1,132 @@+{-----------------------------------------------------------------------------+ reactive-banana-threepenny+ + Example: Emit a wave of light.+ 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"++import Control.Monad+import qualified Data.List as List+import Data.Maybe+import Data.Ord+++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (Event)++import Reactive.Banana+import Reactive.Banana.Threepenny++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+lightCount = 15 -- number of lights that comprise the wave+waveLength = 4 -- number of lights that are lit at once+dt = 70 -- half the cycle duration++main :: IO ()+main = do+ startGUI Config+ { tpPort = 10000+ , tpCustomHTML = Nothing+ , tpStatic = ""+ } setup++setup :: Window -> IO ()+setup window = do+ return window # set title "Waves of Light"+ + left <- UI.button #+ [string "Left" ]+ right <- UI.button #+ [string "Right"]+ lights <- sequence $ replicate lightCount $ UI.span # set text "•"+ + getBody window #+ [column+ [row [element left, element right]+ ,row $ map element lights+ ]]+ + timer <- UI.timer+ + let networkDescription :: forall t. Frameworks t => Moment t ()+ networkDescription = do++ eLeft <- event UI.click left+ eRight <- event UI.click right+ + -- event describing all the lights+ eWave <- scheduleQueue timer $ (waveLeft <$ eLeft ) `union` + (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"+ + return bulb # sink color (colorize <$> bBulb)++ network <- compile networkDescription + actuate network++color = mkWriteAttr $ \i -> set' style [("color",i)]++type Index = Int+type Action = (Index, Bool)++-- describe wave pattern as a list+wave :: (Index -> Index) -> [(Duration, Action)]+wave f = deltas $ merge ons offs+ where+ merge xs ys = List.sortBy (comparing fst) $ xs ++ ys+ deltas xs = zipWith relativize (0 : map fst xs) xs+ where relativize dt1 (dt2,x) = (dt2-dt1, x)+ + ons = [(k*2*dt, (f k, True)) | k <- [1..lightCount]]+ offs = [(dt+(waveLength+k)*2*dt, (f k, False)) | k <- [1..lightCount]]++waveLeft = wave id+waveRight = wave (\k -> lightCount - k + 1)+++{-----------------------------------------------------------------------------+ Timer magic+------------------------------------------------------------------------------}+type Duration = Int -- in milliseconds+type Queue a = [(Duration, a)] -- [(time to wait, occurrence to happen)]+type Enqueue a = Queue a++-- Schedule events to happen after a given duration from their occurrence+-- However, new events will *not* be scheduled before the old ones have finished.+scheduleQueue :: Frameworks t =>+ UI.Timer -> Event t (Enqueue a) -> Moment t (Event t a)+scheduleQueue t e = do+ liftIO $ UI.stop t+ eAlarm <- event UI.tick t+ 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 = do { return t # set UI.interval dt; UI.start t }+ stop = UI.stop t+ 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+