diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/banana.png b/data/banana.png new file mode 100644 Binary files /dev/null and b/data/banana.png differ diff --git a/data/burning.png b/data/burning.png new file mode 100644 Binary files /dev/null and b/data/burning.png differ diff --git a/data/circle.png b/data/circle.png new file mode 100644 Binary files /dev/null and b/data/circle.png differ diff --git a/data/cross.png b/data/cross.png new file mode 100644 Binary files /dev/null and b/data/cross.png differ diff --git a/data/empty.png b/data/empty.png new file mode 100644 Binary files /dev/null and b/data/empty.png differ diff --git a/data/explode.wav b/data/explode.wav new file mode 100644 Binary files /dev/null and b/data/explode.wav differ diff --git a/data/rock.png b/data/rock.png new file mode 100644 Binary files /dev/null and b/data/rock.png differ diff --git a/data/ship.png b/data/ship.png new file mode 100644 Binary files /dev/null and b/data/ship.png differ diff --git a/reactive-banana-threepenny.cabal b/reactive-banana-threepenny.cabal new file mode 100644 --- /dev/null +++ b/reactive-banana-threepenny.cabal @@ -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 +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 diff --git a/src/Animation.hs b/src/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Animation.hs @@ -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) + diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Arithmetic.hs @@ -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 diff --git a/src/Asteroids.hs b/src/Asteroids.hs new file mode 100644 --- /dev/null +++ b/src/Asteroids.hs @@ -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) diff --git a/src/BarTab.hs b/src/BarTab.hs new file mode 100644 --- /dev/null +++ b/src/BarTab.hs @@ -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 diff --git a/src/CRUD.hs b/src/CRUD.hs new file mode 100644 --- /dev/null +++ b/src/CRUD.hs @@ -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 +-} diff --git a/src/Counter.hs b/src/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Counter.hs @@ -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 diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs new file mode 100644 --- /dev/null +++ b/src/CurrencyConverter.hs @@ -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 + diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs new file mode 100644 --- /dev/null +++ b/src/NetMonitor.hs @@ -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 diff --git a/src/Paths.hs b/src/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Paths.hs @@ -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 diff --git a/src/Reactive/Banana/Threepenny.hs b/src/Reactive/Banana/Threepenny.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Threepenny.hs @@ -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 @