gloss 1.9.4.1 → 1.10.1.1

raw patch · 24 files changed

+477/−142 lines, 24 filesdep ~GLFW-bdep ~OpenGLdep ~gloss-renderingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: GLFW-b, OpenGL, gloss-rendering

API changes (from Hackage documentation)

Files

• Graphics/Gloss.hs +37/−25
• Graphics/Gloss/Data/Bitmap.hs +1/−1
• Graphics/Gloss/Data/Color.hs +3/−3
• Graphics/Gloss/Data/Controller.hs +15/−0
• Graphics/Gloss/Data/ViewPort.hs +1/−1
• Graphics/Gloss/Data/ViewState.hs +87/−29
• Graphics/Gloss/Interface/IO/Animate.hs +13/−4
• Graphics/Gloss/Interface/IO/Display.hs +67/−0
• Graphics/Gloss/Interface/IO/Game.hs +2/−1
• Graphics/Gloss/Interface/Pure/Animate.hs +1/−0
• Graphics/Gloss/Interface/Pure/Display.hs +7/−9
• Graphics/Gloss/Interface/Pure/Game.hs +8/−7
• Graphics/Gloss/Interface/Pure/Simulate.hs +6/−5
• Graphics/Gloss/Internals/Interface/Animate.hs +24/−2
• Graphics/Gloss/Internals/Interface/Animate/Timing.hs +14/−10
• Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +15/−7
• Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +90/−10
• Graphics/Gloss/Internals/Interface/Backend/Types.hs +23/−7
• Graphics/Gloss/Internals/Interface/Display.hs +33/−8
• Graphics/Gloss/Internals/Interface/Game.hs +7/−1
• Graphics/Gloss/Internals/Interface/Simulate.hs +5/−1
• Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +5/−4
• Graphics/Gloss/Internals/Interface/Window.hs +7/−3
• gloss.cabal +6/−4

