UISF 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+2226/−1396 lines, 15 filesdep ~GLFWdep ~OpenGLdep ~arrows
Dependency ranges changed: GLFW, OpenGL, arrows, deepseq, monadIO, stm
Files
- FRP/UISF.hs +4/−1
- FRP/UISF/AuxFunctions.hs +117/−50
- FRP/UISF/Examples/Crud.hs +2/−1
- FRP/UISF/Examples/Examples.hs +8/−8
- FRP/UISF/Examples/Pinochle.hs +124/−68
- FRP/UISF/Examples/SevenGuis.lhs +521/−0
- FRP/UISF/SOE.hs +19/−7
- FRP/UISF/Types/MSF.hs +35/−2
- FRP/UISF/UIMonad.hs +312/−0
- FRP/UISF/UIMonad.lhs +0/−267
- FRP/UISF/UISF.hs +320/−0
- FRP/UISF/UISF.lhs +0/−280
- FRP/UISF/Widget.hs +759/−0
- FRP/UISF/Widget.lhs +0/−708
- UISF.cabal +5/−4
FRP/UISF.hs view
@@ -4,7 +4,9 @@ , runUI' -- :: String -> UISF () () -> IO () , runUI -- :: Dimension -> String -> UISF () () -> IO () , convertToUISF -- :: NFData b => Double -> Double -> SF a b -> UISF a ([b], Bool) - , asyncUISF -- :: NFData b => Automaton a b -> UISF (SEvent a) (SEvent b) + , asyncUISF -- :: NFData b => Automaton a b -> UISF (ASyncInput a) (ASyncOutput b) + , AsyncInput (..) -- data AsyncInput a = AINoValue | AIClearBuffer | AIValue a + , AsyncOutput (..) -- data AsyncOutput b = AONoValue | AOCalculating Int | AOValue b , Dimension -- type Dimension = (Int, Int) , topDown, bottomUp, leftRight, rightLeft -- :: UISF a b -> UISF a b , setSize -- :: Dimension -> UISF a b -> UISF a b @@ -28,6 +30,7 @@ , hiSlider, viSlider -- :: Integral a => a -> (a, a) -> a -> UISF () a , realtimeGraph -- :: RealFrac a => Layout -> Time -> Color -> UISF (Time, [(a,Time)]) () , histogram -- :: RealFrac a => Layout -> UISF (Event [a]) () + , histogramWithScale -- :: RealFrac a => Layout -> UISF (SEvent [(a,String)]) () , listbox -- :: (Eq a, Show a) => UISF ([a], Int) Int , canvas -- :: Dimension -> UISF (Event Graphic) () , canvas' -- :: Layout -> (a -> Dimension -> Graphic) -> UISF (Event a) ()
FRP/UISF/AuxFunctions.hs view
@@ -1,25 +1,47 @@+----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.AuxFunctions +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental +-- +-- Auxiliary functions for use with UISF or other arrows. + {-# LANGUAGE Arrows, ScopedTypeVariables #-} module FRP.UISF.AuxFunctions ( + -- * Types SEvent, Time, DeltaT, ArrowTime, time, - constA, + -- * Useful SF Utilities (Mediators) + constA, constSF, edge, accum, unique, hold, now, mergeE, (~++), - concatA, foldA, - delay, vdelay, fdelay, + concatA, foldA, foldSF, + -- * Delays and Timers + delay, + -- | delay is a unit delay. It is exactly the delay from ArrowCircuit. + vdelay, fdelay, vdelayC, fdelayC, timer, genEvents, - BufferEvent (..), BufferControl, eventBuffer, + -- * Event buffer + BufferEvent (..), Tempo, BufferControl, eventBuffer, -- (=>>), (->>), (.|.), -- snapshot, snapshot_, + -- * Signal Function Conversions + -- $conversions + -- ** Types Automaton(..), toAutomaton, msfiToAutomaton, + -- *** Conversions + -- $conversions2 toMSF, toRealTimeMSF, - async + async, AsyncInput(..), AsyncOutput(..) ) where import Prelude @@ -45,9 +67,10 @@ -- Types -------------------------------------- --- | SEvent is short for "Stream Event" and is a type synonym for Maybe +-- | SEvent is short for \"Stream Event\" and is a type synonym for Maybe. type SEvent = Maybe +-- | Time is simply represented as a Double. type Time = Double -- | DeltaT is a type synonym referring to a change in Time. @@ -65,6 +88,10 @@ constA :: Arrow a => c -> a b c constA = arr . const +-- | constSF is a convenience +constSF :: Arrow a => b -> a b d -> a c d +constSF s sf = constA s >>> sf + -- | edge generates an event whenever the Boolean input signal changes -- from False to True -- in signal processing this is called an ``edge -- detector,'' and thus the name chosen here. @@ -117,6 +144,8 @@ rec (ds,c) <- delay ([],0) -< (take n (d:ds), c+1) returnA -< if c >= n && c `mod` k == 0 then Just ds else Nothing +-- | Combines the input list of arrows into one arrow that takes a +-- list of inputs and returns a list of outputs. concatA :: Arrow a => [a b c] -> a [b] [c] concatA [] = arr $ const [] concatA (sf:sfs) = proc (b:bs) -> do @@ -124,6 +153,9 @@ cs <- concatA sfs -< bs returnA -< (c:cs) +-- | This essentially allows an arrow that processes b to c to take +-- [b] and recursively generate cs, combining them all into a +-- final output d. foldA :: ArrowChoice a => (c -> d -> d) -> d -> a b c -> a [b] d foldA merge i sf = h where h = proc inp -> case inp of @@ -133,7 +165,17 @@ d <- h -< bs returnA -< merge c d +-- | For folding results of a list of signal functions +foldSF :: Arrow a => (b -> c -> c) -> c -> [a () b] -> a () c +foldSF f b sfs = + foldr g (constA b) sfs where + g sfa sfb = + proc () -> do + s1 <- sfa -< () + s2 <- sfb -< () + returnA -< f s1 s2 + -------------------------------------- -- Delays and Timers -------------------------------------- @@ -195,7 +237,7 @@ -- older value if necessary). Be warned that this version of delay can -- both omit some data entirely and emit the same data multiple times. -- As such, it is usually inappropriate for events (use vdelay). --- vdelayC takes a "maxDT" argument that stands for the maximum delay +-- vdelayC takes a 'maxDT' argument that stands for the maximum delay -- time that it can handle. This is to prevent a space leak. -- -- Implementation note: Rather than keep a single buffer, we keep two @@ -268,15 +310,20 @@ -- Event buffer -------------------------------------- +-- | The BufferEvent data type is used in tandem with 'BufferControl' +-- to provide the right control information to 'eventBuffer'. data BufferEvent b = - Clear -- Erase the buffer - | SkipAhead DeltaT -- Skip ahead a certain amount of time in the buffer - | AddData [(DeltaT, b)] -- Merge data into the buffer - | AddDataToEnd [(DeltaT, b)] -- Add data to the end of the buffer + Clear -- ^ Erase the buffer + | SkipAhead DeltaT -- ^ Skip ahead a certain amount of time in the buffer + | AddData [(DeltaT, b)] -- ^ Merge data into the buffer + | AddDataToEnd [(DeltaT, b)] -- ^ Add data to the end of the buffer + +-- | Tempo is just a Double. type Tempo = Double + +-- | BufferControl has a Buffer event, a bool saying whether to Play (true) or +-- Pause (false), and a tempo multiplier. type BufferControl b = (SEvent (BufferEvent b), Bool, Tempo) --- BufferControl has a Buffer event, a bool saying whether to Play (true) or --- Pause (false), and a tempo multiplier. -- | eventBuffer allows for a timed series of events to be prepared and -- emitted. The streaming input is a BufferControl, described above. @@ -350,23 +397,24 @@ -- Signal Function Conversions -------------------------------------- +-- $conversions -- Due to the internal monad (specifically, because it could be IO), MSFs are --- not necessarily pure. Thus, when we run them, we say that they run "in --- real time". This means that the time between two samples can vary and is +-- not necessarily pure. Thus, when we run them, we say that they run \"in +-- real time\". This means that the time between two samples can vary and is -- inherently unpredictable. - +-- -- However, sometimes we have a pure computation that we would like to run -- on a simulated clock. This computation will expect to produce values at -- specific intervals, and because it's pure, that expectation can sort of be -- satisfied. - +-- -- The three functions in this section are three different ways to handle --- this case. toMSF simply lifts the pure computation and ``hopes'' +-- this case. toMSF simply lifts the pure computation and \"hopes\" -- that the timing works the way you want. As expected, this is not -- recommended. async lets the pure computation compute in its own thread, -- but it puts no restrictions on speed. toRealTimeMSF takes a signal rate -- argument and attempts to mediate between real and virtual time. - +-- -- Rather than use MSF Identity as our default pure function, we present -- the Automaton type: newtype Automaton a b = Automaton (a -> (b, Automaton a b)) @@ -381,9 +429,13 @@ msfiToAutomaton (MSF msf) = Automaton $ second msfiToAutomaton . runIdentity . msf --- | The following two functions are for lifting SFs to MSFs. The first --- one is a quick and dirty solution, and the second one appropriately --- converts a simulated time SF into a real time one. +-- $conversions2 +-- The following two functions are for lifting Automatons to MSFs. The first +-- one is a quick and dirty solution, and the second one appropriately +-- converts a simulated time Automaton into a real time one. + +-- | This function should be avoided, as it directly converts the automaton +-- with no real regard for time. toMSF :: Monad m => Automaton a b -> MSF m a b toMSF (Automaton f) = MSF $ return . second toMSF . f @@ -398,11 +450,14 @@ -- Note that the returned list may be long if the clockrate is much -- faster than real time and potentially empty if it's slower. -- Note also that the caller can check the time stamp on the element --- at the end of the list to see if the inner, "simulated" signal +-- at the end of the list to see if the inner, \"simulated\" signal -- function is performing as fast as it should. toRealTimeMSF :: forall m a b . (Monad m, MonadIO m, MonadFix m, NFData b) => - Double -> DeltaT -> (ThreadId -> m ()) -> Automaton a b - -> MSF m (a, Double) [(b, Double)] + Double -- ^ Clockrate + -> DeltaT -- ^ Amount of time to buffer + -> (ThreadId -> m ()) -- ^ The thread handler + -> Automaton a b -- ^ The automaton to convert to realtime + -> MSF m (a, Time) [(b, Time)] toRealTimeMSF clockrate buffer threadHandler sf = MSF initFun where -- initFun creates some refs and threads and is never used again. @@ -435,47 +490,59 @@ worker inp out timevar t' (count+1) sf' seqLastElem s = Seq.index s (Seq.length s - 1) --- | The async function takes a pure (non-monadic) signal function and converts + +data AsyncInput a = AINoValue | AIClearBuffer | AIValue a +data AsyncOutput b = AONoValue | AOCalculating Int | AOValue b + +-- | The async function takes a pure signal function (an Automaton) and converts -- it into an asynchronous signal function usable in a MonadIO signal -- function context. The output MSF takes events of type a, feeds them to -- the asynchronously running input SF, and returns events with the output -- b whenever they are ready. The input SF is expected to run slowly -- compared to the output MSF, but it is capable of running just as fast. --- --- Might we practically want a way to "clear the buffer" if we accidentally --- queue up too many async inputs? --- Perhaps the output should be something like: --- data AsyncOutput b = None | Calculating Int | Value b --- where the Int is the size of the buffer. Similarly, we could have --- data AsyncInput a = None | ClearBuffer | Value a +-- The input stream is a value, an option to clear any buffered values, or +-- nothing, and the output stream is either a result value, a AOCalculating +-- indicating that the asynchronous function is calculating and giving the +-- buffer size, or nothing. async :: forall m a b. (Monad m, MonadIO m, MonadFix m, NFData b) => - (ThreadId -> m ()) -> Automaton a b -> MSF m (SEvent a) (SEvent b) -async threadHandler sf = delay Nothing >>> MSF initFun + (ThreadId -> m ()) -- ^ The thread handler + -> Automaton a b -- ^ The automaton to convert to asynchronize + -> MSF m (AsyncInput a) (AsyncOutput b) +async threadHandler sf = delay AINoValue >>> MSF initFun where -- initFun creates some refs and threads and is never used again. -- All future processing is done in sfFun and the spawned worker thread. - initFun :: (SEvent a) -> m ((SEvent b), MSF m (SEvent a) (SEvent b)) + initFun :: (AsyncInput a) -> m ((AsyncOutput b), MSF m (AsyncInput a) (AsyncOutput b)) initFun ea = do - inp <- newChan + inp <- newIORef empty out <- newIORef empty - tid <- liftIO $ forkIO $ worker inp out sf + proceed <- newEmptyMVar + tid <- liftIO $ forkIO $ worker proceed inp out sf threadHandler tid - sfFun inp out ea + sfFun 0 proceed inp out ea -- sfFun communicates with the worker thread, sending it the input values -- and collecting from it the output values. - sfFun :: Chan a -> IORef (Seq b) - -> (SEvent a) -> m ((SEvent b), MSF m (SEvent a) (SEvent b)) - sfFun inp out ea = do - maybe (return ()) (writeChan inp) ea -- send the worker the new input + sfFun :: Int -> MVar () -> IORef (Seq a) -> IORef (Seq b) + -> (AsyncInput a) -> m ((AsyncOutput b), MSF m (AsyncInput a) (AsyncOutput b)) + sfFun count proceed inp out ea = do + count' <- case ea of + AIValue a -> atomicModifyIORef inp (\is -> (is |> a, ())) >> tryPutMVar proceed () >> return (count+1) + AIClearBuffer -> atomicModifyIORef inp (\_ -> (empty, ())) >> tryTakeMVar proceed >> return 0 + AINoValue -> return count b <- atomicModifyIORef out seqRestHead -- collect any ready results - return (b, MSF (sfFun inp out)) + let (b', count'') = maybe (Nothing, count') (\x -> (Just x, count'-1)) b + b'' = maybe (if count'' <= 0 then AONoValue else AOCalculating count'') AOValue b' + return (b'', MSF (sfFun count'' proceed inp out)) -- worker processes the inner, "simulated" signal function. - worker :: Chan a -> IORef (Seq b) -> Automaton a b -> IO () - worker inp out (Automaton sf) = do - a <- readChan inp -- get the latest input (or block if unavailable) - let (b, sf') = sf a -- do the calculation - deepseq b $ atomicModifyIORef out (\s -> (s |> b, ())) - worker inp out sf' + worker :: MVar () -> IORef (Seq a) -> IORef (Seq b) -> Automaton a b -> IO () + worker proceed inp out (Automaton sf) = do + ea <- atomicModifyIORef inp seqRestHead + case ea of + Nothing -> takeMVar proceed >> worker proceed inp out (Automaton sf) + Just a -> do + let (b, sf') = sf a -- do the calculation + deepseq b $ atomicModifyIORef out (\s -> (s |> b, ())) + worker proceed inp out sf' seqRestHead s = case viewl s of EmptyL -> (s, Nothing) a :< s' -> (s', Just a)
FRP/UISF/Examples/Crud.hs view
@@ -12,7 +12,7 @@ -- Here we use UISF to create a similar example using arrowized FRP. -{-# LANGUAGE Arrows, DoRec #-} +{-# LANGUAGE Arrows, RecursiveDo #-} module FRP.UISF.Examples.Crud where import FRP.UISF @@ -42,6 +42,7 @@ -- | This function will run the crud GUI with the default names. crud = runUI (350, 400) "CRUD" (crudUISF defaultnames) +-- | main = crud main = crud -- | This is the main function that creates the crud GUI. It takes an
FRP/UISF/Examples/Examples.hs view
@@ -14,11 +14,11 @@ import Numeric (showHex) import Data.Maybe (listToMaybe, catMaybes) --- This example displays the time from the start of the GUI application.+-- | This example displays the time from the start of the GUI application. timeEx :: UISF () () timeEx = title "Time" $ getTime >>> display --- This example shows off buttons and state by presenting a plus and +-- | This example shows off buttons and state by presenting a plus and -- minus button with a counter that is adjusted by them. buttonEx :: UISF () () buttonEx = title "Buttons" $ proc _ -> do@@ -32,7 +32,7 @@ _ -> v) display -< v --- This example shows off the checkbox widgets.+-- | This example shows off the checkbox widgets. checkboxEx :: UISF () () checkboxEx = title "Checkboxes" $ proc _ -> do x <- checkbox "Monday" False -< ()@@ -44,20 +44,20 @@ bin True = "1" bin False = "0" --- This example shows off the radio button widget.+-- | This example shows off the radio button widget. radioButtonEx :: UISF () () radioButtonEx = title "Radio Buttons" $ radio list 0 >>> arr (list!!) >>> displayStr where list = ["apple", "orange", "banana"] --- This example shows off integral sliders (horizontal in the case).+-- | This example shows off integral sliders (horizontal in the case). shoppinglist :: UISF () () shoppinglist = title "Shopping List" $ 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 +-- | 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.@@ -78,7 +78,7 @@ 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 textbox widget. Text can be typed in, and +-- | This example shows off the textbox widget. Text can be typed in, and -- that text is transferred to the display widget below when the button -- is pressed. textboxdemo :: UISF () ()@@ -89,7 +89,7 @@ leftRight $ label "Saved value: " >>> displayStr -< str' returnA -< () --- This is the main demo that incorporates all of the other examples +-- | This is the main demo that incorporates all of the other examples -- together (except for fftEx). 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
FRP/UISF/Examples/Pinochle.hs view
@@ -1,6 +1,6 @@ -- Author: Daniel Winograd-Cort -- Date Created: unknown --- Date Last Modified: 12/12/2013 +-- Date Last Modified: 7/15/2014 -- This is a pinochle assistant. The user enters his hand at the GUI -- and selects his preferred trump suit, and his meld is displayed. @@ -13,20 +13,27 @@ -- This module requires the array package. --- make sure to use "ghc --make -O2 pinochle.hs" for pest performance +-- make sure to use "ghc --make -main-is FRP.UISF.Examples.Pinochle -O2 pinochle.hs" for best performance {-# LANGUAGE Arrows, BangPatterns #-} module FRP.UISF.Examples.Pinochle where import FRP.UISF hiding (accum) +-- We make our own special type of button for inputting hand information, +-- so we import a few things directly from Widget and SOE. +import FRP.UISF.Widget (cyclebox', padding, (//), whenG, box, marked, pushed, popped) +import FRP.UISF.SOE (text, withColor) + import Data.List (delete, foldl', group) import GHC.Arr (Ix(..), indexError) -import Data.Array +import Data.Array hiding ((//)) import Data.List (transpose) - - -main = runUI (800,600) "Pinochole Assistant" pinochleSF +import Data.Maybe (fromMaybe) +import qualified Data.Map.Strict as Map +------------------------------------------------------------- +---------------------- Cards and Hands ---------------------- +------------------------------------------------------------- data Card = Card Suit Number deriving (Eq, Ord) @@ -49,8 +56,7 @@ deriving (Show, Eq, Enum, Ord) allSuits = [Spades, Hearts, Diamonds, Clubs] ---nums = [Nine, Nine, Jack, Jack, Queen, Queen, King, King, Ten, Ten, Ace, Ace] -nums = [Ace, Ace, Ten, Ten, King, King, Queen, Queen, Jack, Jack, Nine, Nine] +nums = [Ace, Ten, King, Queen, Jack, Nine] type Hand = Array Card Int @@ -87,43 +93,75 @@ shortShow = show . map shortShow +------------------------------------------------------------- +--------------------------- Main ---------------------------- +------------------------------------------------------------- + +-- The main running function +main = runUI (800,700) "Pinochole Assistant" pinochleSF + pinochleSF :: UISF () () pinochleSF = proc _ -> do - spadeB <- title "Spades" $ leftRight $ mapA $ map (stickyButton . show) nums -< repeat () - heartB <- title "Hearts" $ leftRight $ mapA $ map (stickyButton . show) nums -< repeat () - diamondB <- title "Diamonds" $ leftRight $ mapA $ map (stickyButton . show) nums -< repeat () - clubB <- title "Clubs" $ leftRight $ mapA $ map (stickyButton . show) nums -< repeat () + 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 trump <- leftRight $ label "Choose Trump:" >>> radio (map show allSuits) 0 >>> arr toEnum -< () - let spades = [n | (b,n) <- zip spadeB nums, b] - hearts = [n | (b,n) <- zip heartB nums, b] - diamonds = [n | (b,n) <- zip diamondB nums, b] - clubs = [n | (b,n) <- zip clubB nums, b] + 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 --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 "0") -< case (hand == hand', handLength hand) of + 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 _ -> Nothing restr <- checkbox "Restrict trump suit?" False -< () b <- edge <<< button "Calculate meld from kitty" -< () - --let kre = Nothing - kre <- (asyncUISF $ toAutomaton $ uncurry $ uncurry kittyResult) -< + kre <- (asyncUISF $ toAutomaton $ uncurry $ uncurry kittyResult) -< toAsyncInput $ fmap (const ((hand, kittenSizeStr), if restr then Just trump else Nothing)) b - k <- hold [] -< maybe (fmap (const ["Calculating ..."]) b) Just kre + k <- hold [] -< case (clearEv, kre) of + (Just _, _) -> Just [] + (Nothing, AOValue (r,_)) -> Just r + (Nothing, AOCalculating _) -> Just ["Calculating ..."] + _ -> Nothing displayStrList -< k + histogramWithScale (makeLayout (Stretchy 10) (Fixed 150)) -< case (clearEv, kre) of + (Just _, _) -> Just [] + (_, AOValue (_,m)) -> Just $ prepHistogramData m + (_, AOCalculating _) -> Just [] + _ -> Nothing returnA -< () -kittyResult :: Hand -> String -> Maybe Suit -> [String] -kittyResult _ s _ | null (reads s :: [(Int,String)]) = ["Unable to parse kitty size"] +toAsyncInput :: SEvent a -> AsyncInput a +toAsyncInput (Just a) = AIValue a +toAsyncInput Nothing = AINoValue + + +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 = - ["Kitty size + hand size > deck size"] -kittyResult hand s trump = ("Mean = " ++ show meanMeld ++ ", Max = " + (["Kitty size + hand size > deck size"], Map.empty) +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 + map (\m -> show (thd4 m) ++ " of " ++ show (snd4 m) ++ " with " ++ show (fth4 m) ++ " as trump") maxMeld, + meldMap) where kittySize = fst (head (reads s :: [(Int,String)])) restOfDeck = complementHand hand @@ -133,46 +171,22 @@ allMelds = maybe allMelds' getSuitMelds trump allMelds' = concatMap (fst . meldStats) $ transpose $ map getSuitMelds [Spades, Hearts, Diamonds, Clubs] -- meldStats returns the pair (list of all best melds, (sum of all melds, count of all melds)) - meldStats = foldl' (\(a@((v,_,_,_):_),(s,c)) b@(v2,_,r,_) -> seq s $ seq c ((case compare v v2 of + meldStats = foldl' (\(a@((v,_,_,_):_),c) b@(v2,_,r,_) -> ((case compare v v2 of LT -> [b] EQ -> b:a - GT -> a),(s+r*v2,c+r))) ([(-1,[],0,Spades)], (0,0)) - (maxMeld, meanMeld) = let (m,(s,c)) = meldStats allMelds in (m, fromIntegral s / fromIntegral c) - --stddevMeld = stddev . map (fromIntegral . fst) . expand + GT -> a),Map.alter (maybe (Just r) (Just . (+ r))) v2 c)) ([(-1,[],0,Spades)], Map.empty) + (maxMeld, meldMap) = meldStats allMelds + meanMeld = let (s,c) = Map.foldrWithKey' (\v c' (s,c) -> (s+c'*v,c+c')) (0,0) meldMap in fromIntegral s / fromIntegral c calc suit h (k,n) = (sum $ map snd3 $ getMeld suit (addToHand h k),k,n,suit) - expand :: [(Int, [Card], Int)] -> [(Int, [Card])] - expand [] = [] - expand ((v,c,r):lst) = replicate r (v,c) ++ expand lst possibleKitties :: Int -> Hand -> [([Card],Int)] possibleKitties i hand = map (head &&& length) $ group $ ncr (assocs hand) i --- this only works for the ints in the list between 0 and 2 inclusive. -ncr :: [(a, Int)] -> Int -> [[a]] -ncr _ r | r < 0 = error "Zero or more elements should be extracted." -ncr _ 0 = [[]] -ncr [] _ = [] -ncr ((x,0):xs) r = ncr xs r -ncr ((x,1):xs) r = map (x:) (ncr xs (r-1)) ++ ncr xs r -ncr ((x,2):xs) 1 = [[x],[x]] ++ ncr xs 1 -ncr ((x,2):xs) r = map ([x,x]++) (ncr xs (r-2)) ++ concatMap (\l -> [x:l,x:l]) (ncr xs (r-1)) ++ ncr xs r -mean :: Floating a => [a] -> a -mean x = fst $ foldl' (\(!m, !n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x - --- |Standard deviation of sample -stddev :: (Floating a) => [a] -> a -stddev xs = sqrt $ var xs - --- |Sample variance -var xs = var' 0 0 0 xs / fromIntegral (length xs - 1) - where - var' _ _ s [] = s - var' m n s (x:xs) = var' nm (n + 1) (s + delta * (x - nm)) xs - where - delta = x - m - nm = m + delta/fromIntegral (n + 1) +------------------------------------------------------------- +--------------------- Meld calculation ---------------------- +------------------------------------------------------------- -- | Takes a hand and a set of meld data to potentially return meld. -- The meld data is a list of meld names, a list of meld points, and @@ -228,19 +242,65 @@ (["Pinochle","Double Pinochle"], [4,30], [Card Diamonds Jack, Card Spades Queen]), (["9 of Trump","2x9s of Trump"], [1,2], [Card trump Nine])] - - +------------------------------------------------------------- +-------------------------- Widgets -------------------------- +------------------------------------------------------------- +-- 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. +-- It takes as argument the names of the cards to select and a dynamic +-- "clear" event. +cardSelector :: String -> UISF (SEvent ()) Int +cardSelector str = arr (fmap (const 0)) >>> cyclebox' d lst 0 where + (tw, th) = (8 * (length str + 3), 16) + (minw, minh) = (tw + padding * 2, th + padding * 2) + d = makeLayout (Stretchy minw) (Fixed minh) + draw (i, s) b@((x,y), (w,h)) inFocus = + let x' = x + (w - tw) `div` 2 + if i>0 then 0 else -1 + y' = y + (h - th) `div` 2 + if i>0 then 0 else -1 + in withColor Black (text (x', y') s) + // whenG inFocus (box marked b) + // box (if i>0 then pushed else popped) b + lst = zip (map draw [(0,"0 "++str++"s"), (1, "1 "++str), (2, "2 "++str++"s")]) [0,1,2] -mapA :: Arrow a => [a b c] -> a [b] [c] -mapA [] = arr $ const [] -mapA (sf:sfs) = proc (b:bs) -> do - c <- sf -< b - cs <- mapA sfs -< bs - returnA -< (c:cs) +displayStrList :: UISF [String] () +displayStrList = proc strs -> + if null strs then returnA -< () else (arr snd <<< (displayStr *** displayStrList) -< (head strs, tail strs)) + +------------------------------------------------------------- +--------------------- Helper Functions ---------------------- +------------------------------------------------------------- + +-- this only works for the ints in the list between 0 and 2 inclusive. +ncr :: [(a, Int)] -> Int -> [[a]] +ncr _ r | r < 0 = error "Zero or more elements should be extracted." +ncr _ 0 = [[]] +ncr [] _ = [] +ncr ((x,0):xs) r = ncr xs r +ncr ((x,1):xs) r = map (x:) (ncr xs (r-1)) ++ ncr xs r +ncr ((x,2):xs) 1 = [[x],[x]] ++ ncr xs 1 +ncr ((x,2):xs) r = map ([x,x]++) (ncr xs (r-2)) ++ concatMap (\l -> [x:l,x:l]) (ncr xs (r-1)) ++ ncr xs r + +mean :: Floating a => [a] -> a +mean x = fst $ foldl' (\(!m, !n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x + +-- Standard deviation of sample +stddev :: (Floating a) => [a] -> a +stddev xs = sqrt $ var xs + +-- Sample variance +var xs = var' 0 0 0 xs / fromIntegral (length xs - 1) + where + var' _ _ s [] = s + var' m n s (x:xs) = var' nm (n + 1) (s + delta * (x - nm)) xs + where + delta = x - m + nm = m + delta/fromIntegral (n + 1) + fst3 (a,b,c) = a snd3 (a,b,c) = b thd3 (a,b,c) = c @@ -250,9 +310,5 @@ thd4 (a,b,c,d) = c fth4 (a,b,c,d) = d - -displayStrList :: UISF [String] () -displayStrList = proc strs -> - if null strs then returnA -< () else (arr snd <<< (displayStr *** displayStrList) -< (head strs, tail strs))
+ FRP/UISF/Examples/SevenGuis.lhs view
@@ -0,0 +1,521 @@++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 (250,24) "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 (400,24) "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 <- delay "" <<< 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 <- delay 0 <<< 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 (800,200) "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 (800,200) "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 (450, 400) "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) <- delay (Nothing, Nothing) <<< 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 -< ()+> 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 rightClicks +> || isJust minorU || isJust majorU || isJust cancel+> returnA -< ()+> where defaultRadius = 30+> +> circleDraw = runUI (450, 400) "Circle Draw" circleDrawSF+> gui6 = circleDraw+
FRP/UISF/SOE.hs view
@@ -1,4 +1,5 @@ module FRP.UISF.SOE ( + -- * Window Functions runGraphics, Title, Size, @@ -13,6 +14,7 @@ setDirty, closeWindow, openWindowEx, + -- * Drawing Functions RedrawMode, drawGraphic, drawBufferedGraphic, @@ -52,9 +54,11 @@ -- getKey, -- See note at definition for why these are left out -- getLBP, -- getRBP, + -- * Event Handling Functions Key(..), SpecialKey (..), UIEvent (..), + hasShiftModifier, hasCtrlModifier, hasAltModifier, maybeGetWindowEvent, getWindowEvent, Word32, @@ -108,11 +112,11 @@ type Size = (Int, Int) data Window = Window { - graphicVar :: MVar (Graphic, Bool), -- boolean to remember if it's dirty + graphicVar :: MVar (Graphic, Bool), -- ^ boolean to remember if it's dirty eventsChan :: TChan UIEvent } --- Graphic is just a wrapper for OpenGL IO +-- | Graphic is just a wrapper for OpenGL IO newtype Graphic = Graphic (IO ()) initialized, opened :: MVar Bool @@ -209,7 +213,7 @@ modifyMVar_ (graphicVar win) (\ (g, _) -> return (overGraphic graphic g, True)) --- if window is marked as dirty, mark it clean, draw and swap buffer; +-- | if window is marked as dirty, mark it clean, draw and swap buffer; -- otherwise do nothing. updateWindowIfDirty :: Window -> IO () updateWindowIfDirty win = do @@ -222,7 +226,7 @@ drawInWindow win graphic updateWindowIfDirty win --- setGraphic set the given Graphic over empty (black) background for +-- | setGraphic set the given Graphic over empty (black) background for -- display in current Window. setGraphic :: Window -> Graphic -> IO () setGraphic win graphic = @@ -551,7 +555,15 @@ | NoUIEvent deriving Show +hasShiftModifier :: ([Char],[SpecialKey]) -> Bool +hasShiftModifier (_, sks) = elem LSHIFT sks || elem RSHIFT sks +hasCtrlModifier :: ([Char],[SpecialKey]) -> Bool +hasCtrlModifier (_, sks) = elem LCTRL sks || elem RCTRL sks + +hasAltModifier :: ([Char],[SpecialKey]) -> Bool +hasAltModifier (_, sks) = elem LALT sks || elem RALT sks + -- | getWindowEvent and maybeGetWindowEvent both take an additional argument -- sleepTime that tells how long to sleep in the case where there are no -- window events to return. This is used to allow the cpu to take other @@ -601,7 +613,7 @@ Just e -> atomically (unGetTChan ch e) >> return prev --- | getKeyEx, getKey, getButton, getLBP, and getRBP are defined here but +-- getKeyEx, getKey, getButton, getLBP, and getRBP are defined here but -- never used in Euterpea. Furthermore, due to the change in getWindowEvent -- so that it now requires a sleepTime argument (previously fixed at 0.01), -- they either need to be parameterized over sleepTime or set. I'm not @@ -639,14 +651,14 @@ getRBP w = getButton w 2 True -} --- use GLFW's high resolution timer +-- | use GLFW's high resolution timer timeGetTime :: IO Double timeGetTime = GL.get GLFW.time word32ToInt :: Word32 -> Int word32ToInt = fromIntegral --- Designed to be used with Key, CharKey, or SpecialKey +-- | Designed to be used with Key, CharKey, or SpecialKey isKeyPressed :: Enum a => a -> IO Bool isKeyPressed k = do kbs <- GLFW.getKey k
FRP/UISF/Types/MSF.hs view
@@ -1,5 +1,16 @@-{-# LANGUAGE CPP, DoRec, FlexibleInstances, MultiParamTypeClasses, OverlappingInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.Types.MSF +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental +-- +-- MSF is a monadic signal function. +{-# LANGUAGE CPP, RecursiveDo, FlexibleInstances, MultiParamTypeClasses, OverlappingInstances #-} + module FRP.UISF.Types.MSF where #if __GLASGOW_HASKELL__ >= 610 @@ -10,7 +21,9 @@ import Control.Arrow.Operations import Control.Monad.Fix - +-- | The MSF data type describes a monadic signal function. +-- Essentially, it is a Kleisli automaton, but we define it +-- explicitly here. data MSF m a b = MSF { msfFun :: (a -> m (b, MSF m a b)) } @@ -87,7 +100,10 @@ instance MonadFix m => ArrowCircuit (MSF m) where delay i = MSF (h i) where h i x = return (i, MSF (h x)) +-- * MSF Constructors +-- $ The source, sink, and pipe functions allow one to lift a monadic +-- action to the MSF data type. source :: Monad m => m c -> MSF m () c sink :: Monad m => (b -> m ()) -> MSF m b () pipe :: Monad m => (b -> m c) -> MSF m b c @@ -95,6 +111,8 @@ sink f = MSF h where h x = f x >> return ((), MSF h) pipe f = MSF h where h x = f x >>= return . (\x -> (x, MSF h)) +-- $ The sourceE, sinkE, and pipeE functions allow one to lift a monadic +-- action to the MSF data type in event form. sourceE :: Monad m => m c -> MSF m (Maybe ()) (Maybe c) sinkE :: Monad m => (b -> m ()) -> MSF m (Maybe b) (Maybe ()) pipeE :: Monad m => (b -> m c) -> MSF m (Maybe b) (Maybe c) @@ -102,14 +120,21 @@ sinkE f = MSF h where h = maybe (return (Nothing, MSF h)) (\b -> f b >> return (Just (), MSF h)) pipeE f = MSF h where h = maybe (return (Nothing, MSF h)) (\b -> f b >>= return . (\c -> (Just c, MSF h))) +-- | This function first performs a monadic action and then uses the +-- result of that action to complete the MSF. initialAction :: Monad m => m x -> (x -> MSF m a b) -> MSF m a b initialAction mx f = MSF $ \a -> do x <- mx msfFun (f x) a +-- | This function creates a MSF source based on an infinite list. listSource :: Monad m => [c] -> MSF m () c listSource cs = MSF (h cs) where h (c:cs) _ = return (c, MSF (h cs)) +-- * Running MSF + +-- | This steps through the given MSF using the [a] as inputs. +-- The result is [b] in the monad. stepMSF :: Monad m => MSF m a b -> [a] -> m [b] stepMSF _ [] = return [] stepMSF (MSF f) (x:xs) = do @@ -117,6 +142,8 @@ ys <- stepMSF f' xs return (y:ys) +-- | This is the same as 'stepMSF' but additionally returns the +-- next computation. stepMSF' :: Monad m => MSF m a b -> [a] -> m ([b], MSF m a b) stepMSF' g [] = return ([], g) stepMSF' (MSF f) (x:xs) = do @@ -124,14 +151,20 @@ (ys, g) <- stepMSF' f' xs return (y:ys, g) +-- | The stream data type is used to \"stream\" the results of +-- running an MSF. data Stream m b = Stream { stream :: m (b, Stream m b) } +-- | Given an input list of values, this produces a stream of +-- results that can be unwound as necessary. streamMSF :: Monad m => MSF m a b -> [a] -> Stream m b streamMSF (MSF f) (x:xs) = Stream $ do (y, f') <- f x return (y, streamMSF f' xs) +-- | This function runs the MSF on a single value. runMSF :: Monad m => a -> MSF m a b -> m b runMSF a f = run f where run (MSF f) = do f a >>= run . snd +-- | This function runs an MSF that takes unit input for a single value. runMSF' :: Monad m => MSF m () b -> m b runMSF' = runMSF ()
+ FRP/UISF/UIMonad.hs view
@@ -0,0 +1,312 @@+----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.UIMonad +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental +-- +-- A simple Graphical User Interface with concepts borrowed from Phooey +-- by Conal Elliot. + +{-# LANGUAGE RecursiveDo #-} + +module FRP.UISF.UIMonad where + +import FRP.UISF.SOE +import FRP.UISF.AuxFunctions (Time) + +import Control.Applicative +import Control.Monad (ap) +import Control.Monad.Fix +import Control.Concurrent.MonadIO + + +------------------------------------------------------------ +-- * UI Type Definition +------------------------------------------------------------ + +-- | A UI widget runs under a given context and any focus information from +-- earlier widgets and maps input signals to outputs, which consists of 6 parts: +-- +-- - its layout, +-- +-- - whether the widget needs to be redrawn, +-- +-- - any focus information that needs to be conveyed to future widgets +-- +-- - the action (to render graphics or/and sounds), +-- +-- - any new ThreadIds to keep track of (for proper shutdown when finished), +-- +-- - and the parametrized output type. + +newtype UI a = UI + { unUI :: (CTX, Focus, Time, UIEvent) -> + IO (Layout, DirtyBit, Focus, Action, ControlData, a) } + +-- For reexporting: +-- | Lifts an \'IO a\' to a \'UI a\' +ioToUI :: IO a -> UI a +ioToUI = liftIO + +------------------------------------------------------------ +-- * Control Data +------------------------------------------------------------ + +-- | The control data is simply a list of Thread Ids. +type ControlData = [ThreadId] + +-- | No new thread ids. +nullCD :: ControlData +nullCD = [] + +-- | A thread handler for the UI monad. +addThreadID :: ThreadId -> UI () +addThreadID t = UI (\(_,f,_,_) -> return (nullLayout, False, f, nullAction, [t], ())) + +-- | A method for merging to control data objects. +mergeCD :: ControlData -> ControlData -> ControlData +mergeCD = (++) + + +------------------------------------------------------------ +-- * Rendering Context +------------------------------------------------------------ + +-- | A rendering context specifies the following: + +data CTX = CTX + { flow :: Flow + -- ^ A layout direction to flow widgets. + + , bounds :: Rect + -- ^ A rectangle bound of current drawing area to render a UI + -- component. It specifies the max size of a widget, not the + -- actual size. It's up to each individual widget to decide + -- where in this bound to put itself. + + , isConjoined :: Bool + -- ^ A flag to tell whether we are in a conjoined state or not. + -- A conjoined context will duplicate itself for subcomponents + -- rather than splitting. This can be useful for making compound + -- widgets when one widget takes up space and the other performs + -- some side effect having to do with that space. + } + +-- | Flow determines widget ordering. +data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show) +-- | A dimension specifies size. +type Dimension = (Int, Int) +-- | A rectangle has a corner point and a dimension. +type Rect = (Point, Dimension) + + +------------------------------------------------------------ +-- * UI Layout +------------------------------------------------------------ + +-- $ctc 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 +-- Layout must be independent of the Context so that they are avaiable before +-- the UI function is even evaluated. + +-- | Layouts for individual widgets typically come in a few standard flavors, +-- so we have this convenience function for their creation. +-- This function takes layout information for first the horizontal +-- dimension and then the vertical. +makeLayout :: LayoutType -> -- ^ Horizontal Layout information + LayoutType -> -- ^ Vertical Layout information + Layout +makeLayout (Fixed h) (Fixed v) = Layout 0 0 h v h v +makeLayout (Stretchy minW) (Fixed v) = Layout 1 0 0 v minW v +makeLayout (Fixed h) (Stretchy minH) = Layout 0 1 h 0 h minH +makeLayout (Stretchy minW) (Stretchy minH) = Layout 1 1 0 0 minW minH + +-- | A dimension can either be: +data LayoutType = + Stretchy { minSize :: Int } + -- ^ Stretchy with a minimum size in pixels + | Fixed { fixedSize :: Int } + -- ^ Fixed with a size measured in pixels + +-- | The null layout is useful for \"widgets\" that do not appear or +-- take up space on the screen. +nullLayout = Layout 0 0 0 0 0 0 + + +-- | More complicated layouts can be manually constructed with direct +-- access to the Layout data type. +-- +-- 1. hFill and vFill specify how much stretching space (in comparative +-- units) in the horizontal and vertical directions should be +-- allocated for this widget. +-- +-- 2. hFixed and vFixed specify how much non-stretching space (in pixels) +-- of width and height should be allocated for this widget. +-- +-- 3. minW and minH specify minimum values (in pixels) of width and height +-- for the widget's dimensions. + +data Layout = Layout + { hFill :: Int + , vFill :: Int + , hFixed :: Int + , vFixed :: Int + , minW :: Int + , minH :: Int + } deriving (Eq, Show) + + + +------------------------------------------------------------ +-- * Context and Layout Functions +------------------------------------------------------------ + +--------------- +-- divideCTX -- +--------------- +-- | Divides the CTX according to the ratio of a widget's layout and the +-- overall layout of the widget that receives this CTX. Therefore, the +-- first layout argument should basically be a sublayout of the second. + +divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX) +divideCTX ctx@(CTX a ((x, y), (w, h)) c) + ~(Layout m n u v minw minh) ~(Layout m' n' u' v' minw' minh') = + if c then (ctx, ctx) else + case a of + TopDown -> (CTX a ((x, y), (w'', h')) c, + CTX a ((x, y + h'), (w, h - h')) c) + BottomUp -> (CTX a ((x, y + h - h'), (w'', h')) c, + CTX a ((x, y), (w, h - h')) c) + LeftRight -> (CTX a ((x, y), (w', h'')) c, + CTX a ((x + w', y), (w - w', h)) c) + RightLeft -> (CTX a ((x + w - w', y), (w', h'')) c, + CTX a ((x, y), (w - w', h)) c) + where + w' = max minw (m * div' (w - u') m' + u) + h' = max minh (n * div' (h - v') n' + v) + w'' = max minw (if m == 0 then u else w) + h'' = max minh (if n == 0 then v else h) + div' b 0 = 0 + div' b d = div b d + + +----------------- +-- mergeLayout -- +----------------- +-- | Merge two layouts into one. + +mergeLayout a (Layout n m u v minw minh) (Layout n' m' u' v' minw' minh') = + case a of + TopDown -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') + BottomUp -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') + LeftRight -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') + RightLeft -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') + where + max' 0 0 = 0 + max' _ _ = 1 + + +------------------------------------------------------------ +-- * Action and System State +------------------------------------------------------------ + +-- | Actions include both Graphics and Sound output. Even though both +-- are indeed just IO monads, we separate them because Sound output +-- must be immediately delivered, while graphics can wait until the +-- next screen refresh. +type Action = (Graphic, Sound) +-- | A type synonym for sounds. +type Sound = IO () + +-- | This is used when there is no sound produced. +nullSound = return () :: Sound +-- | This is used when no Action happens at all. +nullAction = (nullGraphic, nullSound) :: Action +-- | Convert a Sound to an Action with no Graphic. +justSoundAction :: Sound -> Action +justSoundAction s = (nullGraphic, s) +-- | Convert a Graphic to an Action with no Sound. +justGraphicAction :: Graphic -> Action +justGraphicAction g = (g, nullSound) + +-- | Merge two actions into one. +mergeAction (g, s) (g', s') = (overGraphic g' g, s >> s') + +-- | Use a context to bound the graphical effects of an action. +scissorAction :: CTX -> Action -> Action +scissorAction ctx (g, s) = (scissorGraphic (bounds ctx) g, s) + + +-- The Focus and DirtyBit types are for system state. + +-- | The Focus type helps focusable widgets communicate with each +-- other about which widget is in focus. It consists of a WidgetID +-- and a FocusInfo. +type Focus = (WidgetID, FocusInfo) + +-- | The WidgetID for any given widget is dynamic based +-- on how many focusable widgets are active at the moment. It is designed +-- basically as a counter that focusable widgets will automatically (via the +-- focusable function) increment. +type WidgetID = Int + +-- | The FocusInfo means one of the following: +data FocusInfo = + HasFocus + -- ^ Indicates that this widget is a subwidget of + -- a widget that is in focus. Thus, this widget too is in focus, and + -- this widget should pass HasFocus forward. + | NoFocus + -- ^ Indicates that there is no focus information to + -- communicate between widgets. + | SetFocusTo WidgetID + -- ^ Indicates that the widget whose id is given + -- should take focus. That widget should then pass NoFocus onward. + deriving (Show, Eq) + +-- | The dirty bit is a bit to indicate if the widget needs to be redrawn. +type DirtyBit = Bool + +------------------------------------------------------------ +-- Monadic Instances +------------------------------------------------------------ + +instance Functor UI where + fmap f ui = ui >>= return . f + +instance Applicative UI where + pure = return + (<*>) = ap + +instance Monad UI where + return i = UI (\(_,foc,_,_) -> return (nullLayout, False, foc, nullAction, nullCD, i)) + + (UI m) >>= f = UI (\(ctx, foc, t, inp) -> do + rec let (ctx1, ctx2) = divideCTX ctx l1 layout + (l1, db1, foc1, a1, cd1, v1) <- m (ctx1, foc, t, inp) + (l2, db2, foc2, a2, cd2, v2) <- unUI (f v1) (ctx2, foc1, t, inp) + let action = (if l1 == nullLayout || l2 == nullLayout then id + else scissorAction ctx) $ mergeAction a1 a2 + layout = mergeLayout (flow ctx) l1 l2 + cd = mergeCD cd1 cd2 + dirtybit = ((||) $! db1) $! db2 + return (layout, dirtybit, foc2, action, cd, v2)) + +-- UIs are also instances of MonadFix so that we can define value +-- level recursion. + +instance MonadFix UI where + mfix f = UI aux + where + aux (ctx, foc, t, inp) = u + where u = do rec (l, db, foc', a, cd, r) <- unUI (f r) (ctx, foc, t, inp) + return (l, db, foc', a, cd, r) + +instance MonadIO UI where + liftIO a = UI (\(_,foc,_,_) -> a >>= (\v -> return (nullLayout, False, foc, nullAction, nullCD, v))) +
− FRP/UISF/UIMonad.lhs
@@ -1,267 +0,0 @@-A simple Graphical User Interface with concepts borrowed from Phooey -by Conal Elliot. - -> {-# LANGUAGE DoRec #-} - -> module FRP.UISF.UIMonad where - -> import FRP.UISF.SOE -> import FRP.UISF.AuxFunctions (Time) - -> import Control.Monad.Fix -> import Control.Concurrent.MonadIO - - -============================================================ -==================== UI Type Definition ==================== -============================================================ - -A UI widget runs under a given context and any focus information from -earlier widgets and maps input signals to outputs, which consists of 6 parts: - - its layout, - - whether the widget needs to be redrawn, - - any focus information that needs to be conveyed to future widgets - - the action (to render graphics or/and sounds), - - any new ThreadIds to keep track of (for proper shutdown when finished), - - and the parametrized output type. - -> newtype UI a = UI -> { unUI :: (CTX, Focus, Time, UIEvent) -> -> IO (Layout, DirtyBit, Focus, Action, ControlData, a) } - -For reexporting: - -> ioToUI :: IO a -> UI a -> ioToUI = liftIO - -============================================================ -======================= Control Data ======================= -============================================================ - -> type ControlData = [ThreadId] -> nullCD :: ControlData -> nullCD = [] - -> addThreadID :: ThreadId -> UI () -> addThreadID t = UI (\(_,f,_,_) -> return (nullLayout, False, f, nullAction, [t], ())) - -> mergeCD :: ControlData -> ControlData -> ControlData -> mergeCD = (++) - - -============================================================ -===================== Rendering Context ==================== -============================================================ - -A rendering context specifies the following: - -1. A layout direction to flow widgets. - -2. A rectangle bound of current drawing area to render a UI - component. It specifies the max size of a widget, not the - actual size. It's up to each individual widget to decide - where in this bound to put itself. - -3. A flag to tell whether we are in a conjoined state or not. - A conjoined context will duplicate itself for subcomponents - rather than splitting. This can be useful for making compound - widgets when one widget takes up space and the other performs - some side effect having to do with that space. - -> data CTX = CTX -> { flow :: Flow -> , bounds :: Rect -> , isConjoined :: Bool -> } - -> data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show) -> type Dimension = (Int, Int) -> type Rect = (Point, Dimension) - - -============================================================ -========================= UI Layout ======================== -============================================================ - -The layout of a widget provides data to calculate its actual size -in a given context. - -> data Layout = Layout -> { hFill :: Int -> , vFill :: Int -> , hFixed :: Int -> , vFixed :: Int -> , minW :: Int -> , minH :: Int -> } deriving (Eq, Show) - -1. hFill/vFill specify how much stretching space (in units) in - horizontal/vertical direction should be allocated for this widget. - -2. hFixed/vFixed specify how much non-stretching space (width/height in - pixels) should be allocated for this widget. - -3. minW/minH specify minimum values (width/height in pixels) for the widget's - dimensions. - -Layout calculation makes use of lazy evaluation to do it in one pass. -Although the UI function maps from Context to Layout, all of the fields of -Layout must be independent of the Context so that they are avaiable before -the UI function is even evaluated. - -Layouts can end up being quite complicated, but that is usually due to -layouts being merged (i.e. for multiple widgets used together). Layouts -for individual widgets typically come in a few standard flavors, so we -have the following convenience function for their creation: - ----------------- - | makeLayout | ----------------- -This function takes layout information for first the horizontal -dimension and then the vertical. A dimension can be either stretchy -(with a minimum size in pixels) or fixed (measured in pixels). - -> data LayoutType = Stretchy { minSize :: Int } -> | Fixed { fixedSize :: Int } -> -> makeLayout :: LayoutType -> LayoutType -> Layout -> makeLayout (Fixed h) (Fixed v) = Layout 0 0 h v h v -> makeLayout (Stretchy minW) (Fixed v) = Layout 1 0 0 v minW v -> makeLayout (Fixed h) (Stretchy minH) = Layout 0 1 h 0 h minH -> makeLayout (Stretchy minW) (Stretchy minH) = Layout 1 1 0 0 minW minH - -Null layout. - -> nullLayout = Layout 0 0 0 0 0 0 - - -============================================================ -=============== Context and Layout Functions =============== -============================================================ - ---------------- - | divideCTX | ---------------- -Divides the CTX according to the ratio of a widget's layout and the -overall layout of the widget that receives this CTX. Therefore, the -first layout argument should basically be a sublayout of the second. - -> divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX) -> divideCTX ctx@(CTX a ((x, y), (w, h)) c) -> ~(Layout m n u v minw minh) ~(Layout m' n' u' v' minw' minh') = -> if c then (ctx, ctx) else -> case a of -> TopDown -> (CTX a ((x, y), (w'', h')) c, -> CTX a ((x, y + h'), (w, h - h')) c) -> BottomUp -> (CTX a ((x, y + h - h'), (w'', h')) c, -> CTX a ((x, y), (w, h - h')) c) -> LeftRight -> (CTX a ((x, y), (w', h'')) c, -> CTX a ((x + w', y), (w - w', h)) c) -> RightLeft -> (CTX a ((x + w - w', y), (w', h'')) c, -> CTX a ((x, y), (w - w', h)) c) -> where -> w' = max minw (m * div' (w - u') m' + u) -> h' = max minh (n * div' (h - v') n' + v) -> w'' = max minw (if m == 0 then u else w) -> h'' = max minh (if n == 0 then v else h) -> div' b 0 = 0 -> div' b d = div b d - - ------------------ - | mergeLayout | ------------------ -Merge two layouts into one. - -> mergeLayout a (Layout n m u v minw minh) (Layout n' m' u' v' minw' minh') = -> case a of -> TopDown -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') -> BottomUp -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') -> LeftRight -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') -> RightLeft -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') -> where -> max' 0 0 = 0 -> max' _ _ = 1 - - -============================================================ -================== Action and System State ================= -============================================================ - -Actions include both Graphics and Sound output. Even though both -are indeed just IO monads, we separate them because Sound output -must be immediately delivered, while graphics can wait until -next screen refresh. - -> type Action = (Graphic, Sound) -> type Sound = IO () -> nullSound = return () :: Sound -> nullAction = (nullGraphic, nullSound) :: Action -> justSoundAction :: Sound -> Action -> justSoundAction s = (nullGraphic, s) -> justGraphicAction :: Graphic -> Action -> justGraphicAction g = (g, nullSound) - -> mergeAction (g, s) (g', s') = (overGraphic g' g, s >> s') - -> scissorAction :: CTX -> Action -> Action -> scissorAction ctx (g, s) = (scissorGraphic (bounds ctx) g, s) - - -The Focus and DirtyBit types are for system state. - -The Focus type helps focusable widgets communicate with each -other about which widget is in focus. It consists of a WidgetID -and a FocusInfo. The WidgetID for any given widget is dynamic based -on how many focusable widgets are active at the moment. It is designed -basically as a counter that focusable widgets will automaticall (via the -focusable function) increment. The FocusInfo means one of the following. -- A signal of HasFocus indicates that this widget is a subwidget of - a widget that is in focus. Thus, this widget too is in focus, and - this widget should pass HasFocus forward. -- A signal of NoFocus indicates that there is no focus information to - communicate between widgets. -- A signal of (SetFocusTo n) indicates that the widget whose id equals - n should take focus. That widget should then pass NoFocus onward. - -> type Focus = (WidgetID, FocusInfo) -> type WidgetID = Int - -> data FocusInfo = HasFocus | NoFocus | SetFocusTo WidgetID -> deriving (Show, Eq) - -The dirty bit is a bit to indicate if the widget needs to be redrawn. - -> type DirtyBit = Bool - -============================================================ -===================== Monadic Instances ==================== -============================================================ - -> instance Monad UI where -> return i = UI (\(_,foc,_,_) -> return (nullLayout, False, foc, nullAction, nullCD, i)) - -> (UI m) >>= f = UI (\(ctx, foc, t, inp) -> do -> rec let (ctx1, ctx2) = divideCTX ctx l1 layout -> (l1, db1, foc1, a1, cd1, v1) <- m (ctx1, foc, t, inp) -> (l2, db2, foc2, a2, cd2, v2) <- unUI (f v1) (ctx2, foc1, t, inp) -> let action = (if l1 == nullLayout || l2 == nullLayout then id -> else scissorAction ctx) $ mergeAction a1 a2 -> layout = mergeLayout (flow ctx) l1 l2 -> cd = mergeCD cd1 cd2 -> dirtybit = ((||) $! db1) $! db2 -> return (layout, dirtybit, foc2, action, cd, v2)) - -UIs are also instances of MonadFix so that we can define value -level recursion. - -> instance MonadFix UI where -> mfix f = UI aux -> where -> aux (ctx, foc, t, inp) = u -> where u = do rec (l, db, foc', a, cd, r) <- unUI (f r) (ctx, foc, t, inp) -> return (l, db, foc', a, cd, r) - -> instance MonadIO UI where -> liftIO a = UI (\(_,foc,_,_) -> a >>= (\v -> return (nullLayout, False, foc, nullAction, nullCD, v))) -
+ FRP/UISF/UISF.hs view
@@ -0,0 +1,320 @@+----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.UISF +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental +-- +-- A simple Graphical User Interface with concepts borrowed from Phooey +-- by Conal Elliot. + +{-# LANGUAGE ScopedTypeVariables, Arrows, RecursiveDo, CPP, OverlappingInstances, FlexibleInstances, TypeSynonymInstances #-} + +module FRP.UISF.UISF ( + UISF, + -- * UISF Getters + getTime, getCTX, getEvents, getFocusData, getMousePosition, + -- * UISF constructors, transformers, and converters + -- $ctc + mkUISF, mkUISF', expandUISF, compressUISF, transformUISF, + initialIOAction, + uisfSourceE, uisfSinkE, uisfPipeE, + -- * UISF Lifting + -- $lifting + toUISF, convertToUISF, asyncUISF, + -- * Layout Transformers + -- $lt + leftRight, rightLeft, topDown, bottomUp, + conjoin, unconjoin, + setLayout, setSize, pad, + -- * Execute UI Program + runUI, runUI' + +) where + +#if __GLASGOW_HASKELL__ >= 610 +import Control.Category +import Prelude hiding ((.)) +#endif +import Control.Arrow +import Control.Arrow.Operations + +import FRP.UISF.SOE +import FRP.UISF.UIMonad + +import FRP.UISF.Types.MSF +import FRP.UISF.AuxFunctions (Automaton, Time, toMSF, toRealTimeMSF, + SEvent, ArrowTime (..), + async, AsyncInput (..), AsyncOutput (..)) + +import Control.Monad (when) +import qualified Graphics.UI.GLFW as GLFW (sleep, SpecialKey (..)) +import Control.Concurrent.MonadIO +import Control.DeepSeq + + +-- | The main UI signal function, built from the UI monad and MSF. +type UISF = MSF UI + +instance ArrowCircuit UISF where + delay i = MSF (h i) where h i x = seq i $ return (i, MSF (h x)) + -- We probably want this to be a deepseq, but changing the types is a pain. + +instance ArrowTime UISF where + time = getTime + + +------------------------------------------------------------ +-- * UISF Getters +------------------------------------------------------------ + +-- | Get the time signal from a UISF +getTime :: UISF () Time +getTime = mkUISF (\_ (_,f,t,_) -> (nullLayout, False, f, nullAction, nullCD, t)) + +-- | Get the context signal from a UISF +getCTX :: UISF () CTX +getCTX = mkUISF (\_ (c,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, c)) + +-- | Get the UIEvent signal from a UISF +getEvents :: UISF () UIEvent +getEvents = mkUISF (\_ (_,f,_,e) -> (nullLayout, False, f, nullAction, nullCD, e)) + +-- | Get the focus data from a UISF +getFocusData :: UISF () Focus +getFocusData = mkUISF (\_ (_,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, f)) + +-- | Get the mouse position from a UISF +getMousePosition :: UISF () Point +getMousePosition = proc _ -> do + e <- getEvents -< () + rec p' <- delay (0,0) -< p + let p = case e of + MouseMove pt -> pt + _ -> p' + returnA -< p + + +------------------------------------------------------------ +-- * UISF constructors, transformers, and converters +------------------------------------------------------------ + +-- $ctc These fuctions are various shortcuts for creating UISFs. +-- The types pretty much say it all for how they work. + +mkUISF :: (a -> (CTX, Focus, Time, UIEvent) -> (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b +mkUISF f = pipe (\a -> UI (return . f a)) + +mkUISF' :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b +mkUISF' = pipe . (UI .) + +expandUISF :: UISF a b -> a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b)) +{-# INLINE expandUISF #-} +expandUISF (MSF f) = unUI . f + +compressUISF :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b))) -> UISF a b +{-# INLINE compressUISF #-} +compressUISF f = MSF (UI . f) + +transformUISF :: (UI (c, UISF b c) -> UI (c, UISF b c)) -> UISF b c -> UISF b c +transformUISF f (MSF sf) = MSF $ \a -> do + (c, nextSF) <- f (sf a) + return (c, transformUISF f nextSF) + +-- | Apply the given IO action when this UISF is first run and use its +-- result to produce the UISF to run +initialIOAction :: IO x -> (x -> UISF a b) -> UISF a b +initialIOAction = initialAction . liftIO + +-- source, sink, and pipe functions +-- DWC Note: I don't feel comfortable with how generic these are. +-- Also, the continuous ones can't work. +-- +-- uisfSource :: IO c -> UISF () c +-- uisfSink :: (b -> IO ()) -> UISF b () +-- uisfPipe :: (b -> IO c) -> UISF b c +-- uisfSource = source . liftIO +-- uisfSink = sink . (liftIO .) +-- uisfPipe = pipe . (liftIO .) + +-- | Generate a source UISF from the IO action. +uisfSourceE :: IO c -> UISF (SEvent ()) (SEvent c) +uisfSourceE = (delay Nothing >>>) . sourceE . liftIO + +-- | Generate a sink UISF from the IO action. +uisfSinkE :: (b -> IO ()) -> UISF (SEvent b) (SEvent ()) +uisfSinkE = (delay Nothing >>>) . sinkE . (liftIO .) + +-- | Generate a pipe UISF from the IO action. +uisfPipeE :: (b -> IO c) -> UISF (SEvent b) (SEvent c) +uisfPipeE = (delay Nothing >>>) . pipeE . (liftIO .) + + + +------------------------------------------------------------ +-- * UISF Lifting +------------------------------------------------------------ + +-- $lifting The following two functions are for lifting SFs to UISFs. + +-- | This is a quick and dirty solution that ignores timing issues. +toUISF :: Automaton a b -> UISF a b +toUISF = toMSF + +-- | This is the standard one that appropriately keeps track of +-- simulated time vs real time. +-- +-- The clockrate is the simulated rate of the input signal function. +-- The buffer is the number of time steps the given signal function is allowed +-- to get ahead of real time. The real amount of time that it can get ahead is +-- the buffer divided by the clockrate seconds. +-- The output signal function takes and returns values in real time. The return +-- values are the list of bs generated in the given time step, each time stamped. +-- +-- Note that the returned list may be long if the clockrate is much +-- faster than real time and potentially empty if it's slower. +-- Note also that the caller can check the time stamp on the element +-- at the end of the list to see if the inner, "simulated" signal +-- function is performing as fast as it should. +convertToUISF :: NFData b => Double -> Double -> Automaton a b -> UISF a [(b, Time)] +convertToUISF clockrate buffer sf = proc a -> do + t <- time -< () + toRealTimeMSF clockrate buffer addThreadID sf -< (a, t) + + +-- | We can also lift a signal function to a UISF asynchronously. +asyncUISF :: NFData b => Automaton a b -> UISF (AsyncInput a) (AsyncOutput b) +asyncUISF = async addThreadID + + +------------------------------------------------------------ +-- * Layout Transformers +------------------------------------------------------------ + +-- $lt These functions are UISF transformers that modify the context. + +topDown, bottomUp, leftRight, rightLeft, conjoin, unconjoin :: UISF a b -> UISF a b +topDown = modifyFlow (\ctx -> ctx {flow = TopDown}) +bottomUp = modifyFlow (\ctx -> ctx {flow = BottomUp}) +leftRight = modifyFlow (\ctx -> ctx {flow = LeftRight}) +rightLeft = modifyFlow (\ctx -> ctx {flow = RightLeft}) +conjoin = modifyFlow (\ctx -> ctx {isConjoined = True}) +unconjoin = modifyFlow (\ctx -> ctx {isConjoined = False}) + + +modifyFlow :: (CTX -> CTX) -> UISF a b -> UISF a b +modifyFlow h = transformUISF (modifyFlow' h) + where modifyFlow' :: (CTX -> CTX) -> UI a -> UI a + modifyFlow' h (UI f) = UI g where g (c,s,t,i) = f (h c,s,t,i) + + +-- | Set a new layout for this widget. +setLayout :: Layout -> UISF a b -> UISF a b +setLayout l = transformUISF (setLayout' l) + where setLayout' :: Layout -> UI a -> UI a + setLayout' d (UI f) = UI aux + where + aux inps = do + (_, db, foc, a, ts, v) <- f inps + return (d, db, foc, a, ts, v) + +-- | A convenience function for setLayout, setSize sets the layout to a +-- fixed size (in pixels). +setSize :: Dimension -> UISF a b -> UISF a b +setSize (w,h) = setLayout $ makeLayout (Fixed w) (Fixed h) + +-- | Add space padding around a widget. +pad :: (Int, Int, Int, Int) -> UISF a b -> UISF a b +pad args = transformUISF (pad' args) + where pad' :: (Int, Int, Int, Int) -> UI a -> UI a + pad' (w,n,e,s) (UI f) = UI aux + where + aux (ctx@(CTX i _ c), foc, t, inp) = do + rec (l, db, foc', a, ts, v) <- f (CTX i ((x + w, y + n),(bw,bh)) c, foc, t, inp) + let d = l { hFixed = hFixed l + w + e, vFixed = vFixed l + n + s } + ((x,y),(bw,bh)) = bounds ctx + return (d, db, foc', a, ts, v) + + +------------------------------------------------------------ +-- * Execute UI Program +------------------------------------------------------------ + +defaultSize :: Dimension +defaultSize = (300, 300) +defaultCTX :: Dimension -> CTX +defaultCTX size = CTX TopDown ((0,0), size) False +defaultFocus :: Focus +defaultFocus = (0, SetFocusTo 0) +resetFocus :: (WidgetID, FocusInfo) -> (WidgetID, FocusInfo) +resetFocus (n,SetFocusTo i) = (0, SetFocusTo $ (i+n) `rem` n) +resetFocus (_,_) = (0,NoFocus) + +-- | Run the UISF with the default size (300 x 300). +runUI' :: String -> UISF () () -> IO () +runUI' = runUI defaultSize + +-- | Run the UISF +runUI :: Dimension -> String -> UISF () () -> IO () +runUI windowSize title sf = runGraphics $ do + w <- openWindowEx title (Just (0,0)) (Just windowSize) drawBufferedGraphic + (events, addEv) <- makeStream + let pollEvents = windowUser w addEv + -- poll events before we start to make sure event queue isn't empty + t0 <- timeGetTime + pollEvents + let render :: Bool -> [UIEvent] -> Focus -> Stream UI () -> [ThreadId] -> IO [ThreadId] + render drawit' (inp:inps) lastFocus uistream tids = do + wSize <- getMainWindowSize + t <- timeGetTime + let rt = t - t0 + let ctx = defaultCTX wSize + (_, dirty, foc, (graphic, sound), tids', (_, uistream')) <- (unUI $ stream uistream) (ctx, lastFocus, rt, inp) + -- always output sound + sound + -- and delay graphical output when event queue is not empty + setGraphic' w graphic + let drawit = dirty || drawit' + newtids = tids'++tids + foc' = resetFocus foc + foc' `seq` newtids `seq` case inp of + -- Timer only comes in when we are done processing user events + NoUIEvent -> do + -- output graphics + when drawit $ setDirty w + quit <- pollEvents + if quit then return newtids + else render False inps foc' uistream' newtids + _ -> render drawit inps foc' uistream' newtids + render _ [] _ _ tids = return tids + tids <- render True events defaultFocus (streamMSF sf (repeat ())) [] + -- wait a little while before all Midi messages are flushed + GLFW.sleep 0.5 + mapM_ killThread tids + +windowUser :: Window -> (UIEvent -> IO ()) -> IO Bool +windowUser w addEv = do + quit <- getEvents + addEv NoUIEvent + return quit + where + getEvents :: IO Bool + getEvents = do + mev <- maybeGetWindowEvent 0.001 w + case mev of + Nothing -> return False + Just e -> case e of +-- There's a bug somewhere with GLFW that makes pressing ESC freeze up +-- GHCi (specifically when calling GLFW.closeWindow), so I've removed this. +-- SKey GLFW.ESC True -> closeWindow w >> return True + Closed -> return True + _ -> addEv e >> getEvents + +makeStream :: IO ([a], a -> IO ()) +makeStream = do + ch <- newChan + contents <- getChanContents ch + return (contents, writeChan ch) +
− FRP/UISF/UISF.lhs
@@ -1,280 +0,0 @@-A simple Graphical User Interface with concepts borrowed from Phooey -by Conal Elliot. - -> {-# LANGUAGE ScopedTypeVariables, Arrows, DoRec, CPP, OverlappingInstances, FlexibleInstances, TypeSynonymInstances #-} - -> module FRP.UISF.UISF where - -#if __GLASGOW_HASKELL__ >= 610 -> import Control.Category -> import Prelude hiding ((.)) -#endif -> import Control.Arrow -> import Control.Arrow.Operations - -> import FRP.UISF.SOE -> import FRP.UISF.UIMonad - -> import FRP.UISF.Types.MSF -> import FRP.UISF.AuxFunctions (Automaton, Time, toMSF, toRealTimeMSF, -> async, SEvent, ArrowTime (..)) - -> import Control.Monad (when) -> import qualified Graphics.UI.GLFW as GLFW (sleep, SpecialKey (..)) -> import Control.Concurrent.MonadIO -> import Control.DeepSeq - - -The main UI signal function, built from the UI monad and MSF. - -> type UISF = MSF UI - -We probably want this to be a deepseq, but changing the types is a pain. - -> instance ArrowCircuit UISF where -> delay i = MSF (h i) where h i x = seq i $ return (i, MSF (h x)) - -> instance ArrowTime UISF where -> time = getTime - - -============================================================ -======================= UISF Getters ======================= -============================================================ - -> getTime :: UISF () Time -> getTime = mkUISF (\_ (_,f,t,_) -> (nullLayout, False, f, nullAction, nullCD, t)) - -> getCTX :: UISF () CTX -> getCTX = mkUISF (\_ (c,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, c)) - -> getEvents :: UISF () UIEvent -> getEvents = mkUISF (\_ (_,f,_,e) -> (nullLayout, False, f, nullAction, nullCD, e)) - -> getFocusData :: UISF () Focus -> getFocusData = mkUISF (\_ (_,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, f)) - -> getMousePosition :: UISF () Point -> getMousePosition = proc _ -> do -> e <- getEvents -< () -> rec p' <- delay (0,0) -< p -> let p = case e of -> MouseMove pt -> pt -> _ -> p' -> returnA -< p - - -UISF constructors, transformers, and converters -=============================================== - -These fuctions are various shortcuts for creating UISFs. -The types pretty much say it all for how they work. - -> mkUISF :: (a -> (CTX, Focus, Time, UIEvent) -> (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b -> mkUISF f = pipe (\a -> UI (return . f a)) - -> mkUISF' :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b -> mkUISF' = pipe . (UI .) - -> expandUISF :: UISF a b -> a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b)) -> {-# INLINE expandUISF #-} -> expandUISF (MSF f) = unUI . f - -> compressUISF :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b))) -> UISF a b -> {-# INLINE compressUISF #-} -> compressUISF f = MSF (UI . f) - -> transformUISF :: (UI (c, UISF b c) -> UI (c, UISF b c)) -> UISF b c -> UISF b c -> transformUISF f (MSF sf) = MSF $ \a -> do -> (c, nextSF) <- f (sf a) -> return (c, transformUISF f nextSF) - -> initialIOAction :: IO x -> (x -> UISF a b) -> UISF a b -> initialIOAction = initialAction . liftIO - -source, sink, and pipe functions -DWC Note: I don't feel comfortable with how generic these are. -Also, the continuous ones can't work. - -uisfSource :: IO c -> UISF () c -uisfSink :: (b -> IO ()) -> UISF b () -uisfPipe :: (b -> IO c) -> UISF b c -uisfSource = source . liftIO -uisfSink = sink . (liftIO .) -uisfPipe = pipe . (liftIO .) - -> uisfSourceE :: IO c -> UISF (SEvent ()) (SEvent c) -> uisfSinkE :: (b -> IO ()) -> UISF (SEvent b) (SEvent ()) -> uisfPipeE :: (b -> IO c) -> UISF (SEvent b) (SEvent c) -> uisfSourceE = (delay Nothing >>>) . sourceE . liftIO -> uisfSinkE = (delay Nothing >>>) . sinkE . (liftIO .) -> uisfPipeE = (delay Nothing >>>) . pipeE . (liftIO .) - - - -UISF Lifting -============ - -The following two functions are for lifting SFs to UISFs. The first is a -quick and dirty solution that ignores timing issues. The second is the -standard one that appropriately keeps track of simulated time vs real time. - -> toUISF :: Automaton a b -> UISF a b -> toUISF = toMSF - -The clockrate is the simulated rate of the input signal function. -The buffer is the number of time steps the given signal function is allowed -to get ahead of real time. The real amount of time that it can get ahead is -the buffer divided by the clockrate seconds. -The output signal function takes and returns values in real time. The return -values are the list of bs generated in the given time step, each time stamped. - -Note that the returned list may be long if the clockrate is much -faster than real time and potentially empty if it's slower. -Note also that the caller can check the time stamp on the element -at the end of the list to see if the inner, "simulated" signal -function is performing as fast as it should. - -> convertToUISF :: NFData b => Double -> Double -> Automaton a b -> UISF a [(b, Time)] -> convertToUISF clockrate buffer sf = proc a -> do -> t <- time -< () -> toRealTimeMSF clockrate buffer addThreadID sf -< (a, t) - -We can also lift a signal function to a UISF asynchronously. - -> asyncUISF :: NFData b => Automaton a b -> UISF (SEvent a) (SEvent b) -> asyncUISF = async addThreadID - - -Layout Transformers -=================== - -Thes functions are UISF transformers that modify the flow in the context. - -> topDown, bottomUp, leftRight, rightLeft, conjoin, unconjoin :: UISF a b -> UISF a b -> topDown = modifyFlow (\ctx -> ctx {flow = TopDown}) -> bottomUp = modifyFlow (\ctx -> ctx {flow = BottomUp}) -> leftRight = modifyFlow (\ctx -> ctx {flow = LeftRight}) -> rightLeft = modifyFlow (\ctx -> ctx {flow = RightLeft}) -> conjoin = modifyFlow (\ctx -> ctx {isConjoined = True}) -> unconjoin = modifyFlow (\ctx -> ctx {isConjoined = False}) - -> modifyFlow :: (CTX -> CTX) -> UISF a b -> UISF a b -> modifyFlow h = transformUISF (modifyFlow' h) -> where modifyFlow' :: (CTX -> CTX) -> UI a -> UI a -> modifyFlow' h (UI f) = UI g where g (c,s,t,i) = f (h c,s,t,i) - - -Set a new layout for this widget. - -> setLayout :: Layout -> UISF a b -> UISF a b -> setLayout l = transformUISF (setLayout' l) -> where setLayout' :: Layout -> UI a -> UI a -> setLayout' d (UI f) = UI aux -> where -> aux inps = do -> (_, db, foc, a, ts, v) <- f inps -> return (d, db, foc, a, ts, v) - -A convenience function for setLayout, setSize sets the layout to a -fixed size (in pixels). - -> setSize :: Dimension -> UISF a b -> UISF a b -> setSize (w,h) = setLayout $ makeLayout (Fixed w) (Fixed h) - - - -Add space padding around a widget. - -> pad :: (Int, Int, Int, Int) -> UISF a b -> UISF a b -> pad args = transformUISF (pad' args) -> where pad' :: (Int, Int, Int, Int) -> UI a -> UI a -> pad' (w,n,e,s) (UI f) = UI aux -> where -> aux (ctx@(CTX i _ c), foc, t, inp) = do -> rec (l, db, foc', a, ts, v) <- f (CTX i ((x + w, y + n),(bw,bh)) c, foc, t, inp) -> let d = l { hFixed = hFixed l + w + e, vFixed = vFixed l + n + s } -> ((x,y),(bw,bh)) = bounds ctx -> return (d, db, foc', a, ts, v) - - -Execute UI Program -================== - -Some default parameters we start with. - -> defaultSize :: Dimension -> defaultSize = (300, 300) -> defaultCTX :: Dimension -> CTX -> defaultCTX size = CTX TopDown ((0,0), size) False -> defaultFocus :: Focus -> defaultFocus = (0, SetFocusTo 0) -> resetFocus :: (WidgetID, FocusInfo) -> (WidgetID, FocusInfo) -> resetFocus (n,SetFocusTo i) = (0, SetFocusTo $ (i+n) `rem` n) -> resetFocus (_,_) = (0,NoFocus) - -> runUI' :: String -> UISF () () -> IO () -> runUI' = runUI defaultSize - -> runUI :: Dimension -> String -> UISF () () -> IO () -> runUI windowSize title sf = runGraphics $ do -> w <- openWindowEx title (Just (0,0)) (Just windowSize) drawBufferedGraphic -> (events, addEv) <- makeStream -> let pollEvents = windowUser w addEv -> -- poll events before we start to make sure event queue isn't empty -> t0 <- timeGetTime -> pollEvents -> let render :: Bool -> [UIEvent] -> Focus -> Stream UI () -> [ThreadId] -> IO [ThreadId] -> render drawit' (inp:inps) lastFocus uistream tids = do -> wSize <- getMainWindowSize -> t <- timeGetTime -> let rt = t - t0 -> let ctx = defaultCTX wSize -> (_, dirty, foc, (graphic, sound), tids', (_, uistream')) <- (unUI $ stream uistream) (ctx, lastFocus, rt, inp) -> -- always output sound -> sound -> -- and delay graphical output when event queue is not empty -> setGraphic' w graphic -> let drawit = dirty || drawit' -> newtids = tids'++tids -> foc' = resetFocus foc -> foc' `seq` newtids `seq` case inp of -> -- Timer only comes in when we are done processing user events -> NoUIEvent -> do -> -- output graphics -> when drawit $ setDirty w -> quit <- pollEvents -> if quit then return newtids -> else render False inps foc' uistream' newtids -> _ -> render drawit inps foc' uistream' newtids -> render _ [] _ _ tids = return tids -> tids <- render True events defaultFocus (streamMSF sf (repeat ())) [] -> -- wait a little while before all Midi messages are flushed -> GLFW.sleep 0.5 -> mapM_ killThread tids - -> windowUser :: Window -> (UIEvent -> IO ()) -> IO Bool -> windowUser w addEv = do -> quit <- getEvents -> addEv NoUIEvent -> return quit -> where -> getEvents :: IO Bool -> getEvents = do -> mev <- maybeGetWindowEvent 0.001 w -> case mev of -> Nothing -> return False -> Just e -> case e of -> -- There's a bug somewhere with GLFW that makes pressing ESC freeze up -> -- GHCi, so I've removed this. -> -- SKey GLFW.ESC True -> closeWindow w >> return True -> -- Key '\00' True -> return True -> Closed -> return True -> _ -> addEv e >> getEvents - -> makeStream :: IO ([a], a -> IO ()) -> makeStream = do -> ch <- newChan -> contents <- getChanContents ch -> return (contents, writeChan ch) -
+ FRP/UISF/Widget.hs view
@@ -0,0 +1,759 @@+----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.Widget +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental +-- +-- A simple Graphical User Interface based on FRP. It uses the SOE +-- graphics library, and draws custom widgets on the screen. +-- +-- SOE graphics uses OpenGL as the primitive drawing routine, and +-- GLFW library to provide window and input support. +-- +-- The monadic UI concept is borrowed from Phooey by Conal Elliott. + +{-# LANGUAGE RecursiveDo, Arrows, TupleSections #-} +{-# OPTIONS_HADDOCK prune #-} + +module FRP.UISF.Widget where + +import FRP.UISF.SOE +import FRP.UISF.UIMonad +import FRP.UISF.UISF +import FRP.UISF.AuxFunctions (SEvent, Time, timer, edge, delay, constA, concatA) + +import Control.Arrow +import Data.Maybe (fromMaybe) + +------------------------------------------------------------ +-- Shorthand and Helper Functions +------------------------------------------------------------ + +-- Default padding between border and content +padding :: Int +padding = 3 + +-- Introduce a shorthand for overGraphic +(//) :: Graphic -> Graphic -> Graphic +(//) = overGraphic + +-- And a nice way to make a graphic under only certain conditions +whenG :: Bool -> Graphic -> Graphic +whenG b g = if b then g else nullGraphic + +------------------------------------------------------------ +-- * Widgets +------------------------------------------------------------ + +---------------- +-- Text Label -- +---------------- +-- | Labels are always left aligned and vertically centered. +label :: String -> UISF a a +label s = mkBasicWidget layout draw + 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 + +----------------- +-- Display Box -- +----------------- +-- | DisplayStr is an output widget showing the instantaneous value of +-- a signal of strings. +displayStr :: UISF String () +displayStr = mkWidget "" d (\v v' _ _ -> ((), v, v /= v')) draw + where + minh = 16 + padding * 2 + d = makeLayout (Stretchy 8) (Fixed minh) + draw b@((x,y), (w, _h)) _ s = + let n = (w - padding * 2) `div` 8 + in withColor Black (text (x + padding, y + padding) (take n s)) + // box pushed b + // withColor White (block b) + +-- | display is a widget that takes any show-able value and displays it. +display :: Show a => UISF a () +display = arr show >>> displayStr + +-- | withDisplay is a widget modifier that modifies the given widget +-- so that it also displays its output value. +withDisplay :: Show b => UISF a b -> UISF a b +withDisplay sf = proc a -> do + b <- sf -< a + display -< b + returnA -< b + + +-------------- +-- Text Box -- +-------------- +-- | Textbox is a widget showing the instantaneous value of a signal of +-- strings. +-- +-- The textbox widget will often be used with ArrowLoop (the rec keyword). +-- However, it uses 'delay' internally, so there should be no fear of a blackhole. +-- +-- The textbox widget supports mouse clicks and typing as well as the +-- left, right, end, home, delete, and backspace special keys. +textbox :: UISF String String +textbox = focusable $ + conjoin $ proc s -> do + inFocus <- isInFocus -< () + k <- getEvents -< () + ctx <- getCTX -< () + rec let (s', i) = if inFocus then update s iPrev ctx k else (s, iPrev) + iPrev <- delay 0 -< i + displayStr -< seq i s' + inf <- delay False -< inFocus + b <- if inf then timer -< 0.5 else returnA -< Nothing + b' <- edge -< not inFocus --For use in drawing the cursor + rec willDraw <- delay True -< willDraw' + let willDraw' = maybe willDraw (const $ not willDraw) b --if isJust b then not willDraw else willDraw + canvas' displayLayout drawCursor -< case (inFocus, b, b', i == iPrev) of + (True, Just _, _, _) -> Just (willDraw, i) + (True, _, _, False) -> Just (willDraw, i) + (False, _, Just _, _) -> Just (False, i) + _ -> Nothing + returnA -< s' + where + minh = 16 + padding * 2 + displayLayout = makeLayout (Stretchy 8) (Fixed minh) + update s i _ (Key c _ True) = (take i s ++ [c] ++ drop i s, i+1) + update s i _ (SKey BACKSPACE _ True) = (take (i-1) s ++ drop i s, max (i-1) 0) + update s i _ (SKey DEL _ True) = (take i s ++ drop (i+1) s, i) + update s i _ (SKey LEFT _ True) = (s, max (i-1) 0) + update s i _ (SKey RIGHT _ True) = (s, min (i+1) (length s)) + update s _i _ (SKey END _ True) = (s, length s) + update s _i _ (SKey HOME _ True) = (s, 0) + update s _i c (Button (x,_) True True) = (s, min (length s) $ (x - xoffset c) `div` 8) + update s i _ _ = (s, max 0 $ min i $ length s) + drawCursor (False, _) _ = nullGraphic + drawCursor (True, i) (w,_h) = + let linew = padding + i*8 + in if linew > w then nullGraphic else withColor Black $ + line (linew, padding) (linew, 16+padding) + xoffset = fst . fst . bounds + +-- | This variant of the textbox takes a static argument that is +-- the initial value in the textbox. Then, it takes a stream of +-- 'SEvent String' and only externally updates the contents of the +-- textbox when an event occurs. +textboxE :: String -> UISF (SEvent String) String +textboxE startingVal = proc ms -> do + rec s' <- delay startingVal -< ts + let s = maybe s' id ms + ts <- textbox -< maybe s id ms + returnA -< ts + +----------- +-- Title -- +----------- +-- | Title frames a UI by borders, and displays a static title text. +title :: String -> UISF a b -> UISF a b +title l uisf = compressUISF (modsf uisf) + where + (tw, th) = (length l * 8, 16) + drawit ((x, y), (w, h)) g = + withColor Black (text (x + 10, y) l) + // withColor' bg (block ((x + 8, y), (tw + 4, th))) + // box marked ((x, y + 8), (w, h - 16)) + // g + modsf sf a (CTX _ bbx@((x,y), (w,h)) _,f,t,inp) = do + (l,db,f',action,ts,(v,nextSF)) <- expandUISF sf a (CTX TopDown ((x + 4, y + 20), (w - 8, h - 32)) + False, f, t, inp) + let d = l { hFixed = hFixed l + 8, vFixed = vFixed l + 36, + minW = max (tw + 20) (minW l), minH = max 36 (minH l) } + return (d, db, f', first (drawit bbx) action, ts, (v,compressUISF (modsf nextSF))) + + +------------ +-- Button -- +------------ +-- | A button is a focusable input widget with a state of being on or off. +-- It can be activated with either a button press or the enter key. +-- (Currently, there is no support for the space key due to non-special +-- keys not having Release events.) +-- Buttons also show a static label. +-- +-- The regular button is down as long as the mouse button or key press is +-- down and then returns to up. +button :: String -> UISF () Bool +button = genButton False + +-- | The sticky button, on the other hand, once +-- pressed, remains depressed until is is clicked again to be released. +-- Thus, it looks like a button, but it behaves more like a checkbox. +stickyButton :: String -> UISF () Bool +stickyButton = genButton True + +-- This is used to create the buttons. +genButton :: Bool -> String -> UISF () Bool +genButton sticky l = focusable $ + mkWidget False d (if sticky then processSticky else processRegular) draw + where + (tw, th) = (8 * length l, 16) + (minw, minh) = (tw + padding * 2, th + padding * 2) + d = makeLayout (Stretchy minw) (Fixed minh) + draw b@((x,y), (w,h)) inFocus down = + let x' = x + (w - tw) `div` 2 + if down then 0 else -1 + y' = y + (h - th) `div` 2 + if down then 0 else -1 + in withColor Black (text (x', y') l) + // whenG inFocus (box marked b) + // box (if down then pushed else popped) b + processRegular _ s b evt = (s', s', s /= s') + where + s' = case evt of + Button _ True down -> case (s, down) of + (False, True) -> True + (True, False) -> False + _ -> s + MouseMove pt -> (pt `inside` b) && s + SKey ENTER _ down -> down + Key ' ' _ down -> down + _ -> s + processSticky _ s _ evt = (s', s', s /= s') + where + s' = case evt of + Button _ True True -> not s + SKey ENTER _ True -> not s + Key ' ' _ True -> not s + _ -> s + + +--------------- +-- Check Box -- +--------------- +-- | Checkbox allows selection or deselection of an item. +-- It has a static label as well as an initial state. +checkbox :: String -> Bool -> UISF () Bool +checkbox l state = proc _ -> do + rec s <- delay state -< s' + e <- edge <<< toggle state d draw -< s + let s' = maybe s (const $ not s) e + returnA -< s' + where + (tw, th) = (8 * length l, 16) + (minw, minh) = (tw + padding * 2, th + padding * 2) + d = makeLayout (Stretchy minw) (Fixed minh) + draw ((x,y), (_w,h)) inFocus down = + let x' = x + padding + 16 + y' = y + (h - th) `div` 2 + b = ((x + padding + 2, y + h `div` 2 - 6), (12, 12)) + in withColor Black (text (x', y') l) + // whenG inFocus (box marked b) + // whenG down + (withColor' gray3 $ polyline + [(x + padding + 5, y + h `div` 2), + (x + padding + 7, y + h `div` 2 + 3), + (x + padding + 11, y + h `div` 2 - 2)]) + // box pushed b + // withColor White (block b) + + +--------------------- +-- Check Box Group -- +--------------------- +-- | The checkGroup widget creates a group of 'checkbox'es that all send +-- their outputs to the same output stream. It takes a static list of +-- labels for the check boxes and assumes they all start unchecked. +-- +-- The output stream is a list of each a value that was paired with a +-- String value for which the check box is checked. +checkGroup :: [(String, a)] -> UISF () [a] +checkGroup sas = let (s, a) = unzip sas in + constA (repeat ()) >>> + concatA (zipWith checkbox s (repeat False)) >>> + arr (map fst . filter snd . zip a) + +--checkGroup :: [String] -> UISF () [Bool] +--checkGroup ss = constA (repeat ()) >>> +-- concatA (zipWith checkbox ss (repeat False)) + + +------------------- +-- Radio Buttons -- +------------------- +-- | Radio button presents a list of choices and only one of them can be +-- selected at a time. It takes a static list of choices (as Strings) +-- and the index of the initially selected one, and the widget itself +-- returns the continuous stream representing the index of the selected +-- choice. +radio :: [String] -> Int -> UISF () Int +radio labels i = proc _ -> do + rec s <- delay i -< s'' + s' <- aux 0 labels -< s + let s'' = maybe s id s' + returnA -< s'' + where + aux :: Int -> [String] -> UISF Int (SEvent Int) + aux _ [] = arr (const Nothing) + aux j (l:ls) = proc n -> do + u <- edge <<< toggle (i == j) d draw -< n == j + v <- aux (j + 1) ls -< n + returnA -< maybe v (const $ Just j) u + where + (tw, th) = (8 * length l, 16) + (minw, minh) = (tw + padding * 2, th + padding * 2) + d = makeLayout (Stretchy minw) (Fixed minh) + draw ((x,y), (_w,h)) inFocus down = + let x' = x + padding + 16 + y' = y + (h - th) `div` 2 + in withColor Black (text (x', y') l) + // whenG down (circle gray3 (x,y) (5,6) (9,10)) + // circle gray3 (x,y) (2,3) (12,13) + // circle gray0 (x,y) (2,3) (13,14) + // whenG inFocus (circle gray2 (x,y) (0,0) (14,15)) + +-------------- +-- List Box -- +-------------- +-- | The listbox widget creates a box with selectable entries. +-- The input stream is the list of entries as well as which entry is +-- currently selected, and the output stream is the index of the newly +-- selected entry. Note that the index can be greater than the length +-- of the list (simply indicating no choice selected). +listbox :: (Eq a, Show a) => UISF ([a], Int) Int +listbox = focusable $ mkWidget ([], -1) layout process draw >>> delay (-1) + where + layout = makeLayout (Stretchy 80) (Stretchy 16) + -- takes the rectangle to draw in and a tuple of the list of choices and the index selected + lineheight = 16 + --draw :: Show a => Rect -> ([a], Int) -> Graphic + draw rect@(_,(w,_h)) _ (lst, i) = + genTextGraphic rect i lst + // box pushed rect + // withColor White (block rect) + where + n = (w - padding * 2) `div` 8 + genTextGraphic _ _ [] = nullGraphic + genTextGraphic ((x,y),(w,h)) i (v:vs) = (if i == 0 + then withColor White (text (x + padding, y + padding) (take n (show v))) + // withColor Blue (block ((x,y),(w,lineheight))) + else withColor Black (text (x + padding, y + padding) (take n (show v)))) + // genTextGraphic ((x,y+lineheight),(w,h-lineheight)) (i - 1) vs + process :: Eq a => ([a], Int) -> ([a], Int) -> Rect -> UIEvent -> (Int, ([a], Int), Bool) + process (lst,i) olds bbx e = (i', (lst, i'), olds /= (lst, i')) + where + i' = case e of + Button pt True True -> boundCheck $ pt2index pt + SKey DOWN _ True -> min (i+1) (length lst - 1) + SKey UP _ True -> max (i-1) 0 + SKey HOME _ True -> 0 + SKey END _ True -> length lst - 1 + _ -> boundCheck i + ((_,y),_) = bbx + pt2index (_px,py) = (py-y) `div` lineheight + boundCheck j = if j >= length lst then -1 else j + + +---------------- +-- *** Sliders +---------------- + +-- $ Sliders are input widgets that allow the user to choose a value within +-- a given range. They come in both continous and discrete flavors as well +-- as in both vertical and horizontal layouts. +-- +-- Sliders take a boundary argument giving the minimum and maximum possible +-- values for the output as well as an initial value. In addition, discrete +-- (or integral) sliders take a step size as their first argument. + +hSlider, vSlider :: RealFrac a => (a, a) -> a -> UISF () a +-- | Horizontal Continuous Slider +hSlider = slider True +-- | Vertical Continuous Slider +vSlider = slider False +hiSlider, viSlider :: Integral a => a -> (a, a) -> a -> UISF () a +-- | Horizontal Discrete Slider +hiSlider = iSlider True +-- | Vertical Discrete Slider +viSlider = iSlider False + +slider :: RealFrac a => Bool -> (a, a) -> a -> UISF () a +slider hori (min, max) = mkSlider hori v2p p2v jump + where + v2p v w = truncate ((v - min) / (max - min) * fromIntegral w) + p2v p w = + let v = min + (fromIntegral (p - padding) / fromIntegral w * (max - min)) + in if v < min then min else if v > max then max else v + jump d w v = + let v' = v + fromIntegral d * (max - min) * 16 / fromIntegral w + in if v' < min then min else if v' > max then max else v' + +iSlider :: Integral a => Bool -> a -> (a, a) -> a -> UISF () a +iSlider hori step (min, max) = mkSlider hori v2p p2v jump + where + v2p v w = w * fromIntegral (v - min) `div` fromIntegral (max - min) + p2v p w = + let v = min + fromIntegral (round (fromIntegral (max - min) * + fromIntegral (p - padding) / fromIntegral w)) + in if v < min then min else if v > max then max else v + jump d _w v = + let v' = v + step * fromIntegral d + in if v' < min then min else if v' > max then max else v' + + +--------------------- +-- *** Graphs +--------------------- + +--------------------- +-- Real Time Graph -- +--------------------- +-- | The realtimeGraph widget creates a graph of the data with trailing values. +-- It takes a dimension parameter, the length of the history of the graph +-- measured in time, and a color for the graphed line. +-- The signal function then takes an input stream of time as well as +-- (value,time) event pairs, but since there can be zero or more points +-- at once, we use [] rather than 'SEvent' for the type. +-- The values in the (value,time) event pairs should be between -1 and 1. +realtimeGraph :: RealFrac a => Layout -> Time -> Color -> UISF [(a,Time)] () +realtimeGraph layout hist color = arr ((),) >>> first getTime >>> + mkWidget ([(0,0)],0) layout process draw + where draw _ _ ([], _) = nullGraphic + draw ((x,y), (w,h)) _ (lst@(_:_), t) = translateGraphic (x,y) $ + withColor color $ polyline (map (adjust t) lst) + where adjust t (i,t0) = (truncate $ fromIntegral w * (hist + t0 - t) / hist, + buffer + truncate (fromIntegral (h - 2*buffer) * (1 + i)/2)) + buffer = truncate $ fromIntegral h / 10 + removeOld _ [] = [] + removeOld t ((i,t0):is) = if t0+hist>=t then (i,t0):is else removeOld t is + process (t,is) (lst,_) _ _ = ((), (removeOld t (lst ++ is), t), True) + + + +--------------- +-- Histogram -- +--------------- +-- | The histogram widget creates a histogram of the input map. It assumes +-- that the elements are to be displayed linearly and evenly spaced. +histogram :: RealFrac a => Layout -> UISF (SEvent [a]) () +histogram layout = + mkWidget Nothing layout process draw + where process Nothing Nothing _ _ = ((), Nothing, False) + process Nothing (Just a) _ _ = ((), Just a, False) --TODO check if this should be True + process (Just a) _ _ _ = ((), Just a, True) + draw (xy, (w, h)) _ = translateGraphic xy . mymap (polyline . mkPts) + where mkPts l = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l) + xs n = [0,(w `div` (n-1))..w] + adjust i = buffer + truncate (fromIntegral (h - 2*buffer) * (1 - i)) + normalize lst = map (/m) lst where m = maximum lst + buffer = truncate $ fromIntegral h / 10 + mymap :: ([a] -> Graphic) -> SEvent [a] -> Graphic + mymap f (Just lst@(_:_)) = f lst + mymap _ _ = nullGraphic + +-- | The histogramWithScale widget creates a histogram and an x coordinate scale. +histogramWithScale :: RealFrac a => Layout -> UISF (SEvent [(a,String)]) () +histogramWithScale layout = + mkWidget Nothing layout process draw + where process Nothing Nothing _ _ = ((), Nothing, False) + process Nothing (Just a) _ _ = ((), Just a, False) --TODO check if this should be True + process (Just a) _ _ _ = ((), Just a, True) + draw (xy, (w, h)) _ = mymap (polyline . mkPts) mkScale + where mkPts l = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l) + xs n = [sidebuffer,(sidebuffer+((w-sidebuffer*2) `div` (n-1)))..(w-sidebuffer)] + adjust i = bottombuffer + truncate (fromIntegral (h - topbuffer - bottombuffer) * (1 - i)) + normalize lst = map (/m) lst where m = maximum lst + topbuffer = truncate $ fromIntegral h / 10 + bottombuffer = max 20 topbuffer + sidebuffer = 20 + mkScale l = foldl (\pg (x,s) -> translateGraphic xy (withColor Black (text (x-((8*length s) `div` 2), h-12) s)) // pg) + nullGraphic $ zip (xs $ length l) l + mymap :: ([a] -> Graphic) -> ([String] -> Graphic) -> SEvent [(a,String)] -> Graphic + mymap f g (Just lst@(_:_)) = let (fl,gl) = unzip lst in g gl // translateGraphic xy (f fl) + mymap _ _ _ = nullGraphic + + +------------------------------------------------------------ +-- * Widget Builders +------------------------------------------------------------ + +-- | mkWidget is a helper function to make stateful widgets easier to write. +-- In essence, it breaks down the idea of a widget into 4 constituent +-- components: state, layout, computation, and drawing. +-- +-- As 'mkWidget' allows for making stateful widgets, the first parameter is +-- simply the initial state. +-- +-- The layout is the static layout that this widget will use. It +-- cannot be dependent on any streaming arguments, but a layout can have +-- \"stretchy\" sides so that it can expand/shrink to fit an area. Learn +-- more about making layouts in 'UIMonad's UI Layout section -- specifically, +-- check out the 'makeLayout' function and the 'LayoutType' data type. +-- +-- The computation is where the logic of the widget is held. This +-- function takes as input the streaming argument a, the widget's state, +-- a Rect of coordinates indicating the area that has been allotted for +-- this widget, and the 'UIEvent' that is triggering this widget's activation +-- (see the definition of 'UIEvent' in SOE). The output consists of the +-- streaming output, the new state, and the dirty bit, which represents +-- whether the widget needs to be redrawn. +-- +-- Lastly, the drawing routine takes the same Rect as the computation, a +-- Bool that is true when this widget is in focus and false otherwise, +-- and the current state of the widget (technically, this state is the +-- one freshly returned from the computation). Its output is the Graphic +-- that this widget should display. + +mkWidget :: s -- ^ initial state + -> Layout -- ^ layout + -> (a -> s -> Rect -> UIEvent -> + (b, s, DirtyBit)) -- ^ computation + -> (Rect -> Bool -> s -> Graphic) -- ^ drawing routine + -> UISF a b +mkWidget i layout comp draw = proc a -> do + rec s <- delay i -< s' + (b, s') <- mkUISF aux -< (a, s) + returnA -< b + --loop $ second (delay i) >>> arr (uncurry inj) >>> mkUISF aux + where + aux (a,s) (ctx,f,t,e) = (layout, db, f, justGraphicAction g, nullCD, (b, s')) + where + rect = bounds ctx + (b, s', db) = comp a s rect e + g = draw rect (snd f == HasFocus) s' + +-- | Occasionally, one may want to display a non-interactive graphic in +-- the UI. 'mkBasicWidget' facilitates this. It takes a layout and a +-- simple drawing routine and produces a non-interacting widget. +mkBasicWidget :: Layout -- ^ layout + -> (Rect -> Graphic) -- ^ drawing routine + -> UISF a a +mkBasicWidget layout draw = mkUISF $ \a (ctx, f, _, _) -> + (layout, False, f, justGraphicAction (draw $ bounds ctx), nullCD, a) + + +-- | The toggle is useful in the creation of both 'checkbox'es and 'radio' +-- buttons. It displays on/off according to its input, and when the mouse +-- is clicked on it, it will output True (otherwise it outputs False). +-- +-- The UISF returned from a call to toggle accepts the state stream and +-- returns whether the toggle is being clicked. + +toggle :: (Eq s) => s -- ^ Initial state value + -> Layout -- ^ The layout for the toggle + -> (Rect -> Bool -> s -> Graphic) -- ^ The drawing routine + -> UISF s Bool +toggle iState layout draw = focusable $ + mkWidget iState layout process draw + where + process s s' _ e = (on, s, s /= s') + where + on = case e of + Button _ True True -> True + SKey ENTER _ True -> True + Key ' ' _ True -> True + _ -> False + +-- | The mkSlider widget builder is useful in the creation of all sliders. + +mkSlider :: Eq a => Bool -- ^ True for horizontal, False for vertical + -> (a -> Int -> Int) -- ^ A function for converting a value to a position + -> (Int -> Int -> a) -- ^ A function for converting a position to a value + -> (Int -> Int -> a -> a) -- ^ A function for determining how much to jump when + -- a click is on the slider but not the target + -> a -- ^ The initial value for the slider + -> UISF () a +mkSlider hori val2pos pos2val jump val0 = focusable $ + mkWidget (val0, Nothing) d process draw + where + rotP p@(x,y) ((bx,by),_) = if hori then p else (bx + y - by, by + x - bx) + rotR r@(p,(w,h)) bbx = if hori then r else (rotP p bbx, (h,w)) + (minw, minh) = (16 + padding * 2, 16 + padding * 2) + (tw, th) = (16, 8) + d = if hori then makeLayout (Stretchy minw) (Fixed minh) + else makeLayout (Fixed minh) (Stretchy minw) + val2pt val ((bx,by), (bw,_bh)) = + let p = val2pos val (bw - padding * 2 - tw) + in (bx + p + padding, by + 8 - th `div` 2 + padding) + bar ((x,y),(w,_h)) = ((x + padding + tw `div` 2, y + 6 + padding), + (w - tw - padding * 2, 4)) + draw b inFocus (val, _) = + let p@(mx,my) = val2pt val (rotR b b) + in box popped (rotR (p, (tw, th)) b) + // whenG inFocus (box marked $ rotR (p, (tw-2, th-2)) b) + // withColor' bg (block $ rotR ((mx + 2, my + 2), (tw - 4, th - 4)) b) + // box pushed (rotR (bar (rotR b b)) b) + process _ (val, s) b evt = (val', (val', s'), val /= val') + where + (val', s') = case evt of + Button pt' True down -> let pt = rotP pt' bbx in + case (pt `inside` target, down) of + (True, True) -> (val, Just (ptDiff pt val)) + (_, False) -> (val, Nothing) + (False, True) | pt `inside` bar' -> clickonbar pt + _ -> (val, s) + MouseMove pt' -> let pt = rotP pt' bbx in + case s of + Just pd -> (pt2val pd pt, Just pd) + Nothing -> (val, s) + SKey LEFT _ True -> if hori then (jump (-1) bw val, s) else (val, s) + SKey RIGHT _ True -> if hori then (jump 1 bw val, s) else (val, s) + SKey UP _ True -> if hori then (val, s) else (jump (-1) bw val, s) + SKey DOWN _ True -> if hori then (val, s) else (jump 1 bw val, s) + SKey HOME _ True -> (pos2val 0 (bw - 2 * padding - tw), s) + SKey END _ True -> (pos2val bw (bw - 2 * padding - tw), s) + _ -> (val, s) + bbx@((bx,_by),(bw,_bh)) = rotR b b + bar' = let ((x,y),(w,h)) = bar bbx in ((x,y-4),(w,h+8)) + target = (val2pt val bbx, (tw, th)) + ptDiff (x,_) val = + let (x', y') = val2pt val bbx + in (x' + tw `div` 2 - x, y' + th `div` 2 - x) + pt2val (dx, _dy) (x,_y) = pos2val (x + dx - bx - tw `div` 2) (bw - 2 * padding - tw) + clickonbar (x',_y') = + let (x,_y) = val2pt val bbx + val' = jump (if x' < x then -1 else 1) bw val + in (val', s) + + +-- | Canvas displays any graphics. The input is a signal of graphics +-- events because we only want to redraw the screen when the input +-- is there. +canvas :: Dimension -> UISF (SEvent Graphic) () +canvas (w, h) = mkWidget nullGraphic layout process draw + where + layout = makeLayout (Fixed w) (Fixed h) + draw ((x,y),(w,h)) _ = translateGraphic (x,y) + process (Just g) _ _ _ = ((), g, True) + process Nothing g _ _ = ((), g, False) + +-- | canvas' uses a layout and a graphic generator. This allows it to +-- behave similarly to 'canvas', but it can adjust in cases with stretchy layouts. +canvas' :: Layout -> (a -> Dimension -> Graphic) -> UISF (SEvent a) () +canvas' layout draw = mkWidget Nothing layout process drawit + where + drawit (pt, dim) _ = maybe nullGraphic (\a -> translateGraphic pt $ draw a dim) + process (Just a) _ _ _ = ((), Just a, True) + process Nothing a _ _ = ((), a, False) + + +--------------- +-- Cycle Box -- +--------------- +-- | cyclebox is a clickable widget that cycles through a predefined set +-- set of appearances/output values. +cyclebox :: Layout -> [(Rect -> Bool -> Graphic, b)] -> Int -> UISF () b +cyclebox d lst start = focusable $ + mkWidget start d process draw + where + len = length lst + incr i = (i+1) `mod` len + draw b inFocus i = (fst (lst!!i)) b inFocus + process _ i b evt = (snd (lst!!i'), i', i /= i') + where + i' = case evt of + Button _ True True -> incr i + SKey ENTER _ True -> incr i + Key ' ' _ True -> incr i + _ -> i + +-- | cyclebox' is a cyclebox that additionally accepts input events that +-- can set it to a particular appearance/output. +cyclebox' :: Layout -> [(Rect -> Bool -> Graphic, b)] -> Int -> UISF (SEvent Int) b +cyclebox' d lst start = focusable $ + mkWidget start d process draw + where + len = length lst + incr i = (i+1) `mod` len + draw b inFocus i = (fst (lst!!i)) b inFocus + process ei i b evt = (snd (lst!!i'), i', i /= i') + where + j = fromMaybe i ei + i' = case evt of + Button _ True True -> incr j + SKey ENTER _ True -> incr j + Key ' ' _ True -> incr j + _ -> j + + +------------------------------------------------------------ +-- * Focus +------------------------------------------------------------ + +-- $ Any widget that wants to accept mouse button clicks or keystrokes +-- must be focusable. The focusable function below achieves this. + +-- | Making a widget focusable makes it accessible to tabbing and allows +-- it to see any mouse button clicks and keystrokes when it is actually +-- in focus. +focusable :: UISF a b -> UISF a b +focusable widget = proc x -> do + rec hasFocus <- delay False -< hasFocus' + (y, hasFocus') <- compressUISF (h widget) -< (x, hasFocus) + returnA -< y + where + h w (a, hasFocus) (ctx, (myid,focus),t, inp) = do + lshift <- isKeyPressed LSHIFT + rshift <- isKeyPressed RSHIFT + let isShift = lshift || rshift + (f, hasFocus') = case (focus, hasFocus, inp) of + (HasFocus, _, _) -> (HasFocus, True) + (SetFocusTo n, _, _) | n == myid -> (NoFocus, True) + (_, _, 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 + inp' = if hasFocus' then (case inp of + SKey TAB _ _ -> NoUIEvent + _ -> inp) + else (case inp of + Button _ _ True -> NoUIEvent + Key _ _ _ -> NoUIEvent + SKey _ _ _ -> NoUIEvent + _ -> inp) + redraw = hasFocus /= hasFocus' + (l, db, _, act, tids, (b, w')) <- expandUISF w a (ctx, (myid,focus'), t, inp') + return (l, db || redraw, (myid+1,f), act, tids, ((b, hasFocus'), compressUISF (h w'))) + +-- | Although mouse button clicks and keystrokes will be available once a +-- widget marks itself as focusable, the widget may also simply want to +-- know whether it is currently in focus to change its appearance. This +-- can be achieved with the following signal function. +isInFocus :: UISF () Bool +isInFocus = getFocusData >>> arr ((== HasFocus) . snd) + + +------------------------------------------------------------ +-- UI colors and drawing routine +------------------------------------------------------------ + +bg, gray0, gray1, gray2, gray3, blue3 :: RGB +bg = rgb 0xec 0xe9 0xd8 +gray0 = rgb 0xff 0xff 0xff +gray1 = rgb 0xf1 0xef 0xe2 +gray2 = rgb 0xac 0xa8 0x99 +gray3 = rgb 0x71 0x6f 0x64 +blue3 = rgb 0x31 0x3c 0x79 + +box :: [(RGB,RGB)] -> Rect -> Graphic +box [] _ = nullGraphic +box ((t, b):cs) ((x, y), (w, h)) = + box cs ((x + 1, y + 1), (w - 2, h - 2)) + // withColor' t (line (x, y) (x, y + h - 1) + // line (x, y) (x + w - 2, y)) + // withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) + // line (x + w - 1, y) (x + w - 1, y + h - 1)) + +circle :: RGB -> Point -> Dimension -> Dimension -> Graphic +circle c (x, y) (w1, h1) (w2, h2) = + withColor' c $ arc (x + padding + w1, y + padding + h1) + (x + padding + w2, y + padding + h2) 0 360 + +block :: Rect -> Graphic +block ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)] + +pushed, popped, marked :: [(RGB,RGB)] +pushed = [(gray2, gray0),(gray3, gray1)] +popped = [(gray1, gray3),(gray0, gray2)] +marked = [(gray2, gray0),(gray0, gray2)] + +inside :: Point -> Rect -> Bool +inside (u, v) ((x, y), (w, h)) = u >= x && v >= y && u < x + w && v < y + h +
− FRP/UISF/Widget.lhs
@@ -1,708 +0,0 @@-A simple Graphical User Interface based on FRP. It uses the SOE -graphics library, and draws custom widgets on the screen. - -SOE graphics uses OpenGL as the primitive drawing routine, and -GLFW library to provide window and input support. - -The monadic UI concept is borrowed from Phooey by Conal Elliott. - -> {-# LANGUAGE DoRec, Arrows, TupleSections #-} - -> module FRP.UISF.Widget where - -> import FRP.UISF.SOE -> import FRP.UISF.UIMonad -> import FRP.UISF.UISF -> import FRP.UISF.AuxFunctions (SEvent, Time, timer, edge, delay, constA, concatA) - -> import Control.Arrow - - -============================================================ -============== Shorthand and Helper Functions ============== -============================================================ - -Default padding between border and content - -> padding :: Int -> padding = 3 - -Introduce a shorthand for overGraphic - -> (//) :: Graphic -> Graphic -> Graphic -> (//) = overGraphic - -And a nice way to make a graphic under only certain conditions - -> whenG :: Bool -> Graphic -> Graphic -> whenG b g = if b then g else nullGraphic - - -mkWidget is a helper function to make stateful widgets easier to write. -In essence, it breaks down the idea of a widget into 4 constituent -components: state, layout, computation, and drawing. - -As mkWidget allows for making stateful widgets, the first parameter is -simply the initial state. - -The layout is the static layout that this widget will use. It -cannot be dependent on any streaming arguments, but a layout can have -``stretchy'' sides so that it can expand/shrink to fit an area. Learn -more about making layouts in UIMonad's UI Layout section -- specifically, -check out the makeLayout function and the LayoutType data type. - -The computation is where the logic of the widget is held. This -function takes as input the streaming argument a, the widget's state, -a Rect of coordinates indicating the area that has been allotted for -this widget, and the UIEvent that is triggering this widget's activation -(see the definition of UIEvent in SOE). The output consists of the -streaming output, the new state, and the dirty bit, which represents -whether the widget needs to be redrawn. - -Lastly, the drawing routine takes the same Rect as the computation, a -Bool that is true when this widget is in focus and false otherwise, -and the current state of the widget (technically, this state is the -one freshly returned from the computation). Its output is the Graphic -that this widget should display. - -> mkWidget :: s -- initial state -> -> Layout -- layout -> -> (a -> s -> Rect -> UIEvent -> -- computation -> (b, s, DirtyBit)) -> -> (Rect -> Bool -> s -> Graphic) -- drawing routine -> -> UISF a b -> mkWidget i layout comp draw = proc a -> do -> rec s <- delay i -< s' -> (b, s') <- mkUISF aux -< (a, s) -> returnA -< b -> --loop $ second (delay i) >>> arr (uncurry inj) >>> mkUISF aux -> where -> aux (a,s) (ctx,f,t,e) = (layout, db, f, justGraphicAction g, nullCD, (b, s')) -> where -> rect = bounds ctx -> (b, s', db) = comp a s rect e -> g = draw rect (snd f == HasFocus) s' - -Occasionally, one may want to display a non-interactive graphic in -the UI: mkBasicWidget facilitates this. It takes a layout and a -simple drawing routine and produces a non-interacting widget. - -> mkBasicWidget :: Layout -- layout -> -> (Rect -> Graphic) -- drawing routine -> -> UISF a a -> mkBasicWidget layout draw = mkUISF $ \a (ctx, f, _, _) -> -> (layout, False, f, justGraphicAction (draw $ bounds ctx), nullCD, a) - - -============================================================ -========================= Widgets ========================== -============================================================ - ----------------- - | Text Label | ----------------- -Labels are always left aligned and vertically centered. - -> label :: String -> UISF a a -> label s = mkBasicWidget layout draw -> 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 - ------------------ - | Display Box | ------------------ -DisplayStr is an output widget showing the instantaneous value of -a signal of strings. - -> displayStr :: UISF String () -> displayStr = mkWidget "" d (\v v' _ _ -> ((), v, v /= v')) draw -> where -> minh = 16 + padding * 2 -> d = makeLayout (Stretchy 8) (Fixed minh) -> draw b@((x,y), (w, _h)) _ s = -> let n = (w - padding * 2) `div` 8 -> in withColor Black (text (x + padding, y + padding) (take n s)) -> // box pushed b -> // withColor White (block b) - -display is a widget that takes any show-able value and displays it. - -> display :: Show a => UISF a () -> display = arr show >>> displayStr - -withDisplay is a widget modifier that modifies the given widget -so that it also displays its output value. - -> withDisplay :: Show b => UISF a b -> UISF a b -> withDisplay sf = proc a -> do -> b <- sf -< a -> display -< b -> returnA -< b - - --------------- - | Text Box | --------------- -Textbox is a widget showing the instantaneous value of a signal of -strings. It takes one static arguments: - startingVal - The initial value in the textbox - -The textbox widget will often be used with ArrowLoop (the rec keyword). -However, it uses delay internally, so there should be no fear of a blackhole. - -The textbox widget supports mouse clicks and typing as well as the -left, right, end, home, delete, and backspace special keys. - -> textboxE :: String -> UISF (SEvent String) String -> textboxE startingVal = proc ms -> do -> rec s' <- delay startingVal -< ts -> let s = maybe s' id ms -> ts <- textbox -< maybe s id ms -> returnA -< ts - -> textbox :: UISF String String -> textbox = focusable $ -> conjoin $ proc s -> do -> inFocus <- isInFocus -< () -> k <- getEvents -< () -> ctx <- getCTX -< () -> rec let (s', i) = if inFocus then update s iPrev ctx k else (s, iPrev) -> iPrev <- delay 0 -< i -> displayStr -< seq i s' -> inf <- delay False -< inFocus -> b <- if inf then timer -< 0.5 else returnA -< Nothing -> b' <- edge -< not inFocus --For use in drawing the cursor -> rec willDraw <- delay True -< willDraw' -> let willDraw' = maybe willDraw (const $ not willDraw) b --if isJust b then not willDraw else willDraw -> canvas' displayLayout drawCursor -< case (inFocus, b, b', i == iPrev) of -> (True, Just _, _, _) -> Just (willDraw, i) -> (True, _, _, False) -> Just (willDraw, i) -> (False, _, Just _, _) -> Just (False, i) -> _ -> Nothing -> returnA -< s' -> where -> minh = 16 + padding * 2 -> displayLayout = makeLayout (Stretchy 8) (Fixed minh) -> update s i _ (Key c _ True) = (take i s ++ [c] ++ drop i s, i+1) -> update s i _ (SKey BACKSPACE _ True) = (take (i-1) s ++ drop i s, max (i-1) 0) -> update s i _ (SKey DEL _ True) = (take i s ++ drop (i+1) s, i) -> update s i _ (SKey LEFT _ True) = (s, max (i-1) 0) -> update s i _ (SKey RIGHT _ True) = (s, min (i+1) (length s)) -> update s _i _ (SKey END _ True) = (s, length s) -> update s _i _ (SKey HOME _ True) = (s, 0) -> update s _i c (Button (x,_) True True) = (s, min (length s) $ (x - xoffset c) `div` 8) -> update s i _ _ = (s, max 0 $ min i $ length s) -> drawCursor (False, _) _ = nullGraphic -> drawCursor (True, i) (w,_h) = -> let linew = padding + i*8 -> in if linew > w then nullGraphic else withColor Black $ -> line (linew, padding) (linew, 16+padding) -> xoffset = fst . fst . bounds - - ------------ - | Title | ------------ -Title frames a UI by borders, and displays a static title text. - -> title :: String -> UISF a b -> UISF a b -> title l uisf = compressUISF (modsf uisf) -> where -> (tw, th) = (length l * 8, 16) -> drawit ((x, y), (w, h)) g = -> withColor Black (text (x + 10, y) l) -> // withColor' bg (block ((x + 8, y), (tw + 4, th))) -> // box marked ((x, y + 8), (w, h - 16)) -> // g -> modsf sf a (CTX _ bbx@((x,y), (w,h)) _,f,t,inp) = do -> (l,db,f',action,ts,(v,nextSF)) <- expandUISF sf a (CTX TopDown ((x + 4, y + 20), (w - 8, h - 32)) -> False, f, t, inp) -> let d = l { hFixed = hFixed l + 8, vFixed = vFixed l + 36, -> minW = max (tw + 20) (minW l), minH = max 36 (minH l) } -> return (d, db, f', first (drawit bbx) action, ts, (v,compressUISF (modsf nextSF))) - - ------------- - | Button | ------------- -A button is a focusable input widget with a state of being on or off. -It can be activated with either a button press or the enter key. -(Currently, there is no support for the space key due to non-special - keys not having Release events.) -Buttons also show a static label. - -The regular button is down as long as the mouse button or key press is -down and then returns to up. The sticky button, on the other hand, once -pressed, remains depressed until is is clicked again to be released. -Thus, it looks like a button, but it behaves more like a checkbox. - -> button :: String -> UISF () Bool -> button = genButton False - -> stickyButton :: String -> UISF () Bool -> stickyButton = genButton True - -> genButton :: Bool -> String -> UISF () Bool -> genButton sticky l = focusable $ -> mkWidget False d (if sticky then processSticky else processRegular) draw -> where -> (tw, th) = (8 * length l, 16) -> (minw, minh) = (tw + padding * 2, th + padding * 2) -> d = makeLayout (Stretchy minw) (Fixed minh) -> draw b@((x,y), (w,h)) inFocus down = -> let x' = x + (w - tw) `div` 2 + if down then 0 else -1 -> y' = y + (h - th) `div` 2 + if down then 0 else -1 -> in withColor Black (text (x', y') l) -> // whenG inFocus (box marked b) -> // box (if down then pushed else popped) b -> processRegular _ s b evt = (s', s', s /= s') -> where -> s' = case evt of -> Button _ True down -> case (s, down) of -> (False, True) -> True -> (True, False) -> False -> _ -> s -> MouseMove pt -> (pt `inside` b) && s -> SKey ENTER _ down -> down -> Key ' ' _ down -> down -> _ -> s -> processSticky _ s _ evt = (s', s', s /= s') -> where -> s' = case evt of -> Button _ True True -> not s -> SKey ENTER _ True -> not s -> Key ' ' _ True -> not s -> _ -> s - - ---------------- - | Check Box | ---------------- -Checkbox allows selection or deselection of an item. -It has a static label as well as an initial state. - -> checkbox :: String -> Bool -> UISF () Bool -> checkbox l state = proc _ -> do -> rec s <- delay state -< s' -> e <- edge <<< toggle state d draw -< s -> let s' = maybe s (const $ not s) e -> returnA -< s' -> where -> (tw, th) = (8 * length l, 16) -> (minw, minh) = (tw + padding * 2, th + padding * 2) -> d = makeLayout (Stretchy minw) (Fixed minh) -> draw ((x,y), (_w,h)) inFocus down = -> let x' = x + padding + 16 -> y' = y + (h - th) `div` 2 -> b = ((x + padding + 2, y + h `div` 2 - 6), (12, 12)) -> in withColor Black (text (x', y') l) -> // whenG inFocus (box marked b) -> // whenG down -> (withColor' gray3 $ polyline -> [(x + padding + 5, y + h `div` 2), -> (x + padding + 7, y + h `div` 2 + 3), -> (x + padding + 11, y + h `div` 2 - 2)]) -> // box pushed b -> // withColor White (block b) - - --------------------- - | Checkbox Group | --------------------- -The checkGroup widget creates a group of check boxes that all send -their outputs to the same output stream. It takes a static list of -labels for the check boxes and assumes they all start unchecked. - -The output stream is a list of each a value that was paired with a -String value for which the check box is checked. - -checkGroup :: [String] -> UISF () [Bool] -checkGroup ss = constA (repeat ()) >>> - concatA (zipWith checkbox ss (repeat False)) - -> checkGroup :: [(String, a)] -> UISF () [a] -> checkGroup sas = let (s, a) = unzip sas in -> constA (repeat ()) >>> -> concatA (zipWith checkbox s (repeat False)) >>> -> arr (map fst . filter snd . zip a) - - -------------------- - | Radio Buttons | -------------------- -Radio button presents a list of choices and only one of them can be -selected at a time. It takes a static list of choices (as Strings) -and the index of the initially selected one, and the widget itself -returns the continuous stream representing the index of the selected -choice. - -> radio :: [String] -> Int -> UISF () Int -> radio labels i = proc _ -> do -> rec s <- delay i -< s'' -> s' <- aux 0 labels -< s -> let s'' = maybe s id s' -> returnA -< s'' -> where -> aux :: Int -> [String] -> UISF Int (SEvent Int) -> aux _ [] = arr (const Nothing) -> aux j (l:ls) = proc n -> do -> u <- edge <<< toggle (i == j) d draw -< n == j -> v <- aux (j + 1) ls -< n -> returnA -< maybe v (const $ Just j) u -> where -> (tw, th) = (8 * length l, 16) -> (minw, minh) = (tw + padding * 2, th + padding * 2) -> d = makeLayout (Stretchy minw) (Fixed minh) -> draw ((x,y), (_w,h)) inFocus down = -> let x' = x + padding + 16 -> y' = y + (h - th) `div` 2 -> in withColor Black (text (x', y') l) -> // whenG down (circle gray3 (x,y) (5,6) (9,10)) -> // circle gray3 (x,y) (2,3) (12,13) -> // circle gray0 (x,y) (2,3) (13,14) -> // whenG inFocus (circle gray2 (x,y) (0,0) (14,15)) - - -------------- - | Sliders | -------------- - -Sliders are input widgets that allow the user to choose a value within -a given range. They come in both continous and discrete flavors as well -as in both vertical and horizontal layouts. - -Sliders take a boundary argument giving the minimum and maximum possible -values for the output as well as an initial value. In addition, discrete -(or integral) sliders take a step size as their first argument. - -> hSlider, vSlider :: RealFrac a => (a, a) -> a -> UISF () a -> hSlider = slider True -- Horizontal Continuous Slider -> vSlider = slider False -- Vertical Continuous Slider -> hiSlider, viSlider :: Integral a => a -> (a, a) -> a -> UISF () a -> hiSlider = iSlider True -- Horizontal Discrete Slider -> viSlider = iSlider False -- Vertical Discrete Slider - -> slider :: RealFrac a => Bool -> (a, a) -> a -> UISF () a -> slider hori (min, max) = mkSlider hori v2p p2v jump -> where -> v2p v w = truncate ((v - min) / (max - min) * fromIntegral w) -> p2v p w = -> let v = min + (fromIntegral (p - padding) / fromIntegral w * (max - min)) -> in if v < min then min else if v > max then max else v -> jump d w v = -> let v' = v + fromIntegral d * (max - min) * 16 / fromIntegral w -> in if v' < min then min else if v' > max then max else v' - -> iSlider :: Integral a => Bool -> a -> (a, a) -> a -> UISF () a -> iSlider hori step (min, max) = mkSlider hori v2p p2v jump -> where -> v2p v w = w * fromIntegral (v - min) `div` fromIntegral (max - min) -> p2v p w = -> let v = min + fromIntegral (round (fromIntegral (max - min) * -> fromIntegral (p - padding) / fromIntegral w)) -> in if v < min then min else if v > max then max else v -> jump d _w v = -> let v' = v + step * fromIntegral d -> in if v' < min then min else if v' > max then max else v' - - ---------------------- - | Real Time Graph | ---------------------- -The realtimeGraph widget creates a graph of the data with trailing values. -It takes a dimension parameter, the length of the history of the graph -measured in time, and a color for the graphed line. -The signal function then takes an input stream of time as well as -(value,time) event pairs, but since there can be zero or more points -at once, we use [] rather than SEvent for the type. -The values in the (value,time) event pairs should be between -1 and 1. - -> realtimeGraph :: RealFrac a => Layout -> Time -> Color -> UISF [(a,Time)] () -> realtimeGraph layout hist color = arr ((),) >>> first getTime >>> -> mkWidget ([(0,0)],0) layout process draw -> where draw _ _ ([], _) = nullGraphic -> draw ((x,y), (w,h)) _ (lst@(_:_), t) = translateGraphic (x,y) $ -> withColor color $ polyline (map (adjust t) lst) -> where adjust t (i,t0) = (truncate $ fromIntegral w * (hist + t0 - t) / hist, -> buffer + truncate (fromIntegral (h - 2*buffer) * (1 + i)/2)) -> buffer = truncate $ fromIntegral h / 10 -> removeOld _ [] = [] -> removeOld t ((i,t0):is) = if t0+hist>=t then (i,t0):is else removeOld t is -> process (t,is) (lst,_) _ _ = ((), (removeOld t (lst ++ is), t), True) - - - ---------------- - | Histogram | ---------------- -The histogram widget creates a histogram of the input map. It assumes -that the elements are to be displayed linearly and evenly spaced. - -> histogram :: RealFrac a => Layout -> UISF (SEvent [a]) () -> histogram layout = -> mkWidget Nothing layout process draw -> where process Nothing Nothing _ _ = ((), Nothing, False) -> process Nothing (Just a) _ _ = ((), Just a, False) --TODO check if this should be True -> process (Just a) _ _ _ = ((), Just a, True) -> draw (xy, (w, h)) _ = translateGraphic xy . mymap (polyline . mkPts) -> where mkPts l = zip (xs $ length l) (map adjust . normalize . reverse $ l) -> xs n = reverse $ map truncate [0,(fromIntegral w / fromIntegral (n-1))..(fromIntegral w)] -> adjust i = buffer + truncate (fromIntegral (h - 2*buffer) * (1 - i)) -> normalize lst = map (/m) lst where m = maximum lst -> buffer = truncate $ fromIntegral h / 10 -> mymap :: ([a] -> Graphic) -> SEvent [a] -> Graphic -> mymap f (Just lst@(_:_)) = f lst -> mymap _ _ = nullGraphic - - --------------- - | List Box | --------------- -The listbox widget creates a box with selectable entries. -The input stream is the list of entries as well as which entry is -currently selected, and the output stream is the index of the newly -selected entry. Note that the index can be greater than the length -of the list (simply indicating no choice selected). - -> listbox :: (Eq a, Show a) => UISF ([a], Int) Int -> listbox = focusable $ mkWidget ([], -1) layout process draw >>> delay (-1) -> where -> layout = makeLayout (Stretchy 80) (Stretchy 16) -> -- takes the rectangle to draw in and a tuple of the list of choices and the index selected -> lineheight = 16 -> --draw :: Show a => Rect -> ([a], Int) -> Graphic -> draw rect@(_,(w,_h)) _ (lst, i) = -> genTextGraphic rect i lst -> // box pushed rect -> // withColor White (block rect) -> where -> n = (w - padding * 2) `div` 8 -> genTextGraphic _ _ [] = nullGraphic -> genTextGraphic ((x,y),(w,h)) i (v:vs) = (if i == 0 -> then withColor White (text (x + padding, y + padding) (take n (show v))) -> // withColor Blue (block ((x,y),(w,lineheight))) -> else withColor Black (text (x + padding, y + padding) (take n (show v)))) -> // genTextGraphic ((x,y+lineheight),(w,h-lineheight)) (i - 1) vs -> process :: Eq a => ([a], Int) -> ([a], Int) -> Rect -> UIEvent -> (Int, ([a], Int), Bool) -> process (lst,i) olds bbx e = (i', (lst, i'), olds /= (lst, i')) -> where -> i' = case e of -> Button pt True True -> boundCheck $ pt2index pt -> SKey DOWN _ True -> min (i+1) (length lst - 1) -> SKey UP _ True -> max (i-1) 0 -> SKey HOME _ True -> 0 -> SKey END _ True -> length lst - 1 -> _ -> boundCheck i -> ((_,y),_) = bbx -> pt2index (_px,py) = (py-y) `div` lineheight -> boundCheck j = if j >= length lst then -1 else j - - -============================================================ -===================== Widget Builders ====================== -============================================================ - ----------------------- - | Toggle | ----------------------- -The toggle is useful in the creation of both checkboxes and radio -buttons. It displays on/off according to its input, and when the mouse -is clicked on it, it will output True (otherwise it outputs False). - -The UISF returned from a call to toggle accepts the state stream and -returns whether the toggle is being clicked. - -> toggle :: (Eq s) => s -- Initial state value -> -> Layout -- The layout for the toggle -> -> (Rect -> Bool -> s -> Graphic) -- The drawing routine -> -> UISF s Bool -> toggle iState layout draw = focusable $ -> mkWidget iState layout process draw -> where -> process s s' _ e = (on, s, s /= s') -> where -> on = case e of -> Button _ True True -> True -> SKey ENTER _ True -> True -> Key ' ' _ True -> True -> _ -> False - --------------- - | mkSlider | --------------- -The mkSlider widget builder is useful in the creation of all sliders. - -> mkSlider :: Eq a => Bool -- True for horizontal, False for vertical -> -> (a -> Int -> Int) -- A function for converting a value to a position -> -> (Int -> Int -> a) -- A function for converting a position to a value -> -> (Int -> Int -> a -> a) -- A function for determining how much to jump when -> -- a click is on the slider but not the target -> -> a -- The initial value for the slider -> -> UISF () a -> mkSlider hori val2pos pos2val jump val0 = focusable $ -> mkWidget (val0, Nothing) d process draw -> where -> rotP p@(x,y) ((bx,by),_) = if hori then p else (bx + y - by, by + x - bx) -> rotR r@(p,(w,h)) bbx = if hori then r else (rotP p bbx, (h,w)) -> (minw, minh) = (16 + padding * 2, 16 + padding * 2) -> (tw, th) = (16, 8) -> d = if hori then makeLayout (Stretchy minw) (Fixed minh) -> else makeLayout (Fixed minh) (Stretchy minw) -> val2pt val ((bx,by), (bw,_bh)) = -> let p = val2pos val (bw - padding * 2 - tw) -> in (bx + p + padding, by + 8 - th `div` 2 + padding) -> bar ((x,y),(w,_h)) = ((x + padding + tw `div` 2, y + 6 + padding), -> (w - tw - padding * 2, 4)) -> draw b inFocus (val, _) = -> let p@(mx,my) = val2pt val (rotR b b) -> in box popped (rotR (p, (tw, th)) b) -> // whenG inFocus (box marked $ rotR (p, (tw-2, th-2)) b) -> // withColor' bg (block $ rotR ((mx + 2, my + 2), (tw - 4, th - 4)) b) -> // box pushed (rotR (bar (rotR b b)) b) -> process _ (val, s) b evt = (val', (val', s'), val /= val') -> where -> (val', s') = case evt of -> Button pt' True down -> let pt = rotP pt' bbx in -> case (pt `inside` target, down) of -> (True, True) -> (val, Just (ptDiff pt val)) -> (_, False) -> (val, Nothing) -> (False, True) | pt `inside` bar' -> clickonbar pt -> _ -> (val, s) -> MouseMove pt' -> let pt = rotP pt' bbx in -> case s of -> Just pd -> (pt2val pd pt, Just pd) -> Nothing -> (val, s) -> SKey LEFT _ True -> if hori then (jump (-1) bw val, s) else (val, s) -> SKey RIGHT _ True -> if hori then (jump 1 bw val, s) else (val, s) -> SKey UP _ True -> if hori then (val, s) else (jump (-1) bw val, s) -> SKey DOWN _ True -> if hori then (val, s) else (jump 1 bw val, s) -> SKey HOME _ True -> (pos2val 0 (bw - 2 * padding - tw), s) -> SKey END _ True -> (pos2val bw (bw - 2 * padding - tw), s) -> _ -> (val, s) -> bbx@((bx,_by),(bw,_bh)) = rotR b b -> bar' = let ((x,y),(w,h)) = bar bbx in ((x,y-4),(w,h+8)) -> target = (val2pt val bbx, (tw, th)) -> ptDiff (x,_) val = -> let (x', y') = val2pt val bbx -> in (x' + tw `div` 2 - x, y' + th `div` 2 - x) -> pt2val (dx, _dy) (x,_y) = pos2val (x + dx - bx - tw `div` 2) (bw - 2 * padding - tw) -> clickonbar (x',_y') = -> let (x,_y) = val2pt val bbx -> val' = jump (if x' < x then -1 else 1) bw val -> in (val', s) - ------------- - | Canvas | ------------- -Canvas displays any graphics. The input is a signal of graphics -event because we only want to redraw the screen when the input -is there. - -> canvas :: Dimension -> UISF (SEvent Graphic) () -> canvas (w, h) = mkWidget nullGraphic layout process draw -> where -> layout = makeLayout (Fixed w) (Fixed h) -> draw ((x,y),(w,h)) _ = translateGraphic (x,y) -> process (Just g) _ _ _ = ((), g, True) -> process Nothing g _ _ = ((), g, False) - -canvas' uses a layout and a graphic generator which allows canvas to be -used in cases with stretchy layouts. - -> canvas' :: Layout -> (a -> Dimension -> Graphic) -> UISF (SEvent a) () -> canvas' layout draw = mkWidget Nothing layout process drawit -> where -> drawit (pt, dim) _ = maybe nullGraphic (\a -> translateGraphic pt $ draw a dim) -> process (Just a) _ _ _ = ((), Just a, True) -> process Nothing a _ _ = ((), a, False) - - -============================================================ -======================== Focus Stuff ======================= -============================================================ - -Any widget that wants to accept mouse button clicks or keystrokes -must be focusable. The focusable function below achieves this. - -Making a widget focusable makes it accessible to tabbing and allows -it to see any mouse button clicks and keystrokes when it is actually -in focus. - -> focusable :: UISF a b -> UISF a b -> focusable widget = proc x -> do -> rec hasFocus <- delay False -< hasFocus' -> (y, hasFocus') <- compressUISF (h widget) -< (x, hasFocus) -> returnA -< y -> where -> h w (a, hasFocus) (ctx, (myid,focus),t, inp) = do -> lshift <- isKeyPressed LSHIFT -> rshift <- isKeyPressed RSHIFT -> let isShift = lshift || rshift -> (f, hasFocus') = case (focus, hasFocus, inp) of -> (HasFocus, _, _) -> (HasFocus, True) -> (SetFocusTo n, _, _) | n == myid -> (NoFocus, True) -> (_, _, 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 -> inp' = if hasFocus' then (case inp of -> SKey TAB _ _ -> NoUIEvent -> _ -> inp) -> else (case inp of -> Button _ _ True -> NoUIEvent -> Key _ _ _ -> NoUIEvent -> SKey _ _ _ -> NoUIEvent -> _ -> inp) -> redraw = hasFocus /= hasFocus' -> (l, db, _, act, tids, (b, w')) <- expandUISF w a (ctx, (myid,focus'), t, inp') -> return (l, db || redraw, (myid+1,f), act, tids, ((b, hasFocus'), compressUISF (h w'))) - -Although mouse button clicks and keystrokes will be available once a -widget marks itself as focusable, the widget may also simply want to -know whether it is currently in focus to change its appearance. This -can be achieved with the following signal function. - -> isInFocus :: UISF () Bool -> isInFocus = getFocusData >>> arr ((== HasFocus) . snd) - - -============================================================ -=============== UI colors and drawing routine ============== -============================================================ - -> bg, gray0, gray1, gray2, gray3, blue3 :: RGB -> bg = rgb 0xec 0xe9 0xd8 -> gray0 = rgb 0xff 0xff 0xff -> gray1 = rgb 0xf1 0xef 0xe2 -> gray2 = rgb 0xac 0xa8 0x99 -> gray3 = rgb 0x71 0x6f 0x64 -> blue3 = rgb 0x31 0x3c 0x79 - -> box :: [(RGB,RGB)] -> Rect -> Graphic -> box [] _ = nullGraphic -> box ((t, b):cs) ((x, y), (w, h)) = -> box cs ((x + 1, y + 1), (w - 2, h - 2)) -> // withColor' t (line (x, y) (x, y + h - 1) -> // line (x, y) (x + w - 2, y)) -> // withColor' b (line (x + 1, y + h - 1) (x + w - 1, y + h - 1) -> // line (x + w - 1, y) (x + w - 1, y + h - 1)) - -> circle :: RGB -> Point -> Dimension -> Dimension -> Graphic -> circle c (x, y) (w1, h1) (w2, h2) = -> withColor' c $ arc (x + padding + w1, y + padding + h1) -> (x + padding + w2, y + padding + h2) 0 360 - -> block :: Rect -> Graphic -> block ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)] - -> pushed, popped, marked :: [(RGB,RGB)] -> pushed = [(gray2, gray0),(gray3, gray1)] -> popped = [(gray1, gray3),(gray0, gray2)] -> marked = [(gray2, gray0),(gray0, gray2)] - -> inside :: Point -> Rect -> Bool -> inside (u, v) ((x, y), (w, h)) = u >= x && v >= y && u < x + w && v < y + h -
UISF.cabal view
@@ -1,9 +1,9 @@ name: UISF -version: 0.1.0.0 +version: 0.2.0.0 Cabal-Version: >= 1.8 license: BSD3 license-file: License -copyright: Copyright (c) 2013 Daniel Winograd-Cort +copyright: Copyright (c) 2014 Daniel Winograd-Cort category: GUI stability: experimental build-type: Simple @@ -17,6 +17,7 @@ extra-source-files: ReadMe.txt, FRP/UISF/Examples/EnableGUI.hs + FRP/UISF/Examples/SevenGuis.lhs FRP/UISF/Examples/Pinochle.hs FRP/UISF/Examples/fft.hs @@ -39,5 +40,5 @@ other-modules: build-depends: base >= 4 && < 5, containers, transformers, - arrows == 0.4.*, GLFW == 0.5.*, OpenGL == 2.8.*, - monadIO == 0.10.*, deepseq == 1.3.*, stm == 2.4.* + arrows >= 0.4, GLFW >= 0.5, OpenGL >= 2.8, + monadIO >= 0.10, deepseq >= 1.3, stm >= 2.4