{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} -- | Support for using GLFW as the window manager backend. module Graphics.Gloss.Internals.Interface.Backend.GLFW (GLFWState) where import Data.IORef import Control.Monad import Graphics.UI.GLFW (WindowValue(..)) import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL -- [Note: FreeGlut] -- ~~~~~~~~~~~~~~~~ -- We use GLUT for font rendering. -- On freeglut-based installations (usually linux) we need to explicitly -- initialize GLUT before we can use any of it's functions. -- --- We also need to deinitialize (exit) GLUT when we close the GLFW -- window, otherwise opening a gloss window again from GHCi will crash. -- For the OS X and Windows version of GLUT there are no such restrictions. -- -- We assume also assume that only linux installations use freeglut. -- #ifdef linux_HOST_OS import qualified Graphics.UI.GLUT as GLUT #endif import Graphics.Gloss.Internals.Interface.Backend.Types -- | State of the GLFW backend library. data GLFWState = GLFWState { -- | Status of Ctrl, Alt or Shift (Up or Down?) modifiers :: Modifiers -- | Latest mouse position , mousePosition :: (Int,Int) -- | Latest mousewheel position , mouseWheelPos :: Int -- | Does the screen need to be redrawn? , dirtyScreen :: Bool -- | Action that draws on the screen , display :: IO () -- | Action perforrmed when idling , idle :: IO () } -- | Initial GLFW state. glfwStateInit :: GLFWState glfwStateInit = GLFWState { modifiers = Modifiers Up Up Up , mousePosition = (0, 0) , mouseWheelPos = 0 , dirtyScreen = True , display = return () , idle = return () } instance Backend GLFWState where initBackendState = glfwStateInit initializeBackend = initializeGLFW exitBackend = exitGLFW openWindow = openWindowGLFW dumpBackendState = dumpStateGLFW installDisplayCallback = installDisplayCallbackGLFW installWindowCloseCallback = installWindowCloseCallbackGLFW installReshapeCallback = installReshapeCallbackGLFW installKeyMouseCallback = installKeyMouseCallbackGLFW installMotionCallback = installMotionCallbackGLFW installIdleCallback = installIdleCallbackGLFW runMainLoop = runMainLoopGLFW postRedisplay = postRedisplayGLFW getWindowDimensions = (\_ -> GLFW.getWindowDimensions) elapsedTime = (\_ -> GLFW.getTime) sleep = (\_ sec -> GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do _ <- GLFW.initialize glfwVersion <- GLFW.getGlfwVersion #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. (_progName, _args) <- GLUT.getArgsAndInitialize #endif when debug $ putStr $ " glfwVersion = " ++ show glfwVersion ++ "\n" -- Exit ----------------------------------------------------------------------- -- | Tell the GLFW backend to close the window and exit. exitGLFW :: IORef GLFWState -> IO () exitGLFW _ = do #ifdef linux_HOST_OS -- See comment in header on why we exit GLUT for Linux GLUT.exit #endif GLFW.closeWindow -- Open Window ---------------------------------------------------------------- -- | Open a new window. openWindowGLFW :: IORef GLFWState -> String -> (Int,Int) -> (Int,Int) -> IO () openWindowGLFW _ windowName (sizeX,sizeY) (posX,posY) = do _ <- GLFW.openWindow GLFW.defaultDisplayOptions { GLFW.displayOptions_width = sizeX , GLFW.displayOptions_height = sizeY } GLFW.setWindowPosition posX posY GLFW.setWindowTitle windowName -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. GLFW.setWindowBufferSwapInterval 1 -- Dump State ----------------------------------------------------------------- -- | Print out the internal GLFW state. dumpStateGLFW :: IORef a -> IO () dumpStateGLFW _ = do (ww,wh) <- GLFW.getWindowDimensions r <- GLFW.getWindowValue NumRedBits g <- GLFW.getWindowValue NumGreenBits b <- GLFW.getWindowValue NumBlueBits a <- GLFW.getWindowValue NumAlphaBits let rgbaBD = [r,g,b,a] depthBD <- GLFW.getWindowValue NumDepthBits ra <- GLFW.getWindowValue NumAccumRedBits ga <- GLFW.getWindowValue NumAccumGreenBits ba <- GLFW.getWindowValue NumAccumBlueBits aa <- GLFW.getWindowValue NumAccumAlphaBits let accumBD = [ra,ga,ba,aa] stencilBD <- GLFW.getWindowValue NumStencilBits auxBuffers <- GLFW.getWindowValue NumAuxBuffers fsaaSamples <- GLFW.getWindowValue NumFsaaSamples putStr $ "* dumpGlfwState\n" ++ " windowWidth = " ++ show ww ++ "\n" ++ " windowHeight = " ++ show wh ++ "\n" ++ " depth rgba = " ++ show rgbaBD ++ "\n" ++ " depth = " ++ show depthBD ++ "\n" ++ " accum = " ++ show accumBD ++ "\n" ++ " stencil = " ++ show stencilBD ++ "\n" ++ " aux Buffers = " ++ show auxBuffers ++ "\n" ++ " FSAA Samples = " ++ show fsaaSamples ++ "\n" ++ "\n" -- Display Callback ----------------------------------------------------------- -- | Callback for when GLFW needs us to redraw the contents of the window. installDisplayCallbackGLFW :: IORef GLFWState -> [Callback] -> IO () installDisplayCallbackGLFW stateRef callbacks = modifyIORef stateRef $ \s -> s { display = callbackDisplay stateRef callbacks } callbackDisplay :: IORef GLFWState -> [Callback] -> IO () callbackDisplay stateRef 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 stateRef | (Display f) <- callbacks] sequence_ funs return () -- Close Callback ------------------------------------------------------------- -- | Callback for when the user closes the window. -- We can do some cleanup here. installWindowCloseCallbackGLFW :: IORef GLFWState -> IO () installWindowCloseCallbackGLFW _ = GLFW.setWindowCloseCallback $ do #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit #endif return True -- Reshape -------------------------------------------------------------------- -- | Callback for when the user reshapes the window. installReshapeCallbackGLFW :: Backend a => IORef a -> [Callback] -> IO () installReshapeCallbackGLFW stateRef callbacks = GLFW.setWindowSizeCallback (callbackReshape stateRef callbacks) callbackReshape :: Backend a => IORef a -> [Callback] -> Int -> Int -> IO () callbackReshape glfwState callbacks sizeX sizeY = sequence_ $ map (\f -> f (sizeX, sizeY)) [f glfwState | Reshape f <- callbacks] -- KeyMouse ----------------------------------------------------------------------- -- | Callbacks for when the user presses a key or moves / clicks the mouse. -- This is a bit verbose because we have to do impedence matching between -- GLFW's event system, and the one use by Gloss which was originally -- based on GLUT. The main problem is that GLUT only provides a single callback -- slot for character keys, arrow keys, mouse buttons and mouse wheel movement, -- while GLFW provides a single slot for each. -- installKeyMouseCallbackGLFW :: IORef GLFWState -> [Callback] -> IO () installKeyMouseCallbackGLFW stateRef callbacks = do GLFW.setKeyCallback $ (callbackKeyboard stateRef callbacks) GLFW.setCharCallback $ (callbackChar stateRef callbacks) GLFW.setMouseButtonCallback $ (callbackMouseButton stateRef callbacks) GLFW.setMouseWheelCallback $ (callbackMouseWheel stateRef callbacks) -- GLFW calls this on a non-character keyboard action. callbackKeyboard :: IORef GLFWState -> [Callback] -> GLFW.Key -> Bool -> IO () callbackKeyboard stateRef callbacks key keystate = do (modsSet, GLFWState mods pos _ _ _ _) <- setModifiers stateRef key keystate let key' = fromGLFW key let keystate' = if keystate then Down else Up -- Call the Gloss KeyMouse actions with the new state. unless modsSet $ sequence_ $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] setModifiers :: IORef GLFWState -> GLFW.Key -> Bool -> IO (Bool, GLFWState) setModifiers stateRef key pressed = do glfwState <- readIORef stateRef let mods = modifiers glfwState let mods' = case key of GLFW.KeyLeftShift -> mods {shift = if pressed then Down else Up} GLFW.KeyLeftCtrl -> mods {ctrl = if pressed then Down else Up} GLFW.KeyLeftAlt -> mods {alt = if pressed then Down else Up} _ -> mods if (mods' /= mods) then do let glfwState' = glfwState {modifiers = mods'} writeIORef stateRef glfwState' return (True, glfwState') else return (False, glfwState) -- GLFW calls this on a when the user presses or releases a character key. callbackChar :: IORef GLFWState -> [Callback] -> Char -> Bool -> IO () callbackChar stateRef callbacks key keystate = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef let key' = if (fromEnum key == 32) then SpecialKey KeySpace else Char key let keystate' = if keystate then Down else Up -- Call all the Gloss KeyMouse actions with the new state. sequence_ $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] -- GLFW calls on this when the user clicks or releases a mouse button. callbackMouseButton :: IORef GLFWState -> [Callback] -> GLFW.MouseButton -> Bool -> IO () callbackMouseButton stateRef callbacks key keystate = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef let key' = fromGLFW key let keystate' = if keystate then Down else Up -- Call all the Gloss KeyMouse actions with the new state. sequence_ $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] -- GLFW calls on this when the user moves the mouse wheel. callbackMouseWheel :: IORef GLFWState -> [Callback] -> Int -> IO () callbackMouseWheel stateRef callbacks w = do (key, keystate) <- setMouseWheel stateRef w (GLFWState mods pos _ _ _ _) <- readIORef stateRef -- Call all the Gloss KeyMouse actions with the new state. sequence_ $ map (\f -> f key keystate mods pos) [f stateRef | KeyMouse f <- callbacks] setMouseWheel :: IORef GLFWState -> Int -> IO (Key, KeyState) setMouseWheel stateRef w = do glfwState <- readIORef stateRef writeIORef stateRef $ glfwState {mouseWheelPos = w} case compare w (mouseWheelPos glfwState) of LT -> return (MouseButton WheelDown , Down) GT -> return (MouseButton WheelUp , Down) EQ -> return (SpecialKey KeyUnknown, Up ) -- Motion Callback ------------------------------------------------------------ -- | Callback for when the user moves the mouse. installMotionCallbackGLFW :: IORef GLFWState -> [Callback] -> IO () installMotionCallbackGLFW stateRef callbacks = GLFW.setMousePositionCallback $ (callbackMotion stateRef callbacks) callbackMotion :: IORef GLFWState -> [Callback] -> Int -> Int -> IO () callbackMotion stateRef callbacks x y = do pos <- setMousePos stateRef x y -- Call all the Gloss Motion actions with the new state. sequence_ $ map (\f -> f pos) [f stateRef | Motion f <- callbacks] setMousePos :: IORef GLFWState -> Int -> Int -> IO (Int, Int) setMousePos stateRef x y = do let pos = (x,y) modifyIORef stateRef (\s -> s {mousePosition = pos}) return pos -- Idle Callback -------------------------------------------------------------- -- | Callback for when GLFW has finished its jobs and it's time for us to do -- something for our application. installIdleCallbackGLFW :: IORef GLFWState -> [Callback] -> IO () installIdleCallbackGLFW stateRef callbacks = modifyIORef stateRef (\s -> s {idle = callbackIdle stateRef callbacks}) callbackIdle :: IORef GLFWState -> [Callback] -> IO () callbackIdle stateRef callbacks = sequence_ $ [f stateRef | Idle f <- callbacks] -- Main Loop ------------------------------------------------------------------ runMainLoopGLFW :: IORef GLFWState -> IO () runMainLoopGLFW stateRef = do windowIsOpen <- GLFW.windowIsOpen when windowIsOpen $ do dirty <- fmap dirtyScreen $ readIORef stateRef when dirty $ do s <- readIORef stateRef display s GLFW.swapBuffers modifyIORef stateRef $ \s -> s { dirtyScreen = False } (readIORef stateRef) >>= (\s -> idle s) GLFW.sleep 0.001 runMainLoopGLFW stateRef -- Redisplay ------------------------------------------------------------------ postRedisplayGLFW :: IORef GLFWState -> IO () postRedisplayGLFW stateRef = modifyIORef stateRef $ \s -> s { dirtyScreen = True } -- Key Code Conversion -------------------------------------------------------- class GLFWKey a where fromGLFW :: a -> Key instance GLFWKey GLFW.Key where fromGLFW key = case key of GLFW.CharKey _ -> SpecialKey KeyUnknown GLFW.KeySpace -> SpecialKey KeySpace GLFW.KeyEsc -> SpecialKey KeyEsc GLFW.KeyF1 -> SpecialKey KeyF1 GLFW.KeyF2 -> SpecialKey KeyF2 GLFW.KeyF3 -> SpecialKey KeyF3 GLFW.KeyF4 -> SpecialKey KeyF4 GLFW.KeyF5 -> SpecialKey KeyF5 GLFW.KeyF6 -> SpecialKey KeyF6 GLFW.KeyF7 -> SpecialKey KeyF7 GLFW.KeyF8 -> SpecialKey KeyF8 GLFW.KeyF9 -> SpecialKey KeyF9 GLFW.KeyF10 -> SpecialKey KeyF10 GLFW.KeyF11 -> SpecialKey KeyF11 GLFW.KeyF12 -> SpecialKey KeyF12 GLFW.KeyF13 -> SpecialKey KeyF13 GLFW.KeyF14 -> SpecialKey KeyF14 GLFW.KeyF15 -> SpecialKey KeyF15 GLFW.KeyF16 -> SpecialKey KeyF16 GLFW.KeyF17 -> SpecialKey KeyF17 GLFW.KeyF18 -> SpecialKey KeyF18 GLFW.KeyF19 -> SpecialKey KeyF19 GLFW.KeyF20 -> SpecialKey KeyF20 GLFW.KeyF21 -> SpecialKey KeyF21 GLFW.KeyF22 -> SpecialKey KeyF22 GLFW.KeyF23 -> SpecialKey KeyF23 GLFW.KeyF24 -> SpecialKey KeyF24 GLFW.KeyF25 -> SpecialKey KeyF25 GLFW.KeyUp -> SpecialKey KeyUp GLFW.KeyDown -> SpecialKey KeyDown GLFW.KeyLeft -> SpecialKey KeyLeft GLFW.KeyRight -> SpecialKey KeyRight GLFW.KeyTab -> SpecialKey KeyTab GLFW.KeyEnter -> SpecialKey KeyEnter GLFW.KeyBackspace -> SpecialKey KeyBackspace GLFW.KeyInsert -> SpecialKey KeyInsert GLFW.KeyDel -> SpecialKey KeyDelete GLFW.KeyPageup -> SpecialKey KeyPageUp GLFW.KeyPagedown -> SpecialKey KeyPageDown GLFW.KeyHome -> SpecialKey KeyHome GLFW.KeyEnd -> SpecialKey KeyEnd GLFW.KeyPad0 -> SpecialKey KeyPad0 GLFW.KeyPad1 -> SpecialKey KeyPad1 GLFW.KeyPad2 -> SpecialKey KeyPad2 GLFW.KeyPad3 -> SpecialKey KeyPad3 GLFW.KeyPad4 -> SpecialKey KeyPad4 GLFW.KeyPad5 -> SpecialKey KeyPad5 GLFW.KeyPad6 -> SpecialKey KeyPad6 GLFW.KeyPad7 -> SpecialKey KeyPad7 GLFW.KeyPad8 -> SpecialKey KeyPad8 GLFW.KeyPad9 -> SpecialKey KeyPad9 GLFW.KeyPadDivide -> SpecialKey KeyPadDivide GLFW.KeyPadMultiply -> SpecialKey KeyPadMultiply GLFW.KeyPadSubtract -> SpecialKey KeyPadSubtract GLFW.KeyPadAdd -> SpecialKey KeyPadAdd GLFW.KeyPadDecimal -> SpecialKey KeyPadDecimal GLFW.KeyPadEqual -> SpecialKey KeyPadEqual GLFW.KeyPadEnter -> SpecialKey KeyPadEnter _ -> SpecialKey KeyUnknown instance GLFWKey GLFW.MouseButton where fromGLFW mouse = case mouse of GLFW.MouseButton0 -> MouseButton LeftButton GLFW.MouseButton1 -> MouseButton RightButton GLFW.MouseButton2 -> MouseButton MiddleButton GLFW.MouseButton3 -> MouseButton $ AdditionalButton 3 GLFW.MouseButton4 -> MouseButton $ AdditionalButton 4 GLFW.MouseButton5 -> MouseButton $ AdditionalButton 5 GLFW.MouseButton6 -> MouseButton $ AdditionalButton 6 GLFW.MouseButton7 -> MouseButton $ AdditionalButton 7