UISF 0.3.0.1 → 0.3.0.2
raw patch · 11 files changed
+702/−687 lines, 11 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ FRP.UISF.UITypes: DenyFocus :: FocusInfo
Files
- FRP/UISF/AuxFunctions.hs +2/−2
- FRP/UISF/Examples/Examples.hs +101/−102
- FRP/UISF/Examples/Pinochle.hs +38/−44
- FRP/UISF/Examples/SevenGuis.lhs +526/−522
- FRP/UISF/Examples/fft.hs +3/−3
- FRP/UISF/SOE.hs +5/−1
- FRP/UISF/UISF.hs +0/−1
- FRP/UISF/UITypes.hs +12/−6
- FRP/UISF/Widget.hs +6/−5
- UISF.cabal +2/−1
- changelog.txt +7/−0
FRP/UISF/AuxFunctions.hs view
@@ -14,8 +14,8 @@ module FRP.UISF.AuxFunctions ( -- * Types SEvent, Time, DeltaT, - ArrowTime, time, - ArrowIO, liftAIO, initialAIO, + ArrowTime(..), + ArrowIO(..), -- * Useful SF Utilities (Mediators) constA, constSF, edge,
FRP/UISF/Examples/Examples.hs view
@@ -1,102 +1,101 @@-{-# LANGUAGE Arrows #-}---- Last modified by: Daniel Winograd-Cort--- Last modified on: 5/25/2013---- This file is a set of various UI examples showing off the features --- of the various widgets in UISF.--module FRP.UISF.Examples.Examples where--import FRP.UISF-import FRP.UISF.SOE (withColor', rgb, polygon)--import Numeric (showHex)---- | This example displays the time from the start of the GUI application.-timeEx :: UISF () ()-timeEx = title "Time" $ getTime >>> display---- | This example shows off 'button's and state by presenting a plus and --- minus button with a counter that is adjusted by them.-buttonEx :: UISF () ()-buttonEx = title "Buttons" $ topDown $ proc _ -> do- (x,y) <- leftRight (proc _ -> do- x <- edge <<< button "+" -< ()- y <- edge <<< button "-" -< ()- returnA -< (x, y)) -< ()- rec v <- delay 0 -< (case (x,y) of- (Just _, Nothing) -> v+1- (Nothing, Just _) -> v-1- _ -> v)- display -< v---- | This example shows off the 'checkbox' widgets.-checkboxEx :: UISF () ()-checkboxEx = title "Checkboxes" $ topDown $ proc _ -> do- x <- checkbox "Monday" False -< ()- y <- checkbox "Tuesday" True -< ()- z <- checkbox "Wednesday" True -< ()- let v = bin x ++ bin y ++ bin z- displayStr -< v- where- bin True = "1"- bin False = "0"---- | This example shows off the 'radio' button widget.-radioButtonEx :: UISF () ()-radioButtonEx = title "Radio Buttons" $ topDown $ radio list 0 >>> arr (list!!) >>> displayStr- where- list = ["apple", "orange", "banana"]---- | This example shows off integral sliders (horizontal 'hiSlider's in --- this case).-shoppinglist :: UISF () ()-shoppinglist = title "Shopping List" $ topDown $ proc _ -> do- a <- title "apples" $ hiSlider 1 (0,10) 3 -< ()- b <- title "bananas" $ hiSlider 1 (0,10) 7 -< () - title "total" $ display -< (a + b)---- | This example shows off both vertical sliders as well as the 'canvas' --- widget. The canvas widget can be used to easily create custom graphics --- in the GUI. Here, it is used to make a color swatch that is --- controllable with RGB values by the sliders.-colorDemo :: UISF () ()-colorDemo = setSize (300, 220) $ title "Color" $ pad (4,0,4,0) $ leftRight $ proc _ -> do- r <- newColorSlider "R" -< ()- g <- newColorSlider "G" -< ()- b <- newColorSlider "B" -< ()- prevRGB <- delay (0,0,0) -< (r,g,b)- changed <- delay True -< (r,g,b) == prevRGB- let rect = withColor' (rgb r g b) (box ((0,0),d))- pad (4,8,0,0) $ canvas d -< if changed then Just rect else Nothing- where- d = (170,170)- newColorSlider l = title l $ topDown $ proc _ -> do- v <- viSlider 16 (0,255) 0 -< ()- _ <- displayStr -< showHex v ""- returnA -< v- box ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)]---- | This example shows off the 'textboxE' widget. Text can be typed in, and --- that text is transferred to the 'display' widget below when the button --- is pressed.-textboxdemo :: UISF () ()-textboxdemo = setLayout (makeLayout (Stretchy 150) (Fixed 100)) $ - title "Saving Text" $ topDown $ proc _ -> do- str <- leftRight $ label "Text: " >>> textboxE "" -< Nothing- b <- button "Save text to below" -< ()- rec str' <- delay "" -< if b then str else str'- leftRight $ label "Saved value: " >>> displayStr -< str' - returnA -< ()---- | This is the main demo that incorporates all of the other examples --- together. In addition to demonstrating how --- different widgets can connect, it also shows off the tabbing --- behavior built in to the GUI. Pressing tab cycles through focuable --- elements, and pressing shift-tab cycles in reverse.-main :: IO ()-main = runUI (defaultUIParams {uiSize=(500, 500)}) $ - (leftRight $ (bottomUp $ timeEx >>> buttonEx) >>> (topDown $ checkboxEx >>> arr id) >>> radioButtonEx) >>>- (leftRight $ shoppinglist >>> colorDemo) >>> textboxdemo >>> arr id-+{-# LANGUAGE Arrows #-} + +-- Last modified by: Daniel Winograd-Cort +-- Last modified on: 5/25/2013 + +-- This file is a set of various UI examples showing off the features +-- of the various widgets in UISF. + +module FRP.UISF.Examples.Examples where + +import FRP.UISF +import FRP.UISF.SOE (withColor', rgb, polygon) + +import Numeric (showHex) + +-- | This example displays the time from the start of the GUI application. +timeEx :: UISF () () +timeEx = title "Time" $ getTime >>> display + +-- | This example shows off 'button's and state by presenting a plus and +-- minus button with a counter that is adjusted by them. +buttonEx :: UISF () () +buttonEx = title "Buttons" $ topDown $ proc _ -> do + (x,y) <- leftRight (proc _ -> do + x <- edge <<< button "+" -< () + y <- edge <<< button "-" -< () + returnA -< (x, y)) -< () + rec v <- delay 0 -< (case (x,y) of + (Just _, Nothing) -> v+1 + (Nothing, Just _) -> v-1 + _ -> v) + display -< v + +-- | This example shows off the 'checkbox' widgets. +checkboxEx :: UISF () () +checkboxEx = title "Checkboxes" $ topDown $ proc _ -> do + x <- checkbox "Monday" False -< () + y <- checkbox "Tuesday" True -< () + z <- checkbox "Wednesday" True -< () + let v = bin x ++ bin y ++ bin z + displayStr -< v + where + bin True = "1" + bin False = "0" + +-- | This example shows off the 'radio' button widget. +radioButtonEx :: UISF () () +radioButtonEx = title "Radio Buttons" $ topDown $ radio list 0 >>> arr (list!!) >>> displayStr + where + list = ["apple", "orange", "banana"] + +-- | This example shows off integral sliders (horizontal 'hiSlider's in +-- this case). +shoppinglist :: UISF () () +shoppinglist = title "Shopping List" $ topDown $ proc _ -> do + a <- title "apples" $ hiSlider 1 (0,10) 3 -< () + b <- title "bananas" $ hiSlider 1 (0,10) 7 -< () + title "total" $ display -< (a + b) + +-- | This example shows off both vertical sliders as well as the 'canvas' +-- widget. The canvas widget can be used to easily create custom graphics +-- in the GUI. Here, it is used to make a color swatch that is +-- controllable with RGB values by the sliders. +colorDemo :: UISF () () +colorDemo = setSize (300, 220) $ title "Color" $ pad (4,0,4,0) $ leftRight $ proc _ -> do + r <- newColorSlider "R" -< () + g <- newColorSlider "G" -< () + b <- newColorSlider "B" -< () + changed <- unique -< (r,g,b) + let rect = withColor' (rgb r g b) (box ((0,0),d)) + pad (4,8,0,0) $ canvas d -< fmap (const rect) changed + where + d = (170,170) + newColorSlider l = title l $ topDown $ proc _ -> do + v <- viSlider 16 (0,255) 0 -< () + _ <- displayStr -< showHex v "" + returnA -< v + box ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)] + +-- | This example shows off the 'textboxE' widget. Text can be typed in, and +-- that text is transferred to the 'display' widget below when the button +-- is pressed. +textboxdemo :: UISF () () +textboxdemo = setLayout (makeLayout (Stretchy 150) (Fixed 100)) $ + title "Saving Text" $ topDown $ proc _ -> do + str <- leftRight $ label "Text: " >>> textboxE "" -< Nothing + b <- button "Save text to below" -< () + rec str' <- delay "" -< if b then str else str' + leftRight $ label "Saved value: " >>> displayStr -< str' + returnA -< () + +-- | This is the main demo that incorporates all of the other examples +-- together. In addition to demonstrating how +-- different widgets can connect, it also shows off the tabbing +-- behavior built in to the GUI. Pressing tab cycles through focusable +-- elements, and pressing shift-tab cycles in reverse. +main :: IO () +main = runUI (defaultUIParams {uiSize=(500, 500)}) $ + (leftRight $ (bottomUp $ timeEx >>> buttonEx) >>> (topDown $ checkboxEx) >>> radioButtonEx) >>> + (leftRight $ shoppinglist >>> colorDemo) >>> textboxdemo >>> arr id +
FRP/UISF/Examples/Pinochle.hs view
@@ -16,6 +16,7 @@ -- make sure to use "ghc --make -main-is FRP.UISF.Examples.Pinochle -O2 pinochle.hs" for best performance -- TODO: Perhaps make the "calculate meld" button disabled when it is mid-calculation +-- TODO: Change kitty size to a radio of 1-5(?) {-# LANGUAGE Arrows, BangPatterns #-} module FRP.UISF.Examples.Pinochle where @@ -58,7 +59,7 @@ deriving (Show, Eq, Enum, Ord) allSuits = [Spades, Hearts, Diamonds, Clubs] -nums = [Ace, Ten, King, Queen, Jack, Nine] +allNums = [Ace, Ten, King, Queen, Jack, Nine] type Hand = Array Card Int @@ -104,59 +105,42 @@ pinochleSF :: UISF () () pinochleSF = proc _ -> do - clearEv <- edge <<< setSize (120,22) (button "Clear hand?") -< () - spadeB <- title "Spades" $ leftRight $ concatA $ map (cardSelector . show) nums -< repeat clearEv - heartB <- title "Hearts" $ leftRight $ concatA $ map (cardSelector . show) nums -< repeat clearEv - diamondB <- title "Diamonds" $ leftRight $ concatA $ map (cardSelector . show) nums -< repeat clearEv - clubB <- title "Clubs" $ leftRight $ concatA $ map (cardSelector . show) nums -< repeat clearEv + clearEv <- edge <<< setSize (120,22) (button "Clear hand?") -< () + hand <- handSelector allSuits allNums -< clearEv trump <- leftRight $ label "Choose Trump:" >>> radio (map show allSuits) 0 >>> arr toEnum -< () - let spades = concat $ zipWith replicate spadeB nums - hearts = concat $ zipWith replicate heartB nums - diamonds = concat $ zipWith replicate diamondB nums - clubs = concat $ zipWith replicate clubB nums - hand = addToHand emptyHand $ map (Card Spades) spades ++ map (Card Hearts) hearts ++ map (Card Diamonds) diamonds ++ map (Card Clubs) clubs - (trump',hand') <- delay (Spades,emptyHand) -< (trump,hand) - rec meld <- delay [] -< if hand == hand' && trump == trump' then meld else getMeld trump hand + updateEv <- unique -< (trump,hand) + meld <- hold [] -< fmap (uncurry getMeld) updateEv --display -< shortShow hand leftRight $ label "Number of cards:" >>> setSize (40,22) display -< handLength hand leftRight $ label "Total meld =" >>> displayStr -< show (sum (map snd3 meld)) ++ ": " ++ show (map fst3 meld) - kittenSizeStr <- leftRight $ label "Kitty size =" >>> setSize (40,22) (textboxE "2") -< case (hand == hand', handLength hand) of - (False, 11) -> Just $ show 4 - (False, 15) -> Just $ show 3 + kittenSizeStr <- leftRight $ label "Kitty size =" >>> setSize (40,22) (textboxE "2") -< case (updateEv, handLength hand) of + (Just _, 11) -> Just $ show 4 + (Just _, 15) -> Just $ show 3 _ -> Nothing restr <- checkbox "Restrict trump suit?" False -< () b <- edge <<< button "Calculate meld from kitty" -< () - kre <- (asyncUISFE $ arr $ uncurry $ uncurry kittyResult) -< - fmap (const ((hand, kittenSizeStr), if restr then Just trump else Nothing)) b - k <- hold [] -< case (clearEv, kre, b) of - (Just _, _, _) -> Just [] - (Nothing, Just (r,_), _) -> Just r - (Nothing, _, Just _) -> Just ["Calculating ..."] - _ -> Nothing - displayStrList -< k - histogramWithScale (makeLayout (Stretchy 10) (Fixed 150)) -< case (clearEv, kre, b) of - (Just _, _, _) -> Just [] - (_, Just (_,m), _) -> Just $ prepHistogramData m - (_, _, Just _) -> Just [] - _ -> Nothing + kre <- (asyncUISFE $ arr kittyResult) -< + fmap (const (hand, kittenSizeStr, if restr then Just trump else Nothing)) b + let (k,d) = case (clearEv, kre, b) of + (Just _, _, _) -> (Just [], Just []) + (Nothing, Just (k,d), _) -> (Just k, Just $ prepHistogramData d) + (Nothing, _, Just _) -> (Just ["Calculating ..."], Just []) + _ -> (Nothing, Nothing) + runDynamic displayStr <<< hold [] -< k + histogramWithScale (makeLayout (Stretchy 10) (Fixed 150)) -< d returnA -< () -prepHistogramData :: Map.Map Int Int -> [(Double, String)] -prepHistogramData m = map f [0..x] where - x = maybe 0 (fst . fst) $ Map.maxViewWithKey m -- get max meld value (the max key in the map) - f i = (fromIntegral $ fromMaybe 0 $ Map.lookup i m, show i) -- return pair of count and meld value (in String form) - ------------------------------------------------------------- --------------------- Kitty calculation --------------------- ------------------------------------------------------------- -kittyResult :: Hand -> String -> Maybe Suit -> ([String], Map.Map Int Int) -kittyResult _ s _ | null (reads s :: [(Int,String)]) = (["Unable to parse kitty size"], Map.empty) -kittyResult hand s _ | handLength hand + fst (head (reads s :: [(Int,String)])) > handLength deckArray = +kittyResult :: (Hand, String, Maybe Suit) -> ([String], Map.Map Int Int) +kittyResult (_, s, _) | null (reads s :: [(Int,String)]) = (["Unable to parse kitty size"], Map.empty) +kittyResult (hand, s, _) | handLength hand + fst (head (reads s :: [(Int,String)])) > handLength deckArray = (["Kitty size + hand size > deck size"], Map.empty) -kittyResult hand s trump = (("Mean = " ++ show meanMeld ++ ", Max = " +kittyResult (hand, s, trump) = (("Mean = " ++ show meanMeld ++ ", Max = " ++ show (fst4 $ head maxMeld) ++ " with " ++ show (sum $ map thd4 maxMeld) ++ " options:"): map (\m -> show (thd4 m) ++ " of " ++ show (snd4 m) ++ " with " ++ show (fth4 m) ++ " as trump") maxMeld, meldMap) @@ -245,9 +229,17 @@ -------------------------- Widgets -------------------------- ------------------------------------------------------------- +handSelector :: [Suit] -> [Number] -> UISF (SEvent ()) Hand +handSelector [] _ = constA emptyHand +handSelector (s:ss) ns = proc ev -> do + bs <- leftRight $ title (show s) $ concatA $ map (cardSelector . show) ns -< repeat ev + hand <- handSelector ss ns -< ev + returnA -< addToHand hand (map (Card s) (concat $ zipWith replicate bs ns)) + + -- cardSelector is a widget that looks kind of like a button except that --- in its unpressed state, it shows 0, when it's pressed once, it shows --- 1, and when it's pressed twice, it shows 2. A third press resets it. +-- in its unpressed state, it shows 0; when it's pressed once, it shows +-- 1; and when it's pressed twice, it shows 2. A third press resets it. -- It takes as argument the names of the cards to select and a dynamic -- "clear" event. cardSelector :: String -> UISF (SEvent ()) Int @@ -264,14 +256,16 @@ lst = zip (map draw [(0,"0 "++str++"s"), (1, "1 "++str), (2, "2 "++str++"s")]) [0,1,2] -displayStrList :: UISF [String] () -displayStrList = proc strs -> - if null strs then returnA -< () else (arr snd <<< (displayStr *** displayStrList) -< (head strs, tail strs)) - ------------------------------------------------------------- --------------------- Helper Functions ---------------------- ------------------------------------------------------------- + +prepHistogramData :: Map.Map Int Int -> [(Double, String)] +prepHistogramData m = map f [0..x] where + x = maybe 0 (fst . fst) $ Map.maxViewWithKey m -- get max meld value (the max key in the map) + f i = (fromIntegral $ fromMaybe 0 $ Map.lookup i m, show i) -- return pair of count and meld value (in String form) + -- this only works for the ints in the list between 0 and 2 inclusive. ncr :: [(a, Int)] -> Int -> [[a]]
FRP/UISF/Examples/SevenGuis.lhs view
@@ -1,522 +1,526 @@--Last modified by: Daniel Winograd-Cort-Last modified on: 9/10/2014--This module is intended to show UISF's ability to implement the -seven GUIs listed on https://github.com/eugenkiss/7guis/wiki.--Note that this module is not exposed in UISF because it requires the -additional time and old-locale packages.--We begin my including the language pragma for arrows, as they are -integral for easily writing arrowized FRP.--> {-# LANGUAGE Arrows #-}--We declare the module name and import UISF--> module FRP.UISF.Examples.SevenGuis where-> import FRP.UISF-> import Text.Read (readMaybe) -- For Temperature Converter-> import Control.Monad (join) -- For Temperature Converter-> -> import System.Locale -- For Flight Booker-> --import Data.Time.Format.Locale -- FIXME To be used with time >= 1.5-> import Data.Time -- For Flight Booker-> import Data.Time.Clock (getCurrentTime) -- For Flight Booker-> import Data.Time.Format -- For Flight Booker-> import Data.Maybe -- For Flight Booker, Circle Draw-> -> import FRP.UISF.Widget -- For Timer, Circle Draw-> -> import Data.List (isInfixOf) -- For CRUD-> import Data.Char (toLower) -- For CRUD-> -> import FRP.UISF.SOE -- For Circle Draw-> import Data.List (delete) -- For Circle Draw-> import Control.Monad (mplus) -- For Circle Draw---------------------------------------------------------- Counter ---------------------------------------------------------The first GUI is a simple counter consisting of a button and a -displayed field indicating how many times the button as been pressed.--We'll start by creating the UISF. Note that rightLeft is used here -to set the layout ordering.--The button widget returns a stream of True or False depending on whether -the button is down or not, so we use the "edge" transformer to turn that -stream into an event stream, with unit events every time the button is -pressed and nothing otherwise.--Arrows make it easy to send data from one widget to another. In this case, -we use the rec keyword and the delay operator to create some state in our -GUI (to keep track of the count), and then feedback the v value upon itself, -updating as necessary when the button is pressed.--> counterSF :: UISF () ()-> counterSF = rightLeft $ proc _ -> do-> b <- edge <<< button "Count" -< ()-> rec v <- delay 0 -< maybe v (const $ v+1) b-> display -< v--This is the guts of the counter, and to run it, we merely need -to pass it to runUI.--> counter :: IO ()-> counter = runUI (defaultUIParams {uiSize=(250, 24), uiTitle="Counter"}) counterSF-> gui1 = counter--------------------------------------------------- Temperature Converter --------------------------------------------------The second GUI is a temperature converter that dynamically converts -between celsius and fahrenheit. This introduces text parsing and -bidirectional dataflow, the first of which is fairly easy with -standard Haskell, and the second of which is simple with arrowized -FRP.--The textboxE function takes a starting String to create a widget that -accepts an Event String as input and produces String as output. We use -the "unique" transformer to transform this output into events that only -update when a change occurs.--The first half of the program sets up the 4 widgets (two textboxes and -two labels), and the second half does the text parsing and actual -conversion (note that this half is all pure Haskell code).--Note that because we are moving data bidirectionally, we have actually -coded a recursive structure where each field defines the other. In order -to prevent infinite recursion, we must put a "delay" into the loop, and -so we do this twice, once for each textbox.--> tempCovertSF :: UISF () ()-> tempCovertSF = leftRight $ proc _ -> do-> rec c <- unique <<< textboxE "" <<< delay Nothing -< updateC-> label "degrees Celsius = " -< ()-> f <- unique <<< textboxE "" <<< delay Nothing -< updateF-> label "degrees Fahrenheit" -< ()-> let cNum = join $ fmap (readMaybe :: String -> Maybe Double) c-> fNum = join $ fmap (readMaybe :: String -> Maybe Double) f-> updateC = fmap (\f -> show $ round $ (f - 32) * (5/9)) fNum-> updateF = fmap (\c -> show $ round $ c * (9/5) + 32) cNum-> returnA -< ()->-> tempConvert = runUI (defaultUIParams {uiSize=(400, 24), uiTitle="Temp Converter"}) tempCovertSF-> gui2 = tempConvert------------------------------------------------------- Flight Booker ------------------------------------------------------For the flight booker example, we make a few modifications to the -given design. First off, UISF does not currently have a built-in -combobox widget, so we instead use a radio button widget. Second, -although it is possible to create custom text colors and backgrounds, -this is not basic behavior or UISF, so we use a slightly different -method for pointing out invalid data to the user.--One neat feature of UISF is its ability to dynamically add and remove -widgets based on user input, a feature typically not found in arrowized -FRP (or if found, more complicated and confusing then necessary). We -use this feature both to make the booking button inactive (we actually -just remove it altogether) and to point out invalid date entries. Note -that this dynamic layout structure requires the use of a delay at any -point where user data is used for layout changes.--To start, we will create a custom textbox widget that will only accept -valid dates. For invalid dates, it will add a label to the right -indicating that the entry is invalid.--> timeInputTextbox :: TimeLocale -> String -> String -> UISF () (SEvent UTCTime)-> timeInputTextbox tl format start = leftRight $ proc _ -> do-> t <- textboxE start -< Nothing-> let ret = readTimeMaybe tl format t-> case ret of-> Just _ -> returnA -< ret-> Nothing -> label "invalid!" -< Nothing-> where readTimeMaybe :: TimeLocale -> String -> String -> Maybe UTCTime-> readTimeMaybe tl format s = case readsTime tl format s of-> -- readTimeMaybe tl format s = case readSTime True tl format s of -- FIXME To be used with time >= 1.5-> [(x, "")] -> Just x-> _ -> Nothing--Note the use of the delay with the textboxE -- we need this because we -will use the value t to determine whether to insert the label or not.--Note the clever use of unique and resetText. We would like the display -box that shows the booking confirmation to reset every time the user -changes anything. To achieve this, we create an event whenever choice, -t1, or t2 change, and on those events, we set resultStr to the empty -string.--> flightBookerSF :: TimeLocale -> UTCTime -> UISF () ()-> flightBookerSF tl currentTime = proc _ -> do-> choice <- radio ["one-way flight","return flight"] 0 -< ()-> t1 <- timeInputTextbox tl format (formatTime tl format currentTime) -< ()-> t2 <- case choice of-> 1 -> timeInputTextbox tl format (formatTime tl format currentTime) -< ()-> _ -> label "" -< Nothing-> resetText <- unique -< (choice, t1, t2)-> b <- if (choice == 0 && isJust t1) || (choice == 1 && verifyGreater t1 t2)-> then do-> b' <- edge <<< button "Book" -< ()-> returnA -< if isJust resetText then Just "" else fmap (const $ outText tl format choice t1 t2) b'-> else label "" -< Just "Please change your options to make a booking"-> resultStr <- hold "" -< b-> displayStr -< resultStr-> where format ="%Y.%m.%d"-> -- outText formats the data for a booking confirmation-> outText tl format 0 (Just t1) _ = "You have booked a one-way flight on " -> ++ (formatTime tl format t1) ++ "."-> outText tl format 1 (Just t1) (Just t2) = "You have booked a return flight leaving on " -> ++ (formatTime tl format t1) ++ " and returning on " ++ (formatTime tl format t2) ++ "."-> outText _ _ _ _ _ = "ERROR!"-> -- verifyGreater makes sure both times exist and that the first is less than the second-> verifyGreater (Just t1) (Just t2) = t1 < t2-> verifyGreater _ _ = False-> -> flightBooker = getCurrentTime >>= \time -> runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Flight Booker"}) -> (flightBookerSF defaultTimeLocale time)-> gui3 = flightBooker----------------------------------------------------------- Timer ----------------------------------------------------------The timer is very straightforward with UISF even though there is no -built-in "gauge" widget. We'll start by defining one by using the -canvas' widget builder. The widget will take the pair of -(elapsed time, total duration) and draw a block of the appropriate -size. To use canvas', we supply a layout argument (stretchy in the -horizontal direction but fixed to 30 pixels in the vertical direction).--> guage :: UISF (DeltaT, DeltaT) ()-> guage = arr Just >>> canvas' (makeLayout (Stretchy 0) (Fixed 30)) draw where-> draw (x,t) (w,h) = block ((0,padding),(round $ x*(fromIntegral (w - 2*padding))/t,h-2*padding))--Next, we make a short helper function for keeping track of elapsed time. -UISF provides "getTime", which provides the number of seconds since the -GUI started; here we write getDeltaTime, which uses a simple "delay" -operator to find how much time has gone by in the most recent clock cycle.--> getDeltaTime :: UISF () DeltaT-> getDeltaTime = proc _ -> do-> t <- getTime -< ()-> pt <- delay 0 -< t-> returnA -< t - pt--With these two helpers, the program is a snap. Note once again that -since the elapsed time "e" is being used directly in the GUI's output, -we must apply a delay to it to prevent an infinite recursion.--> timerGUISF :: UISF () ()-> timerGUISF = proc _ -> do-> rec leftRight $ label "Elapsed Time:" >>> guage -< (e,d)-> display -< e-> leftRight $ label "Duration:" >>> display -< d-> d <- hSlider (0,30) 4 -< ()-> reset <- button "Reset" -< ()-> dt <- getDeltaTime -< ()-> e <- delay 0 -< case (reset, e >= d) of-> (True, _) -> 0-> (False, True) -> e-> _ -> e + dt-> returnA -< ()-> -> timerGUI = runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Timer"}) timerGUISF-> gui4 = timerGUI----------------------------------------------------------- CRUD ----------------------------------------------------------For the CRUD example, we require a database in addition to the standard -GUI tools. We'll make a simple one out of a list and a NameEntry type--> type Database a = [a]-> data NameEntry = NameEntry {firstName :: String, lastName :: String}-> -> instance Show NameEntry where-> show (NameEntry f l) = l ++ ", " ++ f-> -> instance Eq NameEntry where-> (NameEntry f1 l1) == (NameEntry f2 l2) = f1 == f2 && l1 == l2--The delete and update helper functions below take an additional -"filter function" argument. When the database is viewed with a -filter, the selected index may not match up directly with the -database. Therefore, the filtering function is supplied along with -the index.--> deleteFromDB :: (a -> Bool) -> Int -> Database a -> Database a-> deleteFromDB _ _ [] = []-> deleteFromDB f i (x:xs) = case (f x, i == 0) of-> (True, True) -> xs-> (True, False) -> x:deleteFromDB f (i-1) xs-> (False, _) -> x:deleteFromDB f i xs->-> updateDB :: (a -> Bool) -> Int -> a -> Database a -> Database a-> updateDB _ _ _ [] = []-> updateDB f i a (x:xs) = case (f x, i == 0) of-> (True, True) -> a:xs-> (True, False) -> x:updateDB f (i-1) a xs-> (False, _) -> x:updateDB f i a xs---We'll even create some default names to populate our database.--> defaultnames :: Database NameEntry-> defaultnames = [-> NameEntry "Paul" "Hudak",-> NameEntry "Dan" "Winograd-Cort",-> NameEntry "Donya" "Quick"]--The CRUD example has a much more complex layout than the previous -examples we have dealt with so far. One way to simplify it would -be to make a few different components, each of which is a combination -of widgets, and then link them together. Each component could have a -different layout, and when combined, the overall layout effect is -achieved.--Another option, which we will illustrate here, is to use banana brackets-Banana brackets allow one to apply a -transformation function to a "sub-arrow" -- here, we use them to -apply layout transformations to specific components of the GUI. -Unfortunately, banana brackets were made for arrows, not UISF, and -the variables that are defined within them are not in scope outside. -Thus, we have a somewhat ugly result, where the last line in the -brackets is a returnA of all the variables, which are then saved -outside of the brackets. It's better than if we separated everything, -in which case the banana bracketed code would not inherit its parent's -scope either, but still, it is less than ideal.--We start by asking for the filter text and then using banana brackets -to define a "leftRight" layout portion.--> crudSF :: Database NameEntry -> UISF () ()-> crudSF initnamesDB = proc _ -> do-> rec-> fStr <- leftRight $ label "Filter text: " >>> textboxE "" -< Nothing-> (i, db, fdb, nameData) <- (| leftRight (do--This leftRight portion will have a listbox on the left and then a -topDown portion on the right that will be for entering name data.--> rec i <- listbox -< (fdb, i')-> db <- delay initnamesDB -< db'-> let fdb = filter (filterFun fStr) db-> nameData <- (| topDown (do--We add two textboxes for the first name and surname strings and -then set them to update whenever one of the listbox items is selected.--> rec nameStr <- leftRight $ label "Name: " >>> textboxE "" -< nameStr'-> surnStr <- leftRight $ label "Surname: " >>> textboxE "" -< surnStr'-> iUpdate <- unique -< i-> let nameStr' = fmap (const $ firstName ((filter (filterFun fStr) db') `at` i')) iUpdate-> surnStr' = fmap (const $ lastName ((filter (filterFun fStr) db') `at` i')) iUpdate-> returnA -< NameEntry nameStr surnStr) |)-> returnA -< (i, db, fdb, nameData)) |)--Finally, we make the three buttons, which we can do all at once with -arrow combinators. Based on button presses, we update the database.--> buttons <- leftRight $ (edge <<< button "Create") &&& -> (edge <<< button "Update") &&& -> (edge <<< button "Delete") -< ()-> let (db', i') = case buttons of-> (Just _, (_, _)) -> (db ++ [nameData], length fdb)-> (Nothing, (Just _, _)) -> (updateDB (filterFun fStr) i nameData db, i)-> (Nothing, (Nothing, Just _)) -> (deleteFromDB (filterFun fStr) i db,-> if i == length fdb - 1 then length fdb - 2 else i)-> _ -> (db, i)-> returnA -< ()-> where-> filterFun str name = and (map (\s -> isInfixOf s (map toLower $ show name)) (words (map toLower str)))-> lst `at` index = if index >= length lst || index < 0 then NameEntry "" "" else lst!!index-> -> crud = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="CRUD"}) (crudSF defaultnames)-> gui5 = crud------------------------------------------------------- Circle Draw ------------------------------------------------------The drawing canvas for the circle draw example is a bit more involved than -the custom guage widget we used for the timer, and so instead of using the -canvas widget builder, we will use the more powerful mkWidget.--To start, let's write some code for circles. We'll begin with a very -simple circle type, accessors for it, and a distance function for points.--> -- type Point = (Int, Int) -- The Point class is imported from FRP.UISF.SOE-> type Radius = Double-> type Circle = (Point, Radius)-> -> getCenter :: Circle -> Point-> getCenter = fst-> -> getRadius :: Circle -> Radius-> getRadius = snd-> -> distance :: Point -> Point -> Double-> distance (x1,y1) (x2,y2) = sqrt $ fromIntegral $-> (x1 - x2)^2 + (y1 - y2)^2--We'll make one more helper function to figure out which circle should -be ``selected'', and colored gray. The arguments are the mouse position -and the list of Circles that exist, and the output is the circle to color -gray (if it exists)--> getSelectedCircle :: Point -> [Circle] -> Maybe Circle-> getSelectedCircle p = getCircle' Nothing where-> getCircle' res [] = fmap snd res-> getCircle' res (c@(cp,cr):cs) = let d = distance p cp in-> case (d<cr, isJust res) of-> (True, True) -> getCircle' (if d < fst (fromJust res) then Just (d,c) else res) cs-> (True, False) -> getCircle' (Just (d,c)) cs-> _ -> getCircle' res cs--Next, we'll make the widget for drawing the circles. -We will keep the undo/redo functionality separate from the circle canvas. -Thus, the canvas will have three properties:- - It will keep track of a list of circles to draw, updating them based - on its input stream.- - It will send output events corresponding to mouse clicks.- - It will display the circles with any that the cursor is in highlighted.--First, we'll make two little drawing functions for making filled and open -circles. UISF provides the more generic 'ellipse' and 'arc' functions, but -they can be easily adjusted for our purposes:--> filledCircle (x,y) r' = let r = round r' in ellipse (x-r,y-r) (x+r,y+r)-> openCircle (x,y) r' = let r = round r' in arc (x-r,y-r) (x+r,y+r) 0 360--Now, we have the tools to make the circle canvas--> type LeftClicks = SEvent Point-> type RightClicks = SEvent Circle-> -> circleCanvas :: UISF (SEvent [Circle]) (LeftClicks, RightClicks)-> circleCanvas = focusable $ mkWidget ([], Nothing, (0,0)) layout process draw-> where-> layout = makeLayout (Stretchy 100) (Stretchy 100)-> process inpLst (prevLst, prevFC, prevPt) _bbx evt = (clickEvts, (newLst, focusCircle, mousePt), redraw)-> where -> newLst = fromMaybe prevLst inpLst-> (clickEvts, focusCircle, mousePt, redraw) = case (evt, isJust inpLst) of-> (Button pt True True, d) -> ((Just pt, Nothing), prevFC, prevPt, d)-> (Button pt False True, d) -> ((Nothing, getSelectedCircle pt newLst), prevFC, prevPt, d)-> (MouseMove pt, d) -> let fc = getSelectedCircle pt newLst in ((Nothing, Nothing), fc, pt, prevFC /= fc || d)-> (_, d) -> ((Nothing, Nothing), getSelectedCircle prevPt newLst, prevPt, d)-> draw _ _ (cs,fc,_) = draw' cs fc-> draw' [] Nothing = nullGraphic-> draw' [] (Just (p,r)) = withColor' gray2 $ filledCircle p r-> draw' ((p,r):cs) fc = withColor Black (openCircle p r) // draw' cs fc--Lastly, we'll create the undo/redo functionality. This is all pure -Haskell code and has no UISF components.--> data Update = C Circle | Minor Circle Radius | Major Circle Radius-> type UndoList = [Update]-> type RedoList = [Update]--We assert that an UndoList and a RedoList are [Update] with the condition -that no element except the first element in the list can be a Minor Update.--> addMinor :: Circle -> Radius -> UndoList -> UndoList-> addMinor c r ((Minor _ _):lst) = Minor c r : lst-> addMinor c r lst = Minor c r : lst-> -> removeMinor :: UndoList -> UndoList-> removeMinor ((Minor _ _):lst) = lst-> removeMinor lst = lst-> -> addMajor :: Circle -> Radius -> UndoList -> UndoList-> addMajor c r ((Minor _ _):lst) = Major c r : lst-> addMajor c r lst = Major c r : lst-> -> addCircle :: Circle -> UndoList -> UndoList-> addCircle c (m@(Minor _ _):lst) = m : C c : lst-> addCircle c lst = C c : lst-> -> undoListToCircles :: UndoList -> [Circle]-> undoListToCircles [] = []-> undoListToCircles ((Minor c@(pt,_) r):lst) = (pt,r) : delete c (undoListToCircles lst)-> undoListToCircles ((Major c@(pt,_) r):lst) = (pt,r) : delete c (undoListToCircles lst)-> undoListToCircles ((C c):lst) = c : undoListToCircles lst-> -> performUndo :: UndoList -> RedoList -> (UndoList, RedoList)-> performUndo ((Minor _ _):undos) redos = (undos, redos)-> performUndo (u:undos) redos = (undos, u:redos)-> performUndo [] redos = ([], redos)-> -> performRedo :: UndoList -> RedoList -> (UndoList, RedoList)-> performRedo undos [] = (undos, [])-> performRedo undos (u:redos) = (u:undos, redos)--With both the undo/redo logic and the circle drawing canvas complete, we can -create the UISF.--> circleDrawSF :: UISF () ()-> circleDrawSF = proc _ -> do-> rec-> (undo, redo) <- leftRight $ (edge <<< button "Undo") &&& -> (edge <<< button "Redo") -< () -> updatesOld <- delay [] -< updates-> redoListOld <- delay [] -< redoList-> (leftClicks, rightClicks) <- circleCanvas -< -> if doUpdate then Just (undoListToCircles updates) else Nothing-> let (updates', redoList) = case (undo, redo, leftClicks) of-> (Just _, _, _) -> performUndo updatesOld redoListOld-> (_, Just _, _) -> performRedo updatesOld redoListOld-> (_,_,Just pt) -> (addCircle (pt, defaultRadius) updatesOld, [])-> _ -> (updatesOld, redoListOld)--In the above first half of the UISF, we create the undo and redo buttons, we -intitialize the state of the update list and the redo list, we declare the -circle canvas, and we process the undo and redo buttons.--The next portion of the UISF deals with making diameter adjustments. -GLFW does not support popup context menus, and thus UISF does not support -them either. Therefore, when a right click is detected, we will instead add -the adjustment slider as a widget to the bottom of the current frame. -The adjustment slider should only appear after a right click and before -the cancel or set buttons are pressed -- we use an 'accum' to achieve this.--> isAdjustActive <- accum False -< fmap (const . const False) majorU -> `mplus` fmap (const . const False) cancel-> `mplus` fmap (const . const True) rightClicks-> adjustC <- accum ((0,0),0) -< fmap const rightClicks-> (minorU, majorU, cancel) <- if isAdjustActive-> then do-> leftRight (label "Adjust Diameter of circle at" >>> display) -< getCenter adjustC-> newR <- hSlider (2,200) defaultRadius -< () -- fmap getRadius rightClicks-> newRU <- unique -< newR-> (setButton, cancelButton) <- leftRight $ (edge <<< button "Set") &&& -> (edge <<< button "Cancel") -< ()-> returnA -< (newRU, fmap (const newR) setButton, cancelButton)-> else returnA -< (Nothing, Nothing, Nothing)-> let updates = case (majorU, cancel, minorU) of-> (Just r, _, _) -> addMajor adjustC r updates'-> (Nothing, Just _, _) -> removeMinor updates'-> (Nothing, Nothing, Just r) -> addMinor adjustC r updates'-> _ -> updates'-> let doUpdate = isJust undo || isJust redo || isJust leftClicks-> || isJust minorU || isJust majorU || isJust cancel-> returnA -< ()-> where defaultRadius = 30-> -> circleDraw = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="Circle Draw"}) circleDrawSF-> gui6 = circleDraw-+ +Last modified by: Daniel Winograd-Cort +Last modified on: 9/10/2014 + +This module is intended to show UISF's ability to implement the +seven GUIs listed on https://github.com/eugenkiss/7guis/wiki. + +Note that this module is not exposed in UISF because it requires the +additional time and old-locale packages. + +We begin my including the language pragma for arrows, as they are +integral for easily writing arrowized FRP. + +> {-# LANGUAGE Arrows #-} + +We declare the module name and import UISF + +> module FRP.UISF.Examples.SevenGuis where +> import FRP.UISF +> import FRP.UISF.UITypes (Layout) +> import Text.Read (readMaybe) -- For Temperature Converter +> import Control.Monad (join) -- For Temperature Converter +> +> import System.Locale -- For Flight Booker +> --import Data.Time.Format.Locale -- FIXME To be used with time >= 1.5 +> import Data.Time -- For Flight Booker +> import Data.Time.Clock (getCurrentTime) -- For Flight Booker +> import Data.Time.Format -- For Flight Booker +> import Data.Maybe -- For Flight Booker, Circle Draw +> +> import FRP.UISF.Widget -- For Timer, Circle Draw +> +> import Data.List (isInfixOf) -- For CRUD +> import Data.Char (toLower) -- For CRUD +> +> import FRP.UISF.SOE -- For Circle Draw +> import Data.List (delete) -- For Circle Draw +> import Control.Monad (mplus) -- For Circle Draw + + +--------------------------------------- +--------------- Counter --------------- +--------------------------------------- + +The first GUI is a simple counter consisting of a button and a +displayed field indicating how many times the button as been pressed. + +We'll start by creating the UISF. Note that rightLeft is used here +to set the layout ordering. + +The button widget returns a stream of True or False depending on whether +the button is down or not, so we use the "edge" transformer to turn that +stream into an event stream, with unit events every time the button is +pressed and nothing otherwise. + +Arrows make it easy to send data from one widget to another. In this case, +we use the rec keyword and the delay operator to create some state in our +GUI (to keep track of the count), and then feedback the v value upon itself, +updating as necessary when the button is pressed. + +> counterSF :: UISF () () +> counterSF = rightLeft $ proc _ -> do +> b <- edge <<< button "Count" -< () +> rec v <- delay 0 -< maybe v (const $ v+1) b +> display -< v + +This is the guts of the counter, and to run it, we merely need +to pass it to runUI. + +> counter :: IO () +> counter = runUI (defaultUIParams {uiSize=(250, 24), uiTitle="Counter"}) counterSF +> gui1 = counter + + +--------------------------------------- +-------- Temperature Converter -------- +--------------------------------------- + +The second GUI is a temperature converter that dynamically converts +between Celsius and Fahrenheit. This introduces text parsing and +bidirectional dataflow, the first of which is fairly easy with +standard Haskell, and the second of which is simple with arrowized +FRP. + +The textboxE function takes a starting String to create a widget that +accepts an Event String as input and produces String as output. We use +the "unique" transformer to transform this output into events that only +update when a change occurs. + +The first half of the program sets up the 4 widgets (two textboxes and +two labels), and the second half does the text parsing and actual +conversion (note that this half is all pure Haskell code). + +Note that because we are moving data bidirectionally, we have actually +coded a recursive structure where each field defines the other. In order +to prevent infinite recursion, we must put a "delay" into the loop, and +so we do this twice, once for each textbox. + +> tempCovertSF :: UISF () () +> tempCovertSF = leftRight $ proc _ -> do +> rec c <- unique <<< textboxE "" -< updateC +> label "degrees Celsius = " -< () +> f <- unique <<< textboxE "" -< updateF +> label "degrees Fahrenheit" -< () +> let cNum = join $ fmap (readMaybe :: String -> Maybe Double) c +> fNum = join $ fmap (readMaybe :: String -> Maybe Double) f +> cNum' = if c == updateC then Nothing else cNum +> fNum' = if f == updateF then Nothing else fNum +> updateC <- delay Nothing -< fmap (\f -> show $ round $ (f - 32) * (5/9)) fNum' +> updateF <- delay Nothing -< fmap (\c -> show $ round $ c * (9/5) + 32) cNum' +> returnA -< () +> +> tempConvert = runUI (defaultUIParams {uiSize=(400, 24), uiTitle="Temp Converter"}) tempCovertSF +> gui2 = tempConvert + + +--------------------------------------- +------------ Flight Booker ------------ +--------------------------------------- + +For the flight booker example, we make a few modifications to the +given design. First off, UISF does not currently have a built-in +combobox widget, so we instead use a radio button widget. Second, +although it is possible to create custom text colors and backgrounds, +this is not basic behavior or UISF, so we use a slightly different +method for pointing out invalid data to the user. + +One neat feature of UISF is its ability to dynamically add and remove +widgets based on user input, a feature typically not found in arrowized +FRP (or if found, more complicated and confusing then necessary). We +use this feature both to make the booking button inactive (we actually +just remove it altogether) and to point out invalid date entries. Note +that this dynamic layout structure requires the use of a delay at any +point where user data is used for layout changes. + +To start, we will create a custom textbox widget that will only accept +valid dates. For invalid dates, it will add a label to the right +indicating that the entry is invalid. + +> timeInputTextbox :: TimeLocale -> String -> String -> UISF () (SEvent UTCTime) +> timeInputTextbox tl format start = leftRight $ proc _ -> do +> t <- textboxE start -< Nothing +> let ret = readTimeMaybe tl format t +> case ret of +> Just _ -> returnA -< ret +> Nothing -> label "invalid!" -< Nothing +> where readTimeMaybe :: TimeLocale -> String -> String -> Maybe UTCTime +> readTimeMaybe tl format s = case readsTime tl format s of +> -- readTimeMaybe tl format s = case readSTime True tl format s of -- FIXME To be used with time >= 1.5 +> [(x, "")] -> Just x +> _ -> Nothing + +Note the use of the delay with the textboxE -- we need this because we +will use the value t to determine whether to insert the label or not. + +Note the clever use of unique and resetText. We would like the display +box that shows the booking confirmation to reset every time the user +changes anything. To achieve this, we create an event whenever choice, +t1, or t2 change, and on those events, we set resultStr to the empty +string. + +> flightBookerSF :: TimeLocale -> UTCTime -> UISF () () +> flightBookerSF tl currentTime = proc _ -> do +> choice <- radio ["one-way flight","return flight"] 0 -< () +> t1 <- timeInputTextbox tl format (formatTime tl format currentTime) -< () +> t2 <- case choice of +> 1 -> timeInputTextbox tl format (formatTime tl format currentTime) -< () +> _ -> label "" -< Nothing +> resetText <- unique -< (choice, t1, t2) +> b <- if (choice == 0 && isJust t1) || (choice == 1 && verifyGreater t1 t2) +> then do +> b' <- edge <<< button "Book" -< () +> returnA -< if isJust resetText then Just "" else fmap (const $ outText tl format choice t1 t2) b' +> else label "" -< Just "Please change your options to make a booking" +> resultStr <- hold "" -< b +> displayStr -< resultStr +> where format ="%Y.%m.%d" +> -- outText formats the data for a booking confirmation +> outText tl format 0 (Just t1) _ = "You have booked a one-way flight on " +> ++ (formatTime tl format t1) ++ "." +> outText tl format 1 (Just t1) (Just t2) = "You have booked a return flight leaving on " +> ++ (formatTime tl format t1) ++ " and returning on " ++ (formatTime tl format t2) ++ "." +> outText _ _ _ _ _ = "ERROR!" +> -- verifyGreater makes sure both times exist and that the first is less than the second +> verifyGreater (Just t1) (Just t2) = t1 < t2 +> verifyGreater _ _ = False +> +> flightBooker = getCurrentTime >>= \time -> runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Flight Booker"}) +> (flightBookerSF defaultTimeLocale time) +> gui3 = flightBooker + + +--------------------------------------- +---------------- Timer ---------------- +--------------------------------------- + +The timer is very straightforward with UISF even though there is no +built-in "gauge" widget. We'll start by defining one by using the +canvas' widget builder. The widget will take the pair of +(elapsed time, total duration) and draw a block of the appropriate +size. To use canvas', we supply a layout argument (stretchy in the +horizontal direction but fixed to 30 pixels in the vertical direction). + +> gauge :: Layout -> UISF (DeltaT, DeltaT) () +> gauge l = unique >>> canvas' l draw where +> draw (x,t) (w,h) = block ((0,padding),(min w' $ round $ x*(fromIntegral w')/t,h-2*padding)) +> where w' = (w - 2*padding) + +Next, we make a short helper function for keeping track of elapsed time. +UISF provides "getTime", which provides the number of seconds since the +GUI started; here we write getDeltaTime, which uses a simple "delay" +operator to find how much time has gone by in the most recent clock cycle. + +> getDeltaTime :: UISF () DeltaT +> getDeltaTime = proc _ -> do +> t <- getTime -< () +> pt <- delay 0 -< t +> returnA -< t - pt + +With these two helpers, the program is a snap. Note once again that +since the elapsed time "e" is being used directly in the GUI's output, +we must apply a delay to it to prevent an infinite recursion. + +> timerGUISF :: UISF () () +> timerGUISF = proc _ -> do +> rec leftRight $ label "Elapsed Time:" >>> gauge (makeLayout (Stretchy 1) (Fixed 30)) -< (e,d) +> display -< e +> leftRight $ label "Duration:" >>> display -< d +> d <- hSlider (0,30) 4 -< () +> reset <- button "Reset" -< () +> dt <- getDeltaTime -< () +> e <- delay 0 -< case (reset, e >= d) of +> (True, _) -> 0 +> (False, True) -> e +> _ -> e + dt +> returnA -< () +> +> timerGUI = runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Timer"}) timerGUISF +> gui4 = timerGUI + + +--------------------------------------- +---------------- CRUD ---------------- +--------------------------------------- + +For the CRUD example, we require a database in addition to the standard +GUI tools. We'll make a simple one out of a list and a NameEntry type + +> type Database a = [a] +> data NameEntry = NameEntry {firstName :: String, lastName :: String} +> +> instance Show NameEntry where +> show (NameEntry f l) = l ++ ", " ++ f +> +> instance Eq NameEntry where +> (NameEntry f1 l1) == (NameEntry f2 l2) = f1 == f2 && l1 == l2 + +The delete and update helper functions below take an additional +"filter function" argument. When the database is viewed with a +filter, the selected index may not match up directly with the +database. Therefore, the filtering function is supplied along with +the index. + +> deleteFromDB :: (a -> Bool) -> Int -> Database a -> Database a +> deleteFromDB _ _ [] = [] +> deleteFromDB f i (x:xs) = case (f x, i == 0) of +> (True, True) -> xs +> (True, False) -> x:deleteFromDB f (i-1) xs +> (False, _) -> x:deleteFromDB f i xs +> +> updateDB :: (a -> Bool) -> Int -> a -> Database a -> Database a +> updateDB _ _ _ [] = [] +> updateDB f i a (x:xs) = case (f x, i == 0) of +> (True, True) -> a:xs +> (True, False) -> x:updateDB f (i-1) a xs +> (False, _) -> x:updateDB f i a xs + + +We'll even create some default names to populate our database. + +> defaultnames :: Database NameEntry +> defaultnames = [ +> NameEntry "Paul" "Hudak", +> NameEntry "Dan" "Winograd-Cort", +> NameEntry "Donya" "Quick"] + +The CRUD example has a much more complex layout than the previous +examples we have dealt with so far. One way to simplify it would +be to make a few different components, each of which is a combination +of widgets, and then link them together. Each component could have a +different layout, and when combined, the overall layout effect is +achieved. + +Another option, which we will illustrate here, is to use banana brackets +Banana brackets allow one to apply a +transformation function to a "sub-arrow" -- here, we use them to +apply layout transformations to specific components of the GUI. +Unfortunately, banana brackets were made for arrows, not UISF, and +the variables that are defined within them are not in scope outside. +Thus, we have a somewhat ugly result, where the last line in the +brackets is a returnA of all the variables, which are then saved +outside of the brackets. It's better than if we separated everything, +in which case the banana bracketed code would not inherit its parent's +scope either, but still, it is less than ideal. + +We start by asking for the filter text and then using banana brackets +to define a "leftRight" layout portion. + +> crudSF :: Database NameEntry -> UISF () () +> crudSF initnamesDB = proc _ -> do +> rec +> fStr <- leftRight $ label "Filter text: " >>> textboxE "" -< Nothing +> (i, db, fdb, nameData) <- (| leftRight (do + +This leftRight portion will have a listbox on the left and then a +topDown portion on the right that will be for entering name data. + +> rec i <- listbox -< (fdb, i') +> db <- delay initnamesDB -< db' +> let fdb = filter (filterFun fStr) db +> nameData <- (| topDown (do + +We add two textboxes for the first name and surname strings and +then set them to update whenever one of the listbox items is selected. + +> rec nameStr <- leftRight $ label "Name: " >>> textboxE "" -< nameStr' +> surnStr <- leftRight $ label "Surname: " >>> textboxE "" -< surnStr' +> iUpdate <- unique -< i +> let nameStr' = fmap (const $ firstName ((filter (filterFun fStr) db') `at` i')) iUpdate +> surnStr' = fmap (const $ lastName ((filter (filterFun fStr) db') `at` i')) iUpdate +> returnA -< NameEntry nameStr surnStr) |) +> returnA -< (i, db, fdb, nameData)) |) + +Finally, we make the three buttons, which we can do all at once with +arrow combinators. Based on button presses, we update the database. + +> buttons <- leftRight $ (edge <<< button "Create") &&& +> (edge <<< button "Update") &&& +> (edge <<< button "Delete") -< () +> let (db', i') = case buttons of +> (Just _, (_, _)) -> (db ++ [nameData], length fdb) +> (Nothing, (Just _, _)) -> (updateDB (filterFun fStr) i nameData db, i) +> (Nothing, (Nothing, Just _)) -> (deleteFromDB (filterFun fStr) i db, +> if i == length fdb - 1 then length fdb - 2 else i) +> _ -> (db, i) +> returnA -< () +> where +> filterFun str name = and (map (\s -> isInfixOf s (map toLower $ show name)) (words (map toLower str))) +> lst `at` index = if index >= length lst || index < 0 then NameEntry "" "" else lst!!index +> +> crud = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="CRUD"}) (crudSF defaultnames) +> gui5 = crud + + +--------------------------------------- +------------ Circle Draw ------------ +--------------------------------------- + +The drawing canvas for the circle draw example is a bit more involved than +the custom gauge widget we used for the timer, and so instead of using the +canvas widget builder, we will use the more powerful mkWidget. + +To start, let's write some code for circles. We'll begin with a very +simple circle type, accessors for it, and a distance function for points. + +> -- type Point = (Int, Int) -- The Point class is imported from FRP.UISF.SOE +> type Radius = Double +> type Circle = (Point, Radius) +> +> getCenter :: Circle -> Point +> getCenter = fst +> +> getRadius :: Circle -> Radius +> getRadius = snd +> +> distance :: Point -> Point -> Double +> distance (x1,y1) (x2,y2) = sqrt $ fromIntegral $ +> (x1 - x2)^2 + (y1 - y2)^2 + +We'll make one more helper function to figure out which circle should +be ``selected'', and colored gray. The arguments are the mouse position +and the list of Circles that exist, and the output is the circle to color +gray (if it exists) + +> getSelectedCircle :: Point -> [Circle] -> Maybe Circle +> getSelectedCircle p = getCircle' Nothing where +> getCircle' res [] = fmap snd res +> getCircle' res (c@(cp,cr):cs) = let d = distance p cp in +> case (d<cr, isJust res) of +> (True, True) -> getCircle' (if d < fst (fromJust res) then Just (d,c) else res) cs +> (True, False) -> getCircle' (Just (d,c)) cs +> _ -> getCircle' res cs + +Next, we'll make the widget for drawing the circles. +We will keep the undo/redo functionality separate from the circle canvas. +Thus, the canvas will have three properties: + - It will keep track of a list of circles to draw, updating them based + on its input stream. + - It will send output events corresponding to mouse clicks. + - It will display the circles with any that the cursor is in highlighted. + +First, we'll make two little drawing functions for making filled and open +circles. UISF provides the more generic 'ellipse' and 'arc' functions, but +they can be easily adjusted for our purposes: + +> filledCircle (x,y) r' = let r = round r' in ellipse (x-r,y-r) (x+r,y+r) +> openCircle (x,y) r' = let r = round r' in arc (x-r,y-r) (x+r,y+r) 0 360 + +Now, we have the tools to make the circle canvas + +> type LeftClicks = SEvent Point +> type RightClicks = SEvent Circle +> +> circleCanvas :: UISF (SEvent [Circle]) (LeftClicks, RightClicks) +> circleCanvas = focusable $ mkWidget ([], Nothing, (0,0)) layout process draw +> where +> layout = makeLayout (Stretchy 100) (Stretchy 100) +> process inpLst (prevLst, prevFC, prevPt) _bbx evt = (clickEvts, (newLst, focusCircle, mousePt), redraw) +> where +> newLst = fromMaybe prevLst inpLst +> (clickEvts, focusCircle, mousePt, redraw) = case (evt, isJust inpLst) of +> (Button pt True True, d) -> ((Just pt, Nothing), prevFC, prevPt, d) +> (Button pt False True, d) -> ((Nothing, getSelectedCircle pt newLst), prevFC, prevPt, d) +> (MouseMove pt, d) -> let fc = getSelectedCircle pt newLst in ((Nothing, Nothing), fc, pt, prevFC /= fc || d) +> (_, d) -> ((Nothing, Nothing), getSelectedCircle prevPt newLst, prevPt, d) +> draw _ _ (cs,fc,_) = draw' cs fc +> draw' [] Nothing = nullGraphic +> draw' [] (Just (p,r)) = withColor' gray2 $ filledCircle p r +> draw' ((p,r):cs) fc = withColor Black (openCircle p r) // draw' cs fc + +Lastly, we'll create the undo/redo functionality. This is all pure +Haskell code and has no UISF components. + +> data Update = C Circle | Minor Circle Radius | Major Circle Radius +> type UndoList = [Update] +> type RedoList = [Update] + +We assert that an UndoList and a RedoList are [Update] with the condition +that no element except the first element in the list can be a Minor Update. + +> addMinor :: Circle -> Radius -> UndoList -> UndoList +> addMinor c r ((Minor _ _):lst) = Minor c r : lst +> addMinor c r lst = Minor c r : lst +> +> removeMinor :: UndoList -> UndoList +> removeMinor ((Minor _ _):lst) = lst +> removeMinor lst = lst +> +> addMajor :: Circle -> Radius -> UndoList -> UndoList +> addMajor c r ((Minor _ _):lst) = Major c r : lst +> addMajor c r lst = Major c r : lst +> +> addCircle :: Circle -> UndoList -> UndoList +> addCircle c (m@(Minor _ _):lst) = m : C c : lst +> addCircle c lst = C c : lst +> +> undoListToCircles :: UndoList -> [Circle] +> undoListToCircles [] = [] +> undoListToCircles ((Minor c@(pt,_) r):lst) = (pt,r) : delete c (undoListToCircles lst) +> undoListToCircles ((Major c@(pt,_) r):lst) = (pt,r) : delete c (undoListToCircles lst) +> undoListToCircles ((C c):lst) = c : undoListToCircles lst +> +> performUndo :: UndoList -> RedoList -> (UndoList, RedoList) +> performUndo ((Minor _ _):undos) redos = (undos, redos) +> performUndo (u:undos) redos = (undos, u:redos) +> performUndo [] redos = ([], redos) +> +> performRedo :: UndoList -> RedoList -> (UndoList, RedoList) +> performRedo undos [] = (undos, []) +> performRedo undos (u:redos) = (u:undos, redos) + +With both the undo/redo logic and the circle drawing canvas complete, we can +create the UISF. + +> circleDrawSF :: UISF () () +> circleDrawSF = proc _ -> do +> rec +> (undo, redo) <- leftRight $ (edge <<< button "Undo") &&& +> (edge <<< button "Redo") -< () +> updatesOld <- delay [] -< updates +> redoListOld <- delay [] -< redoList +> (leftClicks, rightClicks) <- circleCanvas -< +> if doUpdate then Just (undoListToCircles updates) else Nothing +> let (updates', redoList) = case (undo, redo, leftClicks) of +> (Just _, _, _) -> performUndo updatesOld redoListOld +> (_, Just _, _) -> performRedo updatesOld redoListOld +> (_,_,Just pt) -> (addCircle (pt, defaultRadius) updatesOld, []) +> _ -> (updatesOld, redoListOld) + +In the above first half of the UISF, we create the undo and redo buttons, we +intitialize the state of the update list and the redo list, we declare the +circle canvas, and we process the undo and redo buttons. + +The next portion of the UISF deals with making diameter adjustments. +GLFW does not support popup context menus, and thus UISF does not support +them either. Therefore, when a right click is detected, we will instead add +the adjustment slider as a widget to the bottom of the current frame. +The adjustment slider should only appear after a right click and before +the cancel or set buttons are pressed -- we use an 'accum' to achieve this. + +> isAdjustActive <- accum False -< fmap (const . const False) majorU +> `mplus` fmap (const . const False) cancel +> `mplus` fmap (const . const True) rightClicks +> adjustC <- accum ((0,0),0) -< fmap const rightClicks +> (minorU, majorU, cancel) <- if isAdjustActive +> then do +> leftRight (label "Adjust Diameter of circle at" >>> display) -< getCenter adjustC +> newR <- hSlider (2,200) defaultRadius -< () -- fmap getRadius rightClicks +> newRU <- unique -< newR +> (setButton, cancelButton) <- leftRight $ (edge <<< button "Set") &&& +> (edge <<< button "Cancel") -< () +> returnA -< (newRU, fmap (const newR) setButton, cancelButton) +> else returnA -< (Nothing, Nothing, Nothing) +> let updates = case (majorU, cancel, minorU) of +> (Just r, _, _) -> addMajor adjustC r updates' +> (Nothing, Just _, _) -> removeMinor updates' +> (Nothing, Nothing, Just r) -> addMinor adjustC r updates' +> _ -> updates' +> let doUpdate = isJust undo || isJust redo || isJust leftClicks +> || isJust minorU || isJust majorU || isJust cancel +> returnA -< () +> where defaultRadius = 30 +> +> circleDraw = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="Circle Draw"}) circleDrawSF +> gui6 = circleDraw +
FRP/UISF/Examples/fft.hs view
@@ -13,7 +13,7 @@ {-# LANGUAGE Arrows #-} module FRP.UISF.Examples.FFT where -import FRP.UISF +import FRP.UISF hiding (delay) import Control.Arrow.Operations import Numeric.FFT (fft) import Data.Complex @@ -108,7 +108,7 @@ -- This example shows off the histogram and realtimeGraph widgets by -- summing two sin waves and displaying them. Additionally, it makes -- use of two horizontal sliders. --- This example also shows off convertToUISF and how to take a SigFun, +-- This example also shows off asyncUISFV and how to take a SigFun, -- of the type used to create sound, and convert it to a UISF. fftEx :: UISF () () fftEx = proc _ -> do @@ -116,7 +116,7 @@ _ <- leftRight (label "Freq 1: " >>> display) -< f1 f2 <- hSlider (1, 2000) 440 -< () _ <- leftRight (label "Freq 2: " >>> display) -< f2 - d <- convertToUISF sr 0.1 myAutomaton -< (f1, f2) + d <- asyncUISFV sr 0.1 myAutomaton -< (f1, f2) let fft = listToMaybe $ catMaybes $ map (snd . fst) d s = map (\((s, _), t) -> (s,t)) d _ <- histogram (makeLayout (Stretchy 10) (Fixed 150)) -< fft
FRP/UISF/SOE.hs view
@@ -285,9 +285,13 @@ GL.clear [GL.ColorBuffer, GL.StencilBuffer] translateGraphic :: (Int, Int) -> Graphic -> Graphic -translateGraphic (x, y) (Graphic g) = Graphic $ GL.preservingMatrix $ do +translateGraphic (x, y) (Graphic g) = Graphic $ do GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y) (0::GLfloat)) g + GL.translate (GL.Vector3 (fromIntegral (0-x)) (fromIntegral (0-y)) (0::GLfloat)) +--translateGraphic (x, y) (Graphic g) = Graphic $ GL.preservingMatrix $ do +-- GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y) (0::GLfloat)) +-- g overGraphic :: Graphic -> Graphic -> Graphic overGraphic (Graphic over) (Graphic base) = Graphic (base >> over)
FRP/UISF/UISF.hs view
@@ -19,7 +19,6 @@ -- * UISF Getters getTime, getCTX, getEvents, getFocusData, addTerminationProc, getMousePosition, -- * UISF constructors, transformers, and converters - -- $ctc mkUISF, -- * UISF Lifting -- $lifting
FRP/UISF/UITypes.hs view
@@ -109,7 +109,7 @@ -- * UI Layout ------------------------------------------------------------ --- $ctc The layout of a widget provides data to calculate its actual size +-- $ The layout of a widget provides data to calculate its actual size -- in a given context. -- Layout calculation makes use of lazy evaluation to do everything in one pass. -- Although the UI function maps from Context to Layout, all of the fields of @@ -229,7 +229,7 @@ ------------------------------------------------------------ --- * Graphics and System State +-- * Graphics ------------------------------------------------------------ -- | Merging two graphics can be achieved with overGraphic, but @@ -244,8 +244,14 @@ (False, False) -> overGraphic g2 g1 --- The Focus and DirtyBit types are for system state. +------------------------------------------------------------ +-- * System State +------------------------------------------------------------ +-- $ The DirtyBit and Focus types are for system state. +-- | The dirty bit is a bit to indicate if the widget needs to be redrawn. +type DirtyBit = Bool + -- | The Focus type helps focusable widgets communicate with each -- other about which widget is in focus. It consists of a WidgetID -- and a FocusInfo. @@ -269,10 +275,10 @@ | SetFocusTo WidgetID -- ^ Indicates that the widget whose id is given -- should take focus. That widget should then pass NoFocus onward. + | DenyFocus + -- ^ Any widget that sees this value should recognize that + -- they are no longer in focus. This is useful for nested focus. deriving (Show, Eq) - --- | The dirty bit is a bit to indicate if the widget needs to be redrawn. -type DirtyBit = Bool
FRP/UISF/Widget.hs view
@@ -57,7 +57,7 @@ where (minw, minh) = (length s * 8 + padding * 2, 16 + padding * 2) layout = makeLayout (Fixed minw) (Fixed minh) - draw ((x, y), (w, h)) = withColor Black $ text (x + padding, y + padding) s + draw ((x, y), (w, h)) = withColor Black $ text (x + padding, y + (h `div` 2) - 8) s ----------------- -- Display Box -- @@ -204,7 +204,7 @@ processRegular _ s b evt = (s', s', s /= s') where s' = case evt of - Button _ True down -> case (s, down) of + Button pt True down | pt `inside` b -> case (s, down) of (False, True) -> True (True, False) -> False _ -> s @@ -212,10 +212,10 @@ SKey ENTER _ down -> down Key ' ' _ down -> down _ -> s - processSticky _ s _ evt = (s', s', s /= s') + processSticky _ s b evt = (s', s', s /= s') where s' = case evt of - Button _ True True -> not s + Button pt True True | pt `inside` b -> not s SKey ENTER _ True -> not s Key ' ' _ True -> not s _ -> s @@ -693,11 +693,12 @@ (f, hasFocus') = case (focus, hasFocus, inp) of (HasFocus, _, _) -> (HasFocus, True) (SetFocusTo n, _, _) | n == myid -> (NoFocus, True) + (DenyFocus, _, _) -> (DenyFocus, False) (_, _, Button pt _ True) -> (NoFocus, pt `inside` bounds ctx) (_, True, SKey TAB _ True) -> if isShift then (SetFocusTo (myid-1), False) else (SetFocusTo (myid+1), False) (_, _, _) -> (focus, hasFocus) - focus' = if hasFocus' then HasFocus else NoFocus + focus' = if hasFocus' then HasFocus else DenyFocus inp' = if hasFocus' then (case inp of SKey TAB _ _ -> NoUIEvent _ -> inp)
UISF.cabal view
@@ -1,5 +1,5 @@ name: UISF -version: 0.3.0.1 +version: 0.3.0.2 Cabal-Version: >= 1.8 license: BSD3 license-file: License @@ -16,6 +16,7 @@ UISF is a library for making arrowized GUIs. extra-source-files: ReadMe.txt, + changelog.txt, FRP/UISF/Examples/EnableGUI.hs FRP/UISF/Examples/SevenGuis.lhs FRP/UISF/Examples/Pinochle.hs
+ changelog.txt view
@@ -0,0 +1,7 @@+changelog + +0.3.0.2 +* Added changelog +* Fixed a bug with nested focusable widgets incorrectly focusing +* Fixed some bugs in examples, also cleaned up example code to be clearer and more concise +* Fixed a bug causing translateGraphic to not nest properly