@@ -5,20 +5,35 @@ --   Getting something on the screen is as easy as: -- --  @---    import Graphics.Gloss---    main = `display` (InWindow \"Nice Window\" (200, 200) (10, 10)) `white` (`Circle` 80)+--  import Graphics.Gloss+--  main = `display` (InWindow \"Nice Window\" (200, 200) (10, 10)) `white` (`Circle` 80) --  @ -- --   Once the window is open you can use the following: -----      * Quit - esc-key.+-- @+-- * Quit            +--   - esc-key -----      * Move Viewport - left-click drag, arrow keys.+-- * Move Viewport   +--   - arrow keys+--   - left-click drag -----      * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys.+-- * Zoom Viewport+--   - page up/down-keys+--   - control-left-click drag+--   - right-click drag+--   - mouse wheel -----      * Zoom Viewport - mouse wheel, or page up\/down-keys.+-- * Rotate Viewport+--   - home/end-keys+--   - alt-left-click drag --+-- * Reset Viewport+--   'r'-key+-- @+--+-- --   Animations can be constructed similarly using the `animate`. -- --   If you want to run a simulation based around finite time steps then try@@ -37,30 +52,27 @@ -- @ -- Release Notes: ----- For 1.9:+--  For 1.10.1:+--   * Gloss no longer consumes CPU time when displaying static pictures.+--   * Added displayIO wrapper for mostly static pictures, eg when+--     plotting graphs generated from infrequently updated files.+--   * Allow viewport to be scaled with control-left-click drag.+--   * Rotation of viewport changed to alt-left-click drag.+--   * Preserve current colour when rendering bitmpaps.+--   * Changed to proper sum-of-squares colour mixing, rather than naive+--     addition of components which was causing mixed colours to be too dark.+--  Thanks to Thomas DuBuisson+--   * Allow bitmaps to be specified in RGBA byte order as well as ABGR.+--  Thanks to Gabriel Gonzalez+--   * Package definitions for building with Stack.+--+-- For 1.9.1: --  Thanks to Elise Huard --   * Split rendering code into gloss-rendering package. ----- For 1.8+-- For 1.8.0: --  Thanks to Francesco Mazzoli --   * Factored out ViewPort and ViewState handling into user visible modules.------ For 1.7:---   * Tweaked circle level-of-detail reduction code.---   * Increased frame rate cap to 100hz.---   Thanks to Doug Burke---   * Primitives for drawing arcs and sectors.---   Thanks to Thomas DuBuisson---   * IO versions of animate, simulate and play.------ For 1.6:---   Thanks to Anthony Cowley---   * Full screen display mode.--- --- For 1.5:---   * O(1) Conversion of ForeignPtrs to bitmaps.---   * An extra flag on the Bitmap constructor allows bitmaps to be cached---     in texture memory between frames. -- @ -- -- For more information, check out <http://gloss.ouroborus.net>.

@@ -1,7 +1,7 @@  -- | Functions to load bitmap data from various places. module Graphics.Gloss.Data.Bitmap-        ( BitmapData+        ( BitmapData, BitmapFormat(..), RowOrder(..), PixelFormat(..)         , bitmapOfForeignPtr         , bitmapOfByteString         , bitmapOfBMP

@@ -110,21 +110,21 @@   ---------------------------------------------------------------------------------- | Set the alpha value of a `Color`.+-- | Set the red value of a `Color`. withRed :: Float -> Color -> Color withRed r c  = let  (_, g, b, a) = rgbaOfColor c    in   makeColor r g b a  --- | Set the alpha value of a `Color`.+-- | Set the green value of a `Color`. withGreen :: Float -> Color -> Color withGreen g c  = let  (r, _, b, a) = rgbaOfColor c    in   makeColor r g b a  --- | Set the alpha value of a `Color`.+-- | Set the blue value of a `Color`. withBlue :: Float -> Color -> Color withBlue b c  = let  (r, g, _, a) = rgbaOfColor c

@@ -0,0 +1,15 @@++module Graphics.Gloss.Data.Controller+        ( Controller    (..))+where+import Graphics.Gloss.Data.ViewPort+++-- | Functions to asynchronously control a `Gloss` display.+data Controller+        = Controller+        { -- | Indicate that we want the picture to be redrawn.+          controllerSetRedraw       :: IO ()++          -- | Modify the current viewport, also indicating that it should be redrawn.+        , controllerModifyViewPort  :: (ViewPort -> IO ViewPort) -> IO () }

@@ -55,9 +55,9 @@   -- | Convert degrees to radians-{-# INLINE degToRad #-} degToRad :: Float -> Float degToRad d      = d * pi / 180+{-# INLINE degToRad #-}   -- | Multiply a vector by a scalar.

@@ -25,6 +25,7 @@          | CTranslate         | CRotate+        | CScale          -- bump zoom         | CBumpZoomOut@@ -54,13 +55,22 @@          , (CTranslate,                 [ ( MouseButton LeftButton-                  , Just (Modifiers { shift = Up, ctrl = Up, alt = Up }))+                  , Just (Modifiers { shift = Up, ctrl = Up,   alt = Up }))                 ]) +        , (CScale,+                [ ( MouseButton LeftButton+                  , Just (Modifiers { shift = Up, ctrl = Down, alt = Up }))++                , ( MouseButton RightButton+                  , Just (Modifiers { shift = Up, ctrl = Up,   alt = Up })) +                ])+         , (CRotate,-                [ ( MouseButton RightButton-                  , Nothing)-                , ( MouseButton LeftButton+                [ ( MouseButton LeftButton+                  , Just (Modifiers { shift = Up, ctrl = Up,   alt = Down }))++                , ( MouseButton RightButton                   , Just (Modifiers { shift = Up, ctrl = Down, alt = Up }))                 ]) @@ -140,14 +150,22 @@         -- | How many degrees to rotate the world by for each pixel of x motion.         , viewStateRotateFactor         :: !Float +        -- | Ratio to scale the world by for each pixel of y motion.+        , viewStateScaleFactor          :: !Float+         -- | During viewport translation,-        --      where the mouse was clicked on the window.+        --      where the mouse was clicked on the window to start the translate.         , viewStateTranslateMark        :: !(Maybe (Float, Float))          -- | During viewport rotation,  -        --      where the mouse was clicked on the window+        --      where the mouse was clicked on the window to starte the rotate.         , viewStateRotateMark           :: !(Maybe (Float, Float)) +        -- | During viewport scale,+        --      where the mouse was clicked on the window to start the scale.+        , viewStateScaleMark            :: !(Maybe (Float, Float))++        -- | The current viewport.         , viewStateViewPort             :: ViewPort         } @@ -164,8 +182,10 @@         { viewStateCommands             = Map.fromList commandConfig         , viewStateScaleStep            = 0.85         , viewStateRotateFactor         = 0.6+        , viewStateScaleFactor          = 0.01         , viewStateTranslateMark        = Nothing         , viewStateRotateMark           = Nothing+        , viewStateScaleMark            = Nothing         , viewStateViewPort             = viewPortInit }  @@ -217,41 +237,51 @@         = Just $ viewState { viewStateViewPort                                  = port { viewPortRotate = viewPortRotate port - 5 } } ++        -- Start Translation.         | isCommand commands CTranslate key keyMods         , keyState      == Down-        , not currentlyRotating+        , not  $ currentlyRotating    || currentlyScaling         = Just $ viewState { viewStateTranslateMark = Just pos } -        -- We don't want to use 'isCommand' here because the user may have-        -- released the translation modifier key before the mouse button.-        -- and we still want to cancel the translation.-        | currentlyTranslating-        , keyState      == Up-        = Just $ viewState { viewStateTranslateMark = Nothing }-+        -- Start Rotation.         | isCommand commands CRotate key keyMods         , keyState      == Down-        , not currentlyTranslating+        , not  $ currentlyTranslating || currentlyScaling         = Just $ viewState { viewStateRotateMark = Just pos } -        -- We don't want to use 'isCommand' here because the user may have-        -- released the rotation modifier key before the mouse button, -        -- and we still want to cancel the rotation.-        | currentlyRotating-        , keyState      == Up-        = Just $ viewState { viewStateRotateMark = Nothing }+        -- Start Scale.+        | isCommand commands CScale key keyMods+        , keyState      == Down+        , not  $ currentlyTranslating || currentlyRotating+        = Just $ viewState { viewStateScaleMark  = Just pos } ++        -- Kill current translate/rotate/scale command when the mouse button+        -- is released.+        | keyState      == Up+        = let   killTranslate vs = vs { viewStateTranslateMark = Nothing }+                killRotate    vs = vs { viewStateRotateMark    = Nothing }+                killScale     vs = vs { viewStateScaleMark     = Nothing }+          in  Just+                $ (if currentlyTranslating then killTranslate else id)+                $ (if currentlyRotating    then killRotate    else id)+                $ (if currentlyScaling     then killScale     else id)+                $ viewState+         | otherwise         = Nothing         where   commands                = viewStateCommands viewState                 port                    = viewStateViewPort viewState                 currentlyTranslating    = isJust $ viewStateTranslateMark viewState-                currentlyRotating       = isJust $ viewStateRotateMark viewState+                currentlyRotating       = isJust $ viewStateRotateMark    viewState+                currentlyScaling        = isJust $ viewStateScaleMark     viewState   -- Note that only a translation or rotation applies, not both at the same time. updateViewStateWithEventMaybe (EventMotion pos) viewState- = motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus`+ = motionScale     (viewStateScaleMark     viewState) pos viewState `mplus`+   motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus`    motionRotate    (viewStateRotateMark    viewState) pos viewState  updateViewStateWithEventMaybe (EventResize _) _ @@ -266,7 +296,7 @@         , viewStateScaleStep    = scaleStep }  = viewState          { viewStateViewPort     -                = port { viewPortScale = viewPortScale port * scaleStep } }+                = port { viewPortScale = viewPortScale port / scaleStep } }   -- | Zoom out a `ViewState` by the scale step.@@ -277,7 +307,7 @@         , viewStateScaleStep    = scaleStep }  = viewState         { viewStateViewPort     -                = port { viewPortScale = viewPortScale port / scaleStep } }+                = port { viewPortScale = viewPortScale port * scaleStep } }   -- | Offset a viewport.@@ -295,8 +325,8 @@  -- | Apply a translation to the `ViewState`. motionTranslate -        :: Maybe (Float, Float) -        -> (Float, Float) +        :: Maybe (Float, Float)         -- Location of first mark.+        -> (Float, Float)               -- Current position.         -> ViewState -> Maybe ViewState  motionTranslate Nothing _ _ = Nothing@@ -317,8 +347,8 @@  -- | Apply a rotation to the `ViewState`. motionRotate -        :: Maybe (Float, Float) -        -> (Float, Float) +        :: Maybe (Float, Float)         -- Location of first mark.+        -> (Float, Float)               -- Current position.         -> ViewState -> Maybe ViewState  motionRotate Nothing _ _ = Nothing@@ -331,4 +361,32 @@  where  port            = viewStateViewPort viewState         rotate          = viewPortRotate port         rotateFactor    = viewStateRotateFactor viewState+++-- | Apply a scale to the `ViewState`.+motionScale+        :: Maybe (Float, Float)         -- Location of first mark.+        -> (Float, Float)               -- Current position.+        -> ViewState -> Maybe ViewState++motionScale Nothing _ _ = Nothing+motionScale (Just (_markX, markY)) (posX, posY) viewState+ = Just $ viewState+        { viewStateViewPort+          = let   -- Limit the amount of downward scaling so it maxes+                  -- out at 1 percent of the original. There's not much+                  -- point scaling down to no pixels, or going negative+                  -- so that the image is inverted.+                  ss      = if posY > markY+                                then scale - scale * (scaleFactor * (posY  - markY))+                                else scale + scale * (scaleFactor * (markY - posY))++                  ss'     = max 0.01 ss+            in    port { viewPortScale = ss' }++        , viewStateScaleMark    = Just (posX, posY) }+ where  port            = viewStateViewPort viewState+        scale           = viewPortScale port+        scaleFactor     = viewStateScaleFactor viewState+ 

@@ -1,13 +1,15 @@ --- | Display mode is for drawing a static picture.+-- | Animate a picture in a window. module Graphics.Gloss.Interface.IO.Animate         ( module Graphics.Gloss.Data.Display         , module Graphics.Gloss.Data.Picture         , module Graphics.Gloss.Data.Color         , animateIO-        , animateFixedIO)+        , animateFixedIO+        , Controller (..)) where import Graphics.Gloss.Data.Display+import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Animate@@ -23,14 +25,17 @@         -> Color                  -- ^ Background color.         -> (Float -> IO Picture)  -- ^ Function to produce the next frame of animation.                                    --      It is passed the time in seconds since the program started.+        -> (Controller -> IO ())  -- ^ Callback to take the display controller.         -> IO () -animateIO display backColor frameFunIO+animateIO display backColor+        frameFunIO eatControllerIO         = animateWithBackendIO                  defaultBackendState                  True              -- pannable                 display backColor                 frameFunIO+                eatControllerIO   -- | Like `animateIO` but don't allow the display to be panned around.@@ -40,10 +45,14 @@         -> Color                  -- ^ Background color.         -> (Float -> IO Picture)  -- ^ Function to produce the next frame of animation.                                    --      It is passed the time in seconds since the program started.+        -> (Controller -> IO ())  -- ^ Callback to take the display controller.         -> IO ()-animateFixedIO display backColor frameFunIO++animateFixedIO display backColor+        frameFunIO eatControllerIO         = animateWithBackendIO                  defaultBackendState                  False                 display backColor                 frameFunIO+                eatControllerIO

@@ -0,0 +1,67 @@++-- | Display mode is for drawing a static picture.+module Graphics.Gloss.Interface.IO.Display+        ( module Graphics.Gloss.Data.Display+        , module Graphics.Gloss.Data.Picture+        , module Graphics.Gloss.Data.Color+        , displayIO+        , Controller    (..))+where+import Graphics.Gloss.Data.Display+import Graphics.Gloss.Data.Controller+import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.Color+import Graphics.Gloss.Internals.Interface.Display+import Graphics.Gloss.Internals.Interface.Backend+++-- | Open a new window and display an infrequently updated picture.+--+--   Once the window is open you can use the same commands as with @display@.+--+--   * This wrapper is intended for mostly static pictures that do not+--     need to be updated more than once per second. For example, the picture+--     could show network activity over the last minute, a daily stock price,+--     or a weather forecast. If you want to show a real-time animation where+--     the frames are redrawn more frequently then use the `animate` wrapper+--     instead.+--+--   * The provided picture generating action will be invoked, and the+--     display redrawn in two situation:+--     1) We receive a display event, like someone clicks on the window.+--     2) When `controllerSetRedraw` has been set, some indeterminate time+--     between the last redraw, and one second from that.+--+--   * Note that calling `controllerSetRedraw` indicates that the picture should+--     be redrawn, but does not cause this to happen immediately, due to +--     limitations in the GLUT and GLFW window managers. The display runs on+--     a one second timer interrupt, and if there have been no display events+--     we need to wait for the next timer interrupt before redrawing.+--     Having the timer interrupt period at 1 second keeps the CPU usage+--     due to the context switches at under 1%.+--+--   * Also note that the picture generating action is called for every display+--     event, so if the user pans the display then it will be invoked at 10hz +--     or more during the pan. If you are generating the picture by reading some+--     on-disk files then you should track when the files were last updated+--     and cache the picture between updates. Caching the picture avoids+--     repeatedly reading and re-parsing your files during a pan. Consider+--     storing your current picture in an IORef, passing an action that just+--     reads this IORef, and forking a new thread that watches your files for updates.+--+displayIO+        :: Display                -- ^ Display mode.+        -> Color                  -- ^ Background color.+        -> IO Picture             -- ^ Action to produce the current picture.+        -> (Controller -> IO ())  -- ^ Callback to take the display controller.+        -> IO ()++displayIO dis backColor makePicture eatController+ =      displayWithBackend+                defaultBackendState+                dis+                backColor+                makePicture+                eatController++

