diff --git a/Graphics/Gloss/Interface/Environment.hs b/Graphics/Gloss/Interface/Environment.hs --- a/Graphics/Gloss/Interface/Environment.hs +++ b/Graphics/Gloss/Interface/Environment.hs @@ -1,19 +1,18 @@ module Graphics.Gloss.Interface.Environment where -import Graphics.Gloss.Internals.Interface.Backend.GLUT -import qualified Graphics.UI.GLUT as GLUT -import qualified Graphics.Rendering.OpenGL as GL -import Data.IORef +import Data.IORef (newIORef) +import qualified Graphics.Gloss.Internals.Interface.Backend.Types as Backend.Types +import Graphics.Gloss.Internals.Interface.Backend (defaultBackendState) + -- | Get the size of the screen, in pixels. -- -- This will be the size of the rendered gloss image when -- fullscreen mode is enabled. -- getScreenSize :: IO (Int, Int) -getScreenSize - = do backendStateRef <- newIORef glutStateInit - initializeGLUT backendStateRef False - GL.Size width height <- GLUT.get GLUT.screenSize - return (fromIntegral width, fromIntegral height) +getScreenSize = do + backendStateRef <- newIORef defaultBackendState + Backend.Types.initializeBackend backendStateRef False + Backend.Types.getScreenSize backendStateRef 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 @@ -6,13 +6,12 @@ (GLFWState) where import Data.IORef -import Data.Char (toLower) import Data.Maybe (fromJust) import Control.Concurrent import Control.Monad import Graphics.Gloss.Data.Display --- import Graphics.UI.GLFW (WindowValue(..)) import qualified Graphics.UI.GLFW as GLFW +import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL as GL import qualified Control.Exception as X @@ -58,7 +57,7 @@ , idle :: IO () -- | The Window Handle - , winHdl :: GLFW.Window + , optWinHdl :: Maybe GLFW.Window } @@ -71,10 +70,18 @@ , mouseWheelPos = 0 , dirtyScreen = True , display = return () - , idle = return () } + , idle = return () + , optWinHdl = Nothing } +-- | Fetch the window handle from the state if it has been initialized. +winHdl :: GLFWState -> GLFW.Window +winHdl state = + case optWinHdl state of + Just handle -> handle + Nothing -> error "GLFW backend: requested uninitialized window handle" + instance Backend GLFWState where initBackendState = glfwStateInit initializeBackend = initializeGLFW @@ -90,14 +97,20 @@ runMainLoop = runMainLoopGLFW postRedisplay = postRedisplayGLFW getWindowDimensions = (\ref -> windowHandle ref >>= \win -> GLFW.getWindowSize win) + getScreenSize = getScreenSizeGLFW elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt) - sleep = (\_ sec -> threadDelay (floor (sec * fromIntegral 1000000))) --GLFW.sleep sec) + sleep = (\_ sec -> threadDelay (floor (sec * 1000000.0))) --GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do + + let simpleErrorCallback e s = + putStrLn $ unwords [ "GLFW backend: ", show e, show s ] + GLFW.setErrorCallback (Just simpleErrorCallback) + _ <- GLFW.init glfwVersion <- GLFW.getVersion @@ -120,7 +133,7 @@ GLUT.exit #endif win <- windowHandle ref - GLFW.destroyWindow win + GLFW.setWindowShouldClose win True -- Open Window ---------------------------------------------------------------- @@ -131,15 +144,16 @@ -> IO () openWindowGLFW ref (InWindow title (sizeX, sizeY) pos) - = do win <- GLFW.createWindow + = do win <- GLFW.createWindow sizeX sizeY title Nothing - Nothing + Nothing - modifyIORef' ref (\s -> s { winHdl = fromJust win}) + modifyIORef' ref (\s -> s { optWinHdl = win }) uncurry (GLFW.setWindowPos (fromJust win)) pos + GLFW.makeContextCurrent win -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. @@ -152,14 +166,15 @@ let sizeX = GLFW.videoModeWidth (fromJust vmode) let sizeY = GLFW.videoModeHeight (fromJust vmode) - win <- GLFW.createWindow + win <- GLFW.createWindow sizeX sizeY "" mon - Nothing + Nothing - modifyIORef' ref (\s -> s { winHdl = fromJust win}) + modifyIORef' ref (\s -> s { optWinHdl = win}) + GLFW.makeContextCurrent win -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. @@ -173,16 +188,28 @@ = do s <- readIORef ref return $ winHdl s + +getScreenSizeGLFW :: IORef GLFWState -> IO (Int,Int) +getScreenSizeGLFW _state = do + monitor <- GLFW.getPrimaryMonitor + vmode <- GLFW.getVideoMode (fromJust monitor) + + let sizeX = GLFW.videoModeWidth (fromJust vmode) + let sizeY = GLFW.videoModeHeight (fromJust vmode) + + pure (sizeX, sizeY) + + -- Dump State ----------------------------------------------------------------- -- | Print out the internal GLFW state. dumpStateGLFW :: IORef GLFWState -> IO () dumpStateGLFW ref = do win <- windowHandle ref (ww,wh) <- GLFW.getWindowSize win - + -- GLFW-b does not provide a general function to query windowHints -- could be added by adding additional getWindowHint which --- uses glfwGetWindowAttrib behind the scenes as has been done +-- uses glfwGetWindowAttrib behind the scenes as has been done -- already for e.g. getWindowVisible which uses glfwGetWindowAttrib {- r <- GLFW.getWindowHint NumRedBits @@ -241,6 +268,11 @@ GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) + -- set the OpenGL viewport to account for any HiDPI discrepancy + (width, height) <- windowHandle stateRef >>= GLFW.getFramebufferSize + GL.viewport $= ( GL.Position 0 0 + , GL.Size (fromIntegral width) (fromIntegral height)) + -- get the display callbacks from the chain let funs = [f stateRef | (Display f) <- callbacks] sequence_ funs @@ -259,7 +291,7 @@ GLFW.setWindowCloseCallback win (Just winClosed) where winClosed :: GLFW.WindowCloseCallback - winClosed win = do + winClosed _win = do #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit @@ -279,7 +311,7 @@ :: IORef GLFWState -> [Callback] -> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO () -callbackReshape glfwState callbacks win sizeX sizeY +callbackReshape glfwState callbacks _win sizeX sizeY = sequence_ $ map (\f -> f (sizeX, sizeY)) [f glfwState | Reshape f <- callbacks] @@ -312,7 +344,7 @@ -- -> GLFW.Key -> Bool -- -> IO () -callbackKeyboard stateRef callbacks win key scancode keystateglfw modifiers +callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers = do let keystate = keystateglfw == GLFW.KeyState'Pressed (modsSet, GLFWState mods pos _ _ _ _ _) <- setModifiers stateRef key keystate @@ -357,12 +389,12 @@ -- Window -> Char -> IO () -- -> Char -> Bool -> IO () -callbackChar stateRef callbacks win char -- keystate +callbackChar stateRef callbacks _win char -- keystate = do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef let key' = charToSpecial char - -- TODO: is this correct? GLFW does not provide the keystate + -- TODO: is this correct? GLFW does not provide the keystate -- in a character callback, here we asume that its pressed - let keystate = True + let keystate = True -- Only key presses of characters are passed to this callback, -- character key releases are caught by the 'keyCallback'. This is an @@ -382,8 +414,8 @@ callbackMouseButton :: IORef GLFWState -> [Callback] -> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () - -callbackMouseButton stateRef callbacks win key keystate modifier + +callbackMouseButton stateRef callbacks _win key keystate _modifier = do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef let key' = fromGLFW key let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up @@ -401,7 +433,7 @@ -- -> Int -- -> IO () -- ScrollCallback = Window -> Double -> Double -> IO () -callbackMouseWheel stateRef callbacks win x y +callbackMouseWheel stateRef callbacks _win x _y = do (key, keystate) <- setMouseWheel stateRef (floor x) (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef @@ -439,7 +471,7 @@ callbackMotion :: IORef GLFWState -> [Callback] -> GLFW.CursorPosCallback -callbackMotion stateRef callbacks win x y +callbackMotion stateRef callbacks _win x y = do pos <- setMousePos stateRef (floor x) (floor y) -- Call all the Gloss Motion actions with the new state. @@ -481,38 +513,57 @@ -- Main Loop ------------------------------------------------------------------ -runMainLoopGLFW - :: IORef GLFWState - -> IO () -runMainLoopGLFW stateRef - = X.catch go exit - where - exit :: X.SomeException -> IO () - exit e = print e >> exitGLFW stateRef +runMainLoopGLFW :: IORef GLFWState -> IO () +runMainLoopGLFW stateRef = do + X.catch go handleException + GLFW.destroyWindow =<< windowHandle stateRef + GLFW.terminate - go :: IO () - go - = - do win <- windowHandle stateRef - windowIsOpen <- GLFW.windowShouldClose win - when windowIsOpen - $ do GLFW.pollEvents - dirty <- fmap dirtyScreen $ readIORef stateRef + where + handleException :: X.SomeException -> IO () + handleException = print - when dirty - $ do s <- readIORef stateRef - display s - GLFW.swapBuffers win + clearDirtyFlag :: IO () + clearDirtyFlag = modifyIORef' + stateRef + (\state -> state { dirtyScreen = False }) - modifyIORef' stateRef $ \s -> s - { dirtyScreen = False } + display' :: IO () + display' = readIORef stateRef >>= display - (readIORef stateRef) >>= (\s -> idle s) - threadDelay 1000 - runMainLoopGLFW stateRef + idle' :: IO () + idle' = readIORef stateRef >>= idle + swapBuffers' :: IO () + swapBuffers' = windowHandle stateRef >>= GLFW.swapBuffers + windowShouldClose :: IO Bool + windowShouldClose = windowHandle stateRef >>= GLFW.windowShouldClose + + unlessM :: Monad m => m Bool -> m () -> m () + unlessM testAction action = do + sentinel <- testAction + unless sentinel action + + go :: IO () + go = do + -- Perform drawing, clear the dirty flag, do idle processing + display' + clearDirtyFlag + idle' + + -- Swap buffers. This swaps the GL buffers and will block + -- until the next v-sync. In GLFW, this effectively pegs the + -- maximum frame rate to 60fps, but will also stop the + -- application from consuming 100% CPU. + swapBuffers' + + -- Poll for GLFW events; quit if necessary. + GLFW.pollEvents + unlessM windowShouldClose go + + -- Redisplay ------------------------------------------------------------------ postRedisplayGLFW :: IORef GLFWState @@ -530,31 +581,31 @@ instance GLFWKey GLFW.Key where fromGLFW key = case key of - GLFW.Key'A -> charToSpecial 'a' - GLFW.Key'B -> charToSpecial 'b' - GLFW.Key'C -> charToSpecial 'c' - GLFW.Key'D -> charToSpecial 'd' - GLFW.Key'E -> charToSpecial 'e' - GLFW.Key'F -> charToSpecial 'f' - GLFW.Key'G -> charToSpecial 'g' - GLFW.Key'H -> charToSpecial 'h' - GLFW.Key'I -> charToSpecial 'i' - GLFW.Key'J -> charToSpecial 'j' - GLFW.Key'K -> charToSpecial 'k' - GLFW.Key'L -> charToSpecial 'l' - GLFW.Key'M -> charToSpecial 'm' - GLFW.Key'N -> charToSpecial 'n' - GLFW.Key'O -> charToSpecial 'o' - GLFW.Key'P -> charToSpecial 'p' - GLFW.Key'Q -> charToSpecial 'q' - GLFW.Key'R -> charToSpecial 'r' - GLFW.Key'S -> charToSpecial 's' - GLFW.Key'T -> charToSpecial 't' - GLFW.Key'U -> charToSpecial 'u' - GLFW.Key'V -> charToSpecial 'v' - GLFW.Key'W -> charToSpecial 'w' - GLFW.Key'X -> charToSpecial 'x' - GLFW.Key'Y -> charToSpecial 'y' + GLFW.Key'A -> charToSpecial 'a' + GLFW.Key'B -> charToSpecial 'b' + GLFW.Key'C -> charToSpecial 'c' + GLFW.Key'D -> charToSpecial 'd' + GLFW.Key'E -> charToSpecial 'e' + GLFW.Key'F -> charToSpecial 'f' + GLFW.Key'G -> charToSpecial 'g' + GLFW.Key'H -> charToSpecial 'h' + GLFW.Key'I -> charToSpecial 'i' + GLFW.Key'J -> charToSpecial 'j' + GLFW.Key'K -> charToSpecial 'k' + GLFW.Key'L -> charToSpecial 'l' + GLFW.Key'M -> charToSpecial 'm' + GLFW.Key'N -> charToSpecial 'n' + GLFW.Key'O -> charToSpecial 'o' + GLFW.Key'P -> charToSpecial 'p' + GLFW.Key'Q -> charToSpecial 'q' + GLFW.Key'R -> charToSpecial 'r' + GLFW.Key'S -> charToSpecial 's' + GLFW.Key'T -> charToSpecial 't' + GLFW.Key'U -> charToSpecial 'u' + GLFW.Key'V -> charToSpecial 'v' + GLFW.Key'W -> charToSpecial 'w' + GLFW.Key'X -> charToSpecial 'x' + GLFW.Key'Y -> charToSpecial 'y' GLFW.Key'Z -> charToSpecial 'z' GLFW.Key'Space -> SpecialKey KeySpace GLFW.Key'Escape -> SpecialKey KeyEsc @@ -613,7 +664,7 @@ GLFW.Key'PadDecimal -> SpecialKey KeyPadDecimal GLFW.Key'PadEqual -> Char '=' GLFW.Key'PadEnter -> SpecialKey KeyPadEnter - _ -> SpecialKey KeyUnknown + _ -> SpecialKey KeyUnknown -- | Convert char keys to special keys to work around a bug in 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 @@ -78,6 +78,10 @@ = do GL.Size sizeX sizeY <- get GLUT.windowSize return (fromEnum sizeX,fromEnum sizeY) + getScreenSize _ + = do GL.Size width height <- get GLUT.screenSize + return (fromIntegral width, fromIntegral height) + elapsedTime _ = do t <- get GLUT.elapsedTime return $ (fromIntegral t) / 1000 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 @@ -64,6 +64,9 @@ -- | Function that returns (width,height) of the window in pixels. getWindowDimensions :: IORef a -> IO (Int,Int) + -- | Function that returns (width,height) of a fullscreen window in pixels. + getScreenSize :: IORef a -> IO (Int,Int) + -- | Function that reports the time elapsed since the application started. -- (in seconds) elapsedTime :: IORef a -> IO Double diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,5 +1,5 @@ Name: gloss -Version: 1.13.1.2 +Version: 1.13.2.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -35,11 +35,6 @@ Description: Enable the GLFW backend Default: False -Flag ExplicitBackend - Description: Expose versions of 'display' and friends that allow - you to choose what window manager backend to use. - Default: False - Library Build-Depends: base >= 4.8 && < 5 @@ -108,11 +103,13 @@ If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules: - Graphics.Gloss.Internals.Interface.Backend.GLUT + Graphics.Gloss.Internals.Interface.Backend.GLUT + -- NOTE: GLUT is still required for text rendering, and must be initialized + -- on Linux platforms. Thus, the GLFW backend still requires GLUT. If flag(GLFW) Build-Depends: - GLFW-b >= 1.4.1.0 && < 2 + GLFW-b >= 1.4.1.0 && < 2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW