Ticket #28: reactive-glut.patch

reactive-glut.cabal

@@ -1 +1 @@
 Name:                reactive-glut
-Version:             0.1.6
+Version:             0.2.0
 Cabal-Version:       >= 1.2
 Synopsis:            Connects Reactive and GLUT
 Category:            FRP, graphics
@@ -26 +26 @@
 Library
   hs-Source-Dirs:      src
   Extensions:
-  Build-Depends:       base, old-time, OpenGL, GLUT, vector-space, reactive >= 0.10.5
+  Build-Depends:       base, containers, old-time, OpenGL, GLUT, vector-space, reactive >= 0.10.5
   Exposed-Modules:     
                        FRP.Reactive.GLUT.Adapter
   Other-Modules:

src/FRP/Reactive/GLUT/Adapter.hs

@@ -22 +22 @@
 
 import qualified Graphics.UI.GLUT as G
 
-import FRP.Reactive (Behavior,stepper)
+import FRP.Reactive (Behavior,stepper,flipFlop,accumB)
 import FRP.Reactive.LegacyAdapters
 
 import FRP.Reactive.GLUT.UI
 import FRP.Reactive.GLUT.SimpleGL
 
+import qualified Data.Set as Set
+
 -- | Adapter to connect @FRP.Reactive@ with @GLUT@.  Uses given window
 -- title and a simple canned initialization.  Or do your own
 -- initialization and then invoke 'adapt'.
@@ -42 +44 @@
      let mkE = makeEvent clock
      (mousePosSink , mousePosE ) <- mkE
      (leftDownSink , leftDown  ) <- mkE
+     (leftUpSink   , leftUp    ) <- mkE
      (rightDownSink, rightDown ) <- mkE
+     (rightUpSink  , rightUp   ) <- mkE
      (keyActionSink, keyActions) <- mkE
      (tickSink     , tick      ) <- mkE
+     
      -- TODO: let the initial mouse position be its actual position
      let windowPoint' p = do -- putStrLn $ "window point " ++ show p
                              windowPoint p
@@ -60 +65 @@
      G.keyboardMouseCallback G.$= Just (\k ks _ _ ->
        case (k,ks) of
          (G.MouseButton G.LeftButton ,G.Down) -> leftDownSink  ()
+         (G.MouseButton G.LeftButton ,G.Up)   -> leftUpSink    ()
          (G.MouseButton G.RightButton,G.Down) -> rightDownSink ()
+         (G.MouseButton G.RightButton,G.Up)   -> rightUpSink   ()
          (G.Char c      ,G.Down) -> keyActionSink (Down, Char c)
          (G.SpecialKey s,G.Down) -> keyActionSink (Down, SpecialKey s)
          (G.Char c      ,G.Up)   -> keyActionSink (Up  , Char c)
          (G.SpecialKey s,G.Up)   -> keyActionSink (Up  , SpecialKey s)
          _ -> return ()
       )
+     -- Convenient summary behaviors
+     let leftButtonB  = flipFlop leftDown  leftUp
+         rightButtonB = flipFlop rightDown rightUp
+         keyboardB    = accumB Set.empty (uncurry setAction <$> keyActions)
+             where
+               setAction Down = Set.insert
+               setAction Up   = Set.delete
+     -- 
      updater <- mkUpdater
                  (cGetTime clock)
-                 (glwrap <$> f (UI mousePos leftDown rightDown keyActions tick))
+                 (glwrap <$> f (UI mousePos leftDown leftUp leftButtonB rightDown rightUp rightButtonB keyActions keyboardB tick))
      schedule (updater >> tickSink ())
      -- putStrLn "mainLoop"
      G.mainLoop

src/FRP/Reactive/GLUT/UI.hs

@@ -23 +23 @@
 
 import Control.Applicative (liftA2)
 import qualified Graphics.UI.GLUT as G
+import Data.Map(Map)
+import Data.Set(Set)
 
 import Data.VectorSpace
 import FRP.Reactive
 
 -- | Simple UI type.
 data UI = UI {
-  mousePosition      :: Behavior (Double,Double),
-  leftButtonPressed  :: Event (),
-  rightButtonPressed :: Event (),
-  keyAction          :: Event (KeyState, Key),
-  framePass          :: Event ()
+  mousePosition       :: Behavior (Double,Double),
+  leftButtonPressed   :: Event (),
+  leftButtonReleased  :: Event (),
+  leftButton          :: Behavior Bool,
+  rightButtonPressed  :: Event (),
+  rightButtonReleased :: Event (),
+  rightButton         :: Behavior Bool,
+  keyAction           :: Event (KeyState, Key),
+  keyboard            :: Behavior (Set Key),
+  framePass           :: Event ()
 }
 
 -- TODO: make button and key interfaces alike