@@ -1,7 +1,7 @@ {-# LANGUAGE ExplicitForAll #-}  -- | This game mode lets you manage your own input. Pressing ESC will not abort the program.---   You also don't get automatic pan and zoom controls like with `displayInWindow`.+--   You also don't get automatic pan and zoom controls like with `display`. module Graphics.Gloss.Interface.IO.Game         ( module Graphics.Gloss.Data.Display         , module Graphics.Gloss.Data.Picture@@ -30,6 +30,7 @@  playIO  display backColor simResolution         worldStart worldToPicture worldHandleEvent worldAdvance+  = playWithBackendIO defaultBackendState         display backColor simResolution         worldStart worldToPicture worldHandleEvent worldAdvance

@@ -29,3 +29,4 @@                 True            -- pannable                 display backColor                 (return . frameFun) +                (const (return ()))

@@ -14,17 +14,15 @@   -- | Open a new window and display the given picture.------   Use the following commands once the window is open:------      * Quit - esc-key.---      * Move Viewport - left-click drag, arrow keys.---      * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys.---      * Zoom Viewport - mouse wheel, or page up\/down-keys.--- display :: Display          -- ^ Display mode.         -> Color            -- ^ Background color.         -> Picture          -- ^ The picture to draw.         -> IO () -display = displayWithBackend defaultBackendState+display dis backColor picture+        = displayWithBackend+                defaultBackendState+                dis+                backColor+                (return picture)+                (const (return ()))

@@ -35,10 +35,11 @@ play    display backColor simResolution         worldStart worldToPicture worldHandleEvent worldAdvance - = playWithBackendIO defaultBackendState -        display backColor simResolution-        worldStart -        (return . worldToPicture)-        (\event world -> return $ worldHandleEvent event world)-        (\time  world -> return $ worldAdvance     time  world)-        True+ = do   _       <- playWithBackendIO defaultBackendState +                        display backColor simResolution+                        worldStart +                        (return . worldToPicture)+                        (\event world -> return $ worldHandleEvent event world)+                        (\time  world -> return $ worldAdvance     time  world)+                        True+        return ()

@@ -43,10 +43,11 @@ simulate display backColor simResolution           modelStart modelToPicture modelStep - = simulateWithBackendIO defaultBackendState-         display backColor simResolution-         modelStart-         (return . modelToPicture)-         (\view time model -> return $ modelStep view time model)+ = do   _       <- simulateWithBackendIO defaultBackendState+                        display backColor simResolution+                        modelStart+                        (return . modelToPicture)+                        (\view time model -> return $ modelStep view time model)+        return ()          

@@ -3,6 +3,7 @@         (animateWithBackendIO) where    import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState@@ -30,9 +31,12 @@         -> Color                 -- ^ Background color.         -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation.                                  --     It is passed the time in seconds since the program started.+        -> (Controller -> IO ()) -- ^ Eat the controller.         -> IO () -animateWithBackendIO backend pannable display backColor frameOp+animateWithBackendIO+        backend pannable display backColor+        frameOp eatController  = do            --          viewSR          <- newIORef viewStateInit@@ -76,7 +80,25 @@                   then [callback_viewState_keyMouse viewSR]                   else []) -        createWindow backend display backColor callbacks+        createWindow backend display backColor callbacks +           $ \ backendRef+           ->  eatController+                $ Controller+                { controllerSetRedraw+                   = postRedisplay backendRef++                , controllerModifyViewPort +                   = \modViewPort+                     -> do viewState       <- readIORef viewSR+                           port'           <- modViewPort $ viewStateViewPort viewState+                           let viewState'  =  viewState { viewStateViewPort = port' }+                           writeIORef viewSR viewState'+                           postRedisplay backendRef+                }++++  getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun

@@ -29,15 +29,15 @@         displayTimeLast         <- stateRef `getsIORef` stateDisplayTime         let displayTimeElapsed  = displayTime - displayTimeLast -        stateRef `modifyIORef` \s -> s +        modifyIORef' stateRef $ \s -> s                  { stateDisplayTime      = displayTime                  , stateDisplayTimeLast  = displayTimeLast }          -- increment the animation time-        animate         <- stateRef `getsIORef` stateAnimate-        animateCount    <- stateRef `getsIORef` stateAnimateCount-        animateTime     <- stateRef `getsIORef` stateAnimateTime-        animateStart    <- stateRef `getsIORef` stateAnimateStart+        animate        <- stateRef `getsIORef` stateAnimate+        animateCount   <- stateRef `getsIORef` stateAnimateCount+        animateTime    <- stateRef `getsIORef` stateAnimateTime+        animateStart   <- stateRef `getsIORef` stateAnimateStart  {-      when (animateCount `mod` 5 == 0)          $  putStr  $  "  displayTime        = " ++ show displayTime                ++ "\n"@@ -46,11 +46,11 @@                     ++ "  fps                = " ++ show (truncate $ 1 / displayTimeElapsed)   ++ "\n" -}               when (animate && not animateStart)-         $ stateRef `modifyIORef` \s -> s+         $ modifyIORef' stateRef $ \s -> s                { stateAnimateTime       = animateTime + displayTimeElapsed }                                  when animate-         $ stateRef `modifyIORef` \s -> s+         $ modifyIORef' stateRef $ \s -> s                { stateAnimateCount      = animateCount + 1                , stateAnimateStart      = False  } @@ -64,8 +64,11 @@         -- timing gate, limits the maximum frame frequency (FPS)         timeClamp       <- stateRef `getsIORef` stateDisplayTimeClamp -        gateTimeStart   <- elapsedTime backendRef                       -- the start of this gate-        gateTimeEnd     <- stateRef `getsIORef` stateGateTimeEnd        -- end of the previous gate+        -- the start of this gate+        gateTimeStart   <- elapsedTime backendRef                       ++        -- end of the previous gate+        gateTimeEnd     <- stateRef `getsIORef` stateGateTimeEnd                 let gateTimeElapsed = gateTimeStart - gateTimeEnd          when (gateTimeElapsed < timeClamp)@@ -73,7 +76,7 @@          gateTimeFinal   <- elapsedTime backendRef -        stateRef `modifyIORef` \s -> s +        modifyIORef' stateRef $ \s -> s                  { stateGateTimeEnd      = gateTimeFinal                  , stateGateTimeElapsed  = gateTimeElapsed } @@ -81,3 +84,4 @@ getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun  = liftM fun $ readIORef ref+

@@ -14,6 +14,7 @@ import qualified Graphics.Rendering.OpenGL as GL import qualified Control.Exception         as X + -- [Note: FreeGlut] -- ~~~~~~~~~~~~~~~~ -- We use GLUT for font rendering.@@ -32,6 +33,7 @@  import Graphics.Gloss.Internals.Interface.Backend.Types + -- | State of the GLFW backend library. data GLFWState         = GLFWState@@ -193,8 +195,8 @@         :: IORef GLFWState -> [Callback] -> IO ()  installDisplayCallbackGLFW stateRef callbacks- =  modifyIORef stateRef-        $ \s -> s { display = callbackDisplay stateRef callbacks }+ =  modifyIORef' stateRef $ \s -> s+        { display = callbackDisplay stateRef callbacks }   callbackDisplay@@ -408,7 +410,10 @@         -> IO (Int, Int) setMousePos stateRef x y  = do   let pos = (x,y)-        modifyIORef stateRef (\s -> s {mousePosition = pos})++        modifyIORef' stateRef $ \s -> s +                { mousePosition = pos }+         return pos  @@ -420,7 +425,8 @@         -> IO ()  installIdleCallbackGLFW stateRef callbacks -        = modifyIORef stateRef (\s -> s {idle = callbackIdle stateRef callbacks})+        = modifyIORef' stateRef $ \s -> s +                { idle = callbackIdle stateRef callbacks }  callbackIdle          :: IORef GLFWState -> [Callback]@@ -454,7 +460,9 @@                        display s                        GLFW.swapBuffers -               modifyIORef stateRef $ \s -> s { dirtyScreen = False }+               modifyIORef' stateRef $ \s -> s +                        { dirtyScreen = False }+                (readIORef stateRef) >>= (\s -> idle s)                GLFW.sleep 0.001                runMainLoopGLFW stateRef@@ -466,8 +474,8 @@         -> IO ()  postRedisplayGLFW stateRef-        = modifyIORef stateRef-        $ \s -> s { dirtyScreen = True }+        = modifyIORef' stateRef $ \s -> s +                { dirtyScreen = True }   -- Key Code Conversion --------------------------------------------------------

@@ -13,13 +13,27 @@ import Graphics.Gloss.Internals.Interface.Backend.Types  --- | We don't maintain any state information for the GLUT backend, ---   so this data type is empty.+-- | State information for the GLUT backend. data GLUTState          = GLUTState+        { -- Count of total number of frames that we have drawn.+          glutStateFrameCount   :: Int  +          -- Bool to remember if we've set the timeout callback.+        , glutStateHasTimeout   :: Bool ++          -- Bool to remember if we've set the idle callback.+        , glutStateHasIdle      :: Bool }+        deriving Show+++-- | Initial GLUT state. glutStateInit :: GLUTState-glutStateInit  = GLUTState+glutStateInit  +        = GLUTState+        { glutStateFrameCount   = 0 +        , glutStateHasTimeout   = False +        , glutStateHasIdle      = False }   instance Backend GLUTState where@@ -174,28 +188,79 @@ installDisplayCallbackGLUT ref callbacks         = GLUT.displayCallback $= callbackDisplay ref callbacks + callbackDisplay          :: IORef GLUTState -> [Callback]         -> IO () -callbackDisplay ref callbacks - = do   -- clear the display+callbackDisplay refState callbacks + = do   +        -- Clear the display         GL.clear [GL.ColorBuffer, GL.DepthBuffer]         GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) -        -- get the display callbacks from the chain-        let funs  = [f ref | (Display f) <- callbacks]+        -- Run all the display callbacks to draw the window contents.+        let funs  = [f refState | (Display f) <- callbacks]         sequence_ funs -        -- swap front and back buffers+        -- Swap front and back buffers         GLUT.swapBuffers +        -- Timeout.+        -- When there is no idle callback set the GLUT mainloop will block+        -- forever waiting for display events. This prevents us from updating+        -- the display on external events like files changing. The API doesn't+        -- provide a way to wake it up on these other events.+        --+        -- Set a timeout so that GLUT will return from its mainloop after a+        -- a second and give us a chance to check for other events.+        --+        -- The alternative would be to set an Idle callback and spin the CPU.+        -- This is ok for real-time animations, but a CPU hog for mostly static+        -- displays.+        --+        -- We only want to add a timeout when one doesn't already exist,+        -- otherwise we'll get both events.+        --+        state   <- readIORef refState+        when (  (not $ glutStateHasTimeout state)+             && (not $ glutStateHasIdle    state))+         $ do   +                -- Setting the timer interrupt to 1sec keeps CPU usage for a+                -- single process to < 0.5% or so on OSX. This is the rate+                -- that the process is woken up, but GLUT will only actually+                -- call the display call if postRedisplay has been set.+                let msecHeartbeat = 1000++                -- We're installing this callback on the first display+                -- call because it's a GLUT specific mechanism. +                -- We don't do the same thing for other Backends.+                GLUT.addTimerCallback msecHeartbeat+                 $ timerCallback msecHeartbeat++                -- Rember that we've done this filthy hack.+                atomicModifyIORef' refState+                 $ \s -> (s { glutStateHasTimeout = True }, ())++     -- Don't report errors by default.     -- The windows OpenGL implementation seems to complain for no reason.      --  GLUT.reportErrors +        atomicModifyIORef' refState+         $ \s -> ( s { glutStateFrameCount = glutStateFrameCount s + 1 }+                 , ())+         return () ++-- | Oneshot timer callback that re-registers itself.+timerCallback :: Int -> IO ()+timerCallback msec+ = do   GLUT.addTimerCallback msec+         $ do   timerCallback msec++ -- Reshape Callback ----------------------------------------------------------- installReshapeCallbackGLUT         :: IORef GLUTState -> [Callback]@@ -268,9 +333,20 @@         :: IORef GLUTState -> [Callback]         -> IO () -installIdleCallbackGLUT ref callbacks-        = GLUT.idleCallback $= Just (callbackIdle ref callbacks)+installIdleCallbackGLUT refState callbacks+        -- If the callback list does not actually contain an idle callback+        -- then don't install one that just does nothing. If we do then GLUT+        -- will still call us back after whenever it's idle and waste CPU time.+        | any isIdleCallback callbacks+        = do    GLUT.idleCallback $= Just (callbackIdle refState callbacks)+                atomicModifyIORef' refState+                 $ \state -> (state { glutStateHasIdle = True }, ()) +        | otherwise+        = return ()+++-- | Call back when glut is idle. callbackIdle          :: IORef GLUTState -> [Callback]         -> IO ()@@ -278,6 +354,10 @@ callbackIdle ref callbacks         = sequence_         $ [f ref | Idle f <- callbacks]+++-- Timeout Callback -----------------------------------------------------------+   -------------------------------------------------------------------------------

@@ -77,21 +77,27 @@ -- can thus call the appropriate backend functions.  -- | Display callback has no arguments.-type DisplayCallback       = forall a . Backend a => IORef a -> IO ()+type DisplayCallback+        = forall a . Backend a => IORef a -> IO ()  -- | Arguments: KeyType, Key Up \/ Down, Ctrl \/ Alt \/ Shift pressed, latest mouse location.-type KeyboardMouseCallback = forall a . Backend a => IORef a -> Key -> KeyState -> Modifiers -> (Int,Int) -> IO ()+type KeyboardMouseCallback +        = forall a . Backend a => IORef a -> Key -> KeyState -> Modifiers -> (Int,Int) -> IO ()  -- | Arguments: (PosX,PosY) in pixels.-type MotionCallback        = forall a . Backend a => IORef a -> (Int,Int) -> IO ()+type MotionCallback+        = forall a . Backend a => IORef a -> (Int,Int) -> IO ()  -- | No arguments.-type IdleCallback          = forall a . Backend a => IORef a -> IO ()+type IdleCallback+        = forall a . Backend a => IORef a -> IO ()  -- | Arguments: (Width,Height) in pixels.-type ReshapeCallback       = forall a . Backend a => IORef a -> (Int,Int) -> IO ()+type ReshapeCallback+        = forall a . Backend a => IORef a -> (Int,Int) -> IO ()  +------------------------------------------------------------------------------- data Callback         = Display  DisplayCallback         | KeyMouse KeyboardMouseCallback@@ -99,6 +105,15 @@         | Motion   MotionCallback         | Reshape  ReshapeCallback ++-- | Check if this is an `Idle` callback.+isIdleCallback :: Callback -> Bool+isIdleCallback cc+ = case cc of +        Idle _  -> True+        _       -> False++ ------------------------------------------------------------------------------- -- This is Glosses view of mouse and keyboard events. -- The actual events provided by the backends are converted to this form@@ -193,10 +208,11 @@         | KeyPadEnter         deriving (Show, Eq, Ord) + data Modifiers         = Modifiers         { shift :: KeyState         , ctrl  :: KeyState-        , alt   :: KeyState-        }+        , alt   :: KeyState }         deriving (Show, Eq, Ord)+

