packages feed

buster (empty) → 0.99.1

raw patch · 5 files changed

+494/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, gtk, mtl, old-locale, pretty, time

Files

+ App/Behaviours/PrintEvents.hs view
@@ -0,0 +1,30 @@+module App.Behaviours.PrintEvents where++import qualified Data.ByteString as B+import Text.PrettyPrint+import Data.Time+import System.Locale+import App.EventBus++printEventsBehaviour b = pollAllEventsWith b $ (\(Event n g lifetime edata source t) -> do+    putStrLn.render $ text "name:    " <+> text n $+$+	                  text "source:  " <+> text source $+$+	                  text "group:   " <+> text g $+$+	                  text "ttl:     " <+> text (show lifetime) $+$+	                  text "emitTime:" <+> text (formatTime defaultTimeLocale "%T" t) $+$+	                  (vcat.map showIfPossible $ edata)+    return [])+    where showIfPossible (EString x) = text x+          showIfPossible (EByteString x) = text "ByteString"+          showIfPossible (EByteStringL x) = text "[ByteString]"+          showIfPossible (EInt x) = text (show x)+          showIfPossible (EDouble x) = text (show x)+          showIfPossible (EBool x) = text (show x)+          showIfPossible (EStringL x) = text (show x)+          showIfPossible (EIntL x) = text (show x)+          showIfPossible (EDoubleL x) = text (show x)+          showIfPossible (EBoolL x) = text (show x)+          showIfPossible (EChar x) = char x+          showIfPossible (EOther x) = text "Custom Data"+          showIfPossible (EOtherL x) = text "Custom Data List"+
+ App/EventBus.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- | Not exactly the FRP model, but rather a model of a large application with+--   heterogenous data and many inputs and outputs.  An application is in its+--   essence a collection of widgets and behaviours and events with a bus.+--   The bus holds events and manages the event timeline.  Behaviours and+--   widgets are continuous. Widgets applied to the bus make insertions and+--   never deletions. Behaviours applied to the bus make insertions and deletions.+--+--   Behaviours are composable using combinators that set one Behaviour as either+--   behind, in front, or beside another behaviour on the bus.  The in front and+--   behind combinators  establish that the behaviour "behind" the others+--   sees the results of the other behaviours' application to the bus. The beside+--   combinator says that the combinators see the same bus.+--+module App.EventBus where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Data.Maybe+import Data.List (foldl')+import Data.Monoid+import qualified Data.Set as Set+import Data.Time.Clock+import qualified Data.Map as Map+import qualified Data.ByteString as B+import System.IO.Unsafe++-- generic functions for key ordering.  move somewhere else later+EQ />/ b = b+a />/ _ = a++a /</ EQ = a+_ /</ b = b++g %=> f = f `on` g++on f g a b = f (g a) (g b)++-- IO version of the <* Applicative operator+a =<<^ b = \m -> b >> a m++-- | Defines the amount of time that an event exists.+data TimeSpan =+      Persistent            -- ^ The event exists forever+    | Time DiffTime         -- ^ The event exists for a specified amount of real time+    | Iterations Int        -- ^ The event exists for a certain number of samples of time from its inception.+    deriving (Eq,Ord,Show)++seconds :: Integer -> TimeSpan+seconds = Time . secondsToDiffTime++minutes :: Integer -> TimeSpan+minutes = Time . secondsToDiffTime . (60*)++hours :: Integer -> TimeSpan+hours = Time . secondsToDiffTime . (3600*)++days :: Integer -> TimeSpan+days = Time . secondsToDiffTime . (86400*)++once :: TimeSpan+once = Iterations 1++-- | Defines time in terms of the differences from time t0 to the next instant. This is the type+--   returned by Behaviours to describe time directly after the Behaviour.+data Diff a =+      Insertion (Event a)   -- ^ Time t1 contains all events at time t0 plus this event.+    | Deletion (Event a)    -- ^ Time t1 contains all events at time t0 minus this event.+++-- | Defines the data attachable to events.+data EData a =+      EString String+    | EByteString B.ByteString+    | EByteStringL [B.ByteString]+    | EChar Char+    | EDouble Double+    | EInt Int+    | EBool Bool+    | EStringL [String]+    | EDoubleL [Double]+    | EIntL [Int]+    | EBoolL [Bool]+    | EOther a+    | EOtherL [a]+    deriving (Eq, Show, Read)++-- | An discrete event in time+data Event a = Event+    { name :: String            -- ^ The unique name of an event.  Group + src + name = the fully qualified name FQN of the event.+    , group :: String           -- ^ The group of an event.+    , timespan :: TimeSpan      -- ^ The timespan from "time" that an event exists.+    , eventdata :: [EData a]    -- ^ The data attached to the event.+    , src :: String             -- ^ The behaviour or widget that assigned the event to time.+    , time :: UTCTime }         -- ^ The time of the event's inception.+++instance Ord (Event a) where+    compare l r = ((src %=> compare) l r) />/+                  ((time %=> compare) l r) />/+                  ((group %=> compare) l r) />/+                  ((name %=> compare) l r)++instance Eq (Event a) where+    x == y = (name %=> (==)) x y &&+             (group %=> (==)) x y &&+             (src %=> (==)) x y++-- | The type of a discrete sample of continuous time.+data Bus a = Bus+    { nameMap :: Map.Map String (Set.Set (Event a))                     -- ^ The map of just Event.name to events.+    , srcMap :: Map.Map String (Set.Set (Event a))                      -- ^ The map of just Event.src to events.+    , groupMap :: Map.Map String (Set.Set (Event a))                    -- ^ The map of just Event.group to events.+    , fullyQualifiedMap :: Map.Map (String,String,String) (Event a) }   -- ^ The map of FQNs to events.++instance Monoid (Bus a) where+    mempty = emptyBus+    mappend (Bus n0 s0 g0 f0) (Bus n1 s1 g1 f1) = Bus (Map.union n0 n1) (Map.union s0 s1) (Map.union g0 g1) (Map.union f0 f1)++-- | The empty bus+emptyBus :: Bus a+emptyBus = Bus Map.empty Map.empty Map.empty Map.empty++-- | Add an event to time within the bus+addEvent :: Event a -> Bus a -> Bus a+addEvent edata b = b{ nameMap = Map.insertWith (Set.union) (name edata) (singleton edata) (nameMap b)+                    , srcMap = Map.insertWith (Set.union) (src edata) (singleton edata) (srcMap b)+                    , groupMap = Map.insertWith (Set.union) (group edata) (singleton edata) (groupMap b)+                    , fullyQualifiedMap = Map.insert (group edata, src edata, name edata) edata (fullyQualifiedMap b) }++-- | The type of widgets.+--   A widget is an input-only way to assign Events to time.  A mouse is a widget.  A keyboard is a+--   widget.  A webcam is a widget, and so on.+type Widget a = MVar (Bus a) -> IO ()++-- | The type of future events..+--   A behaviour doesn't know about the time that it assigns events, only that they exist+--   at some point after the time that the Behaviour sampled.+type Future a = IO (MVar a)++-- | An IO action sometime in the future.+future :: IO a -> Future a+future thunk = do+    ref <- newEmptyMVar+    forkIO $ thunk >>= putMVar ref+    return ref++-- | Obtain the final value of a Future.  Blocks until the value is available+immediate = takeMVar++-- | The type of a Behaviour.  A behaviour maps the bus to a list of differences to apply to the bus+--   before the next Behaviour's sample of time.+type Behaviour a = Bus a -> Future [Diff a]++instance Monoid (Behaviour a) where+    mempty = passthrough+    mappend = (>~>) -- x behind y++-- | The null Behaviour.  Samples the bus and adds and deletes nothing.+passthrough :: Behaviour a+passthrough a = future (return [])++-- | the in front of behaviour combinator. behaviour 1 is in front of behaviour 0, so behavour 0 will see the bus filtered through behaviour 1+(<~<) :: Behaviour a -> Behaviour a -> Behaviour a+behaviour1 <~< behaviour0 = \m -> behaviour0 m >>= applyDiff m >>= behaviour1++-- | the behind behaviour combinator. behaviour 0 is behind behaviour 1, so behaviour 0 will see the bus filtered through behaviour 1+(>~>) :: Behaviour a -> Behaviour a -> Behaviour a+behaviour0 >~> behaviour1 = \m -> behaviour0 m >>= applyDiff m >>= behaviour1++-- | the beside behaviour combinator. All behaviours that are side-by-side see the same bus.+(|~|) :: Behaviour a -> Behaviour a -> Behaviour a+behaviour0 |~| behaviour1 = \m -> do+    future0 <- behaviour0 m+    future1 <- behaviour1 m+    future $ concat <$> mapM immediate [future0, future1]++behind = (>~>)+beside = (|~|)+infrontof = (<~<)++-- | An infinite loop of behaviours and widgets over time, sampled forward.+bus :: [Widget a] -> IO b -> Behaviour a -> IO ()+bus widgets widgetThunk behaviour = do+    evBus <- newMVar emptyBus+    forM_ widgets ($evBus)++    let loop = do+        widgetThunk+        busIteration evBus behaviour+        loop++    loop++-- | Sample time and apply the behaviour to that sample.+busIteration :: MVar (Bus a) -> Behaviour a -> IO ()+busIteration b behaviour = do+    v <- tryTakeMVar b+    case v of+        Nothing -> return ()+        Just m -> putMVar b . expire =<< decrementTimeSpan =<< applyDiff m =<< behaviour m++-- | Assign an event to time given some event data and a TimeSpan.+produce :: String -> String -> String -> TimeSpan -> [EData a] -> IO (Diff a)+produce group source nm timetolive edata =+    (return . Insertion . Event nm group timetolive edata source) =<< getCurrentTime++-- | Assign an event to time from a widget.+produce' :: String -> String -> String -> TimeSpan -> [EData a] -> MVar (Bus a) -> IO ()+produce' group source nm timetolive edata b = getCurrentTime >>= \t -> modifyMVar_ b (return . addEvent (Event nm group timetolive edata source t))++-- | Sample all events with a given name at the current time and output their deletions as Diffs as+--   well as any additional Diffs returned by the behaviour.+consumeNamedEventsWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+consumeNamedEventsWith em nm f =+    maybe (future . return $ [])+          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup nm (nameMap em))++-- | Sample all events with a given group at the current time and output their deletions as Diffs as+--   well as any additional Diffs returned by the behaviour.+consumeEventGroupWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+consumeEventGroupWith em gp f =+    maybe (future . return $ [])+          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup gp (groupMap em))++-- | Sample all events with a given source at the current time and output their deletions as Diffs as+--   well as any additional Diffs returned by the behaviour.+consumeEventsFromSourceWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+consumeEventsFromSourceWith em source f =+    maybe (future . return $ [])+          (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev)+          (Map.lookup source (srcMap em))++-- | Sample a single fully qualified event at the current time and output their deletions as Diffs as+--   well as any additional Diffs returned by the behaviour.+consumeFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]+consumeFullyQualifiedEventWith em group source name f =+    maybe (future . return $ [])+          (\ev -> future $ (Deletion ev :) <$> f ev)+          (Map.lookup (group,source,name) (fullyQualifiedMap em))++-- | Sample all events with a given name and apply a Behaviour+pollNamedEventsCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+pollNamedEventsCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (nameMap b))++-- | Sample all events with a given name and apply a Behaviour to each+pollNamedEventsWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]+pollNamedEventsWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (nameMap b)))++-- | Sample all events with a given group and apply a Behaviour+pollEventGroupCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+pollEventGroupCollectivelyWith b nm f = maybe (future . return $[]) (future . f) (Map.lookup nm (groupMap b))++-- | Sample all events with a gien group and apply a Behaviour to each.+pollEventGroupWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]+pollEventGroupWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (groupMap b)))++-- | Sample all events with a given source and apply a Behaviour+pollEventsFromSourceCollectivelyWith :: Bus a -> String -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+pollEventsFromSourceCollectivelyWith b nm f = maybe (future . return $[]) (future.f) (Map.lookup nm (srcMap b))++-- | Sample all events with a given source and apply a Behaviour to each.+pollEventsFromSourceWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]+pollEventsFromSourceWith b nm f = future $ concat <$> (mapM f . Set.toList $ fromMaybe Set.empty (Map.lookup nm (srcMap b)))++-- | Sample a single fully qualified event and output some Diffs.+pollFullyQualifiedEventWith :: Bus a -> String -> String -> String -> (Event a -> IO [Diff a]) -> Future [Diff a]+pollFullyQualifiedEventWith b gp source nm f = maybe (future . return $ []) (future . f) (Map.lookup (gp,source,nm) (fullyQualifiedMap b))++-- | Apply a behaviour to all events in the bus, one event at a time.+pollAllEventsWith :: Bus a -> (Event a -> IO [Diff a]) -> Future [Diff a]+pollAllEventsWith b f = future $ concat <$> (mapM f . Map.elems . fullyQualifiedMap $ b)++-- | Apply a behaviour to the collection of all events on the bus at once+pollAllEventsCollectivelyWith :: Bus a -> (Set.Set (Event a) -> IO [Diff a]) -> Future [Diff a]+pollAllEventsCollectivelyWith b f = future $ f . Set.fromList . Map.elems . fullyQualifiedMap $ b++applyDiff m ds = immediate ds >>= (return . foldl' busDiff m)+    where busDiff b (Insertion ev) = b{ nameMap = Map.insertWith (Set.union) (name ev) (singleton ev) (nameMap b)+                                      , srcMap = Map.insertWith (Set.union) (src ev) (singleton ev) (srcMap b)+                                      , groupMap = Map.insertWith (Set.union) (group ev) (singleton ev) (groupMap b)+                                      , fullyQualifiedMap = Map.insert (group ev, src ev, name ev) ev (fullyQualifiedMap b) }+          busDiff b (Deletion ev) = b { nameMap = deleteOneFrom ev (name ev) (nameMap b) -- should change this to alter instead of delete, check for empty lists+                                      , srcMap = deleteOneFrom ev (src ev) (srcMap b)+                                      , groupMap = deleteOneFrom ev (group ev) (groupMap b)+                                      , fullyQualifiedMap = Map.delete (group ev, src ev, name ev) (fullyQualifiedMap b) }+          deleteOneFrom ev key mp = case Map.lookup key mp of+					Just eset -> let eset' = Set.delete ev eset in if eset' == Set.empty then Map.delete key mp else Map.insert key eset' mp+					Nothing -> mp+					+singleton a = Set.fromList [a]					+	+decrementTimeSpan b = return $ b{ nameMap = Map.map decrements (nameMap b)+                           , srcMap = Map.map decrements (srcMap b)+                           , groupMap = Map.map decrements (groupMap b)+                           , fullyQualifiedMap = Map.map decrement (fullyQualifiedMap b) }+    where decrement e = e{ timespan = decTimeSpan e (timespan e) }+          decrements = Set.map (\e -> e{timespan = decTimeSpan e (timespan e)} )+          decTimeSpan _ Persistent = Persistent+          decTimeSpan e (Time x) = Time . realToFrac $ diffUTCTime (addUTCTime (realToFrac x) (time e)) (unsafePerformIO getCurrentTime)+          decTimeSpan _ (Iterations x) = (Iterations (x-1))++expire b = Bus (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . nameMap $ b)+               (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . srcMap $ b)+               (Map.filter (/=Set.empty) . Map.map (Set.filter (current . timespan)) . groupMap $ b)+               (Map.filter (current . timespan) . fullyQualifiedMap $ b)+	where current (Time x) = x > 0+	      current Persistent = True+	      current (Iterations x) = x > 0+	+{- example usage...+ -+ - handleDataLoad :: Behaviour+ - ...+ -+ - handleZoom :: Behaviour+ - ...+ -+ - handlePan :: Behaviour+ - ...+ -+ - handleRot :: Behaviour+ - ...+ -+ - handleWriteData :: Behaviour+ - ...+ -+ - main = do+ -  ui <- getUIFromFile "something.glade"+ -  mapM_ makeGtkProducers ui+ -  multitouch <- getMultitouchProducer "localhost" 8080+ -  bus (multitouch:ui) $ handleDataLoad >~> handleZoom |~| handlePan |~| handleRot >~> handleWriteData+ -+ -}++{- example of generically wrapping a Gtk widget into a EventBus.Widget+ - buttonWidget :: Gtk.Widget -> Bus a -> IO (Behaviour a)+ - buttonWidget button em = Gtk.onClick button $ do+ -      name <- Gtk.getWidgetName button+ -      value <- EString <$> Gtk.getText button+ -      produce' "ui" name "Click" once em+ -}
+ App/Widgets/GtkMouseKeyboard.hs view
@@ -0,0 +1,54 @@+-- | Gtk mouse keyboard widget.+--+--   For a mouse button press or release, add events named SingleClick or ClickRelease respectively to the bus.+--   For this widget, all events have source ''KeyboardMouseWidget'', and group ''Mouse''+--   Additionally, the data attached to the event follows the form [EString SingleClick|ClickRelease, EDouble x, EDouble y, EStringL [Gtk modifier names]]+--+--   For a keyboard press or release, add events named KeyDown or KeyUp respectively to the bus.+--   All keyboard events have group ''Keyboard'' and source ''WidgetName.KeyboardMouseWidget''+--   Additionally, the data attached to a keyboard event follows the form [EString keyName | EChar keyChar, EStringL [Gtk modifier names]]+module App.Widgets.GtkMouseKeyboard where++import Control.Applicative+import Control.Concurrent+import Data.Maybe+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk+import App.EventBus++-- Gtk's button click event system is annoying, so we're ignoring it and only bothering with the single clicks.+-- when we receive a click, fire off a thread (once) that waits for 100ms to see how many clicks we get total in that time.  Then fire off that number.+buttonHandler _ _ (Gtk.Button _ Gtk.DoubleClick _ _ _ _ _ _ _) = return True+buttonHandler _ _ (Gtk.Button _ Gtk.TripleClick _ _ _ _ _ _ _) = return True+buttonHandler wname b (Gtk.Button sent click time x y modifiers button _ _) = do+    produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show click) once [EString . show $ button, EDouble x, EDouble y, EStringL . map show $ modifiers] b+    return True++scrollWheelHandler wname b (Gtk.Scroll _ _ x y direction _ _) = do+    produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show direction) once [EDouble x, EDouble y] b+    return True++keyboardHandler wname b (Gtk.Key released sent time modifiers withCapsLock withNumLock withScrollLock keyVal keyName keyChar) = do+    produce' "Keyboard" (wname ++ "KeyboardMouseWidget") (if released then "KeyUp" else "KeyDown") once+            [ fromMaybe (EString . show $ keyName) (EChar <$> keyChar)+            , EStringL . map show $ modifiers ] b+    return False++motionHandler wname w b evt = do+    produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Position" once [EDouble . Gtk.eventX $ evt, EDouble . Gtk.eventY $ evt] b+    dwin <- Gtk.widgetGetDrawWindow w+    Gtk.drawWindowGetPointer dwin+    return False++-- | Bind a keyboard mouse widget to the given Gtk widget. Se module documentation for description of events.+bindMouseKeyboardWidget :: Gtk.Widget -> Widget a+bindMouseKeyboardWidget w b = do+    ref <- newEmptyMVar+    wname <- Gtk.widgetGetName w+    Gtk.onButtonPress w (buttonHandler wname b)+    Gtk.onButtonRelease w (buttonHandler wname b)+    Gtk.onScroll w (scrollWheelHandler wname b)+    Gtk.onKeyPress w (keyboardHandler wname b)+    Gtk.onKeyRelease w (keyboardHandler wname b)+    Gtk.onMotionNotify w True (motionHandler wname w b)+    return ()
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ buster.cabal view
@@ -0,0 +1,59 @@+name: buster+version: 0.99.1+cabal-version: -any+build-type: Simple+license: BSD3+license-file: ""+copyright: 2009 Renaissance Computing Institute+maintainer: Jeff Heard <jeff@renci.org>+build-depends: old-locale -any, time -any, containers -any,+               base -any, bytestring -any, gtk -any, mtl -any,+               pretty -any+stability: Experimental+homepage: http://vis.renci.org/jeff/buster+package-url:+bug-reports:+synopsis: Almost but not quite entirely unlike FRP+description: Buster is best described by the following blog post: http://vis.renci.org/jeff/2009/03/31/almost-but-not-quite-entirely-like-frp/+             .+             It is an engine for orchestrating large, complex, and multifaceted applications by couching them in terms of time, events, a bus,+             behaviours, and widgets.  Time is continuous and infininte.  Events are discrete and exist for a particular time.  The bus is a+             discrete sample of time made available to behaviours. Behaviours are continuous and exist for all time, but sample time via+             the bus.  They filter Events to determine what is on the bus at future times.  Widgets are input-only objects that sample the+             outside world and assign events to discrete portions of time.+             .+             Buster is designed to be flexible, with a flexible event model and the ability to add custom data to events, and designed to be+             high performance.  It is simple to integrate with Gtk while at the same time able to handle other kinds of resources, like files+             and sockets.+category: FRP+author: Jeff Heard+tested-with:+data-files:+data-dir: ""+extra-source-files:+extra-tmp-files:+exposed-modules: App.EventBus App.Behaviours.PrintEvents+                 App.Widgets.GtkMouseKeyboard +exposed: True+buildable: True+build-tools:+cpp-options:+cc-options:+ld-options:+pkgconfig-depends:+frameworks:+c-sources:+extensions:+extra-libraries:+extra-lib-dirs:+includes:+install-includes:+include-dirs:+hs-source-dirs: .+other-modules:+ghc-prof-options:+ghc-shared-options:+ghc-options:+hugs-options:+nhc98-options:+jhc-options: