diff --git a/FRP/UISF/AuxFunctions.hs b/FRP/UISF/AuxFunctions.hs --- a/FRP/UISF/AuxFunctions.hs +++ b/FRP/UISF/AuxFunctions.hs @@ -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, diff --git a/FRP/UISF/Examples/Examples.hs b/FRP/UISF/Examples/Examples.hs --- a/FRP/UISF/Examples/Examples.hs +++ b/FRP/UISF/Examples/Examples.hs @@ -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 + diff --git a/FRP/UISF/Examples/Pinochle.hs b/FRP/UISF/Examples/Pinochle.hs --- a/FRP/UISF/Examples/Pinochle.hs +++ b/FRP/UISF/Examples/Pinochle.hs @@ -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]] diff --git a/FRP/UISF/Examples/SevenGuis.lhs b/FRP/UISF/Examples/SevenGuis.lhs --- a/FRP/UISF/Examples/SevenGuis.lhs +++ b/FRP/UISF/Examples/SevenGuis.lhs @@ -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 (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 (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 + diff --git a/FRP/UISF/Examples/fft.hs b/FRP/UISF/Examples/fft.hs --- a/FRP/UISF/Examples/fft.hs +++ b/FRP/UISF/Examples/fft.hs @@ -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 diff --git a/FRP/UISF/SOE.hs b/FRP/UISF/SOE.hs --- a/FRP/UISF/SOE.hs +++ b/FRP/UISF/SOE.hs @@ -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) diff --git a/FRP/UISF/UISF.hs b/FRP/UISF/UISF.hs --- a/FRP/UISF/UISF.hs +++ b/FRP/UISF/UISF.hs @@ -19,7 +19,6 @@ -- * UISF Getters getTime, getCTX, getEvents, getFocusData, addTerminationProc, getMousePosition, -- * UISF constructors, transformers, and converters - -- $ctc mkUISF, -- * UISF Lifting -- $lifting diff --git a/FRP/UISF/UITypes.hs b/FRP/UISF/UITypes.hs --- a/FRP/UISF/UITypes.hs +++ b/FRP/UISF/UITypes.hs @@ -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 diff --git a/FRP/UISF/Widget.hs b/FRP/UISF/Widget.hs --- a/FRP/UISF/Widget.hs +++ b/FRP/UISF/Widget.hs @@ -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) diff --git a/UISF.cabal b/UISF.cabal --- a/UISF.cabal +++ b/UISF.cabal @@ -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 diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -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