@@ -3,6 +3,7 @@         (displayWithBackend) where    import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState@@ -20,22 +21,27 @@  displayWithBackend         :: Backend a-        => a                -- ^ Initial state of the backend.-        -> Display          -- ^ Display config.-        -> Color            -- ^ Background color.-        -> Picture          -- ^ The picture to draw.+        => a                            -- ^ Initial state of the backend.+        -> Display                      -- ^ Display config.+        -> Color                        -- ^ Background color.+        -> IO Picture                   -- ^ Make the picture to draw.+        -> (Controller -> IO ())        -- ^ Eat the controller         -> IO () -displayWithBackend backend displayMode background picture- =  do  viewSR          <- newIORef viewStateInit+displayWithBackend+        backend displayMode background+        makePicture+        eatController + =  do  viewSR          <- newIORef viewStateInit         renderS         <- initState         renderSR        <- newIORef renderS                  let renderFun backendRef = do-                port      <- viewStateViewPort <$> readIORef viewSR-                options   <- readIORef renderSR+                port       <- viewStateViewPort <$> readIORef viewSR+                options    <- readIORef renderSR                 windowSize <- getWindowDimensions backendRef+                picture    <- makePicture                  displayPicture                          windowSize@@ -58,4 +64,23 @@                 , callback_viewState_motion   viewSR                 , callback_viewState_reshape ] +        -- When we create the window we can pass a function to get a+        -- reference to the backend state. Using this we make a controller+        -- so the client can control the window asynchronously.         createWindow backend displayMode background callbacks+         $ \  backendRef+           -> eatController+                $ Controller+                { controllerSetRedraw+                   = do postRedisplay backendRef++                , controllerModifyViewPort +                   = \modViewPort+                     -> do viewState       <- readIORef viewSR+                           port'           <- modViewPort $ viewStateViewPort viewState+                           let viewState'  =  viewState { viewStateViewPort = port' }+                           writeIORef viewSR viewState'+                           postRedisplay backendRef+                }++

@@ -102,7 +102,13 @@         let exitCallback                  = if withCallbackExit then [callback_exit ()] else [] -        createWindow backend display backgroundColor $ callbacks ++ exitCallback+        createWindow +                backend +                display +                backgroundColor +                (callbacks ++ exitCallback)+                (\_ -> return ())+   -- | Callback for KeyMouse events.

@@ -100,4 +100,8 @@                 , callback_viewState_motion   viewSR                 , callback_viewState_reshape ] -        createWindow backend display backgroundColor callbacks+        createWindow backend display backgroundColor+                callbacks+                (const (return ()))++

