diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -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 . diff --git a/Graphics/Gloss/Data/Bitmap.hs b/Graphics/Gloss/Data/Bitmap.hs --- a/Graphics/Gloss/Data/Bitmap.hs +++ b/Graphics/Gloss/Data/Bitmap.hs @@ -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 diff --git a/Graphics/Gloss/Data/Color.hs b/Graphics/Gloss/Data/Color.hs --- a/Graphics/Gloss/Data/Color.hs +++ b/Graphics/Gloss/Data/Color.hs @@ -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 diff --git a/Graphics/Gloss/Data/Controller.hs b/Graphics/Gloss/Data/Controller.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Data/Controller.hs @@ -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 () } diff --git a/Graphics/Gloss/Data/ViewPort.hs b/Graphics/Gloss/Data/ViewPort.hs --- a/Graphics/Gloss/Data/ViewPort.hs +++ b/Graphics/Gloss/Data/ViewPort.hs @@ -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. diff --git a/Graphics/Gloss/Data/ViewState.hs b/Graphics/Gloss/Data/ViewState.hs --- a/Graphics/Gloss/Data/ViewState.hs +++ b/Graphics/Gloss/Data/ViewState.hs @@ -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 + diff --git a/Graphics/Gloss/Interface/IO/Animate.hs b/Graphics/Gloss/Interface/IO/Animate.hs --- a/Graphics/Gloss/Interface/IO/Animate.hs +++ b/Graphics/Gloss/Interface/IO/Animate.hs @@ -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 diff --git a/Graphics/Gloss/Interface/IO/Display.hs b/Graphics/Gloss/Interface/IO/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Display.hs @@ -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 + + diff --git a/Graphics/Gloss/Interface/IO/Game.hs b/Graphics/Gloss/Interface/IO/Game.hs --- a/Graphics/Gloss/Interface/IO/Game.hs +++ b/Graphics/Gloss/Interface/IO/Game.hs @@ -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 diff --git a/Graphics/Gloss/Interface/Pure/Animate.hs b/Graphics/Gloss/Interface/Pure/Animate.hs --- a/Graphics/Gloss/Interface/Pure/Animate.hs +++ b/Graphics/Gloss/Interface/Pure/Animate.hs @@ -29,3 +29,4 @@ True -- pannable display backColor (return . frameFun) + (const (return ())) diff --git a/Graphics/Gloss/Interface/Pure/Display.hs b/Graphics/Gloss/Interface/Pure/Display.hs --- a/Graphics/Gloss/Interface/Pure/Display.hs +++ b/Graphics/Gloss/Interface/Pure/Display.hs @@ -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 ())) diff --git a/Graphics/Gloss/Interface/Pure/Game.hs b/Graphics/Gloss/Interface/Pure/Game.hs --- a/Graphics/Gloss/Interface/Pure/Game.hs +++ b/Graphics/Gloss/Interface/Pure/Game.hs @@ -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 () diff --git a/Graphics/Gloss/Interface/Pure/Simulate.hs b/Graphics/Gloss/Interface/Pure/Simulate.hs --- a/Graphics/Gloss/Interface/Pure/Simulate.hs +++ b/Graphics/Gloss/Interface/Pure/Simulate.hs @@ -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 () diff --git a/Graphics/Gloss/Internals/Interface/Animate.hs b/Graphics/Gloss/Internals/Interface/Animate.hs --- a/Graphics/Gloss/Internals/Interface/Animate.hs +++ b/Graphics/Gloss/Internals/Interface/Animate.hs @@ -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 diff --git a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs --- a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs @@ -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 + diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs @@ -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 -------------------------------------------------------- diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs @@ -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 ----------------------------------------------------------- + ------------------------------------------------------------------------------- diff --git a/Graphics/Gloss/Internals/Interface/Backend/Types.hs b/Graphics/Gloss/Internals/Interface/Backend/Types.hs --- a/Graphics/Gloss/Internals/Interface/Backend/Types.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/Types.hs @@ -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) + diff --git a/Graphics/Gloss/Internals/Interface/Display.hs b/Graphics/Gloss/Internals/Interface/Display.hs --- a/Graphics/Gloss/Internals/Interface/Display.hs +++ b/Graphics/Gloss/Internals/Interface/Display.hs @@ -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 + } + + diff --git a/Graphics/Gloss/Internals/Interface/Game.hs b/Graphics/Gloss/Internals/Interface/Game.hs --- a/Graphics/Gloss/Internals/Interface/Game.hs +++ b/Graphics/Gloss/Internals/Interface/Game.hs @@ -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. diff --git a/Graphics/Gloss/Internals/Interface/Simulate.hs b/Graphics/Gloss/Internals/Interface/Simulate.hs --- a/Graphics/Gloss/Internals/Interface/Simulate.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate.hs @@ -100,4 +100,8 @@ , callback_viewState_motion viewSR , callback_viewState_reshape ] - createWindow backend display backgroundColor callbacks + createWindow backend display backgroundColor + callbacks + (const (return ())) + + diff --git a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs @@ -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 } diff --git a/Graphics/Gloss/Internals/Interface/Window.hs b/Graphics/Gloss/Internals/Interface/Window.hs --- a/Graphics/Gloss/Internals/Interface/Window.hs +++ b/Graphics/Gloss/Internals/Interface/Window.hs @@ -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 () diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -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