UISF (empty) → 0.1.0.0
raw patch · 16 files changed
+3412/−0 lines, 16 filesdep +GLFWdep +OpenGLdep +arrowssetup-changed
Dependencies added: GLFW, OpenGL, arrows, base, containers, deepseq, monadIO, stm, transformers
Files
- FRP/UISF.hs +48/−0
- FRP/UISF/AuxFunctions.hs +482/−0
- FRP/UISF/Examples/Crud.hs +117/−0
- FRP/UISF/Examples/EnableGUI.hs +20/−0
- FRP/UISF/Examples/Examples.hs +101/−0
- FRP/UISF/Examples/Pinochle.hs +258/−0
- FRP/UISF/Examples/fft.hs +138/−0
- FRP/UISF/SOE.hs +698/−0
- FRP/UISF/Types/MSF.hs +137/−0
- FRP/UISF/UIMonad.lhs +267/−0
- FRP/UISF/UISF.lhs +280/−0
- FRP/UISF/Widget.lhs +708/−0
- License +30/−0
- ReadMe.txt +83/−0
- Setup.hs +2/−0
- UISF.cabal +43/−0
+ FRP/UISF.hs view
@@ -0,0 +1,48 @@+module FRP.UISF + ( -- UI functions + UISF + , 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) + , Dimension -- type Dimension = (Int, Int) + , topDown, bottomUp, leftRight, rightLeft -- :: UISF a b -> UISF a b + , setSize -- :: Dimension -> UISF a b -> UISF a b + , setLayout -- :: Layout -> UISF a b -> UISF a b + , pad -- :: (Int, Int, Int, Int) -> UISF a b -> UISF a b + , getTime -- :: UISF () Time + -- Widgets + , label -- :: String -> UISF a a + , displayStr -- :: UISF String () + , display -- :: Show a => UISF a () + , withDisplay -- :: Show b => UISF a b -> UISF a b + , textbox -- :: UISF String String + , textboxE -- :: String -> UISF (Event String) String + , title -- :: String -> UISF a b -> UISF a b + , button -- :: String -> UISF () Bool + , stickyButton -- :: String -> UISF () Bool + , checkbox -- :: String -> Bool -> UISF () Bool + , checkGroup -- :: [(String, a)] -> UISF () [a] + , radio -- :: [String] -> Int -> UISF () Int + , hSlider, vSlider -- :: RealFrac a => (a, a) -> a -> UISF () a + , 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]) () + , listbox -- :: (Eq a, Show a) => UISF ([a], Int) Int + , canvas -- :: Dimension -> UISF (Event Graphic) () + , canvas' -- :: Layout -> (a -> Dimension -> Graphic) -> UISF (Event a) () + -- Widget Utilities + , makeLayout -- :: LayoutType -> LayoutType -> Layout + , LayoutType (..) -- data LayoutType = Stretchy { minSize :: Int } | Fixed { fixedSize :: Int } + , Color (..) -- data Color = Black | Blue | Green | Cyan | Red | Magenta | Yellow | White + , module FRP.UISF.AuxFunctions + , module Control.Arrow + ) where + +import FRP.UISF.UIMonad +import FRP.UISF.UISF +import FRP.UISF.Widget +import FRP.UISF.SOE (Color (..)) + +import FRP.UISF.AuxFunctions +import Control.Arrow
+ FRP/UISF/AuxFunctions.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE Arrows, ScopedTypeVariables #-} + +module FRP.UISF.AuxFunctions ( + SEvent, Time, DeltaT, + ArrowTime, time, + constA, + edge, + accum, unique, + hold, now, + mergeE, (~++), + concatA, foldA, + delay, vdelay, fdelay, + vdelayC, fdelayC, + timer, genEvents, + BufferEvent (..), BufferControl, eventBuffer, + +-- (=>>), (->>), (.|.), +-- snapshot, snapshot_, + + Automaton(..), toAutomaton, msfiToAutomaton, + toMSF, toRealTimeMSF, + async +) where + +import Prelude +import Control.Arrow +import Control.Arrow.Operations +import Data.Sequence (Seq, empty, (<|), (|>), (><), + viewl, ViewL(..), viewr, ViewR(..)) +import qualified Data.Sequence as Seq +import Data.Maybe (listToMaybe) + +-- For use with MSF Conversions +import Control.Monad.Fix +import FRP.UISF.Types.MSF +import Data.Functor.Identity + +import Control.Concurrent.MonadIO +import Data.IORef.MonadIO +import Data.Foldable (toList) +import Control.DeepSeq + + +-------------------------------------- +-- Types +-------------------------------------- + +-- | SEvent is short for "Stream Event" and is a type synonym for Maybe +type SEvent = Maybe + +type Time = Double + +-- | DeltaT is a type synonym referring to a change in Time. +type DeltaT = Double + +-- | Instances of this class have arrowized access to the time +class ArrowTime a where + time :: a () Time + +-------------------------------------- +-- Useful SF Utilities (Mediators) +-------------------------------------- + +-- | constA is an arrowized version of const +constA :: Arrow a => c -> a b c +constA = arr . const + +-- | 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. +edge :: ArrowCircuit a => a Bool (SEvent ()) +edge = proc b -> do + prev <- delay False -< b + returnA -< if not prev && b then Just () else Nothing + +-- | The signal function (accum v) starts with the value v, but then +-- applies the function attached to the first event to that value +-- to get the next value, and so on. +accum :: ArrowCircuit a => b -> a (SEvent (b -> b)) b +accum x = proc f -> do + rec b <- delay x -< maybe b ($b) f + returnA -< b + +unique :: Eq e => ArrowCircuit a => a e (SEvent e) +unique = proc e -> do + prev <- delay Nothing -< Just e + returnA -< if prev == Just e then Nothing else Just e + +-- | hold is a signal function whose output starts as the value of the +-- static argument. This value is held until the first input event +-- happens, at which point it changes to the value attached to that +-- event, which it then holds until the next event, and so on. +hold :: ArrowCircuit a => b -> a (SEvent b) b +hold x = arr (fmap (const $)) >>> accum x + +-- | Now is a signal function that produces one event and then forever +-- after produces nothing. It is essentially an impulse function. +now :: ArrowCircuit a => a () (SEvent ()) +now = arr (const Nothing) >>> delay (Just ()) + +-- | mergeE merges two events with the given resolution function. +mergeE :: (a -> a -> a) -> SEvent a -> SEvent a -> SEvent a +mergeE _ Nothing Nothing = Nothing +mergeE _ le@(Just _) Nothing = le +mergeE _ Nothing re@(Just _) = re +mergeE resolve (Just l) (Just r) = Just (resolve l r) + +-- | A nice infix operator for merging event lists +(~++) :: SEvent [a] -> SEvent [a] -> SEvent [a] +(~++) = mergeE (++) + +-- | Returns n samples of type b from the input stream at a time, +-- updating after k samples. This function is good for chunking +-- data and is a critical component to fftA +quantize :: ArrowCircuit a => Int -> Int -> a b (SEvent [b]) +quantize n k = proc d -> do + rec (ds,c) <- delay ([],0) -< (take n (d:ds), c+1) + returnA -< if c >= n && c `mod` k == 0 then Just ds else Nothing + +concatA :: Arrow a => [a b c] -> a [b] [c] +concatA [] = arr $ const [] +concatA (sf:sfs) = proc (b:bs) -> do + c <- sf -< b + cs <- concatA sfs -< bs + returnA -< (c:cs) + +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 + [] -> returnA -< i + b:bs -> do + c <- sf -< b + d <- h -< bs + returnA -< merge c d + + +-------------------------------------- +-- Delays and Timers +-------------------------------------- + +-- | delay is a unit delay. It is exactly the delay from ArrowCircuit. + + +-- | fdelay is a delay function that delays for a fixed amount of time, +-- given as the static argument. It returns a signal function that +-- takes the current time and an event stream and delays the event +-- stream by the delay amount. +-- fdelay guarantees that the order of events in is the same as the +-- order of events out and that no event will be skipped. However, +-- if events are too densely packed in the signal (compared to the +-- clock rate of the underlying arrow), then some events may be +-- over delayed. +fdelay :: (ArrowTime a, ArrowCircuit a) => DeltaT -> a (SEvent b) (SEvent b) +fdelay d = proc e -> do + t <- time -< () + rec q <- delay empty -< maybe q' (\e' -> q' |> (t+d,e')) e + let (ret, q') = case viewl q of + EmptyL -> (Nothing, q) + (t0,e0) :< qs -> if t >= t0 then (Just e0, qs) else (Nothing, q) + returnA -< ret + +-- | vdelay is a delay function that delays for a variable amount of time. +-- It takes the current time, an amount of time to delay, and an event +-- stream and delays the event stream by the delay amount. +-- vdelay, like fdelay, guarantees that the order of events in is the +-- same as the order of events out and that no event will be skipped. +-- If the events are too dense or the delay argument drops too quickly, +-- some events may be over delayed. +vdelay :: (ArrowTime a, ArrowCircuit a) => a (DeltaT, SEvent b) (SEvent b) +vdelay = proc (d, e) -> do + t <- time -< () + rec q <- delay empty -< maybe q' (\e' -> q' |> (t,e')) e + let (ret, q') = case viewl q of + EmptyL -> (Nothing, q) + (t0,e0) :< qs -> if t-d >= t0 then (Just e0, qs) else (Nothing, q) + returnA -< ret + +-- | fdelayC is a continuous version of fdelay. It takes an initial value +-- to emit for the first dt seconds. After that, the delay will always +-- be accurate, but some data may be ommitted entirely. As such, it is +-- not advisable to use fdelayC for event streams where every event must +-- be processed (that's what fdelay is for). +fdelayC :: (ArrowTime a, ArrowCircuit a) => b -> DeltaT -> a b b +fdelayC i dt = proc v -> do + t <- time -< () + rec q <- delay empty -< q' |> (t+dt, v) -- this list has pairs of (emission time, value) + let (ready, rest) = Seq.spanl ((<= t) . fst) q + (ret, q') = case viewr ready of + EmptyR -> (i, rest) + _ :> (t', v') -> (v', (t',v') <| rest) + returnA -< ret + +-- | vdelayC is a continuous version of vdelay. It will always emit the +-- value that was produced dt seconds earlier (erring on the side of an +-- 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 +-- time that it can handle. This is to prevent a space leak. +-- +-- Implementation note: Rather than keep a single buffer, we keep two +-- sequences that act to produce a sort of lens for a buffer. qlow has +-- all the values that are older than what we currently need, and qhigh +-- has all of the newer ones. Obviously, as time moves forward and the +-- delay amount variably changes, values are moved back and forth between +-- these two sequences as necessary. +-- This should provide a slight performance boost. +vdelayC :: (ArrowTime a, ArrowCircuit a) => DeltaT -> b -> a (DeltaT, b) b +vdelayC maxDT i = proc (dt, v) -> do + t <- time -< () + rec (qlow, qhigh) <- delay (empty,empty) -< + (dropMostWhileL ((< t-maxDT) . fst) qlow', qhigh' |> (t, v)) + -- this is two lists with pairs of (initial time, value) + -- We construct four subsequences:, a, b, c, and d. They are ordered by time and we + -- have an invariant that a >< b >< c >< d is the entire buffer ordered by time. + let (b,a) = Seq.spanr ((> t-dt) . fst) qlow + (c,d) = Seq.spanl ((<= t-dt) . fst) qhigh + -- After the spans, the value we are looking for will be in either c or a. + (ret, qlow', qhigh') = case viewr c of + _ :> (t', v') -> (v', qlow >< c, d) + EmptyR -> case viewr a of + _ :> (t', v') -> (v', a, b >< qhigh) + EmptyR -> (i, a, b >< qhigh) + returnA -< ret + where + -- This function acts like a wrapper for Seq.dropWhileL that will never + -- leave the input queue empty (unless it started that way). At worst, + -- it will leave the queue with its rightmost (latest in time) element. + dropMostWhileL f q = if Seq.null q then empty else case viewl dq of + EmptyL -> Seq.singleton $ Seq.index q (Seq.length q - 1) + _ -> dq + where + dq = Seq.dropWhileL f q + +-- | timer is a variable duration timer. +-- This timer takes the current time as well as the (variable) time between +-- events and returns an SEvent steam. When the second argument is non-positive, +-- the output will be a steady stream of events. As long as the clock speed is +-- fast enough compared to the timer frequency, this should give accurate and +-- predictable output and stay synchronized with any other timer and with +-- time itself. +timer :: (ArrowTime a, ArrowCircuit a) => a DeltaT (SEvent ()) +timer = proc dt -> do + now <- time -< () + rec last <- delay 0 -< t' + let ret = now >= last + dt + t' = latestEventTime last dt now + returnA -< if ret then Just () else Nothing + where + latestEventTime last dt now | dt <= 0 = now + latestEventTime last dt now = + if now > last + dt + then latestEventTime (last+dt) dt now + else last + + +-- | genEvents is a timer that instead of returning unit events +-- returns the next element of the input list. When the input +-- list is empty, the output stream becomes all Nothing. +genEvents :: (ArrowTime a, ArrowCircuit a) => [b] -> a DeltaT (SEvent b) +genEvents lst = proc dt -> do + e <- timer -< dt + rec l <- delay lst -< maybe l (const $ drop 1 l) e + returnA -< maybe Nothing (const $ listToMaybe l) e + + +-------------------------------------- +-- Event buffer +-------------------------------------- + +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 +type Tempo = Double +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. +-- Just as MIDI files have events timed based +-- on ticks since the last event, the events here are timed based on +-- seconds since the last event. If an event is to occur 0.0 seconds +-- after the last event, then it is assumed to be played at the same +-- time as the last event, and all simultaneous events are emitted +-- at the same timestep. In addition to any events emitted, a +-- streaming Bool is emitted that is True if the buffer is empty and +-- False if the buffer is full (meaning that events will still come). +eventBuffer :: (ArrowTime a, ArrowCircuit a) => a (BufferControl b) (SEvent [b], Bool) +eventBuffer = proc (bc, doPlay, tempo) -> do + t <- time -< () + rec tprev <- delay 0 -< t --used to calculate dt, the change in time + buffer <- delay [] -< buffer''' --the buffer + let dt = tempo * (t-tprev) --dt will never be negative + buffer' = if doPlay then subTime buffer dt else buffer + buffer'' = maybe buffer' (update buffer') bc --update the buffer based on the control + (nextMsgs, buffer''') = if doPlay then getNextEvent buffer'' --get any events that are ready + else (Nothing, buffer'') + returnA -< (nextMsgs, null buffer''') + where + subTime :: [(DeltaT, b)] -> DeltaT -> [(DeltaT, b)] + subTime [] _ = [] + subTime ((bt,b):bs) dt = if bt < dt then (0,b):subTime bs (dt-bt) else (bt-dt,b):bs + getNextEvent :: [(DeltaT, b)] -> (SEvent [b], [(DeltaT, b)]) + getNextEvent buffer = + let (es,rest) = span ((<=0).fst) buffer + nextEs = map snd es + in if null buffer then (Nothing, []) + else (Just nextEs, rest) + update :: [(DeltaT, b)] -> BufferEvent b -> [(DeltaT, b)] + update _ Clear = [] + update b (SkipAhead dt) = skipAhead b dt + update b (AddData b') = merge b b' + update b (AddDataToEnd b') = b ++ b' + merge :: [(DeltaT, b)] -> [(DeltaT, b)] -> [(DeltaT, b)] + merge b [] = b + merge [] b = b + merge ((bt1,b1):bs1) ((bt2,b2):bs2) = if bt1 < bt2 + then (bt1,b1):merge bs1 ((bt2-bt1,b2):bs2) + else (bt2,b2):merge ((bt1-bt2,b1):bs1) bs2 + skipAhead :: [(DeltaT, b)] -> DeltaT -> [(DeltaT, b)] + skipAhead [] _ = [] + skipAhead b dt | dt <= 0 = b + skipAhead ((bt,b):bs) dt = if bt < dt + then skipAhead bs (dt-bt) + else (bt-dt,b):bs + + +-------------------------------------- +-- Yampa-style utilities +-------------------------------------- + +(=>>) :: SEvent a -> (a -> b) -> SEvent b +(=>>) = flip fmap +(->>) :: SEvent a -> b -> SEvent b +(->>) = flip $ fmap . const +(.|.) :: SEvent a -> SEvent a -> SEvent a +(.|.) = flip $ flip maybe Just + +snapshot :: SEvent a -> b -> SEvent (a,b) +snapshot = flip $ fmap . flip (,) +snapshot_ :: SEvent a -> b -> SEvent b +snapshot_ = flip $ fmap . const -- same as ->> + + + +-------------------------------------- +-- Signal Function 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 +-- 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'' +-- 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)) + +-- | toAutomaton lifts a pure function to an Automaton. +toAutomaton :: (a -> b) -> Automaton a b +toAutomaton f = g where g = Automaton $ \a -> (f a, g) + +-- | msfiToAutomaton lifts a pure MSF (i.e. one in the Identity monad) to +-- an Automaton. +msfiToAutomaton :: MSF Identity a b -> Automaton a b +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. +toMSF :: Monad m => Automaton a b -> MSF m a b +toMSF (Automaton f) = MSF $ return . second toMSF . f + +-- | The clockrate is the simulated rate of the input signal function. +-- The buffer is the amount of time the given signal function is +-- allowed to get ahead of real time. The threadHandler is where the +-- ThreadId of the forked thread is sent. +-- +-- The output signal function takes and returns values in real time. +-- The input must be paired with time, and 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. +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)] +toRealTimeMSF clockrate buffer threadHandler sf = 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 :: (a, Double) -> m ([(b, Double)], MSF m (a, Double) [(b, Double)]) + initFun (a, t) = do + inp <- newIORef a + out <- newIORef empty + timevar <- newEmptyMVar + tid <- liftIO $ forkIO $ worker inp out timevar 1 1 sf + threadHandler tid + sfFun inp out timevar (a, t) + -- sfFun communicates with the worker thread, sending it the input values + -- and collecting from it the output values. + sfFun :: IORef a -> IORef (Seq (b, Double)) -> MVar Double + -> (a, Double) -> m ([(b, Double)], MSF m (a, Double) [(b, Double)]) + sfFun inp out timevar (a, t) = do + writeIORef inp a -- send the worker the new input + tryPutMVar timevar t -- update the time for the worker + b <- atomicModifyIORef out $ Seq.spanl (\(_,t0) -> t >= t0) --collect ready results + return (toList b, MSF (sfFun inp out timevar)) + -- worker processes the inner, "simulated" signal function. + worker :: IORef a -> IORef (Seq (b, Double)) -> MVar Double + -> DeltaT -> Integer -> Automaton a b -> IO () + worker inp out timevar t count (Automaton sf) = do + a <- readIORef inp -- get the latest input + let (b, sf') = sf a -- do the calculation + s <- deepseq b $ atomicModifyIORef out (\s -> (s |> (b, fromIntegral count/clockrate), s)) + t' <- if Seq.length s > 0 && snd (seqLastElem s) >= t+buffer then takeMVar timevar else return t + 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 +-- 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 +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 + 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 ea = do + inp <- newChan + out <- newIORef empty + tid <- liftIO $ forkIO $ worker inp out sf + threadHandler tid + sfFun 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 + b <- atomicModifyIORef out seqRestHead -- collect any ready results + return (b, MSF (sfFun 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' + seqRestHead s = case viewl s of + EmptyL -> (s, Nothing) + a :< s' -> (s', Just a) +
+ FRP/UISF/Examples/Crud.hs view
@@ -0,0 +1,117 @@+-- Filename: crud.hs +-- Created by: Daniel Winograd-Cort +-- Created on: 11/21/2012 +-- Last Modified by: Daniel Winograd-Cort +-- Last Modified on: 12/10/2013 + +-- -- DESCRIPTION -- +-- This code was inspired by a blog post by Heinrich Apfelmus on +-- bidirectional data flow in GUIs: +-- http://apfelmus.nfshost.com/blog/2012/03/29-frp-three-principles-bidirectional-gui.html +-- +-- Here we use UISF to create a similar example using arrowized FRP. + + +{-# LANGUAGE Arrows, DoRec #-} +module FRP.UISF.Examples.Crud where +import FRP.UISF + +import Data.List (isInfixOf) +import Data.Char (toLower) + + +-- First we create types for the database and the entries for it + +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 + + +-- defaultnames is a default database for our example +defaultnames :: Database NameEntry +defaultnames = [ + NameEntry "Paul" "Hudak", + NameEntry "Dan" "Winograd-Cort", + NameEntry "Donya" "Quick"] + + +-- | This function will run the crud GUI with the default names. +crud = runUI (350, 400) "CRUD" (crudUISF defaultnames) +main = crud + +-- | This is the main function that creates the crud GUI. It takes an +-- initial database of names as an argument. +-- See notes below on the use of banana brackets and nested do blocks. +crudUISF :: Database NameEntry -> UISF () () +crudUISF initnamesDB = proc _ -> do + rec + fStr <- leftRight $ label "Filter text: " >>> textboxE "" -< Nothing + (i, db, fdb, nameStr, surnStr) <- (| leftRight (do + (i, db, fdb) <- (| topDown (do + rec i <- listbox -< (fdb, i') + db <- delay initnamesDB -< db' + let fdb = filter (filterFun fStr) db + returnA -< (i, db, fdb)) |) + (nameStr, surnStr) <- (| topDown (do + rec nameStr <- leftRight $ label "Name: " >>> textboxE "" -< nameStr' + surnStr <- leftRight $ label "Surname: " >>> textboxE "" -< surnStr' + let nameStr' = if previ == i then Nothing else Just $ firstName ((filter (filterFun fStr) db') `at` i') + surnStr' = if previ == i then Nothing else Just $ lastName ((filter (filterFun fStr) db') `at` i') + returnA -< (nameStr, surnStr)) |) + returnA -< (i, db, fdb, nameStr, surnStr)) |) + buttons <- leftRight $ (edge <<< button "Create") &&& + (edge <<< button "Delete") -< () + previ <- delay 0 -< i + let (db', i') = case buttons of + (Just _, Nothing) -> (db ++ [NameEntry nameStr surnStr], length fdb) + (Nothing, Just _) -> (deleteElem (filterFun fStr) i db, + if i == length fdb - 1 then length fdb - 2 else i) + _ -> (db, i) + returnA -< () + where + deleteElem _ _ [] = [] + deleteElem f i (x:xs) = case (f x, i == 0) of + (True, True) -> xs + (True, False) -> x:deleteElem f (i-1) xs + (False, _) -> x:deleteElem f i xs + 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 + + +-- If we don't care about formatting, this code simplifies a huge amount to: +-- crudUISF initnamesDB = proc _ -> do +-- rec +-- (fStr,fi) <- leftRight $ label "Filter text: " >>> cursoredTextbox False ("",0) -< (fStr,fi) +-- i <- listbox -< (fdb, i') +-- db <- delay initnamesDB -< db' +-- let fdb = filter (filterFun fStr) db +-- (nameStr, ni) <- leftRight $ label "Name: " >>> cursoredTextbox False "" -< (nameStr', ni) +-- (surnStr, si) <- leftRight $ label "Surname: " >>> cursoredTextbox False "" -< (surnStr', si) +-- let nameStr' = if previ == i' then nameStr else firstName ((filter (filterFun fStr) db') `at` i') +-- surnStr' = if previ == i' then surnStr else lastName ((filter (filterFun fStr) db') `at` i') +-- buttons <- leftRight $ (edge <<< button "Create") &&& +-- (edge <<< button "Delete") -< () +-- previ <- delay 0 -< i +-- let (db', i') = case buttons of +-- (True, False) -> (db ++ [NameEntry nameStr surnStr], length fdb) +-- (False, True) -> (deleteElem (filterFun fStr) i db, +-- if i == length fdb - 1 then length fdb - 2 else i) +-- _ -> (db, i) +-- returnA -< () +-- where +-- ... +-- +-- Clearly, this is much easier to read and clearer as to what is going on. +-- However, to keep the style entirely arrow-based, we are forced to inject +-- arrow transformers (here leftRight and topDown) to modify chunks of the +-- code. The banana brackets (| |) allow us to refrain from retyping the +-- "proc do" syntax, but in order to give other parts of the program access +-- to the variables created in the banana bracketed chunks, we require +-- extra (seemingly excessive) returnA commands at the end of each. + +
+ FRP/UISF/Examples/EnableGUI.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE ForeignFunctionInterface #-} +module EnableGUI(enableGUI) where + +import Data.Int +import Foreign + +type ProcessSerialNumber = Int64 + +foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 +foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () +foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () + +enableGUI = alloca $ \psn -> do + getCurrentProcess psn + cgsDefaultConnection + cpsEnableForegroundOperation psn + cpsSignalAppReady psn + cpsSetFrontProcess psn
+ FRP/UISF/Examples/Examples.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE Arrows #-}++-- Last modified by: Daniel Winograd-Cort+-- Last modified on: 5/25/2013++-- This file is a set of various UI examples showing off the features +-- of the various widgets in UISF.++module FRP.UISF.Examples.Examples where++import FRP.UISF+import FRP.UISF.SOE (withColor', rgb, polygon)++import Numeric (showHex)+import Data.Maybe (listToMaybe, catMaybes)++-- 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 +-- minus button with a counter that is adjusted by them.+buttonEx :: UISF () ()+buttonEx = title "Buttons" $ proc _ -> do+ (x,y) <- leftRight (proc _ -> do+ x <- edge <<< button "+" -< ()+ y <- edge <<< button "-" -< ()+ returnA -< (x, y)) -< ()+ rec v <- delay 0 -< (case (x,y) of+ (Just _, Nothing) -> v+1+ (Nothing, Just _) -> v-1+ _ -> v)+ display -< v++-- This example shows off the checkbox widgets.+checkboxEx :: UISF () ()+checkboxEx = title "Checkboxes" $ proc _ -> do+ x <- checkbox "Monday" False -< ()+ y <- checkbox "Tuesday" True -< ()+ z <- checkbox "Wednesday" True -< ()+ let v = bin x ++ bin y ++ bin z+ displayStr -< v+ where+ bin True = "1"+ bin False = "0"++-- This example shows off the radio button widget.+radioButtonEx :: UISF () ()+radioButtonEx = title "Radio Buttons" $ radio list 0 >>> arr (list!!) >>> displayStr+ where+ list = ["apple", "orange", "banana"]++-- 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 +-- widget. The canvas widget can be used to easily create custom graphics +-- in the GUI. Here, it is used to make a color swatch that is +-- controllable with RGB values by the sliders.+colorDemo :: UISF () ()+colorDemo = setSize (300, 220) $ title "Color" $ pad (4,0,4,0) $ leftRight $ proc _ -> do+ r <- newColorSlider "R" -< ()+ g <- newColorSlider "G" -< ()+ b <- newColorSlider "B" -< ()+ prevRGB <- delay (0,0,0) -< (r,g,b)+ changed <- delay True -< (r,g,b) == prevRGB+ let rect = withColor' (rgb r g b) (box ((0,0),d))+ pad (4,8,0,0) $ canvas d -< if changed then Just rect else Nothing+ where+ d = (170,170)+ newColorSlider l = title l $ topDown $ proc _ -> do+ v <- viSlider 16 (0,255) 0 -< ()+ _ <- displayStr -< showHex v ""+ returnA -< v+ box ((x,y), (w, h)) = polygon [(x, y), (x + w, y), (x + w, y + h), (x, y + h)]++-- This example shows off the textbox widget. Text can be typed in, and +-- that text is transferred to the display widget below when the button +-- is pressed.+textboxdemo :: UISF () ()+textboxdemo = proc _ -> do+ str <- leftRight $ label "Text: " >>> textboxE "" -< Nothing+ b <- button "Save text to below" -< ()+ rec str' <- delay "" -< if b then str else str'+ leftRight $ label "Saved value: " >>> displayStr -< str' + returnA -< ()++-- This is the main demo that incorporates all of the other examples +-- together (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 +-- elements, and pressing shift-tab cycles in reverse.+main :: IO ()+main = runUI (500,500) "UI Demo" $ + (leftRight $ (bottomUp $ timeEx >>> buttonEx) >>> checkboxEx >>> radioButtonEx) >>>+ (leftRight $ shoppinglist >>> colorDemo) >>> textboxdemo+
+ FRP/UISF/Examples/Pinochle.hs view
@@ -0,0 +1,258 @@+-- Author: Daniel Winograd-Cort +-- Date Created: unknown +-- Date Last Modified: 12/12/2013 + +-- This is a pinochle assistant. The user enters his hand at the GUI +-- and selects his preferred trump suit, and his meld is displayed. +-- If the user chooses a kitty size, he can calculate his potential +-- meld from the kitty. + +-- The kitty meld currently displays the mean expected meld and the +-- max in the form: +-- "# of kitties that produce this much meld"x"meld value":[best possible kitties] + +-- This module requires the array package. + +-- make sure to use "ghc --make -O2 pinochle.hs" for pest performance + +{-# LANGUAGE Arrows, BangPatterns #-} +module FRP.UISF.Examples.Pinochle where +import FRP.UISF hiding (accum) + +import Data.List (delete, foldl', group) +import GHC.Arr (Ix(..), indexError) +import Data.Array +import Data.List (transpose) + + +main = runUI (800,600) "Pinochole Assistant" pinochleSF + +data Card = Card Suit Number + deriving (Eq, Ord) + +instance Enum Card where + toEnum i = let (q,r) = quotRem i 6 in Card (toEnum q) (toEnum r) + fromEnum (Card s n) = (6 * fromEnum s) + fromEnum n + +instance Show Card where + show (Card suit number) = show number ++ " of " ++ show suit + +instance Ix Card where + range (c1,c2) = [c1..c2] + unsafeIndex (c1,c2) c = fromEnum c - fromEnum c1 + index b i | inRange b i = unsafeIndex b i | otherwise = indexError b i "Card" + inRange (m,n) i = m <= i && i <= n + +data Suit = Spades | Hearts | Diamonds | Clubs + deriving (Show, Eq, Enum, Ord) +data Number = Nine | Jack | Queen | King | Ten | Ace + 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] + +type Hand = Array Card Int + +deckArray = listArray (Card Spades Nine, Card Clubs Ace) (repeat 2) + +emptyHand :: Hand +emptyHand = listArray (Card Spades Nine, Card Clubs Ace) (repeat 0) + +addToHand :: Hand -> [Card] -> Hand +addToHand h cs = accum (+) h $ zip cs (repeat 1) + +removeFromHand :: Hand -> [Card] -> Hand +removeFromHand h cs = accum (+) h $ zip cs (repeat (-1)) + +complementHand :: Hand -> Hand +complementHand = fmap (2-) + +handLength :: Hand -> Int +handLength = sum . elems + +class ShortShow a where + shortShow :: a -> String + +instance ShortShow Suit where + shortShow = take 1 . show + +instance ShortShow Number where + shortShow = take 1 . show + +instance ShortShow Card where + shortShow (Card suit number) = shortShow number ++ " of " ++ shortShow suit + +instance ShortShow a => ShortShow [a] where + shortShow = show . map shortShow + + +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 () + 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] + 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 + (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) -< + fmap (const ((hand, kittenSizeStr), if restr then Just trump else Nothing)) b + k <- hold [] -< maybe (fmap (const ["Calculating ..."]) b) Just kre + displayStrList -< k + returnA -< () + +kittyResult :: Hand -> String -> Maybe Suit -> [String] +kittyResult _ s _ | null (reads s :: [(Int,String)]) = ["Unable to parse kitty size"] +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 = " + ++ 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 + where + kittySize = fst (head (reads s :: [(Int,String)])) + restOfDeck = complementHand hand + kitties = possibleKitties kittySize restOfDeck + getSuitMelds s = map (calc s hand) kitties + allMelds :: [(Int, [Card], Int, Suit)] + 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 + 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 + 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) + +-- | 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 +-- a list of meld cards. First, it checks to see if (length meld-points) +-- copies of the cards are in the hand (checking for 2x, 3x, etc. copies +-- of the given meld cards). If so, it halts with the first String and +-- point count, and if not, it recurs. If the cards are never found, +-- the empty list is returned. +-- This always returns either a one-element list or an empty list! +checkMeld :: Hand -> ([String], [Int], [Card]) -> [(String, Int, [Card])] +checkMeld hand (strs,ints,m) = + let n = containsCount hand m in if n == 0 then [] else [(strs!!(n-1), ints!!(n-1), m)] + +-- | Will return the highest value among the indexes in the list +containsCount :: Ix i => Array i Int -> [i] -> Int +containsCount a [] = maxBound +containsCount a (i:is) = let v = a!i in if v == 0 then 0 else min v $ containsCount a is + +-- Meld helpers +roundhouse = concatMap (\s -> [Card s King, Card s Queen]) allSuits +straight trump = [Card trump Ace, Card trump Ten, Card trump King, Card trump Queen, Card trump Jack] + +-- | getMeld +-- Given a trump suit and hand, returns all of the meld for this hand. +getMeld :: Suit -> Hand -> [(String, Int, [Card])] +getMeld trump hand = + concatMap (checkMeld hand) meld2 ++ + case containsCount hand roundhouse of + 2 -> ("2xRoundhouse",48,concat $ replicate 2 roundhouse): + checkMeld hand (["Straight","2xStraight"],[15,30],straight trump) + 1 -> ("Roundhouse",24,roundhouse): + case containsCount hand (straight trump) of + 2 -> ("2xStraight",30,concat $ replicate 2 $ straight trump):concatMap (checkMeld $ removeFromHand hand roundhouse) rhMeld + 1 -> ("Straight",15,straight trump):concatMap (checkMeld $ removeFromHand hand roundhouse) (rKQs:rhMeld) + 0 -> concatMap (checkMeld $ removeFromHand hand roundhouse) (rKQs:rhMeld) + 0 -> case containsCount hand (straight trump) of + 2 -> ("2xStraight",30,concat $ replicate 2 $ straight trump):concatMap (checkMeld hand) rhMeld + 1 -> ("Straight",15,straight trump): + checkMeld (removeFromHand hand [Card trump King, Card trump Queen]) rKQstraight ++ + concatMap (checkMeld hand) rhMeld + 0 -> concatMap (checkMeld hand) (rKQs:rhMeld) + where + rhMeld = map (\s -> (["KQ of "++shortShow s,"2xKQ of "++shortShow s], [2,4], [Card s King, Card s Queen])) (delete trump allSuits) ++ + [(["Eighty Kings","All the Kings"], [8,16], map (flip Card King) allSuits), + (["Sixty Queens","All the Queens"], [6,12], map (flip Card Queen) allSuits)] +-- rhMeld1 = map (\s -> (["KQ of "++shortShow s], [2], [Card s King, Card s Queen])) (delete trump allSuits) ++ +-- [(["Eighty Kings"], [8], map (flip Card King) allSuits), +-- (["Sixty Queens"], [6], map (flip Card Queen) allSuits)] + rKQs = (["Royal Marriage","2xRoyal Marriage"], [4,8], [Card trump King, Card trump Queen]) + rKQstraight = (["Bonus Royal Marriage"], [4], [Card trump King, Card trump Queen]) + meld2 = [(["Hundred Aces","Thousand Aces"], [10,20], map (flip Card Ace) allSuits), + (["Forty Jacks","All the Jacks"], [4,8], map (flip Card Jack) allSuits), + (["Pinochle","Double Pinochle"], [4,30], [Card Diamonds Jack, Card Spades Queen]), + (["9 of Trump","2x9s of Trump"], [1,2], [Card trump Nine])] + + + + + + +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) + + +fst3 (a,b,c) = a +snd3 (a,b,c) = b +thd3 (a,b,c) = c + +fst4 (a,b,c,d) = a +snd4 (a,b,c,d) = b +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/fft.hs view
@@ -0,0 +1,138 @@+-- Filename: fft.hs +-- Created by: Daniel Winograd-Cort +-- Created on: unknown +-- Last Modified by: Daniel Winograd-Cort +-- Last Modified on: 12/12/2013 + +-- -- DESCRIPTION -- +-- This code was inspired by Euterpea. It uses UISF to present a GUI that +-- shows the sum of two waves (whose frequencies are specified by the user) +-- as well as the Fast Fourier Transform of that sum. +-- +-- This module requires the array and pure-fft packages. + +{-# LANGUAGE Arrows #-} +module FRP.UISF.Examples.FFT where +import FRP.UISF +import Control.Arrow.Operations +import Numeric.FFT (fft) +import Data.Complex +import Data.Map (Map) +import Data.Maybe (listToMaybe, catMaybes) +import qualified Data.Map as Map + +import FRP.UISF.Types.MSF +import Data.Array.Unboxed +import Data.Functor.Identity + + + +-- | Alternative for working with Math.FFT instead of Numeric.FFT +--import qualified Math.FFT as FFT +--import Data.Array.IArray +--import Data.Array.CArray +--myFFT n lst = elems $ (FFT.dft) (listArray (0, n-1) lst) + + +-------------------------------------- +-- Sine wave oscillators +-------------------------------------- + +-- Table definition +type Table = UArray Int Double + +-- Sine table generator. Takes an integer representing the number of samples to generate +-- and a list of relative intensities for the overtones of the sine wave. + +tableSinesN :: Int -> [Double] -> Table +tableSinesN size amps = + let wave x = sum (zipWith (*) [sin (2*pi*x*n) | n <- [1..]] amps) + delta = 1 / fromIntegral size + waveform = take size $ map wave [0,delta..] + divisor = (maximum . map abs) waveform + in listArray (0,size) (map (/divisor) waveform) + +-- Two example sine tables. + +tab1, tab2 :: Table +tab1 = tableSinesN 4096 [1] -- Basic sine wave +tab2 = tableSinesN 4096 [1.0,0.5,0.33] + +-- Table-driven oscillator + +osc :: Table -> Double -> MSF Identity Double Double +osc table sr = proc freq -> do + rec + let delta = 1 / sr * freq + phase = if next > 1 then frac next else next + next <- delay 0 -< frac (phase + delta) + returnA -< ((table!).(`mod` size).round.(*rate)) phase + where (_,size) = bounds table + rate = fromIntegral size + frac x = if x > 1 then x - fromIntegral (truncate x) else x + + +-------------------------------------- +-- Fast Fourier Transform +-------------------------------------- + +-- | Returns n samples of type b from the input stream at a time, +-- updating after k samples. This function is good for chunking +-- data and is a critical component to fftA +quantize :: ArrowCircuit a => Int -> Int -> a b (SEvent [b]) +quantize n k = proc d -> do + rec (ds,c) <- delay ([],0) -< (take n (d:ds), c+1) + returnA -< if c >= n && c `mod` k == 0 then Just ds else Nothing + +-- | Converts the vector result of a dft into a map from frequency to magnitude. +-- One common use is: +-- fftA >>> arr (fmap $ presentFFT clockRate) +presentFFT :: Double -> [Double] -> Map Double Double +presentFFT clockRate a = Map.fromList $ zipWith (curry mkAssoc) [0..] a where + mkAssoc (i,c) = (freq, c) where + samplesPerPeriod = fromIntegral (length a) + freq = fromIntegral i * (clockRate / samplesPerPeriod) + +-- | Given a quantization frequency (the number of samples between each +-- successive FFT calculation) and a fundamental period, this will decompose +-- the input signal into its constituent frequencies. +-- NOTE: The fundamental period must be a power of two! +fftA :: ArrowCircuit a => Int -> Int -> a Double (SEvent [Double]) +fftA qf fp = proc d -> do + carray <- quantize fp qf -< d :+ 0 + returnA -< fmap (map magnitude . take (fp `div` 2) . fft) carray + + +-------------------------------------- +-- UISF Example +-------------------------------------- + +-- This example shows off the histogram and realtimeGraph widgets by +-- summing two sin waves and displaying them. Additionally, it makes +-- use of two horizontal sliders. +-- This example also shows off convertToUISF and how to take a SigFun, +-- of the type used to create sound, and convert it to a UISF. +fftEx :: UISF () () +fftEx = proc _ -> do + f1 <- hSlider (1, 2000) 440 -< () + _ <- leftRight (label "Freq 1: " >>> display) -< f1 + f2 <- hSlider (1, 2000) 440 -< () + _ <- leftRight (label "Freq 2: " >>> display) -< f2 + d <- convertToUISF sr 0.1 myAutomaton -< (f1, f2) + let fft = listToMaybe $ catMaybes $ map (snd . fst) d + s = map (\((s, _), t) -> (s,t)) d + _ <- histogram (makeLayout (Stretchy 10) (Fixed 150)) -< fft + _ <- realtimeGraph (makeLayout (Stretchy 10) (Fixed 150)) 2 Black -< s + returnA -< () + where + sr = 1000 -- signal rate + myAutomaton = msfiToAutomaton $ proc (f1, f2) -> do + s1 <- osc tab1 sr -< f1 + s2 <- osc tab2 sr -< f2 + let s = (s1 + s2)/2 + fftData <- fftA 100 256 -< s + returnA -< (s, fftData) + +-- This test is run separately from the others. +main :: IO () +main = runUI (500,600) "FFT Example" fftEx
+ FRP/UISF/SOE.hs view
@@ -0,0 +1,698 @@+module FRP.UISF.SOE ( + runGraphics, + Title, + Size, + Window, + openWindow, + getMainWindowSize, + clearWindow, + drawInWindow, + drawInWindowNow, + setGraphic, + setGraphic', + setDirty, + closeWindow, + openWindowEx, + RedrawMode, + drawGraphic, + drawBufferedGraphic, + Graphic, + nullGraphic, + emptyGraphic, + overGraphic , + overGraphics, + translateGraphic, + Color (..), + RGB, + RGBA, + rgb, + rgba, + withColor, + withColor', + text, + Point, + ellipse, + shearEllipse, + line, + polygon, + polyline, + polyBezier, + Angle, + arc, + scissorGraphic, +-- Region, --Regions are an unused feature +-- createRectangle, +-- createEllipse, +-- createPolygon, +-- andRegion, +-- orRegion, +-- xorRegion, +-- diffRegion, +-- drawRegion, +-- getKey, -- See note at definition for why these are left out +-- getLBP, +-- getRBP, + Key(..), + SpecialKey (..), + UIEvent (..), + maybeGetWindowEvent, + getWindowEvent, + Word32, + timeGetTime, + word32ToInt, + isKeyPressed + ) where + +import Data.Ix (Ix) +import Data.Word (Word32) +import Graphics.UI.GLFW (Key(..), SpecialKey(..), KeyButtonState(..)) +import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL as GL +import Graphics.Rendering.OpenGL (($=), GLfloat) +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad (when, unless) +import Control.Concurrent.STM.TChan +import Control.Monad.STM (atomically) +import Control.Concurrent.MVar +import Data.IORef +import Data.List (delete) + + +------------------- +-- Key state +------------------- + +keyState :: IORef ([Char],[SpecialKey]) +keyState = unsafePerformIO $ newIORef ([],[]) + +addCharToKeyState :: Char -> IO () +addCharToKeyState c = atomicModifyIORef keyState $ \(cs,ss) -> ((c:cs,ss),()) + +addSKeyToKeyState :: SpecialKey -> IO () +addSKeyToKeyState s = atomicModifyIORef keyState $ \(cs,ss) -> ((cs,s:ss),()) + +removeCharFromKeyState :: Char -> IO () +removeCharFromKeyState c = atomicModifyIORef keyState $ \(cs,ss) -> ((delete c cs,ss),()) + +removeSKeyFromKeyState :: SpecialKey -> IO () +removeSKeyFromKeyState s = atomicModifyIORef keyState $ \(cs,ss) -> ((cs,delete s ss),()) + +------------------- +-- Window Functions +------------------- + +runGraphics :: IO () -> IO () +runGraphics main = main + +type Title = String +type Size = (Int, Int) + +data Window = Window { + graphicVar :: MVar (Graphic, Bool), -- boolean to remember if it's dirty + eventsChan :: TChan UIEvent +} + +-- Graphic is just a wrapper for OpenGL IO +newtype Graphic = Graphic (IO ()) + +initialized, opened :: MVar Bool +initialized = unsafePerformIO (newMVar False) +opened = unsafePerformIO (newMVar False) + +initialize :: IO () +initialize = do + i <- readMVar initialized + unless i $ do + _ <- GLFW.initialize + modifyMVar_ initialized (const $ return True) + return () + +openWindow :: Title -> Size -> IO Window +openWindow title size = + openWindowEx title Nothing (Just size) drawBufferedGraphic + +-- pos is always ignored due to GLFW +openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window +openWindowEx title _position size (RedrawMode _useDoubleBuffer) = do + let siz = maybe (GL.Size 400 300) fromSize size + initialize + gVar <- newMVar (emptyGraphic, False) + eChan <- atomically newTChan + _ <- GLFW.openWindow siz [GLFW.DisplayStencilBits 8, GLFW.DisplayAlphaBits 8] GLFW.Window + GLFW.windowTitle $= title + modifyMVar_ opened (\_ -> return True) + GL.shadeModel $= GL.Smooth + -- enable antialiasing + GL.lineSmooth $= GL.Enabled + GL.blend $= GL.Enabled + GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) + GL.lineWidth $= 1.5 + + -- this will hang on Windows + -- let updateWindow = readMVar gVar >>= (\(Graphic g) -> g >> GLFW.swapBuffers) + -- GLFW.windowRefreshCallback $= updateWindow + + let motionCallback (GL.Position x y) = atomically $ + writeTChan eChan MouseMove { pt = (fromIntegral x, fromIntegral y) } + GLFW.mousePosCallback $= motionCallback + + let charCallback c Press = do + ks <- readIORef keyState + atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = True} + charCallBack c Release = return () -- This never happens + let keyCallBack (CharKey c) Press = do +-- ks <- readIORef keyState +-- atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = True} + addCharToKeyState c + keyCallBack (CharKey c) Release = do + removeCharFromKeyState c + ks <- readIORef keyState + atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = False} + keyCallBack (SpecialKey sk) Press = do + ks <- readIORef keyState + atomically $ writeTChan eChan SKey{ skey = sk, modifiers = ks, isDown = True} + addSKeyToKeyState sk + keyCallBack (SpecialKey sk) Release = do + removeSKeyFromKeyState sk + ks <- readIORef keyState + atomically $ writeTChan eChan SKey{ skey = sk, modifiers = ks, isDown = False} + GLFW.charCallback $= charCallback + GLFW.keyCallback $= keyCallBack + GLFW.enableSpecial GLFW.KeyRepeat + + GLFW.mouseButtonCallback $= (\but state -> do + GL.Position x y <- GL.get GLFW.mousePos + atomically $ writeTChan eChan Button{ + pt = (fromIntegral x, fromIntegral y), + isLeft = (but == GLFW.ButtonLeft), + isDown = (state == Press)}) + + GLFW.windowSizeCallback $= atomically . writeTChan eChan . Resize + GLFW.windowRefreshCallback $= atomically (writeTChan eChan Refresh) + GLFW.windowCloseCallback $= (closeWindow_ eChan >> return True) + + return Window { + graphicVar = gVar, + eventsChan = eChan + } + +getMainWindowSize :: IO Size +getMainWindowSize = do + (GL.Size x y) <- GL.get GLFW.windowSize + return (fromIntegral x, fromIntegral y) + +clearWindow :: Window -> IO () +clearWindow win = setGraphic win (Graphic (return ())) + +drawInWindow :: Window -> Graphic -> IO () +drawInWindow win graphic = + modifyMVar_ (graphicVar win) (\ (g, _) -> + return (overGraphic graphic g, True)) + +-- if window is marked as dirty, mark it clean, draw and swap buffer; +-- otherwise do nothing. +updateWindowIfDirty :: Window -> IO () +updateWindowIfDirty win = do + io <- modifyMVar (graphicVar win) (\ (g@(Graphic io), dirty) -> + return ((g, False), when dirty (io >> GLFW.swapBuffers))) + io + +drawInWindowNow :: Window -> Graphic -> IO () +drawInWindowNow win graphic = do + drawInWindow win graphic + updateWindowIfDirty win + +-- setGraphic set the given Graphic over empty (black) background for +-- display in current Window. +setGraphic :: Window -> Graphic -> IO () +setGraphic win graphic = + modifyMVar_ (graphicVar win) (\_ -> + return (overGraphic graphic emptyGraphic, True)) + +setGraphic' :: Window -> Graphic -> IO () +setGraphic' win graphic = + modifyMVar_ (graphicVar win) (\(_, dirty) -> + return (overGraphic graphic emptyGraphic, dirty)) + +setDirty :: Window -> IO () +setDirty win = + modifyMVar_ (graphicVar win) (\(g, _) -> return (g, True)) + +closeWindow :: Window -> IO () +closeWindow win = closeWindow_ (eventsChan win) + +closeWindow_ :: TChan UIEvent -> IO () +closeWindow_ chan = do + atomically $ writeTChan chan Closed + modifyMVar_ opened (\_ -> return False) + GLFW.closeWindow + GLFW.pollEvents + +-------------------- +-- Drawing Functions +-------------------- + +newtype RedrawMode = RedrawMode Bool + +drawGraphic :: RedrawMode +drawGraphic = RedrawMode False + +drawBufferedGraphic :: RedrawMode +drawBufferedGraphic = RedrawMode True + +data Color = Black + | Blue + | Green + | Cyan + | Red + | Magenta + | Yellow + | White + deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read) + +type Angle = GLfloat + +nullGraphic :: Graphic +nullGraphic = Graphic $ return () + +emptyGraphic :: Graphic +emptyGraphic = Graphic $ do + GL.clearColor $= GL.Color4 (0xec/0xff) (0xe9/0xff) (0xd8/0xff) (0x00) -- GL.Color4 0 0 0 0 + GL.clear [GL.ColorBuffer, GL.StencilBuffer] + +translateGraphic :: (Int, Int) -> Graphic -> Graphic +translateGraphic (x, y) (Graphic g) = Graphic $ GL.preservingMatrix $ do + GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y) (0::GLfloat)) + g + +overGraphic :: Graphic -> Graphic -> Graphic +overGraphic (Graphic over) (Graphic base) = Graphic (base >> over) + +overGraphics :: [Graphic] -> Graphic +overGraphics = foldl1 overGraphic + +colorToRGB :: Color -> GL.Color3 GLfloat +colorToRGB Black = GL.Color3 0 0 0 +colorToRGB Blue = GL.Color3 0 0 1 +colorToRGB Green = GL.Color3 0 1 0 +colorToRGB Cyan = GL.Color3 0 1 1 +colorToRGB Red = GL.Color3 1 0 0 +colorToRGB Magenta = GL.Color3 1 0 1 +colorToRGB Yellow = GL.Color3 1 1 0 +colorToRGB White = GL.Color3 1 1 1 + +withColor :: Color -> Graphic -> Graphic +withColor color = withColor' (colorToRGB color) + +withColor' :: GL.Color a => a -> Graphic -> Graphic +withColor' color (Graphic g) = Graphic (GL.color color >> g) + +type RGB = GL.Color3 GL.GLfloat +type RGBA = GL.Color4 GL.GLfloat + +rgb :: (Integral r, Integral g, Integral b) => r -> g -> b -> RGB +rgb r g b = GL.Color3 (c2f r) (c2f g) (c2f b) :: RGB +rgba :: (Integral r, Integral g, Integral b, Integral a) => r -> g -> b -> a -> RGBA +rgba r g b a = GL.Color4 (c2f r) (c2f g) (c2f b) (c2f a) :: RGBA +c2f :: (Integral c, Fractional f) => c -> f +c2f i = fromIntegral i / 255 + +text :: Point -> String -> Graphic +text (x,y) str = Graphic $ GL.preservingMatrix $ do + GL.translate (GL.Vector3 (fromIntegral x) (fromIntegral y + 16) (0::GLfloat)) + GL.scale 1 (-1) (1::GLfloat) + GLFW.renderString GLFW.Fixed8x16 str + +type Point = (Int, Int) + +ellipse :: Point -> Point -> Graphic +ellipse pt1 pt2 = Graphic $ GL.preservingMatrix $ do + let (x, y, width, height) = normaliseBounds pt1 pt2 + (r1, r2) = (width / 2, height / 2) + GL.translate (GL.Vector3 (x + r1) (y + r2) 0) + GL.renderPrimitive GL.Polygon (circle r1 r2 0 (2 * pi) (6 / (r1 + r2))) + +shearEllipse :: Point -> Point -> Point -> Graphic +shearEllipse p0 p1 p2 = Graphic $ + let (x0,y0) = fromPoint p0 + (x1,y1, w, h) = normaliseBounds p1 p2 + (x2,y2) = (x1 + w, y1 + h) + x = (x1 + x2) / 2 -- centre of parallelogram + y = (y1 + y2) / 2 + dx1 = (x1 - x0) / 2 -- distance to corners from centre + dy1 = (y1 - y0) / 2 + dx2 = (x2 - x0) / 2 + dy2 = (y2 - y0) / 2 + pts = [ (x + c*dx1 + s*dx2, y + c*dy1 + s*dy2) + | (c,s) <- cos'n'sins ] + cos'n'sins = [ (cos a, sin a) | a <- segment 0 (2 * pi) (40 / (w + h))] + in GL.renderPrimitive GL.Polygon $ + mapM_ (\ (x, y) -> GL.vertex (vertex3 x y 0)) pts + +line :: Point -> Point -> Graphic +line (x1, y1) (x2, y2) = Graphic $ + GL.renderPrimitive GL.LineStrip (do + GL.vertex (vertex3 (fromIntegral x1) (fromIntegral y1) 0) + GL.vertex (vertex3 (fromIntegral x2) (fromIntegral y2) 0)) + +polygon :: [Point] -> Graphic +polygon ps = Graphic $ + GL.renderPrimitive GL.Polygon (foldr1 (>>) (map + (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0)) + ps)) + +polyline :: [Point] -> Graphic +polyline ps = Graphic $ + GL.renderPrimitive GL.LineStrip (foldr1 (>>) (map + (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0)) + ps)) + +polyBezier :: [Point] -> Graphic +polyBezier [] = Graphic $ return () +polyBezier ps = polyline (map (bezier ps) (segment 0 1 dt)) + where + dt = 1 / (lineLength ps / 8) + lineLength :: [Point] -> GLfloat + lineLength ((x1,y1):(x2,y2):ps') = + let dx = x2 - x1 + dy = y2 - y1 + in sqrt (fromIntegral (dx * dx + dy * dy)) + lineLength ((x2,y2):ps') + lineLength _ = 0 + +bezier :: [Point] -> GLfloat -> Point +bezier [(x1,y1)] _t = (x1, y1) +bezier [(x1,y1),(x2,y2)] t = (x1 + truncate (fromIntegral (x2 - x1) * t), + y1 + truncate (fromIntegral (y2 - y1) * t)) +bezier ps t = bezier (map (\ (p, q) -> bezier [p,q] t) (zip ps (tail ps))) t + +arc :: Point -> Point -> Angle -> Angle -> Graphic +arc pt1 pt2 start extent = Graphic $ GL.preservingMatrix $ do + let (x, y, width, height) = normaliseBounds pt1 pt2 + (r1, r2) = (width / 2, height / 2) + GL.translate (GL.Vector3 (x + r1) (y + r2) 0) + GL.renderPrimitive GL.LineStrip (circle r1 r2 + (-(start + extent) * pi / 180) (-start * pi / 180) (6 / (r1 + r2))) + + +scissorGraphic :: (Point, Size) -> Graphic -> Graphic +scissorGraphic ((x,y), (w,h)) (Graphic g) = Graphic $ do + (_,windowY) <- getMainWindowSize + let [x', y', w', h'] = map fromIntegral [x, windowY-y-h, w, h] + oldScissor <- GL.get GL.scissor + GL.scissor $= Just (GL.Position x' y', GL.Size w' h') + g + GL.scissor $= oldScissor + + +------------------- +-- Region Functions +------------------- + +{- Unused + +createRectangle :: Point -> Point -> Region +createRectangle pt1 pt2 = + let (x,y,width,height) = normaliseBounds' pt1 pt2 + [x0, y0, x1, y1] = map fromIntegral [x, y, x + width, y + height] + drawing = + GL.renderPrimitive GL.Quads (do + GL.vertex (vertex3 x0 y0 0) + GL.vertex (vertex3 x1 y0 0) + GL.vertex (vertex3 x1 y1 0) + GL.vertex (vertex3 x0 y1 0)) + in [[Pos ("R" ++ show (x0,y0,x1,y1), drawing)]] + +createEllipse :: Point -> Point -> Region +createEllipse pt1 pt2 = + let (x,y,width,height) = normaliseBounds' pt1 pt2 + drawing = + GL.preservingMatrix $ do + let (x, y, width, height) = normaliseBounds pt1 pt2 + (r1, r2) = (width / 2, height / 2) + GL.translate (GL.Vector3 (x + r1) (y + r2) 0) + GL.renderPrimitive GL.Polygon (circle r1 r2 0 (2 * pi) (6 / (r1 + r2))) + in [[Pos ("E" ++ show (x, y, width, height), drawing)]] + +createPolygon :: [Point] -> Region +createPolygon [] = [[]] +createPolygon ps = + let (minx, maxx, miny, maxy) = (minimum (map fst ps), maximum (map fst ps), + minimum (map snd ps), maximum (map snd ps)) + drawing = do + GL.renderPrimitive GL.Polygon (foldr1 (>>) (map + (\ (x, y) -> GL.vertex (vertex3 (fromIntegral x) (fromIntegral y) 0)) + ps)) + in [[Pos ("P"++show ps, drawing)]] + +andRegion, orRegion, xorRegion, diffRegion :: Region -> Region -> Region + +-- We'll convert region expression into disjuction canonical form +-- so as to make rendering easier using Stencil buffer. + +type Region = [Conjuction] +type Conjuction = [Atom] +data Atom = Pos Atom' | Neg Atom' +type Atom' = (String, IO ()) +instance Show Atom where + show (Pos (s, _)) = "+" ++ s + show (Neg (s, _)) = "-" ++ s + +conjuction :: Region -> Region -> Region +conjuction xs ys = [ x ++ y | x <- xs, y <- ys ] +disjuction xs ys = xs ++ ys +negTerm [] = [] +negTerm xs = foldl1 conjuction (map negA xs) + where + negA :: Conjuction -> Region + negA ys = map negS ys + negS :: Atom -> Conjuction + negS (Pos i) = [Neg i] + negS (Neg i) = [Pos i] + +data RegionOp = AND | OR | XOR | DIFF + +andRegion = combineRegion AND +orRegion = combineRegion OR +xorRegion = combineRegion XOR +diffRegion = combineRegion DIFF + +drawRegion :: Region -> Graphic +drawRegion term = Graphic drawAux + where + drawAux = do + GL.stencilMask $= 1 + GL.stencilTest $= GL.Enabled + sequence_ [drawConjuction (posT t) (negT t) | t <- term] + GL.stencilTest $= GL.Disabled + + posT [] = [] + posT (Pos x:xs) = x : posT xs + posT (_:xs) = posT xs + + negT [] = [] + negT (Neg x:xs) = x : negT xs + negT (_:xs) = negT xs + + drawConjuction ps ns = do + -- render all positive atoms only to stencil buffer + GL.depthFunc $= Just GL.Never + GL.stencilMask $= 0xff + GL.stencilFunc $= (GL.Greater, 0, 0xff) + -- every pixel rendered increases the value in the stencil buffer by 1 + GL.stencilOp $= (GL.OpIncr, GL.OpIncr, GL.OpZero) + mapM_ drawIt ps + -- render all negative atoms to clear the stencil pixel to 0 + GL.stencilOp $= (GL.OpZero, GL.OpZero, GL.OpZero) + mapM_ drawIt ns + -- finally render all positive atoms to screen where the stencil pixel + -- equals (length ps) + GL.depthFunc $= Just GL.Always + GL.stencilFunc $= (GL.Equal, fromIntegral $ length ps, 0xff) + GL.stencilOp $= (GL.OpZero, GL.OpZero, GL.OpZero) + mapM_ drawIt ps + + drawIt (_, io) = io + +--combineRegion :: Cairo.Operator -> Region -> Region -> Region +combineRegion operator a b = + case operator of + AND -> conjuction a b + OR -> disjuction a b + XOR -> disjuction (conjuction (negTerm a) b) (conjuction a (negTerm b)) + DIFF -> conjuction a (negTerm b) + +-} +--------------------------- +-- Event Handling Functions +--------------------------- + +data UIEvent = + Key { + char :: Char, + modifiers :: ([Char],[SpecialKey]), + isDown :: Bool + } + | SKey { + skey :: SpecialKey, + modifiers :: ([Char],[SpecialKey]), + isDown :: Bool + } + | Button { + pt :: Point, + isLeft :: Bool, + isDown :: Bool + } + | MouseMove { + pt :: Point + } + | Resize GL.Size + | Refresh + | Closed + | NoUIEvent + deriving Show + + +-- | 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 +-- tasks at these times rather than needlessly spinning. The sleepTime +-- parameter used to be fixed at 0.01. + +getWindowEvent :: Double -> Window -> IO UIEvent +getWindowEvent sleepTime win = do + event <- maybeGetWindowEvent sleepTime win + maybe (getWindowEvent sleepTime win) return event + +maybeGetWindowEvent :: Double -> Window -> IO (Maybe UIEvent) +maybeGetWindowEvent sleepTime win = let winChan = eventsChan win in do + updateWindowIfDirty win + mevent <- atomically $ tryReadTChan winChan + case mevent of + Nothing -> GLFW.sleep sleepTime >> GLFW.pollEvents >> return Nothing + Just Refresh -> do + (Graphic io, _) <- readMVar (graphicVar win) + io + GLFW.swapBuffers + maybeGetWindowEvent sleepTime win + Just (e@(Resize _)) -> do + (Resize size@(GL.Size w h)) <- getLastResizeEvent winChan e + GL.viewport $= (GL.Position 0 0, size) + GL.matrixMode $= GL.Projection + GL.loadIdentity + GL.ortho2D 0 (realToFrac w) (realToFrac h) 0 + -- force a refresh, needed for OS X + atomically $ writeTChan winChan Refresh + maybeGetWindowEvent sleepTime win + Just e -> return (Just e) + +-- | When a window is resized, all of the resize events queue up until the +-- mouse button is released. This causes some delay as each individual +-- resize event is handled and then the window is redrawn. This function +-- clears all resize and refresh events until the last resize one. +-- Note that because this function is used, a Refresh event should follow +-- the resizing. +getLastResizeEvent :: TChan UIEvent -> UIEvent -> IO UIEvent +getLastResizeEvent ch prev = do + mevent <- atomically $ tryReadTChan ch + case mevent of + Nothing -> return prev + Just (e@(Resize _)) -> getLastResizeEvent ch e + Just Refresh -> getLastResizeEvent ch prev + Just e -> atomically (unGetTChan ch e) >> return prev + + +-- | 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 +-- sure which is the better solution, so I will leave them commented out +-- until they're needed. + +{- +getKeyEx :: Window -> Bool -> IO Char +getKeyEx win down = loop + where loop = do e <- getWindowEvent win + case e of + (Key { char = ch, isDown = d }) + | d == down -> return ch + Closed -> return '\x0' + _ -> loop + +getKey :: Window -> IO Char +getKey win = do + ch <- getKeyEx win True + if ch == '\x0' then return ch + else getKeyEx win False + +getButton :: Window -> Int -> Bool -> IO Point +getButton win but down = loop + where loop = do e <- getWindowEvent win + case e of + (Button { pt = pt, isDown = id }) + | id == down -> return pt + _ -> loop + +getLBP :: Window -> IO Point +getLBP w = getButton w 1 True + +getRBP :: Window -> IO Point +getRBP w = getButton w 2 True +-} + +-- 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 +isKeyPressed :: Enum a => a -> IO Bool +isKeyPressed k = do + kbs <- GLFW.getKey k + return $ case kbs of + Press -> True + Release -> False + +---------------------- +-- Auxiliary Functions +---------------------- + +--vertex4 :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GL.Vertex4 GLfloat +--vertex4 = GL.Vertex4 + +vertex3 :: GLfloat -> GLfloat -> GLfloat -> GL.Vertex3 GLfloat +vertex3 = GL.Vertex3 + +normaliseBounds :: Point -> Point -> (GLfloat,GLfloat,GLfloat,GLfloat) +normaliseBounds (x1,y1) (x2,y2) = (x, y, width, height) + where x = fromIntegral $ min x1 x2 + y = fromIntegral $ min y1 y2 + width = fromIntegral $ abs $ x1 - x2 + height = fromIntegral $ abs $ y1 - y2 + +--normaliseBounds' :: Point -> Point -> (Int,Int,Int,Int) +--normaliseBounds' (x1,y1) (x2,y2) = (x, y, width, height) +-- where x = min x1 x2 +-- y = min y1 y2 +-- width = abs $ x1 - x2 +-- height = abs $ y1 - y2 + +fromPoint :: Point -> (GLfloat, GLfloat) +fromPoint (x1, x2) = (fromIntegral x1, fromIntegral x2) + +fromSize :: Size -> GL.Size +fromSize (x, y) = GL.Size (fromIntegral x) (fromIntegral y) + +-- we add 20 pixels to the y position to leave space for window title bar +--fromPosition (x, y) = GL.Position (fromIntegral x) (20 + fromIntegral y) + +circle :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO () +circle r1 r2 start stop step = + let vs = [ (r1 * cos i, r2 * sin i) | i <- segment start stop step ] + in mapM_ (\(x, y) -> GL.vertex (vertex3 x y 0)) vs + +segment :: (Num t, Ord t) => t -> t -> t -> [t] +segment start stop step = ts start + where ts i = if i >= stop then [stop] else i : ts (i + step) +
+ FRP/UISF/Types/MSF.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP, DoRec, FlexibleInstances, MultiParamTypeClasses, OverlappingInstances #-} + +module FRP.UISF.Types.MSF where + +#if __GLASGOW_HASKELL__ >= 610 +import Control.Category +import Prelude hiding ((.)) +#endif +import Control.Arrow +import Control.Arrow.Operations +import Control.Monad.Fix + + +data MSF m a b = MSF { msfFun :: (a -> m (b, MSF m a b)) } + + +#if __GLASGOW_HASKELL__ >= 610 +instance Monad m => Category (MSF m) where + id = MSF h where h x = return (x, MSF h) + MSF g . MSF f = MSF (h f g) + where h f g x = do (y, MSF f') <- f x + (z, MSF g') <- g y + return (z, MSF (h f' g')) + +instance Monad m => Arrow (MSF m) where + arr f = MSF h + where h x = return (f x, MSF h) + first (MSF f) = MSF (h f) + where h f (x, z) = do (y, MSF f') <- f x + return ((y, z), MSF (h f')) + f &&& g = MSF (h f g) + where + h f g x = do + (y, f') <- msfFun f x + (z, g') <- msfFun g x + return ((y, z), MSF (h f' g')) + f *** g = MSF (h f g) + where + h f g x = do + (y, f') <- msfFun f (fst x) + (z, g') <- msfFun g (snd x) + return ((y, z), MSF (h f' g')) +#else +instance Monad m => Arrow (MSF m) where + arr f = MSF h + where h x = return (f x, MSF h) + MSF f >>> MSF g = MSF (h f g) + where h f g x = do (y, MSF f') <- f x + (z, MSF g') <- g y + return (z, MSF (h f' g')) + first (MSF f) = MSF (h f) + where h f (x, z) = do (y, MSF f') <- f x + return ((y, z), MSF (h f')) + f &&& g = MSF (h f g) + where + h f g x = do + (y, f') <- msfFun f x + (z, g') <- msfFun g x + return ((y, z), MSF (h f' g')) + f *** g = MSF (h f g) + where + h f g x = do + (y, f') <- msfFun f (fst x) + (z, g') <- msfFun g (snd x) + return ((y, z), MSF (h f' g')) +#endif + +instance MonadFix m => ArrowLoop (MSF m) where + loop (MSF f) = MSF (h f) + where h f x = do rec ((y, z), MSF f') <- f (x, z) + return (y, MSF (h f')) + +instance Monad m => ArrowChoice (MSF m) where + left msf = MSF (h msf) + where h msf x = case x of + Left x' -> do (y, msf') <- msfFun msf x' + return (Left y, MSF (h msf')) + Right y -> return (Right y, MSF (h msf)) + f ||| g = MSF (h f g) + where h f g x = case x of + Left b -> do (d, f') <- msfFun f b + return (d, MSF (h f' g)) + Right c -> do (d, g') <- msfFun g c + return (d, MSF (h f g')) + + +instance MonadFix m => ArrowCircuit (MSF m) where + delay i = MSF (h i) where h i x = return (i, MSF (h x)) + + +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 +source f = MSF h where h _ = f >>= return . (\x -> (x, MSF h)) +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)) + +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) +sourceE f = MSF h where h = maybe (return (Nothing, MSF h)) (\_ -> f >>= return . (\c -> (Just c, MSF h))) +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))) + +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 + +listSource :: Monad m => [c] -> MSF m () c +listSource cs = MSF (h cs) where h (c:cs) _ = return (c, MSF (h cs)) + +stepMSF :: Monad m => MSF m a b -> [a] -> m [b] +stepMSF _ [] = return [] +stepMSF (MSF f) (x:xs) = do + (y, f') <- f x + ys <- stepMSF f' xs + return (y:ys) + +stepMSF' :: Monad m => MSF m a b -> [a] -> m ([b], MSF m a b) +stepMSF' g [] = return ([], g) +stepMSF' (MSF f) (x:xs) = do + (y, f') <- f x + (ys, g) <- stepMSF' f' xs + return (y:ys, g) + +data Stream m b = Stream { stream :: m (b, Stream m b) } +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) + +runMSF :: Monad m => a -> MSF m a b -> m b +runMSF a f = run f where run (MSF f) = do f a >>= run . snd + +runMSF' :: Monad m => MSF m () b -> m b +runMSF' = runMSF ()
+ FRP/UISF/UIMonad.lhs view
@@ -0,0 +1,267 @@+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.lhs view
@@ -0,0 +1,280 @@+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.lhs view
@@ -0,0 +1,708 @@+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 +
+ License view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Dan Winograd-Cort <dwc@cs.yale.edu> + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dan Winograd-Cort <dwc@cs.yale.edu> nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ ReadMe.txt view
@@ -0,0 +1,83 @@+ _ _ _____ _____ ______ + | | | |_ _|/ ____| ____| + | | | | | | | (___ | |__ + | | | | | | \___ \| __| + | |__| |_| |_ ____) | | + \____/|_____|_____/|_| +----------------------------- + +The UISF package provides an arrowized FRP library for graphical user +interfaces. UISF stems from work done on Euterpea +(http://haskell.cs.yale.edu/). + +See Liense for licensing information. + + +============================ +==== Getting the Source ==== +============================ + +Currently (10/26/2013), the most up-to-date version of UISF is +available through GitHub at: + + https://github.com/dwincort/UISF + +When we reach milestones, we will release stable versions to Hackage. + + +============================ +======= Installation ======= +============================ + +Installing From Hackage RECOMMENDED + cabal install UISF + +Installing from source + + 1) Clone the source from github + git clone https://github.com/dwincort/UISF + + 2) cd into the UISF directory + cd UISF + + 3) install UISF with cabal + cabal install + +Note: If you get errors about pacakges not being installed make sure that cabal binaries are in your `$PATH`. +To add cabal binaries to your path first add +export PATH=$HOME/.cabal/bin:$PATH to your .bashrc +then run +source ~/.bashrc. +Now you should be able to successfully cabal install + +This will install UISF locally for GHC. As noted on the Haskell wiki: + + One thing to be especially aware of, is that the packages are installed + locally by default, whereas the commands + + runhaskell Setup configure + runhaskell Setup build + runhaskell Setup install + + install globally by default. If you install a package globally, the + local packages are ignored. The default for cabal-install can be + modified by editing the configuration file. + + Help about cabal-install can be obtained by giving commands like: + + cabal --help + cabal install --help + +(http://www.haskell.org/haskellwiki/Cabal-Install - Accessed on 12/15/2012) + + +============================ +======== Information ======= +============================ + +UISF was created by: + Dan Winograd-Cort <dwc@cs.yale.edu> +as a branch of work on Euterpea (http://haskell.cs.yale.edu/), created by: + Paul Hudak <paul.hudak@cs.yale.edu>, + Eric Cheng <eric.cheng@aya.yale.edu>, + Hai (Paul) Liu <hai.liu@aya.yale.edu>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ UISF.cabal view
@@ -0,0 +1,43 @@+name: UISF +version: 0.1.0.0 +Cabal-Version: >= 1.8 +license: BSD3 +license-file: License +copyright: Copyright (c) 2013 Daniel Winograd-Cort +category: GUI +stability: experimental +build-type: Simple +author: Dan Winograd-Cort <dwc@cs.yale.edu> +maintainer: Dan Winograd-Cort <dwc@cs.yale.edu> +bug-reports: mailto:dwc@cs.yale.edu +homepage: http://haskell.cs.yale.edu/ +synopsis: Library for Arrowized Graphical User Interfaces. +description: + UISF is a library for making arrowized GUIs. +extra-source-files: + ReadMe.txt, + FRP/UISF/Examples/EnableGUI.hs + FRP/UISF/Examples/Pinochle.hs + FRP/UISF/Examples/fft.hs + +source-repository head + type: git + location: https://github.com/dwincort/UISF.git + +Library + hs-source-dirs: . + exposed-modules: + FRP.UISF.Examples.Crud, + FRP.UISF.Examples.Examples, + FRP.UISF.Types.MSF, + FRP.UISF.AuxFunctions, + FRP.UISF.SOE, + FRP.UISF.UIMonad, + FRP.UISF.UISF, + FRP.UISF.Widget, + FRP.UISF + 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.*