@@ -78,16 +78,17 @@         let nFinal      = nStart + thisSteps          -- keep advancing the world until we get to the final iteration number-        (_,world') <- untilM    (\(n, _)        -> n >= nFinal)-                                (\(n, w)        -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w))-                                (nStart, worldS)+        (_,world') +         <- untilM (\(n, _)        -> n >= nFinal)+                   (\(n, w)        -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w))+                   (nStart, worldS)          -- write the world back into its IORef         -- We need to seq on the world to avoid space leaks when the window is not showing.         world' `seq` writeIORef worldSR world'          -- update the control state-        simSR `modifyIORef` \c -> c+        modifyIORef' simSR $ \c -> c                 { SM.stateIteration     = nFinal                 , SM.stateSimTime       = newSimTime }         

@@ -10,7 +10,7 @@ import Graphics.Gloss.Internals.Interface.Debug import Graphics.Rendering.OpenGL                        (($=)) import qualified Graphics.Rendering.OpenGL.GL           as GL-import Data.IORef (newIORef)+import Data.IORef (IORef, newIORef) import Control.Monad  -- | Open a window and use the supplied callbacks to handle window events.@@ -19,7 +19,9 @@         => a         -> Display         -> Color                -- ^ Color to use when clearing.-        -> [Callback]           -- ^ Callbacks to use+        -> [Callback]           -- ^ Callbacks to use.+        -> (IORef a -> IO ())   -- ^ Give the backend back to the caller before+                                --   entering the main loop.         -> IO ()  createWindow@@ -27,6 +29,7 @@         display         clearColor         callbacks+        eatBackend  = do         -- Turn this on to spew debugging info to stdout         let debug       = False@@ -67,6 +70,8 @@                 dumpFramebufferState                 dumpFragmentState +        eatBackend backendStateRef+         when debug          $ do   putStr  $ "* entering mainloop..\n" @@ -76,4 +81,3 @@         when debug          $      putStr  $ "* all done\n" -        return ()

