{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Backend.GLUT (GLUTState,glutStateInit,initializeGLUT) where import Data.IORef import Control.Monad import Control.Concurrent import Graphics.UI.GLUT (get,($=)) import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.UI.GLUT as GLUT import qualified System.Exit as System import Graphics.Gloss.Internals.Interface.Backend.Types import System.IO.Unsafe -- Were we to support freeglut only, we could use GLUT.get to discover -- whether we are initialized or not. If not, we do a quick initialize, -- get the screenzie, and then do GLUT.exit. This avoids the use of -- global variables. Unfortunately, there is no failsafe way to check -- whether glut is initialized in some older versions of glut, which is -- what we'd use instead of the global variable to get the required info. glutInitialized :: IORef Bool {-# NOINLINE glutInitialized #-} glutInitialized = unsafePerformIO $ do newIORef False -- | 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 { glutStateFrameCount = 0 , glutStateHasTimeout = False , glutStateHasIdle = False } instance Backend GLUTState where initBackendState = glutStateInit initializeBackend = initializeGLUT -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop) exitBackend = (\_ -> System.exitWith System.ExitSuccess) openWindow = openWindowGLUT dumpBackendState = dumpStateGLUT installDisplayCallback = installDisplayCallbackGLUT -- We can ask for this in freeglut, but it doesn't seem to work :(. -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns) installWindowCloseCallback = (\_ -> return ()) installReshapeCallback = installReshapeCallbackGLUT installKeyMouseCallback = installKeyMouseCallbackGLUT installMotionCallback = installMotionCallbackGLUT installIdleCallback = installIdleCallbackGLUT -- Call the GLUT mainloop. -- This function will return when something calls GLUT.leaveMainLoop runMainLoop _ = GLUT.mainLoop postRedisplay _ = GLUT.postRedisplay Nothing getWindowDimensions _ = 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 sleep _ sec = do threadDelay (round $ sec * 1000000) -- Initialise ----------------------------------------------------------------- initializeGLUT :: IORef GLUTState -> Bool -> IO () initializeGLUT _ debug = do initialized <- readIORef glutInitialized if not initialized then do (_progName, _args) <- GLUT.getArgsAndInitialize glutVersion <- get GLUT.glutVersion when debug $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" GLUT.initialDisplayMode $= [ GLUT.RGBMode , GLUT.DoubleBuffered] writeIORef glutInitialized True -- See if our requested display mode is possible displayMode <- get GLUT.initialDisplayMode displayModePossible <- get GLUT.displayModePossible when debug $ do putStr $ " displayMode = " ++ show displayMode ++ "\n" ++ " possible = " ++ show displayModePossible ++ "\n" ++ "\n" else when debug (putStrLn "Already initialized") -- Open Window ---------------------------------------------------------------- openWindowGLUT :: IORef GLUTState -> Display -> IO () openWindowGLUT _ display = do -- Setup and create a new window. -- Be sure to set initialWindow{Position,Size} before calling -- createWindow. If we don't do this we get wierd half-created -- windows some of the time. case display of InWindow windowName (sizeX, sizeY) (posX, posY) -> do GLUT.initialWindowSize $= GL.Size (fromIntegral sizeX) (fromIntegral sizeY) GLUT.initialWindowPosition $= GL.Position (fromIntegral posX) (fromIntegral posY) _ <- GLUT.createWindow windowName GLUT.windowSize $= GL.Size (fromIntegral sizeX) (fromIntegral sizeY) FullScreen -> do size <- get GLUT.screenSize GLUT.initialWindowSize $= size _ <- GLUT.createWindow "Gloss Application" GLUT.fullScreen -- Switch some things. -- auto repeat interferes with key up / key down checks. -- BUGS: this doesn't seem to work? GLUT.perWindowKeyRepeat $= GLUT.PerWindowKeyRepeatOff -- Dump State ----------------------------------------------------------------- dumpStateGLUT :: IORef GLUTState -> IO () dumpStateGLUT _ = do wbw <- get GLUT.windowBorderWidth whh <- get GLUT.windowHeaderHeight rgba <- get GLUT.rgba rgbaBD <- get GLUT.rgbaBufferDepths colorBD <- get GLUT.colorBufferDepth depthBD <- get GLUT.depthBufferDepth accumBD <- get GLUT.accumBufferDepths stencilBD <- get GLUT.stencilBufferDepth doubleBuffered <- get GLUT.doubleBuffered colorMask <- get GLUT.colorMask depthMask <- get GLUT.depthMask putStr $ "* dumpGlutState\n" ++ " windowBorderWidth = " ++ show wbw ++ "\n" ++ " windowHeaderHeight = " ++ show whh ++ "\n" ++ " rgba = " ++ show rgba ++ "\n" ++ " depth rgba = " ++ show rgbaBD ++ "\n" ++ " color = " ++ show colorBD ++ "\n" ++ " depth = " ++ show depthBD ++ "\n" ++ " accum = " ++ show accumBD ++ "\n" ++ " stencil = " ++ show stencilBD ++ "\n" ++ " doubleBuffered = " ++ show doubleBuffered ++ "\n" ++ " mask color = " ++ show colorMask ++ "\n" ++ " depth = " ++ show depthMask ++ "\n" ++ "\n" -- Display Callback ----------------------------------------------------------- installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installDisplayCallbackGLUT ref callbacks = GLUT.displayCallback $= callbackDisplay ref callbacks callbackDisplay :: IORef GLUTState -> [Callback] -> IO () callbackDisplay refState callbacks = do -- Clear the display GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) -- Run all the display callbacks to draw the window contents. let funs = [f refState | (Display f) <- callbacks] sequence_ funs -- 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] -> IO () installReshapeCallbackGLUT ref callbacks = GLUT.reshapeCallback $= Just (callbackReshape ref callbacks) callbackReshape :: IORef GLUTState -> [Callback] -> GLUT.Size -> IO () callbackReshape ref callbacks (GLUT.Size sizeX sizeY) = sequence_ $ map (\f -> f (fromEnum sizeX, fromEnum sizeY)) [f ref | Reshape f <- callbacks] -- KeyMouse Callback ---------------------------------------------------------- installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installKeyMouseCallbackGLUT ref callbacks = GLUT.keyboardMouseCallback $= Just (callbackKeyMouse ref callbacks) callbackKeyMouse :: IORef GLUTState -> [Callback] -> GLUT.Key -> GLUT.KeyState -> GLUT.Modifiers -> GLUT.Position -> IO () callbackKeyMouse ref callbacks key keystate modifiers (GLUT.Position posX posY) = sequence_ $ map (\f -> f key' keyState' modifiers' pos) [f ref | KeyMouse f <- callbacks] where key' = glutKeyToKey key keyState' = glutKeyStateToKeyState keystate modifiers' = glutModifiersToModifiers modifiers pos = (fromEnum posX, fromEnum posY) -- Motion Callback ------------------------------------------------------------ installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installMotionCallbackGLUT ref callbacks = do GLUT.motionCallback $= Just (callbackMotion ref callbacks) GLUT.passiveMotionCallback $= Just (callbackMotion ref callbacks) callbackMotion :: IORef GLUTState -> [Callback] -> GLUT.Position -> IO () callbackMotion ref callbacks (GLUT.Position posX posY) = do let pos = (fromEnum posX, fromEnum posY) sequence_ $ map (\f -> f pos) [f ref | Motion f <- callbacks] -- Idle Callback -------------------------------------------------------------- installIdleCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () 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 () callbackIdle ref callbacks = sequence_ $ [f ref | Idle f <- callbacks] ------------------------------------------------------------------------------- -- | Convert GLUTs key codes to our internal ones. glutKeyToKey :: GLUT.Key -> Key glutKeyToKey key = case key of GLUT.Char '\32' -> SpecialKey KeySpace GLUT.Char '\13' -> SpecialKey KeyEnter GLUT.Char '\9' -> SpecialKey KeyTab GLUT.Char '\ESC' -> SpecialKey KeyEsc GLUT.Char '\DEL' -> SpecialKey KeyDelete GLUT.Char c -> Char c GLUT.SpecialKey GLUT.KeyF1 -> SpecialKey KeyF1 GLUT.SpecialKey GLUT.KeyF2 -> SpecialKey KeyF2 GLUT.SpecialKey GLUT.KeyF3 -> SpecialKey KeyF3 GLUT.SpecialKey GLUT.KeyF4 -> SpecialKey KeyF4 GLUT.SpecialKey GLUT.KeyF5 -> SpecialKey KeyF5 GLUT.SpecialKey GLUT.KeyF6 -> SpecialKey KeyF6 GLUT.SpecialKey GLUT.KeyF7 -> SpecialKey KeyF7 GLUT.SpecialKey GLUT.KeyF8 -> SpecialKey KeyF8 GLUT.SpecialKey GLUT.KeyF9 -> SpecialKey KeyF9 GLUT.SpecialKey GLUT.KeyF10 -> SpecialKey KeyF10 GLUT.SpecialKey GLUT.KeyF11 -> SpecialKey KeyF11 GLUT.SpecialKey GLUT.KeyF12 -> SpecialKey KeyF12 GLUT.SpecialKey GLUT.KeyLeft -> SpecialKey KeyLeft GLUT.SpecialKey GLUT.KeyUp -> SpecialKey KeyUp GLUT.SpecialKey GLUT.KeyRight -> SpecialKey KeyRight GLUT.SpecialKey GLUT.KeyDown -> SpecialKey KeyDown GLUT.SpecialKey GLUT.KeyPageUp -> SpecialKey KeyPageUp GLUT.SpecialKey GLUT.KeyPageDown -> SpecialKey KeyPageDown GLUT.SpecialKey GLUT.KeyHome -> SpecialKey KeyHome GLUT.SpecialKey GLUT.KeyEnd -> SpecialKey KeyEnd GLUT.SpecialKey GLUT.KeyInsert -> SpecialKey KeyInsert GLUT.SpecialKey GLUT.KeyNumLock -> SpecialKey KeyNumLock GLUT.SpecialKey GLUT.KeyBegin -> SpecialKey KeyBegin GLUT.SpecialKey GLUT.KeyDelete -> SpecialKey KeyDelete GLUT.SpecialKey (GLUT.KeyUnknown _) -> SpecialKey KeyUnknown GLUT.SpecialKey GLUT.KeyShiftL -> SpecialKey KeyShiftL GLUT.SpecialKey GLUT.KeyShiftR -> SpecialKey KeyShiftR GLUT.SpecialKey GLUT.KeyCtrlL -> SpecialKey KeyCtrlL GLUT.SpecialKey GLUT.KeyCtrlR -> SpecialKey KeyCtrlR GLUT.SpecialKey GLUT.KeyAltL -> SpecialKey KeyAltL GLUT.SpecialKey GLUT.KeyAltR -> SpecialKey KeyAltR GLUT.MouseButton GLUT.LeftButton -> MouseButton LeftButton GLUT.MouseButton GLUT.MiddleButton -> MouseButton MiddleButton GLUT.MouseButton GLUT.RightButton -> MouseButton RightButton GLUT.MouseButton GLUT.WheelUp -> MouseButton WheelUp GLUT.MouseButton GLUT.WheelDown -> MouseButton WheelDown GLUT.MouseButton (GLUT.AdditionalButton i) -> MouseButton (AdditionalButton i) -- | Convert GLUTs key states to our internal ones. glutKeyStateToKeyState :: GLUT.KeyState -> KeyState glutKeyStateToKeyState state = case state of GLUT.Down -> Down GLUT.Up -> Up -- | Convert GLUTs key states to our internal ones. glutModifiersToModifiers :: GLUT.Modifiers -> Modifiers glutModifiersToModifiers (GLUT.Modifiers a b c) = Modifiers (glutKeyStateToKeyState a) (glutKeyStateToKeyState b) (glutKeyStateToKeyState c)