Merge pull request #1 from HeinrichApfelmus/master

Fix GLUT run-time error on OS X.

breakout.cabal

@@ -33,6 +33,6 @@ executable breakout
                        reactive-banana >= 0.6 && < 0.7,
                        semigroups >= 0.3.4 && < 0.9,
                        OpenGLRaw >= 1.2 && < 1.3,
-                       time >= 1.4 && < 1.5,
-                       GLUT >= 2.3 && < 2.4
+                       time >= 1.2 && < 1.5,
+                       GLUT >= 2.1 && < 2.4
 

src/GlutAdapter.hs

@@ -38,12 +38,25 @@ data Key = Char Char | SpecialKey GLUT.SpecialKey
 adapt :: (forall t. Behavior t Active.Time -> UI t -> Behavior t (IO ())) -> IO ()
 adapt f = do
   start <- T.getCurrentTime
+  let getTime = Active.toTime . flip T.diffUTCTime start <$> T.getCurrentTime
+
+  -- set up events
   (tickHandler,    tickSink)    <- newAddHandler
   (mouseHandler,   mouseSink)   <- newAddHandler
   (keyHandler,     keySink)     <- newAddHandler
 
-  let getTime = Active.toTime . flip T.diffUTCTime start <$> T.getCurrentTime
+  GLUT.passiveMotionCallback GLUT.$= Just mouseSink
+  GLUT.motionCallback        GLUT.$= Just mouseSink
+  GLUT.keyboardMouseCallback GLUT.$= Just ( \k ks _ _ ->
+    case (k,ks) of
+      (GLUT.Char       c,GLUT.Down) -> keySink (GLUT.Down, Char       c)
+      (GLUT.SpecialKey s,GLUT.Down) -> keySink (GLUT.Down, SpecialKey s)
+      (GLUT.Char       c,GLUT.Up  ) -> keySink (GLUT.Up  , Char       c)
+      (GLUT.SpecialKey s,GLUT.Up  ) -> keySink (GLUT.Up  , SpecialKey s)
+      _ -> return ()
+      )
 
+  -- compile and run event network
   network <- compile $ do
     eTick    <- fromAddHandler tickHandler
     bMouse   <- fromChanges (GLUT.Position 0 0) mouseHandler
@@ -54,28 +67,23 @@ adapt f = do
     let beh = withClearAndSwap <$> f bTime (UI bMouse eKey eTick bWinWize)
     reactimate (beh <@ eTick)
   actuate network
-  GLUT.passiveMotionCallback GLUT.$= Just mouseSink
-  GLUT.motionCallback        GLUT.$= Just mouseSink
-  GLUT.keyboardMouseCallback GLUT.$= Just ( \k ks _ _ ->
-    case (k,ks) of
-      (GLUT.Char       c,GLUT.Down) -> keySink (GLUT.Down, Char       c)
-      (GLUT.SpecialKey s,GLUT.Down) -> keySink (GLUT.Down, SpecialKey s)
-      (GLUT.Char       c,GLUT.Up  ) -> keySink (GLUT.Up  , Char       c)
-      (GLUT.SpecialKey s,GLUT.Up  ) -> keySink (GLUT.Up  , SpecialKey s)
-      _ -> return ()
-      )
+
+  -- set up important window callbacks
   let resizeScene :: GLUT.Size -> IO ()
       resizeScene (GLUT.Size w 0) = resizeScene (GLUT.Size w 1)
       resizeScene (GLUT.Size w h) = do
-        GL.glViewport 0 0 w h
+        let (w',h') = (fromIntegral w, fromIntegral h)
+        GL.glViewport 0 0 w' h'
         GL.glMatrixMode GL.gl_PROJECTION
         GL.glLoadIdentity
         let (w',h') = (fromIntegral w, fromIntegral h)
             aspect = h'/w'
         GL.glOrtho (-1) 1 (-aspect) aspect (-1) 1
 
   GLUT.reshapeCallback GLUT.$= Just resizeScene
-
+  GLUT.displayCallback GLUT.$= return ()
+
+  -- run main loop                               
   timer 10 (tickSink ())
   GLUT.mainLoop
 

src/ReactiveUtils.hs

@@ -24,9 +24,6 @@ module ReactiveUtils
        , withPrevE
        , withPrevEWith
        , diffE
-       , snapshotWith
-       , snapshot
-       , snapshot_
        , unique
        , once
        ) where
@@ -37,32 +34,23 @@ import Data.AffineSpace
 import Data.Active (fromDuration, Time)
 
 integral :: (VectorSpace v, Scalar v ~ Double) => Event t Time -> Behavior t v -> Behavior t v
-integral t b = sumB (snapshotWith (*^) b (fromDuration <$> diffE t))
+integral t b = sumB $ (\v dt -> fromDuration dt *^ v) <$> b <@> diffE t
 
 sumB :: AdditiveGroup a => Event t a -> Behavior t a
 sumB = accumB zeroV . fmap (^+^)
 
 withPrevE :: Event t a -> Event t (a,a)
-withPrevE = filterJust . fmap f . accumE (Nothing,Nothing) . fmap ((\new (prev,_) -> (new,prev)).Just)
-  where
-    f :: (Maybe a, Maybe b) -> Maybe (a,b)
-    f = uncurry (liftA2 (,))
+withPrevE = withPrevEWith (,)
 
 withPrevEWith :: (a -> a -> b) -> Event t a -> Event t b
-withPrevEWith f e =  fmap (uncurry f) (withPrevE e)
+withPrevEWith f e = filterJust . fst . mapAccum Nothing $ g <$> e
+    where
+    g y Nothing  = (Nothing     , Just y)
+    g y (Just x) = (Just (f y x), Just y)
 
 diffE :: AffineSpace a => Event t a -> Event t (Diff a)
 diffE = withPrevEWith (.-.)
 
-snapshotWith :: (a -> b -> c) -> Behavior t b -> Event t a -> Event t c
-snapshotWith h b e = (flip h <$> b) `apply` e
-
-snapshot :: Behavior t b -> Event t a -> Event t (a,b)
-snapshot = snapshotWith (,)
-
-snapshot_ :: Behavior t b -> Event t a -> Event t b
-snapshot_ = snapshotWith (flip const)
-
 unique :: Eq a => Event t a -> Event t a
 unique = filterJust . accumE Nothing . fmap (\a acc -> if Just a == acc then Nothing else Just a)