diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -22,40 +22,53 @@ -- Animations can be constructed similarly using the `animateInWindow`. -- -- If you want to run a simulation based around finite time steps then try --- `simulateInWindow` from "Graphics.Gloss.Interface.Simulate". +-- `simulateInWindow`. -- --- If you want to manage your own key\/mouse events then use `gameInWindow` from --- "Graphics.Gloss.Interface.Game". +-- If you want to manage your own key\/mouse events then use `gameInWindow`. -- -- Gloss uses OpenGL under the hood, but you don't have to worry about any of that. -- --- @ --- Release Notes: +-- @Release Notes: +-- +-- For 1.4.0: +-- Thanks to Christiaan Baaij: +-- * Refactoring of Gloss internals to support multiple window manager backends. +-- * Support for using GLFW as the window library instead of GLUT. +-- GLUT is still the default, but to use GLFW install gloss with: +-- cabal install gloss --flags=\"GLFW -GLUT\" +-- -- For 1.3.0: --- New support for displaying bitmap files. (Thanks to Ben Lambert-Smith) --- Various wibbles for GHC 7.1 +-- * Various wibbles for GHC 7.1 +-- Thanks to Ben Lambert-Smith: +-- * Support for displaying bitmap files. -- -- For 1.2.0: --- Cleaned up module hierarchy. --- Added line-line intersection utils. --- Fixed a bug causing motion events to give the wrong position. (Thanks to Thomas DuBuisson) --- Fixed a space leak in simulate mode when the window was hidden. (Thanks to Stephan Maka) --- Enabled -Wall and fixed all warnings. --- Various wibbles for GHC 7.0 +-- * Cleaned up module hierarchy. +-- * Added line-line intersection utils. +-- * Enabled -Wall and fixed all warnings. +-- * Various wibbles for GHC 7.0 +-- Thanks to Thomas DuBuisson: +-- * Fixed a bug causing motion events to give the wrong position. +-- Thanks to Stephan Maka: +-- * Fixed a space leak in simulate mode when the window was hidden. -- -- For 1.1.0: --- Added game mode. --- Added QuadTree and Extent structures. --- Added simple ray casting. +-- * Added game mode. +-- * Added QuadTree and Extent structures. +-- * Added simple ray casting. -- @ -- module Graphics.Gloss ( module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color - , displayInWindow - , animateInWindow) + , displayInWindow + , animateInWindow + , simulateInWindow + , gameInWindow) where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Display (displayInWindow) -import Graphics.Gloss.Internals.Interface.Animate (animateInWindow) +import Graphics.Gloss.Internals.Interface.Display +import Graphics.Gloss.Internals.Interface.Animate +import Graphics.Gloss.Internals.Interface.Simulate +import Graphics.Gloss.Internals.Interface.Game diff --git a/Graphics/Gloss/Data/Picture.hs b/Graphics/Gloss/Data/Picture.hs --- a/Graphics/Gloss/Data/Picture.hs +++ b/Graphics/Gloss/Data/Picture.hs @@ -25,14 +25,14 @@ import Graphics.Gloss.Data.Vector import Control.Monad import Data.Monoid - +import Codec.BMP import Data.ByteString (ByteString) -import qualified Data.ByteString as B -- | A path through the x-y plane. type Path = [Point] + -- | A 2D picture data Picture -- Primitives ------------------------------------- @@ -40,7 +40,7 @@ -- | A blank picture, with nothing in it. = Blank - -- | A polygon filled with a solid color. + -- | A convex polygon filled with a solid color. | Polygon Path -- | A line along an arbitrary path. @@ -49,14 +49,19 @@ -- | A circle with the given radius. | Circle Float - -- | A circle with the given thickness and radius. If the thickness is 0 then this is equivalent to `Circle`. + -- | A circle with the given thickness and radius. + -- If the thickness is 0 then this is equivalent to `Circle`. | ThickCircle Float Float -- | Some text to draw with a vector font. | Text String -- | A bitmap image with a width, height and a ByteString holding the 32 bit RGBA bitmap data. - | Bitmap Int Int ByteString + -- + -- The boolean flag controls whether Gloss should cache the data between frames + -- for speed. If you are programatically generating the image for each frame then use + -- `False`. If you have loaded it from a file then use `True`. + | Bitmap Int Int ByteString Bool -- Color ------------------------------------------ -- | A picture drawn with this color. @@ -85,7 +90,6 @@ mconcat = Pictures - -- Constructors ---------------------------------------------------------------------------------- blank :: Picture blank = Blank @@ -105,7 +109,7 @@ text :: String -> Picture text = Text -bitmap :: Int -> Int -> ByteString -> Picture +bitmap :: Int -> Int -> ByteString -> Bool -> Picture bitmap = Bitmap color :: Color -> Picture -> Picture @@ -127,28 +131,15 @@ -- BMP file loader ------------------------------------------------------------ -- | An IO action that loads a BMP format file from the given path, and -- produces a picture. --- TODO: Use Codec.BMP library instead. loadBMP :: FilePath -> IO Picture -loadBMP fname = do - bs <- B.readFile fname - when (not (isBmp bs)) $ error (fname ++ ": not a bmp file" ) - when (bpp bs < 32) $ error (fname ++ ": must be saved in 32-bit RGBA format" ) - when (comp bs /= 0) $ error (fname ++ ": must be saved in uncompressed format") - return (Bitmap (width bs) (height bs) (dat bs)) - where range s n bs = B.unpack (B.take n (B.drop s bs)) - littleEndian ds = sum [ fromIntegral b * 256^k | (b,k) <- zip ds [(0 :: Int) ..] ] - isBmp bs = littleEndian (range 0 2 bs) == (19778 :: Int) - pxOff bs = littleEndian (range 10 4 bs) :: Int - width bs = littleEndian (range 18 4 bs) :: Int - height bs = littleEndian (range 22 4 bs) :: Int - bpp bs = littleEndian (range 28 2 bs) :: Int - comp bs = littleEndian (range 30 4 bs) :: Int - dat bs = swapRB (B.take (4 * width bs * height bs) - (B.drop (pxOff bs) bs)) - swapRB bs - | B.null bs = B.empty - | otherwise = let [b,g,r,a] = B.unpack (B.take 4 bs) - in B.pack [r,g,b,a] `B.append` swapRB (B.drop 4 bs) +loadBMP filePath + = do ebmp <- readBMP filePath + case ebmp of + Left err -> error $ show err + Right bmp + -> do let (width, height) = bmpDimensions bmp + let bs = bmpRawImageData bmp + return $ Bitmap width height bs True -- Shapes ---------------------------------------------------------------------------------------- diff --git a/Graphics/Gloss/Interface/Animate.hs b/Graphics/Gloss/Interface/Animate.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Animate.hs @@ -0,0 +1,10 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.Animate + ( module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , animateInWindow) +where +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Animate diff --git a/Graphics/Gloss/Interface/Display.hs b/Graphics/Gloss/Interface/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Display.hs @@ -0,0 +1,10 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.Display + ( module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , displayInWindow) +where +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Display diff --git a/Graphics/Gloss/Interface/Game.hs b/Graphics/Gloss/Interface/Game.hs --- a/Graphics/Gloss/Interface/Game.hs +++ b/Graphics/Gloss/Interface/Game.hs @@ -12,5 +12,5 @@ where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Game (gameInWindow, Event(..)) -import Graphics.UI.GLUT.Callbacks.Window +import Graphics.Gloss.Internals.Interface.Game +import Graphics.Gloss.Internals.Interface.Backend diff --git a/Graphics/Gloss/Interface/Simulate.hs b/Graphics/Gloss/Interface/Simulate.hs --- a/Graphics/Gloss/Interface/Simulate.hs +++ b/Graphics/Gloss/Interface/Simulate.hs @@ -14,4 +14,4 @@ import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.ViewPort -import Graphics.Gloss.Internals.Interface.Simulate (simulateInWindow) +import Graphics.Gloss.Internals.Interface.Simulate 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 @@ -1,12 +1,13 @@ -{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Animate - (animateInWindow) + ( animateInWindow + , animateInWindowWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort @@ -14,15 +15,15 @@ import Graphics.Gloss.Internals.Interface.ViewPort.Motion import Graphics.Gloss.Internals.Interface.ViewPort.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing -import qualified Graphics.Gloss.Internals.Render.Options as RO +import qualified Graphics.Gloss.Internals.Render.State as RS import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Interface.Callback as Callback -import qualified Graphics.UI.GLUT as GLUT import Data.IORef import Control.Monad import System.Mem +import GHC.Float (double2Float) -- | Open a new window and display the given animation. -- @@ -37,28 +38,44 @@ -- It is passed the time in seconds since the program started. -> IO () -animateInWindow name size pos backColor frameFun +animateInWindow + = animateInWindowWithBackend defaultBackendState + + +animateInWindowWithBackend + :: Backend a + => a -- ^ Initial State of the backend + -> String -- ^ Name of the window. + -> (Int, Int) -- ^ Initial size of the window, in pixels. + -> (Int, Int) -- ^ Initial position of the window, in pixels. + -> Color -- ^ Background color. + -> (Float -> Picture) -- ^ Function to produce the next frame of animation. + -- It is passed the time in seconds since the program started. + -> IO () + +animateInWindowWithBackend backend name size pos backColor frameFun = do viewSR <- newIORef viewPortInit viewControlSR <- newIORef VPC.stateInit - renderSR <- newIORef RO.optionsInit animateSR <- newIORef AN.stateInit + renderS_ <- RS.stateInit + renderSR <- newIORef renderS_ - let displayFun = do + let displayFun backendRef = do -- extract the current time from the state - time <- animateSR `getsIORef` AN.stateAnimateTime - let timeS = (fromIntegral time / 1000) + timeS <- animateSR `getsIORef` AN.stateAnimateTime -- call the user function to get the animation frame - let picture = frameFun timeS + let picture = frameFun (double2Float timeS) renderS <- readIORef renderSR viewS <- readIORef viewSR -- render the frame withViewPort + backendRef viewS - (renderPicture renderS viewS picture) + (renderPicture backendRef renderS viewS picture) -- perform GC every frame to try and avoid long pauses performGC @@ -67,13 +84,13 @@ = [ Callback.Display (animateBegin animateSR) , Callback.Display displayFun , Callback.Display (animateEnd animateSR) - , Callback.Idle (GLUT.postRedisplay Nothing) + , Callback.Idle (\s -> postRedisplay s) , callback_exit () , callback_viewPort_keyMouse viewSR viewControlSR , callback_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] - createWindow name size pos backColor callbacks + createWindow backend name size pos backColor callbacks getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun diff --git a/Graphics/Gloss/Internals/Interface/Animate/State.hs b/Graphics/Gloss/Internals/Interface/Animate/State.hs --- a/Graphics/Gloss/Internals/Interface/Animate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/State.hs @@ -16,26 +16,26 @@ , stateAnimateStart :: Bool -- | Number of msec the animation has been running for - , stateAnimateTime :: Int + , stateAnimateTime :: Double -- | The time when we entered the display callback for the current frame. - , stateDisplayTime :: Int - , stateDisplayTimeLast :: Int + , stateDisplayTime :: Double + , stateDisplayTimeLast :: Double -- | Clamp the minimum time between frames to this value (in msec) -- Most LCD monitors refresh at around 50Hz so setting -- this to < 20msec probably isn't worthwhile. -- - , stateDisplayTimeClamp :: Int + , stateDisplayTimeClamp :: Double -- | The time when the last call to the users render function finished. - , stateGateTimeStart :: Int + , stateGateTimeStart :: Double -- | The time when displayInWindow last finished (after sleeping to clamp fps). - , stateGateTimeEnd :: Int + , stateGateTimeEnd :: Double -- | How long it took to draw this frame - , stateGateTimeElapsed :: Int } + , stateGateTimeElapsed :: Double } stateInit :: State @@ -46,7 +46,7 @@ , stateAnimateTime = 0 , stateDisplayTime = 0 , stateDisplayTimeLast = 0 - , stateDisplayTimeClamp = 20 + , stateDisplayTimeClamp = 0.02 , stateGateTimeStart = 0 , stateGateTimeEnd = 0 , stateGateTimeElapsed = 0 } 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 @@ -12,21 +12,19 @@ ( animateBegin , animateEnd ) where +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Animate.State import Control.Monad -import Control.Concurrent import Data.IORef -import qualified Graphics.UI.GLUT as GLUT -import Graphics.UI.GLUT (get) -- | Handles animation timing details. -- Call this function at the start of each frame. -animateBegin :: IORef State -> IO () -animateBegin stateRef +animateBegin :: IORef State -> DisplayCallback +animateBegin stateRef backendRef = do -- write the current time into the display state - displayTime <- get GLUT.elapsedTime + displayTime <- elapsedTime backendRef displayTimeLast <- stateRef `getsIORef` stateDisplayTime let displayTimeElapsed = displayTime - displayTimeLast @@ -55,21 +53,21 @@ -- | Handles animation timing details. -- Call this function at the end of each frame. -animateEnd :: IORef State -> IO () -animateEnd stateRef +animateEnd :: IORef State -> DisplayCallback +animateEnd stateRef backendRef = do -- timing gate, limits the maximum frame frequency (FPS) timeClamp <- stateRef `getsIORef` stateDisplayTimeClamp - gateTimeStart <- get GLUT.elapsedTime -- the start of this gate + gateTimeStart <- elapsedTime backendRef -- the start of this gate gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd -- end of the previous gate let gateTimeElapsed = gateTimeStart - gateTimeEnd when (gateTimeElapsed < timeClamp) - $ do threadDelay ((timeClamp - gateTimeElapsed) * 1000) + $ do sleep backendRef (timeClamp - gateTimeElapsed) - gateTimeFinal <- get GLUT.elapsedTime + gateTimeFinal <- elapsedTime backendRef stateRef `modifyIORef` \s -> s { stateGateTimeEnd = gateTimeFinal diff --git a/Graphics/Gloss/Internals/Interface/Backend.hs b/Graphics/Gloss/Internals/Interface/Backend.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Interface/Backend.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +-- Import window managed backend specific modules. +-- We need to use #ifdef here because if the backend library hasn't been installed +-- then we won't be able to build it, so it can't be in the import list. +module Graphics.Gloss.Internals.Interface.Backend + ( module Graphics.Gloss.Internals.Interface.Backend.Types +#ifdef WITHGLFW + , module Graphics.Gloss.Internals.Interface.Backend.GLFW +#endif +#ifdef WITHGLUT + , module Graphics.Gloss.Internals.Interface.Backend.GLUT +#endif + , defaultBackendState) +where + +import Graphics.Gloss.Internals.Interface.Backend.Types + +#ifdef WITHGLFW +import Graphics.Gloss.Internals.Interface.Backend.GLFW +#endif +#ifdef WITHGLUT +import Graphics.Gloss.Internals.Interface.Backend.GLUT +#endif + +#ifdef WITHGLUT +defaultBackendState :: GLUTState +#elif WITHGLFW +defaultBackendState :: GLFWState +#else +#error No default backend defined +#endif +defaultBackendState = initBackendState diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs @@ -0,0 +1,521 @@ +{-# 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 diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs @@ -0,0 +1,332 @@ +{-# OPTIONS_HADDOCK hide #-} +module Graphics.Gloss.Internals.Interface.Backend.GLUT + (GLUTState) +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 + + +-- | We don't maintain any state information for the GLUT backend, +-- so this data type is empty. +data GLUTState + = GLUTState + +glutStateInit :: GLUTState +glutStateInit = GLUTState + + +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) + + elapsedTime _ + = do t <- get GLUT.elapsedTime + return $ (fromIntegral t) / 1000 + + sleep _ sec + = do threadDelay (round $ sec * 100000) + + +-- Initialise ----------------------------------------------------------------- +initializeGLUT + :: IORef GLUTState + -> Bool + -> IO () + +initializeGLUT _ debug + = do (_progName, _args) <- GLUT.getArgsAndInitialize + + glutVersion <- get GLUT.glutVersion + when debug + $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" + + GLUT.initialDisplayMode + $= [ GLUT.RGBMode + , GLUT.DoubleBuffered] + + -- 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" + + +-- Open Window ---------------------------------------------------------------- +openWindowGLUT + :: IORef GLUTState + -> String + -> (Int,Int) + -> (Int,Int) + -> IO () + +openWindowGLUT _ windowName (sizeX, sizeY) (posX, posY) + = 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. + GLUT.initialWindowPosition + $= GL.Position + (fromIntegral posX) + (fromIntegral posY) + + GLUT.initialWindowSize + $= GL.Size + (fromIntegral sizeX) + (fromIntegral sizeY) + + _ <- GLUT.createWindow windowName + + GLUT.windowSize + $= GL.Size + (fromIntegral sizeX) + (fromIntegral sizeY) + + -- 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 ref 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] + sequence_ funs + + -- swap front and back buffers + GLUT.swapBuffers + GLUT.reportErrors + return () + + +-- 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 + = GLUT.motionCallback $= 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 ref callbacks + = GLUT.idleCallback $= Just (callbackIdle ref callbacks) + +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.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) diff --git a/Graphics/Gloss/Internals/Interface/Backend/Types.hs b/Graphics/Gloss/Internals/Interface/Backend/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Interface/Backend/Types.hs @@ -0,0 +1,194 @@ + +{-# OPTIONS -fspec-constr-count=5 #-} +{-# LANGUAGE Rank2Types #-} +module Graphics.Gloss.Internals.Interface.Backend.Types + (module Graphics.Gloss.Internals.Interface.Backend.Types) +where +import Data.IORef + + +-- | The functions every backend window managed backend needs to support. +-- +-- The Backend module interfaces with the window manager, and handles opening +-- and closing the window, and managing key events etc. +-- +-- It doesn't know anything about drawing lines or setting colors. +-- When we get a display callback, Gloss will perform OpenGL actions, and +-- the backend needs to have OpenGL in a state where it's able to accept them. +-- +class Backend a where + -- | Initialize the state used by the backend. If you don't use any state, + -- make a Unit-like type; see the GLUT backend for an example. + initBackendState :: a + + -- | Perform any initialization that needs to happen before opening a window + -- The Boolean flag indicates if any debug information should be printed to + -- the terminal + initializeBackend :: IORef a -> Bool -> IO () + + -- | Perform any deinitialization and close the backend. + exitBackend :: IORef a -> IO () + + -- | Open a window. Arguments: Name of the window, (sizeW, sizeH), (posX,posY) + openWindow :: IORef a -> String -> (Int,Int) -> (Int,Int) -> IO () + + -- | Dump information about the backend to the terminal. + dumpBackendState :: IORef a -> IO () + + -- | Install the display callbacks. + installDisplayCallback :: IORef a -> [Callback] -> IO () + + -- | Install the window close callback. + installWindowCloseCallback :: IORef a -> IO () + + -- | Install the reshape callbacks. + installReshapeCallback :: IORef a -> [Callback] -> IO () + + -- | Install the keymouse press callbacks. + installKeyMouseCallback :: IORef a -> [Callback] -> IO () + + -- | Install the mouse motion callbacks. + installMotionCallback :: IORef a -> [Callback] -> IO () + + -- | Install the idle callbacks. + installIdleCallback :: IORef a -> [Callback] -> IO () + + -- | The mainloop of the backend. + runMainLoop :: IORef a -> IO () + + -- | A function that signals that screen has to be updated. + postRedisplay :: IORef a -> IO () + + -- | Function that returns (width,height) of the window in pixels. + getWindowDimensions :: IORef a -> IO (Int,Int) + + -- | Function that reports the time elapsed since the application started. + -- (in seconds) + elapsedTime :: IORef a -> IO Double + + -- | Function that puts the current thread to sleep for 'n' seconds. + sleep :: IORef a -> Double -> IO () + + +-- The callbacks should work for all backends. We pass a reference to the +-- backend state so that the callbacks have access to the class dictionary and +-- can thus call the appropriate backend functions. + +-- | Display callback has no arguments. +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 () + +-- | Arguments: (PosX,PosY) in pixels. +type MotionCallback = forall a . Backend a => IORef a -> (Int,Int) -> IO () + +-- | No arguments. +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 () + + +data Callback + = Display DisplayCallback + | KeyMouse KeyboardMouseCallback + | Idle IdleCallback + | Motion MotionCallback + | Reshape ReshapeCallback + +------------------------------------------------------------------------------- +-- This is Glosses view of mouse and keyboard events. +-- The actual events provided by the backends are converted to this form +-- by the backend module. + +data Key + = Char Char + | SpecialKey SpecialKey + | MouseButton MouseButton + deriving (Show, Eq, Ord) + +data MouseButton + = LeftButton + | MiddleButton + | RightButton + | WheelUp + | WheelDown + | AdditionalButton Int + deriving (Show, Eq, Ord) + +data KeyState + = Down + | Up + deriving (Show, Eq, Ord) + +data SpecialKey + = KeyUnknown + | KeySpace + | KeyEsc + | KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyF13 + | KeyF14 + | KeyF15 + | KeyF16 + | KeyF17 + | KeyF18 + | KeyF19 + | KeyF20 + | KeyF21 + | KeyF22 + | KeyF23 + | KeyF24 + | KeyF25 + | KeyUp + | KeyDown + | KeyLeft + | KeyRight + | KeyTab + | KeyEnter + | KeyBackspace + | KeyInsert + | KeyNumLock + | KeyBegin + | KeyDelete + | KeyPageUp + | KeyPageDown + | KeyHome + | KeyEnd + | KeyPad0 + | KeyPad1 + | KeyPad2 + | KeyPad3 + | KeyPad4 + | KeyPad5 + | KeyPad6 + | KeyPad7 + | KeyPad8 + | KeyPad9 + | KeyPadDivide + | KeyPadMultiply + | KeyPadSubtract + | KeyPadAdd + | KeyPadDecimal + | KeyPadEqual + | KeyPadEnter + deriving (Show, Eq, Ord) + +data Modifiers + = Modifiers + { shift :: KeyState + , ctrl :: KeyState + , alt :: KeyState + } + deriving (Show, Eq, Ord) diff --git a/Graphics/Gloss/Internals/Interface/Callback.hs b/Graphics/Gloss/Internals/Interface/Callback.hs --- a/Graphics/Gloss/Internals/Interface/Callback.hs +++ b/Graphics/Gloss/Internals/Interface/Callback.hs @@ -1,14 +1,12 @@ {-# OPTIONS_HADDOCK hide #-} --- | Event callbacks. -module Graphics.Gloss.Internals.Interface.Callback where - -import qualified Graphics.UI.GLUT as GLUT - --- | Holds callback functions. -data Callback - = Display GLUT.DisplayCallback - | KeyMouse GLUT.KeyboardMouseCallback - | Idle GLUT.IdleCallback - | Motion GLUT.MotionCallback - | Reshape GLUT.ReshapeCallback +-- | Re-export event callbacks. +module Graphics.Gloss.Internals.Interface.Callback + ( Callback(..) + , DisplayCallback + , KeyboardMouseCallback + , MotionCallback + , IdleCallback + , ReshapeCallback) +where +import Graphics.Gloss.Internals.Interface.Backend.Types diff --git a/Graphics/Gloss/Internals/Interface/Common/Exit.hs b/Graphics/Gloss/Internals/Interface/Common/Exit.hs --- a/Graphics/Gloss/Internals/Interface/Common/Exit.hs +++ b/Graphics/Gloss/Internals/Interface/Common/Exit.hs @@ -5,28 +5,21 @@ module Graphics.Gloss.Internals.Interface.Common.Exit (callback_exit) where -import Graphics.Gloss.Internals.Interface.Callback -import qualified Graphics.UI.GLUT as GLUT -import qualified System.Exit as System +import Graphics.Gloss.Internals.Interface.Backend.Types callback_exit :: a -> Callback callback_exit stateRef = KeyMouse (keyMouse_exit stateRef) -keyMouse_exit :: a -> GLUT.KeyboardMouseCallback +keyMouse_exit :: a -> KeyboardMouseCallback keyMouse_exit _ + backend key keyState _ _ - - -- exit - | key == GLUT.Char '\27' - , keyState == GLUT.Down - = do - -- non-freeglut doesn't like this - -- GLUT.leaveMainLoop + | key == SpecialKey KeyEsc + , keyState == Down + = exitBackend backend - System.exitWith System.ExitSuccess - | otherwise = return () diff --git a/Graphics/Gloss/Internals/Interface/Debug.hs b/Graphics/Gloss/Internals/Interface/Debug.hs --- a/Graphics/Gloss/Internals/Interface/Debug.hs +++ b/Graphics/Gloss/Internals/Interface/Debug.hs @@ -1,50 +1,13 @@ {-# OPTIONS_HADDOCK hide #-} --- | Implements functions to dump portions of the GLUT and OpenGL state to stdout. +-- | Implements functions to dump portions of the OpenGL state to stdout. -- Used for debugging. module Graphics.Gloss.Internals.Interface.Debug - ( dumpGlutState - , dumpFramebufferState + ( dumpFramebufferState , dumpFragmentState ) where import qualified Graphics.Rendering.OpenGL.GL as GL -import qualified Graphics.UI.GLUT as GLUT -import Graphics.UI.GLUT (get) - - --- | Dump the internal state of GLUT -dumpGlutState :: IO () -dumpGlutState - = 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" - +import Graphics.Rendering.OpenGL (get) -- | Dump internal state of the OpenGL framebuffer dumpFramebufferState :: IO () 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 @@ -1,26 +1,25 @@ -{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Display - (displayInWindow) + ( displayInWindow + , displayInWindowWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse import Graphics.Gloss.Internals.Interface.ViewPort.Motion import Graphics.Gloss.Internals.Interface.ViewPort.Reshape -import qualified Graphics.Gloss.Internals.Render.Options as RO +import qualified Graphics.Gloss.Internals.Render.State as RS import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import Data.IORef -import Control.Concurrent - -- | Open a new window and display the given picture. -- -- Use the following commands once the window is open: @@ -41,25 +40,41 @@ -> Picture -- ^ The picture to draw. -> IO () -displayInWindow name size pos background picture - = do - viewSR <- newIORef viewPortInit +displayInWindow + = displayInWindowWithBackend defaultBackendState + + +displayInWindowWithBackend + :: Backend a + => a -- ^ Initial state of the backend. + -> String -- ^ Name of the window. + -> (Int, Int) -- ^ Initial size of the window, in pixels. + -> (Int, Int) -- ^ Initial position of the window, in pixels. + -> Color -- ^ Background color. + -> Picture -- ^ The picture to draw. + -> IO () + +displayInWindowWithBackend backend name size pos background picture + = do viewSR <- newIORef viewPortInit viewControlSR <- newIORef VPC.stateInit - renderSR <- newIORef RO.optionsInit + + renderS <- RS.stateInit + renderSR <- newIORef renderS - let renderFun = do + let renderFun backendRef = do view <- readIORef viewSR options <- readIORef renderSR withViewPort + backendRef view - (renderPicture options view picture) + (renderPicture backendRef options view picture) let callbacks = [ Callback.Display renderFun -- Delay the thread for a bit to give the runtime -- a chance to switch back to the OS. - , Callback.Idle (threadDelay 1000) + , Callback.Idle (\stateRef -> sleep stateRef 0.001 >> postRedisplay stateRef) -- Escape exits the program , callback_exit () @@ -69,6 +84,4 @@ , callback_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] - createWindow name size pos background callbacks - - + createWindow backend name size pos background callbacks 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 @@ -1,33 +1,31 @@ {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Game ( gameInWindow + , gameInWindowWithBackend , Event(..)) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window -import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback -import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM -import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Render.Options as RO -import qualified Graphics.UI.GLUT as GLUT -import qualified Graphics.Rendering.OpenGL.GL as GL +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback +import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM +import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN +import qualified Graphics.Gloss.Internals.Render.State as RS import Data.IORef import System.Mem -- | Possible input events. data Event - = EventKey GLUT.Key GLUT.KeyState GLUT.Modifiers (Float, Float) + = EventKey Key KeyState Modifiers (Float, Float) | EventMotion (Float, Float) deriving (Eq, Show) @@ -47,6 +45,26 @@ -> IO () gameInWindow + = gameInWindowWithBackend defaultBackendState + +gameInWindowWithBackend + :: forall world a + . Backend a + => a -- ^ Initial state of the backend + -> String -- ^ Name of the window. + -> (Int, Int) -- ^ Initial size of the window, in pixels. + -> (Int, Int) -- ^ Initial position of the window, in pixels. + -> Color -- ^ Background color. + -> Int -- ^ Number of simulation steps to take for each second of real time. + -> world -- ^ The initial world. + -> (world -> Picture) -- ^ A function to convert the world a picture. + -> (Event -> world -> world) -- ^ A function to handle input events. + -> (Float -> world -> world) -- ^ A function to step the world one iteration. + -- It is passed the period of time (in seconds) needing to be advanced. + -> IO () + +gameInWindowWithBackend + backend windowName windowSize windowPos @@ -67,10 +85,11 @@ -- make the initial GL view and render states viewSR <- newIORef viewPortInit - renderSR <- newIORef RO.optionsInit animateSR <- newIORef AN.stateInit + renderS_ <- RS.stateInit + renderSR <- newIORef renderS_ - let displayFun + let displayFun backendRef = do -- convert the world to a picture world <- readIORef worldSR @@ -81,9 +100,10 @@ viewS <- readIORef viewSR -- render the frame - withViewPort + withViewPort + backendRef viewS - (renderPicture renderS viewS picture) + (renderPicture backendRef renderS viewS picture) -- perform garbage collection performGC @@ -101,7 +121,7 @@ , callback_motion worldSR worldHandleEvent , callback_viewPort_reshape ] - createWindow windowName windowSize windowPos backgroundColor callbacks + createWindow backend windowName windowSize windowPos backgroundColor callbacks -- | Callback for KeyMouse events. @@ -119,14 +139,10 @@ :: IORef a -> t -> (Event -> a -> a) - -> GLUT.Key - -> GLUT.KeyState - -> GLUT.Modifiers - -> GL.Position - -> IO () + -> KeyboardMouseCallback -handle_keyMouse worldRef _ eventFn key keyState keyMods pos - = do pos' <- convertPoint pos +handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos + = do pos' <- convertPoint backendRef pos worldRef `modifyIORef` \world -> eventFn (EventKey key keyState keyMods pos') world @@ -143,20 +159,23 @@ handle_motion :: IORef a -> (Event -> a -> a) - -> GL.Position - -> IO () + -> MotionCallback -handle_motion worldRef eventFn pos - = do pos' <- convertPoint pos +handle_motion worldRef eventFn backendRef pos + = do pos' <- convertPoint backendRef pos worldRef `modifyIORef` \world -> eventFn (EventMotion pos') world -convertPoint :: GL.Position -> IO (Float,Float) -convertPoint pos - = do (GLUT.Size sizeX_ sizeY_) <- GL.get GLUT.windowSize +convertPoint :: + forall a . Backend a + => IORef a + -> (Int, Int) + -> IO (Float,Float) +convertPoint backendRef pos + = do (sizeX_, sizeY_) <- getWindowDimensions backendRef let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) - let GLUT.Position px_ py_ = pos + let (px_, py_) = pos let px = fromIntegral px_ let py = sizeY - fromIntegral py_ 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 @@ -1,13 +1,14 @@ {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Simulate - (simulateInWindow) + ( simulateInWindow + , simulateInWindowWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Internals.Render.Picture import Graphics.Gloss.Internals.Render.ViewPort +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewPort @@ -20,7 +21,7 @@ import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Render.Options as RO +import qualified Graphics.Gloss.Internals.Render.State as RS import Data.IORef import System.Mem @@ -45,6 +46,26 @@ -> IO () simulateInWindow + = simulateInWindowWithBackend defaultBackendState + +simulateInWindowWithBackend + :: forall model a + . Backend a + => a -- ^ Initial state of the backend + -> String -- ^ Name of the window. + -> (Int, Int) -- ^ Initial size of the window, in pixels. + -> (Int, Int) -- ^ Initial position of the window, in pixels. + -> Color -- ^ Background color. + -> Int -- ^ Number of simulation steps to take for each second of real time. + -> model -- ^ The initial model. + -> (model -> Picture) -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> model) -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). + -> IO () + +simulateInWindowWithBackend + backend windowName windowSize windowPos @@ -65,10 +86,11 @@ -- make the initial GL view and render states viewSR <- newIORef viewPortInit viewControlSR <- newIORef VPC.stateInit - renderSR <- newIORef RO.optionsInit animateSR <- newIORef AN.stateInit + renderS_ <- RS.stateInit + renderSR <- newIORef renderS_ - let displayFun + let displayFun backendRef = do -- convert the world to a picture world <- readIORef worldSR @@ -80,8 +102,9 @@ -- render the frame withViewPort + backendRef viewS - (renderPicture renderS viewS picture) + (renderPicture backendRef renderS viewS picture) -- perform garbage collection performGC @@ -99,4 +122,4 @@ , callback_viewPort_motion viewSR viewControlSR , callback_viewPort_reshape ] - createWindow windowName windowSize windowPos backgroundColor callbacks + createWindow backend windowName windowSize windowPos backgroundColor callbacks 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 @@ -4,12 +4,13 @@ ( callback_simulate_idle ) where import Graphics.Gloss.Internals.Interface.ViewPort +import Graphics.Gloss.Internals.Interface.Callback +import qualified Graphics.Gloss.Internals.Interface.Backend as Backend import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM -import qualified Graphics.UI.GLUT as GLUT -import Graphics.UI.GLUT (get) import Data.IORef import Control.Monad +import GHC.Float (double2Float) -- | The graphics library calls back on this function when it's finished drawing @@ -23,9 +24,9 @@ -> (ViewPort -> Float -> world -> world) -- ^ fn to advance the world -> Float -- ^ how much time to advance world by -- in single step mode - -> IO () + -> IdleCallback -callback_simulate_idle simSR animateSR viewSR worldSR worldStart worldAdvance singleStepTime +callback_simulate_idle simSR animateSR viewSR worldSR worldStart worldAdvance singleStepTime backendRef = {-# SCC "callbackIdle" #-} do simS <- readIORef simSR let result @@ -39,14 +40,14 @@ = simulate_step simSR viewSR worldSR worldAdvance singleStepTime | otherwise - = return () + = \_ -> return () - result + result backendRef -- reset the world to -simulate_reset :: IORef SM.State -> IORef a -> a -> IO () -simulate_reset simSR worldSR worldStart +simulate_reset :: IORef SM.State -> IORef a -> a -> IdleCallback +simulate_reset simSR worldSR worldStart backendRef = do writeIORef worldSR worldStart simSR `modifyIORef` \c -> c @@ -54,7 +55,7 @@ , SM.stateIteration = 0 , SM.stateSimTime = 0 } - GLUT.postRedisplay Nothing + Backend.postRedisplay backendRef -- take the number of steps specified by controlWarp @@ -64,17 +65,16 @@ -> IORef ViewPort -> IORef world -> (ViewPort -> Float -> world -> world) - -> IO () + -> IdleCallback -simulate_run simSR _ viewSR worldSR worldAdvance +simulate_run simSR _ viewSR worldSR worldAdvance backendRef = do simS <- readIORef simSR viewS <- readIORef viewSR worldS <- readIORef worldSR -- get the elapsed time since the start simulation (wall clock) - elapsedTime_msec <- get GLUT.elapsedTime - let elapsedTime = fromIntegral elapsedTime_msec / 1000 + elapsedTime <- fmap double2Float $ Backend.elapsedTime backendRef -- get how far along the simulation is simTime <- simSR `getsIORef` SM.stateSimTime @@ -119,7 +119,7 @@ , SM.stateStepsPerFrame = fromIntegral thisSteps } -- tell glut we want to draw the window after returning - GLUT.postRedisplay Nothing + Backend.postRedisplay backendRef -- take a single step @@ -129,9 +129,9 @@ -> IORef world -> (ViewPort -> Float -> world -> world) -> Float - -> IO () + -> IdleCallback -simulate_step simSR viewSR worldSR worldAdvance singleStepTime +simulate_step simSR viewSR worldSR worldAdvance singleStepTime backendRef = do viewS <- readIORef viewSR world <- readIORef worldSR @@ -142,7 +142,7 @@ { SM.stateIteration = SM.stateIteration c + 1 , SM.stateStep = False } - GLUT.postRedisplay Nothing + Backend.postRedisplay backendRef getsIORef :: IORef a -> (a -> r) -> IO r diff --git a/Graphics/Gloss/Internals/Interface/ViewPort/Command.hs b/Graphics/Gloss/Internals/Interface/ViewPort/Command.hs --- a/Graphics/Gloss/Internals/Interface/ViewPort/Command.hs +++ b/Graphics/Gloss/Internals/Interface/ViewPort/Command.hs @@ -7,7 +7,7 @@ , defaultCommandConfig , isCommand ) where -import qualified Graphics.UI.GLUT as GLUT +import Graphics.Gloss.Internals.Interface.Backend import qualified Data.Map as Map -- | The commands suported by the view controller @@ -36,48 +36,48 @@ -- | The default commands defaultCommandConfig = [ (CRestore, - [ (GLUT.Char 'r', Nothing) ]) + [ (Char 'r', Nothing) ]) , (CTranslate, - [ ( GLUT.MouseButton GLUT.LeftButton - , Just (GLUT.Modifiers { GLUT.shift = GLUT.Up, GLUT.ctrl = GLUT.Up, GLUT.alt = GLUT.Up })) + [ ( MouseButton LeftButton + , Just (Modifiers { shift = Up, ctrl = Up, alt = Up })) ]) , (CRotate, - [ ( GLUT.MouseButton GLUT.RightButton + [ ( MouseButton RightButton , Nothing) - , ( GLUT.MouseButton GLUT.LeftButton - , Just (GLUT.Modifiers { GLUT.shift = GLUT.Up, GLUT.ctrl = GLUT.Down, GLUT.alt = GLUT.Up })) + , ( MouseButton LeftButton + , Just (Modifiers { shift = Up, ctrl = Down, alt = Up })) ]) -- bump zoom , (CBumpZoomOut, - [ (GLUT.MouseButton GLUT.WheelDown, Nothing) - , (GLUT.SpecialKey GLUT.KeyPageDown, Nothing) ]) + [ (MouseButton WheelDown, Nothing) + , (SpecialKey KeyPageDown, Nothing) ]) , (CBumpZoomIn, - [ (GLUT.MouseButton GLUT.WheelUp, Nothing) - , (GLUT.SpecialKey GLUT.KeyPageUp, Nothing)] ) + [ (MouseButton WheelUp, Nothing) + , (SpecialKey KeyPageUp, Nothing)] ) -- bump translate , (CBumpLeft, - [ (GLUT.SpecialKey GLUT.KeyLeft, Nothing) ]) + [ (SpecialKey KeyLeft, Nothing) ]) , (CBumpRight, - [ (GLUT.SpecialKey GLUT.KeyRight, Nothing) ]) + [ (SpecialKey KeyRight, Nothing) ]) , (CBumpUp, - [ (GLUT.SpecialKey GLUT.KeyUp, Nothing) ]) + [ (SpecialKey KeyUp, Nothing) ]) , (CBumpDown, - [ (GLUT.SpecialKey GLUT.KeyDown, Nothing) ]) + [ (SpecialKey KeyDown, Nothing) ]) -- bump rotate , (CBumpClockwise, - [ (GLUT.SpecialKey GLUT.KeyHome, Nothing) ]) + [ (SpecialKey KeyHome, Nothing) ]) , (CBumpCClockwise, - [ (GLUT.SpecialKey GLUT.KeyEnd, Nothing) ]) + [ (SpecialKey KeyEnd, Nothing) ]) ] diff --git a/Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs b/Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs --- a/Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs +++ b/Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs @@ -5,7 +5,7 @@ , stateInit ) where import Graphics.Gloss.Internals.Interface.ViewPort.Command -import qualified Graphics.UI.GLUT as GLUT +import Graphics.Gloss.Internals.Interface.Backend import qualified Data.Map as Map import Data.Map (Map) @@ -17,7 +17,7 @@ -- | The command list for the viewport controller. -- These can be safely overwridden at any time by deleting / adding entries to the list. -- Entries at the front of the list take precedence. - stateCommands :: Map Command [(GLUT.Key, Maybe GLUT.Modifiers)] + stateCommands :: Map Command [(Key, Maybe Modifiers)] -- | How much to scale the world by for each step of the mouse wheel. , stateScaleStep :: Float diff --git a/Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs b/Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs --- a/Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs +++ b/Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs @@ -8,12 +8,11 @@ import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.ViewPort.Command -import Graphics.Gloss.Internals.Interface.Callback +import Graphics.Gloss.Internals.Interface.Backend import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC -import qualified Graphics.UI.GLUT as GLUT -import qualified Graphics.Rendering.OpenGL.GL as GL -import Data.IORef import Control.Monad +import Data.IORef +import Data.Maybe -- | Callback to handle keyboard and mouse button events @@ -30,116 +29,139 @@ viewPort_keyMouse :: IORef ViewPort -> IORef VPC.State - -> GLUT.Key - -> GLUT.KeyState - -> GLUT.Modifiers - -> GL.Position - -> IO () + -> KeyboardMouseCallback -viewPort_keyMouse portRef controlRef key keyState keyMods pos +viewPort_keyMouse portRef controlRef stateRef key keyState keyMods pos = do commands <- controlRef `getsIORef` VPC.stateCommands {- putStr $ "keyMouse key = " ++ show key ++ "\n" ++ "keyMouse keyState = " ++ show keyState ++ "\n" ++ "keyMouse keyMods = " ++ show keyMods ++ "\n" -} - viewPort_keyMouse2 commands + -- Whether the user is holding down the translate button. + currentlyTranslating + <- liftM (isJust . VPC.stateTranslateMark) + $ readIORef controlRef + + -- Whether the user is holding down the rotate button. + currentlyRotating + <- liftM (isJust . VPC.stateRotateMark) + $ readIORef controlRef + + viewPort_keyMouse2 + currentlyTranslating + currentlyRotating + commands where - viewPort_keyMouse2 commands + viewPort_keyMouse2 currentlyTranslating currentlyRotating commands -- restore viewport | isCommand commands CRestore key keyMods - , keyState == GLUT.Down + , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortScale = 1 , viewPortTranslate = (0, 0) , viewPortRotate = 0 } - GLUT.postRedisplay Nothing + postRedisplay stateRef -- zoom ---------------------------------------- -- zoom out | isCommand commands CBumpZoomOut key keyMods - , keyState == GLUT.Down - = controlZoomOut portRef controlRef + , keyState == Down + = do controlZoomOut portRef controlRef + postRedisplay stateRef -- zoom in | isCommand commands CBumpZoomIn key keyMods - , keyState == GLUT.Down - = controlZoomIn portRef controlRef + , keyState == Down + = do controlZoomIn portRef controlRef + postRedisplay stateRef -- bump ------------------------------------- -- bump left | isCommand commands CBumpLeft key keyMods - , keyState == GLUT.Down - = motionBump portRef (20, 0) + , keyState == Down + = do motionBump portRef (20, 0) + postRedisplay stateRef -- bump right | isCommand commands CBumpRight key keyMods - , keyState == GLUT.Down - = motionBump portRef (-20, 0) + , keyState == Down + = do motionBump portRef (-20, 0) + postRedisplay stateRef -- bump up | isCommand commands CBumpUp key keyMods - , keyState == GLUT.Down - = motionBump portRef (0, 20) + , keyState == Down + = do motionBump portRef (0, 20) + postRedisplay stateRef -- bump down | isCommand commands CBumpDown key keyMods - , keyState == GLUT.Down - = motionBump portRef (0, -20) + , keyState == Down + = do motionBump portRef (0, -20) + postRedisplay stateRef -- bump clockwise | isCommand commands CBumpClockwise key keyMods - , keyState == GLUT.Down + , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortRotate = (\r -> r + 5) $ viewPortRotate s } - GLUT.postRedisplay Nothing + postRedisplay stateRef -- bump anti-clockwise | isCommand commands CBumpCClockwise key keyMods - , keyState == GLUT.Down + , keyState == Down = do portRef `modifyIORef` \s -> s { viewPortRotate = (\r -> r - 5) $ viewPortRotate s } - GLUT.postRedisplay Nothing + postRedisplay stateRef -- translation -------------------------------------- -- start | isCommand commands CTranslate key keyMods - , keyState == GLUT.Down - = do let GL.Position posX posY = pos + , keyState == Down + , not currentlyRotating + = do let (posX, posY) = pos controlRef `modifyIORef` \s -> s { VPC.stateTranslateMark - = Just ( fromIntegral posX - , fromIntegral posY) } - GLUT.postRedisplay Nothing + = Just ( posX + , posY) } + postRedisplay stateRef -- end - | isCommand commands CTranslate key keyMods - , keyState == GLUT.Up + -- 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 = do controlRef `modifyIORef` \s -> s { VPC.stateTranslateMark = Nothing } - GLUT.postRedisplay Nothing + postRedisplay stateRef -- rotation --------------------------------------- -- start | isCommand commands CRotate key keyMods - , keyState == GLUT.Down - = do let GL.Position posX posY = pos + , keyState == Down + , not currentlyTranslating + = do let (posX, posY) = pos controlRef `modifyIORef` \s -> s { VPC.stateRotateMark - = Just ( fromIntegral posX - , fromIntegral posY) } - GLUT.postRedisplay Nothing + = Just ( posX + , posY) } + postRedisplay stateRef -- end - | isCommand commands CRotate key keyMods - , keyState == GLUT.Up + -- 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 = do controlRef `modifyIORef` \s -> s { VPC.stateRotateMark = Nothing } - GLUT.postRedisplay Nothing + postRedisplay stateRef -- carry on | otherwise @@ -151,7 +173,6 @@ = do scaleStep <- controlRef `getsIORef` VPC.stateScaleStep portRef `modifyIORef` \s -> s { viewPortScale = viewPortScale s * scaleStep } - GLUT.postRedisplay Nothing controlZoomOut :: IORef ViewPort -> IORef VPC.State -> IO () @@ -159,7 +180,6 @@ = do scaleStep <- controlRef `getsIORef` VPC.stateScaleStep portRef `modifyIORef` \s -> s { viewPortScale = viewPortScale s / scaleStep } - GLUT.postRedisplay Nothing motionBump :: IORef ViewPort -> (Float, Float) -> IO () @@ -181,8 +201,6 @@ { viewPortTranslate = ( transX - oX , transY + oY) } - - GLUT.postRedisplay Nothing getsIORef :: IORef a -> (a -> r) -> IO r diff --git a/Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs b/Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs --- a/Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs +++ b/Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs @@ -8,8 +8,8 @@ import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Interface.Callback +import Graphics.Gloss.Internals.Interface.Backend import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC -import qualified Graphics.UI.GLUT as GLUT import qualified Graphics.Rendering.OpenGL.GL as GL import Control.Monad import Data.IORef @@ -28,11 +28,11 @@ viewPort_motion :: IORef ViewPort -> IORef VPC.State - -> GL.Position - -> IO () + -> MotionCallback viewPort_motion portRef controlRef + stateRef pos = do -- putStr $ "motion pos = " ++ show pos ++ "\n" @@ -43,32 +43,36 @@ (case translateMark of Nothing -> return () Just (markX, markY) - -> motionTranslate - portRef controlRef - (fromIntegral markX, fromIntegral markY) - pos ) + -> do + motionTranslate + portRef controlRef + (fromIntegral markX, fromIntegral markY) + pos + postRedisplay stateRef) (case rotateMark of Nothing -> return () Just (markX, markY) - -> motionRotate - portRef controlRef - (fromIntegral markX, fromIntegral markY) - pos ) + -> do + motionRotate + portRef controlRef + (fromIntegral markX, fromIntegral markY) + pos + postRedisplay stateRef) motionTranslate :: IORef ViewPort -> IORef VPC.State -> (GL.GLint, GL.GLint) - -> GL.Position + -> (Int, Int) -> IO () motionTranslate portRef controlRef (markX :: GL.GLint, markY :: GL.GLint) - (GL.Position posX posY) + (posX, posY) = do (transX, transY) <- portRef `getsIORef` viewPortTranslate @@ -76,8 +80,8 @@ scale <- portRef `getsIORef` viewPortScale r <- portRef `getsIORef` viewPortRotate - let dX = fromIntegral $ markX - posX - let dY = fromIntegral $ markY - posY + let dX = fromIntegral $ markX - (fromIntegral posX) + let dY = fromIntegral $ markY - (fromIntegral posY) let offset = (dX / scale, dY / scale) @@ -92,33 +96,29 @@ { VPC.stateTranslateMark = Just (fromIntegral posX, fromIntegral posY) } - GLUT.postRedisplay Nothing - motionRotate :: IORef ViewPort -> IORef VPC.State -> (GL.GLint, GL.GLint) - -> GL.Position + -> (Int, Int) -> IO () motionRotate portRef controlRef (markX :: GL.GLint, _markY :: GL.GLint) - (GL.Position posX posY) + (posX, posY) = do rotate <- portRef `getsIORef` viewPortRotate rotateFactor <- controlRef `getsIORef` VPC.stateRotateFactor portRef `modifyIORef` \s -> s { viewPortRotate - = rotate + rotateFactor * fromIntegral (posX - markX) } + = rotate + rotateFactor * fromIntegral ((fromIntegral posX) - markX) } controlRef `modifyIORef` \s -> s { VPC.stateRotateMark = Just (fromIntegral posX, fromIntegral posY) } - - GLUT.postRedisplay Nothing getsIORef :: IORef a -> (a -> r) -> IO r diff --git a/Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs b/Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs --- a/Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs +++ b/Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs @@ -4,8 +4,8 @@ (callback_viewPort_reshape) where import Graphics.Gloss.Internals.Interface.Callback -import Graphics.UI.GLUT (($=)) -import qualified Graphics.UI.GLUT as GLUT +import Graphics.Gloss.Internals.Interface.Backend +import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL.GL as GL @@ -16,12 +16,12 @@ = Reshape (viewPort_reshape) -viewPort_reshape :: GL.Size -> IO () -viewPort_reshape size +viewPort_reshape :: ReshapeCallback +viewPort_reshape stateRef (width,height) = do -- Setup the viewport -- This controls what part of the window openGL renders to. -- We'll use the whole window. -- - GL.viewport $= (GL.Position 0 0, size) - GLUT.postRedisplay Nothing + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral width) (fromIntegral height)) + postRedisplay stateRef 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 @@ -6,29 +6,30 @@ where import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Color +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Debug -import Graphics.Gloss.Internals.Interface.Callback (Callback) -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback - -import Graphics.UI.GLUT (($=), get) +import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL.GL as GL -import qualified Graphics.UI.GLUT as GLUT +import Data.IORef (newIORef) import Control.Monad -- | Open a window and use the supplied callbacks to handle window events. -createWindow - :: String -- ^ Name of the window. +createWindow + :: Backend a + => a + -> String -- ^ Name of the window. -> (Int, Int) -- ^ Initial size of the window, in pixels. - -> (Int, Int) -- ^ Initial position of the window, in pixels relative to + -> (Int, Int) -- ^ Initial position of the window, in pixels relative to -- the top left corner of the screen. -> Color -- ^ Color to use when clearing. -> [Callback] -- ^ Callbacks to use -> IO () createWindow + backend windowName - (sizeX, sizeY) + (sizeX, sizeY) (posX, posY) clearColor callbacks @@ -36,62 +37,29 @@ -- Turn this on to spew debugging info to stdout let debug = False - -- Initialize GLUT - (_progName, _args) <- GLUT.getArgsAndInitialize - glutVersion <- get GLUT.glutVersion + -- Initialize backend state + backendStateRef <- newIORef backend when debug $ do putStr $ "* displayInWindow\n" - putStr $ " glutVersion = " ++ show glutVersion ++ "\n" - -- 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. - -- - GLUT.initialWindowPosition - $= GL.Position - (fromIntegral posX) - (fromIntegral posY) - - GLUT.initialWindowSize - $= GL.Size - (fromIntegral sizeX) - (fromIntegral sizeY) - - GLUT.initialDisplayMode - $= [ GLUT.RGBMode - , GLUT.DoubleBuffered] + -- Intialize backend + initializeBackend backendStateRef debug - -- 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" - -- Here we go! when debug $ do putStr $ "* creating window\n\n" - _ <- GLUT.createWindow windowName - GLUT.windowSize - $= GL.Size - (fromIntegral sizeX) - (fromIntegral sizeY) - - -- Setup callbacks - GLUT.displayCallback $= callbackDisplay clearColor callbacks - GLUT.reshapeCallback $= Just (callbackReshape callbacks) - GLUT.keyboardMouseCallback $= Just (callbackKeyMouse callbacks) - GLUT.motionCallback $= Just (callbackMotion callbacks) - GLUT.idleCallback $= Just (callbackIdle callbacks) + -- Open window + openWindow backendStateRef windowName (sizeX, sizeY) (posX, posY) - -- Switch some things. - -- auto repeat interferes with key up / key down checks. - -- BUGS: this doesn't seem to work? - GLUT.perWindowKeyRepeat $= GLUT.PerWindowKeyRepeatOff + -- Setup callbacks + installDisplayCallback backendStateRef callbacks + installWindowCloseCallback backendStateRef + installReshapeCallback backendStateRef callbacks + installKeyMouseCallback backendStateRef callbacks + installMotionCallback backendStateRef callbacks + installIdleCallback backendStateRef callbacks -- we don't need the depth buffer for 2d. GL.depthFunc $= Just GL.Always @@ -101,82 +69,17 @@ -- Dump some debugging info when debug - $ do dumpGlutState - dumpFramebufferState + $ do dumpBackendState backendStateRef + dumpFramebufferState dumpFragmentState - --------------- - -- Call the GLUT mainloop. - -- This function will return when something calls GLUT.leaveMainLoop - -- - -- We can ask for this in freeglut, but it doesn't seem to work :(. - -- GLUT.actionOnWindowClose $= GLUT.MainLoopReturns when debug $ do putStr $ "* entering mainloop..\n" - - GLUT.mainLoop + -- Start the main backend loop + runMainLoop backendStateRef + when debug $ putStr $ "* all done\n" - - return () - -callbackDisplay :: t -> [Callback] -> IO () -callbackDisplay _ 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 | (Callback.Display f) <- callbacks] - sequence_ funs - - -- swap front and back buffers - GLUT.swapBuffers - GLUT.reportErrors - return () - - -callbackReshape :: [Callback] -> GLUT.Size -> IO () -callbackReshape callbacks size - = sequence_ - $ map (\f -> f size) - [f | Callback.Reshape f <- callbacks] - - -callbackKeyMouse - :: [Callback] - -> GLUT.Key - -> GLUT.KeyState - -> GLUT.Modifiers - -> GLUT.Position - -> IO () - -callbackKeyMouse callbacks key keystate modifiers pos - = sequence_ - $ map (\f -> f key keystate modifiers pos) - [f | Callback.KeyMouse f <- callbacks] - - -callbackMotion - :: [Callback] - -> GLUT.Position - -> IO () - -callbackMotion callbacks pos - = sequence_ - $ map (\f -> f pos) - [f | Callback.Motion f <- callbacks] - - -callbackIdle - :: [Callback] - -> IO () - -callbackIdle callbacks - = sequence_ - $ [f | Callback.Idle f <- callbacks] - - + return () diff --git a/Graphics/Gloss/Internals/Render/Options.hs b/Graphics/Gloss/Internals/Render/Options.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/Options.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- | Rendering options -module Graphics.Gloss.Internals.Render.Options - ( Options (..) - , optionsInit ) -where - --- | Render options settings -data Options - = Options - { -- | Whether to use color - optionsColor :: Bool - - -- | Whether to force wireframe mode only - , optionsWireframe :: Bool - - -- | Whether to use alpha blending - , optionsBlendAlpha :: Bool - - -- | Whether to use line smoothing - , optionsLineSmooth :: Bool - } - - --- | Default render options -optionsInit :: Options -optionsInit - = Options - { optionsColor = True - , optionsWireframe = False - , optionsBlendAlpha = True - , optionsLineSmooth = False } - - diff --git a/Graphics/Gloss/Internals/Render/Picture.hs b/Graphics/Gloss/Internals/Render/Picture.hs --- a/Graphics/Gloss/Internals/Render/Picture.hs +++ b/Graphics/Gloss/Internals/Render/Picture.hs @@ -7,24 +7,33 @@ where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.ViewPort -import Graphics.Gloss.Internals.Render.Options +import Graphics.Gloss.Internals.Render.State import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Internals.Render.Circle import Graphics.Gloss.Internals.Render.Bitmap -import Graphics.UI.GLUT (($=), get) +import Graphics.Rendering.OpenGL (($=), get) import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.UI.GLUT as GLUT -import Control.Monad +import System.Mem.StableName +import Data.IORef +import Data.List +import Data.ByteString (ByteString) +import Control.Monad + -- ^ Render a picture using the given render options and viewport. renderPicture - :: Options -- ^ The render options to use + :: forall a . Backend a + => IORef a + -> State -- ^ The render state -> ViewPort -- ^ The current viewport. -> Picture -- ^ The picture to render. -> IO () renderPicture + backendRef renderS viewS picture @@ -34,24 +43,26 @@ (matProj_ :: GL.GLmatrix GL.GLdouble) <- get $ GL.matrix (Just $ GL.Projection) viewport_ <- get $ GL.viewport - windowSize_ <- get GLUT.windowSize + windowSize_ <- getWindowDimensions backendRef -- - let ?modeWireframe = optionsWireframe renderS - ?modeColor = optionsColor renderS + let ?modeWireframe = stateWireframe renderS + ?modeColor = stateColor renderS + ?refTextures = stateTextures renderS ?matProj = matProj_ ?viewport = viewport_ ?windowSize = windowSize_ -- setup render state for world - setLineSmooth (optionsLineSmooth renderS) - setBlendAlpha (optionsBlendAlpha renderS) + setLineSmooth (stateLineSmooth renderS) + setBlendAlpha (stateBlendAlpha renderS) drawPicture (viewPortScale viewS) picture drawPicture - :: ( ?modeWireframe :: Bool - , ?modeColor :: Bool) + :: ( ?modeWireframe :: Bool + , ?modeColor :: Bool + , ?refTextures :: IORef [Texture]) => Float -> Picture -> IO () drawPicture circScale picture @@ -143,26 +154,12 @@ drawPicture (circScale * mscale) p ----- - Bitmap width height imgData - -> do -- As OpenGL reads texture pixels as ABGR (instead of RGBA) - -- each pixel's value needs to be reversed we also need to - -- Convert imgData from ByteString to Ptr Word8 - imgData' <- reverseRGBA $ imgData - -- Allocate texture handle for texture - [texObject] <- GL.genObjectNames 1 - GL.textureBinding GL.Texture2D $= Just texObject - - -- Sets the texture in imgData as the current texture - GL.texImage2D - Nothing - GL.NoProxy - 0 - GL.RGBA8 - (GL.TextureSize2D - (gsizei width) - (gsizei height)) - 0 - (GL.PixelData GL.RGBA GL.UnsignedInt8888 imgData') + Bitmap width height imgData cacheMe + -> do + -- Load the image data into a texture, + -- or grab it from the cache if we've already done that before. + tex <- loadTexture ?refTextures width height imgData cacheMe + -- Set up wrap and filtering mode GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat) @@ -173,7 +170,7 @@ GL.textureFunction $= GL.Combine -- Set current texture - GL.textureBinding GL.Texture2D $= Just texObject + GL.textureBinding GL.Texture2D $= Just (texObject tex) -- Set to opaque GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 @@ -191,15 +188,106 @@ -- Disable texturing GL.texture GL.Texture2D $= GL.Disabled - -- Delete texture - GL.deleteObjectNames [texObject] - - -- Free image data - freeBitmapData imgData' + -- Free uncachable texture objects. + freeTexture tex + Pictures ps -> mapM_ (drawPicture circScale) ps +-- Textures --------------------------------------------------------------------------------------- +-- | Load a texture. +-- If we've seen it before then use the pre-installed one from the texture cache, +-- otherwise load it into OpenGL. +loadTexture + :: IORef [Texture] + -> Int -> Int -> ByteString + -> Bool + -> IO Texture + +loadTexture refTextures width height imgData cacheMe + = do textures <- readIORef refTextures + + -- Try and find this same texture in the cache. + name <- makeStableName imgData + let mTexCached + = find (\tex -> texName tex == name + && texWidth tex == width + && texHeight tex == height) + $ textures + + case mTexCached of + Just tex + -> return tex + + Nothing + -> do tex <- installTexture width height imgData cacheMe + when cacheMe + $ writeIORef refTextures (tex : textures) + return tex + + +-- | Install a texture into OpenGL. +installTexture + :: Int -> Int + -> ByteString + -> Bool + -> IO Texture + +installTexture width height imgData cacheMe + = do + -- As OpenGL reads texture pixels as ABGR (instead of RGBA) + -- each pixel's value needs to be reversed we also need to + -- Convert imgData from ByteString to Ptr Word8 + ptrData <- reverseRGBA $ imgData + + -- Allocate texture handle for texture + [tex] <- GL.genObjectNames 1 + GL.textureBinding GL.Texture2D $= Just tex + + -- Sets the texture in imgData as the current texture + GL.texImage2D + Nothing + GL.NoProxy + 0 + GL.RGBA8 + (GL.TextureSize2D + (gsizei width) + (gsizei height)) + 0 + (GL.PixelData GL.RGBA GL.UnsignedInt8888 ptrData) + + -- Make a stable name that we can use to identify this data again. + -- If the user gives us the same texture data at the same size then we + -- can avoid loading it into texture memory again. + name <- makeStableName imgData + + return Texture + { texName = name + , texWidth = width + , texHeight = height + , texData = ptrData + , texObject = tex + , texCacheMe = cacheMe } + + +-- | If this texture does not have its `cacheMe` flag set then delete it from +-- OpenGL and free the memory. +freeTexture :: Texture -> IO () +freeTexture tex + | texCacheMe tex = return () + | otherwise = deleteTexture tex + + +-- | Delete a texture object from OpenGL. +deleteTexture :: Texture -> IO () +deleteTexture tex + = do -- Delete texture + GL.deleteObjectNames [texObject tex] + + -- Free image data + freeBitmapData (texData tex) + -- Utils ------------------------------------------------------------------------------------------ -- | Turn alpha blending on or off diff --git a/Graphics/Gloss/Internals/Render/State.hs b/Graphics/Gloss/Internals/Render/State.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Render/State.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_HADDOCK hide #-} + +-- | Rendering options +module Graphics.Gloss.Internals.Render.State + ( State (..) + , stateInit + , Texture (..)) +where +import qualified Graphics.Rendering.OpenGL.GL as GL +import Foreign.Ptr +import System.Mem.StableName +import Data.ByteString (ByteString) +import Data.Word +import Data.IORef + +-- | Render options settings +data State + = State + { -- | Whether to use color + stateColor :: Bool + + -- | Whether to force wireframe mode only + , stateWireframe :: Bool + + -- | Whether to use alpha blending + , stateBlendAlpha :: Bool + + -- | Whether to use line smoothing + , stateLineSmooth :: Bool + + -- | Cache of Textures that we've sent to OpenGL. + , stateTextures :: IORef [Texture] + } + + +-- | A texture that we've sent to OpenGL. +data Texture + = Texture + { -- | Stable name derived from the `ByteString` that the user gives us. + -- We + texName :: StableName ByteString + + -- | Width of the image, in pixels. + , texWidth :: Int + + -- | Height of the image, in pixels. + , texHeight :: Int + + -- | Pointer to the Raw texture data. + , texData :: Ptr Word8 + + -- | The OpenGL texture object. + , texObject :: GL.TextureObject + + -- | Whether we want to leave this in OpenGL texture memory between frames. + , texCacheMe :: Bool } + + +-- | Default render options +stateInit :: IO State +stateInit + = do textures <- newIORef [] + return State + { stateColor = True + , stateWireframe = False + , stateBlendAlpha = True + , stateLineSmooth = False + , stateTextures = textures } + + diff --git a/Graphics/Gloss/Internals/Render/ViewPort.hs b/Graphics/Gloss/Internals/Render/ViewPort.hs --- a/Graphics/Gloss/Internals/Render/ViewPort.hs +++ b/Graphics/Gloss/Internals/Render/ViewPort.hs @@ -1,32 +1,33 @@ {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} -- | Handling the current viewport during rendering. module Graphics.Gloss.Internals.Render.ViewPort ( withViewPort ) where +import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.ViewPort -import Graphics.Rendering.OpenGL (GLfloat) -import Graphics.UI.GLUT (($=), get) -import qualified Graphics.UI.GLUT as GLUT +import Graphics.Rendering.OpenGL (GLfloat, ($=)) import qualified Graphics.Rendering.OpenGL.GL as GL +import Data.IORef (IORef) -- | Perform a rendering action whilst using the given viewport withViewPort - :: ViewPort -- ^ The viewport to use. + :: forall a . Backend a + => IORef a + -> ViewPort -- ^ The viewport to use. -> IO () -- ^ The rendering action to perform. -> IO () -withViewPort port action +withViewPort backendRef port action = do GL.matrixMode $= GL.Projection GL.preservingMatrix $ do -- setup the co-ordinate system GL.loadIdentity - (GL.Size sizeX sizeY) - <- get GLUT.windowSize + (sizeX, sizeY) <- getWindowDimensions backendRef let (sx, sy) = (fromIntegral sizeX / 2, fromIntegral sizeY / 2) GL.ortho (-sx) sx (-sy) sy 0 (-100) diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,5 +1,5 @@ Name: gloss -Version: 1.3.4.1 +Version: 1.4.0.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -12,14 +12,27 @@ Bug-reports: gloss@ouroborus.net Description: Gloss hides the pain of drawing simple vector graphics behind a nice data type and - a few display functions. Gloss uses OpenGL and GLUT under the hood, but you won't - have to worry about any of that. Get something cool on the screen in under 10 minutes. + a few display functions. Gloss uses OpenGL under the hood, but you won't need to + worry about any of that. Get something cool on the screen in under 10 minutes. Synopsis: Painless 2D vector graphics, animations and simulations. Tested-with: GHC == 6.12.1, GHC == 7.0.1 +Flag GLUT + Description: Enable the GLUT backend + Default: True + +Flag GLFW + Description: Enable the GLFW backend + Default: False + +Flag ExplicitBackend + Description: Expose versions of displayInWindow and friends that allow + you to choose what window manager backend to use. + Default: False + Library Build-Depends: base == 4.*, @@ -27,7 +40,8 @@ containers >= 0.3.0 && < 0.5.0, bytestring == 0.9.*, OpenGL == 2.4.*, - GLUT == 2.2.* + GLUT == 2.2.*, + bmp == 1.1.* ghc-options: -O2 -Wall @@ -44,22 +58,21 @@ Graphics.Gloss.Data.Color Graphics.Gloss.Data.Picture Graphics.Gloss.Algorithms.RayCast + Graphics.Gloss.Interface.Display + Graphics.Gloss.Interface.Animate Graphics.Gloss.Interface.Simulate Graphics.Gloss.Interface.Game Other-modules: Graphics.Gloss.Internals.Color - Graphics.Gloss.Internals.Interface.Animate Graphics.Gloss.Internals.Interface.Animate.State Graphics.Gloss.Internals.Interface.Animate.Timing + Graphics.Gloss.Internals.Interface.Backend.Types Graphics.Gloss.Internals.Interface.Callback Graphics.Gloss.Internals.Interface.Common.Exit Graphics.Gloss.Internals.Interface.Debug - Graphics.Gloss.Internals.Interface.Display - Graphics.Gloss.Internals.Interface.Simulate Graphics.Gloss.Internals.Interface.Simulate.Idle Graphics.Gloss.Internals.Interface.Simulate.State - Graphics.Gloss.Internals.Interface.Game Graphics.Gloss.Internals.Interface.ViewPort Graphics.Gloss.Internals.Interface.ViewPort.Command Graphics.Gloss.Internals.Interface.ViewPort.ControlState @@ -70,7 +83,25 @@ Graphics.Gloss.Internals.Render.Bitmap Graphics.Gloss.Internals.Render.Circle Graphics.Gloss.Internals.Render.Common - Graphics.Gloss.Internals.Render.Options + Graphics.Gloss.Internals.Render.State Graphics.Gloss.Internals.Render.Picture Graphics.Gloss.Internals.Render.ViewPort + + Graphics.Gloss.Internals.Interface.Display + Graphics.Gloss.Internals.Interface.Animate + Graphics.Gloss.Internals.Interface.Simulate + Graphics.Gloss.Internals.Interface.Game + Graphics.Gloss.Internals.Interface.Backend + + If flag(GLUT) + CPP-Options: -DWITHGLUT + Other-modules: + Graphics.Gloss.Internals.Interface.Backend.GLUT + + If flag(GLFW) + Build-Depends: + GLFW-b == 0.0.2.* + CPP-Options: -DWITHGLFW + Other-modules: + Graphics.Gloss.Internals.Interface.Backend.GLFW