gloss 1.3.4.1 → 1.4.0.1

raw patch · 31 files changed

+1732/−528 lines, 31 filesdep +GLFW-bdep +bmpPVP ok

version bump matches the API change (PVP)

Dependencies added: GLFW-b, bmp

API changes (from Hackage documentation)

Files

• Graphics/Gloss.hs +33/−20
• Graphics/Gloss/Data/Picture.hs +19/−28
• Graphics/Gloss/Interface/Animate.hs +10/−0
• Graphics/Gloss/Interface/Display.hs +10/−0
• Graphics/Gloss/Interface/Game.hs +2/−2
• Graphics/Gloss/Interface/Simulate.hs +1/−1
• Graphics/Gloss/Internals/Interface/Animate.hs +30/−13
• Graphics/Gloss/Internals/Interface/Animate/State.hs +8/−8
• Graphics/Gloss/Internals/Interface/Animate/Timing.hs +9/−11
• Graphics/Gloss/Internals/Interface/Backend.hs +33/−0
• Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +521/−0
• Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +332/−0
• Graphics/Gloss/Internals/Interface/Backend/Types.hs +194/−0
• Graphics/Gloss/Internals/Interface/Callback.hs +10/−12
• Graphics/Gloss/Internals/Interface/Common/Exit.hs +6/−13
• Graphics/Gloss/Internals/Interface/Debug.hs +3/−40
• Graphics/Gloss/Internals/Interface/Display.hs +28/−15
• Graphics/Gloss/Internals/Interface/Game.hs +48/−29
• Graphics/Gloss/Internals/Interface/Simulate.hs +30/−7
• Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +17/−17
• Graphics/Gloss/Internals/Interface/ViewPort/Command.hs +17/−17
• Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs +2/−2
• Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs +68/−50
• Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs +22/−22
• Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs +6/−6
• Graphics/Gloss/Internals/Interface/Window.hs +29/−126
• Graphics/Gloss/Internals/Render/Options.hs +0/−35
• Graphics/Gloss/Internals/Render/Picture.hs +125/−37
• Graphics/Gloss/Internals/Render/State.hs +70/−0
• Graphics/Gloss/Internals/Render/ViewPort.hs +9/−8
• gloss.cabal +40/−9

@@ -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

@@ -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 ----------------------------------------------------------------------------------------

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 }

@@ -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 

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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 ()

@@ -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 ()

@@ -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

@@ -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_ 	

@@ -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

@@ -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

@@ -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) ])  	] 

@@ -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	

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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 }-	-

@@ -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

@@ -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 }+	+

@@ -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)

@@ -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