@@ -1,5 +1,5 @@ Name:                gloss-Version:             1.9.4.1+Version:             1.10.1.1 License:             MIT License-file:        LICENSE Author:              Ben Lippmeier@@ -41,10 +41,10 @@         ghc-prim   == 0.4.*,         containers == 0.5.*,         bytestring == 0.10.*,-        OpenGL     == 2.12.*,+        OpenGL     >= 2.12 && < 3.1,         GLUT       == 2.7.*,         bmp        == 1.2.*,-        gloss-rendering == 1.9.3.*+        gloss-rendering == 1.10.*    ghc-options:         -O2 -Wall@@ -53,6 +53,7 @@         Graphics.Gloss         Graphics.Gloss.Data.Bitmap         Graphics.Gloss.Data.Color+        Graphics.Gloss.Data.Controller         Graphics.Gloss.Data.Display         Graphics.Gloss.Data.Picture         Graphics.Gloss.Data.Point@@ -66,6 +67,7 @@         Graphics.Gloss.Interface.Pure.Simulate         Graphics.Gloss.Interface.Pure.Game         Graphics.Gloss.Interface.IO.Animate+        Graphics.Gloss.Interface.IO.Display         Graphics.Gloss.Interface.IO.Simulate         Graphics.Gloss.Interface.IO.Game @@ -101,7 +103,7 @@    If flag(GLFW)     Build-Depends:-        GLFW-b >= 0.1.4.1 && < 0.2+        GLFW-b >= 1.4.1.0 && < 2     CPP-Options: -DWITHGLFW     Other-modules:         Graphics.Gloss.Internals.Interface.Backend.GLFW