gloss 1.7.8.4 → 1.8.0.1

raw patch · 27 files changed

+673/−730 lines, 27 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Graphics/Gloss.hs +6/−7
• Graphics/Gloss/Data/Vector.hs +14/−9
• Graphics/Gloss/Data/ViewPort.hs +57/−0
• Graphics/Gloss/Data/ViewState.hs +334/−0
• Graphics/Gloss/Geometry/Angle.hs +3/−9
• Graphics/Gloss/Interface/IO/Simulate.hs +1/−1
• Graphics/Gloss/Interface/Pure/Simulate.hs +1/−1
• Graphics/Gloss/Internals/Interface/Animate.hs +13/−15
• Graphics/Gloss/Internals/Interface/Display.hs +13/−15
• Graphics/Gloss/Internals/Interface/Event.hs +52/−0
• Graphics/Gloss/Internals/Interface/Game.hs +12/−39
• Graphics/Gloss/Internals/Interface/Simulate.hs +16/−17
• Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +14/−13
• Graphics/Gloss/Internals/Interface/ViewPort.hs +0/−29
• Graphics/Gloss/Internals/Interface/ViewPort/Command.hs +0/−101
• Graphics/Gloss/Internals/Interface/ViewPort/ControlState.hs +0/−46
• Graphics/Gloss/Internals/Interface/ViewPort/KeyMouse.hs +0/−208
• Graphics/Gloss/Internals/Interface/ViewPort/Motion.hs +0/−126
• Graphics/Gloss/Internals/Interface/ViewPort/Reshape.hs +0/−28
• Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs +32/−0
• Graphics/Gloss/Internals/Interface/ViewState/Motion.hs +34/−0
• Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs +28/−0
• Graphics/Gloss/Internals/Render/Common.hs +30/−0
• Graphics/Gloss/Internals/Render/Picture.hs +4/−2
• Graphics/Gloss/Internals/Render/ViewPort.hs +0/−55
• LICENSE +1/−1
• gloss.cabal +8/−8

@@ -31,9 +31,15 @@ --   Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime --   will limit the frame-rate to around 20Hz. --+--   To build gloss using the GLFW window manager instead of GLUT use+--        @cabal install gloss --flags=\"GLFW -GLUT\"@ -- -- @Release Notes: --+-- For 1.8.0+--  Thanks to Francesco Mazzoli+--   * Factored out ViewPort and ViewState handling into user visible modules.+-- -- For 1.7.0: --   * Tweaked circle level-of-detail reduction code. --   * Increased frame rate cap to 100hz.@@ -50,13 +56,6 @@ --   * O(1) Conversion of ForeignPtrs to bitmaps. --   * An extra flag on the Bitmap constructor allows bitmaps to be cached --     in texture memory between frames.------ 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 more information, check out <http://gloss.ouroborus.net>.

@@ -23,45 +23,49 @@  -- | The magnitude of a vector. magV :: Vector -> Float-{-# INLINE magV #-} magV (x, y) 	 	= sqrt (x * x + y * y)+{-# INLINE magV #-} + -- | The angle of this vector, relative to the +ve x-axis. argV :: Vector -> Float-{-# INLINE argV #-} argV (x, y) 	= normaliseAngle $ atan2 y x+{-# INLINE argV #-} + -- | The dot product of two vectors. dotV :: Vector -> Vector -> Float-{-# INLINE dotV #-} dotV (x1, x2) (y1, y2) 	= x1 * y1 + x2 * y2+{-# INLINE dotV #-} + -- | The determinant of two vectors. detV :: Vector -> Vector -> Float-{-# INLINE detV #-} detV (x1, y1) (x2, y2) 	= x1 * y2 - y1 * x2+{-# INLINE detV #-} + -- | Multiply a vector by a scalar. mulSV :: Float -> Vector -> Vector-{-# INLINE mulSV #-} mulSV s (x, y)		 	= (s * x, s * y)+{-# INLINE mulSV #-} + -- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. rotateV :: Float -> Vector -> Vector-{-# INLINE rotateV #-} rotateV r (x, y)  = 	(  x * cos r - y * sin r         ,  x * sin r + y * cos r)+{-# INLINE rotateV #-}   -- | Compute the inner angle (in radians) between two vectors. angleVV :: Vector -> Vector -> Float-{-# INLINE angleVV #-} angleVV p1 p2  = let 	m1	= magV p1  	m2	= magV p2@@ -69,18 +73,19 @@ 	aDiff	= acos $ d / (m1 * m2)     in	aDiff	+{-# INLINE angleVV #-}   -- | Normalise a vector, so it has a magnitude of 1. normaliseV :: Vector -> Vector-{-# INLINE normaliseV #-} normaliseV v	= mulSV (1 / magV v) v+{-# INLINE normaliseV #-}   -- | Produce a unit vector at a given angle relative to the +ve x-axis. --	The provided angle is in radians. unitVectorAtAngle :: Float -> Vector-{-# INLINE unitVectorAtAngle #-} unitVectorAtAngle r 	= (cos r, sin r)+{-# INLINE unitVectorAtAngle #-} 

@@ -0,0 +1,57 @@+module Graphics.Gloss.Data.ViewPort+	( ViewPort(..)+	, viewPortInit+	, applyViewPortToPicture+	, invertViewPort )+where+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Geometry.Angle+import Graphics.Gloss.Data.Picture (Picture(..))+import Graphics.Gloss.Data.Point+++-- | The 'ViewPort' represents the global transformation applied to the displayed picture.+--      When the user pans, zooms, or rotates the display then this changes the 'ViewPort'.+data ViewPort+	= ViewPort { +	-- | Global translation.+	  viewPortTranslate	:: !(Float, Float)++	-- | Global rotation (in degrees).+	, viewPortRotate	:: !Float		++	-- | Global scaling (of both x and y coordinates).+	, viewPortScale		:: !Float		+	}+	+	+-- | The initial state of the viewport.+viewPortInit :: ViewPort+viewPortInit+	= ViewPort+	{ viewPortTranslate	= (0, 0) +	, viewPortRotate	= 0+	, viewPortScale		= 1 +	}+++-- | Translates, rotates, and scales an image according to the 'ViewPort'.+applyViewPortToPicture :: ViewPort  -> Picture -> Picture+applyViewPortToPicture+	ViewPort	{ viewPortScale		= scale+                        , viewPortTranslate	= (transX, transY)+			, viewPortRotate	= rotate }+	= Scale scale scale . Rotate rotate . Translate transX transY+++-- | Takes a point using screen coordinates, and uses the `ViewPort` to convert+--   it to Picture coordinates. This is the inverse of `applyViewPortToPicture` +--   for points.+invertViewPort :: ViewPort -> Point -> Point+invertViewPort+	ViewPort	{ viewPortScale		= scale+			, viewPortTranslate	= trans+			, viewPortRotate	= rotate }+        pos+	= rotateV (degToRad rotate) (mulSV (1 / scale) pos) - trans+

@@ -0,0 +1,334 @@+module Graphics.Gloss.Data.ViewState+        ( Command      (..)+        , CommandConfig+        , defaultCommandConfig+        , ViewState     (..)+        , ViewPort      (..)+        , viewStateInit+        , viewStateInitWithConfig+        , updateViewStateWithEvent+        , updateViewStateWithEventMaybe+        , applyViewPortToPicture+        , invertViewPort )+where+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Data.ViewPort+import Graphics.Gloss.Geometry.Angle+import Graphics.Gloss.Internals.Interface.Backend+import Graphics.Gloss.Internals.Interface.Event+import qualified Data.Map                       as Map+import Data.Map                                 (Map)+import Data.Maybe+import Control.Monad (mplus)+++-- | The commands suported by the view controller.+data Command+        = CRestore++        | CTranslate+        | CRotate++        -- bump zoom+        | CBumpZoomOut+        | CBumpZoomIn++        -- bump translate+        | CBumpLeft+        | CBumpRight+        | CBumpUp+        | CBumpDown++        -- bump rotate+        | CBumpClockwise+        | CBumpCClockwise+        deriving (Show, Eq, Ord)+++type CommandConfig = [(Command, [(Key, Maybe Modifiers)])]+++-- | The default commands.  Left click pans, wheel zooms, right click+--   rotates, "r" key resets.+defaultCommandConfig :: CommandConfig+defaultCommandConfig+ =      [ (CRestore,+                [ (Char 'r',                    Nothing) ])++        , (CTranslate,+                [ ( MouseButton LeftButton+                  , Just (Modifiers { shift = Up, ctrl = Up, alt = Up }))+                ])++        , (CRotate,+                [ ( MouseButton RightButton+                  , Nothing)+                , ( MouseButton LeftButton+                  , Just (Modifiers { shift = Up, ctrl = Down, alt = Up }))+                ])++        -- bump zoom+        , (CBumpZoomOut,+                [ (MouseButton WheelDown,       Nothing)+                , (SpecialKey  KeyPageDown,     Nothing) ])++        , (CBumpZoomIn,+                [ (MouseButton WheelUp,         Nothing)+                , (SpecialKey  KeyPageUp,       Nothing)] )++        -- bump translate+        , (CBumpLeft,+                [ (SpecialKey  KeyLeft,         Nothing) ])++        , (CBumpRight,+                [ (SpecialKey  KeyRight,        Nothing) ])++        , (CBumpUp,+                [ (SpecialKey  KeyUp,           Nothing) ])++        , (CBumpDown,+                [ (SpecialKey  KeyDown,         Nothing) ])++        -- bump rotate+        , (CBumpClockwise,+                [ (SpecialKey  KeyHome,         Nothing) ])++        , (CBumpCClockwise,+                [ (SpecialKey  KeyEnd,          Nothing) ])++        ]+++-- | Check if the provided key combination is some gloss viewport command.+isCommand +        :: Map Command [(Key, Maybe Modifiers)] +        -> Command -> Key -> Modifiers -> Bool++isCommand commands c key keyMods+        | Just csMatch          <- Map.lookup c commands+        = or $ map (isCommand2 c key keyMods) csMatch++        | otherwise+        = False+++-- | Check if the provided key combination is some gloss viewport command.+isCommand2 :: Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool+isCommand2 _ key keyMods cMatch+        | (keyC, mModsC)        <- cMatch+        , keyC == key+        , case mModsC of+                Nothing         -> True+                Just modsC      -> modsC == keyMods+        = True++        | otherwise+        = False+++-- ViewControl State -----------------------------------------------------------+-- | State for controlling the viewport.+--      These are used by the viewport control component.+data ViewState+        = ViewState {+        -- | The command list for the viewport controller.+        --      These can be safely overwridden at any time by deleting+        --      or adding entries to the list.+        --      Entries at the front of the list take precedence.+          viewStateCommands             :: !(Map Command [(Key, Maybe Modifiers)])++        -- | How much to scale the world by for each step of the mouse wheel.+        , viewStateScaleStep            :: !Float++        -- | How many degrees to rotate the world by for each pixel of x motion.+        , viewStateRotateFactor         :: !Float++        -- | During viewport translation,+        --      where the mouse was clicked on the window.+        , viewStateTranslateMark        :: !(Maybe (Float, Float))++        -- | During viewport rotation,  +        --      where the mouse was clicked on the window+        , viewStateRotateMark           :: !(Maybe (Float, Float))++        , viewStateViewPort             :: ViewPort+        }+++-- | The initial view state.+viewStateInit :: ViewState+viewStateInit+        = viewStateInitWithConfig defaultCommandConfig++-- | Initial view state, with user defined config.+viewStateInitWithConfig :: CommandConfig -> ViewState+viewStateInitWithConfig commandConfig+        = ViewState+        { viewStateCommands             = Map.fromList commandConfig+        , viewStateScaleStep            = 0.85+        , viewStateRotateFactor         = 0.6+        , viewStateTranslateMark        = Nothing+        , viewStateRotateMark           = Nothing+        , viewStateViewPort             = viewPortInit }+++-- | Apply an event to a `ViewState`.+updateViewStateWithEvent :: Event -> ViewState -> ViewState+updateViewStateWithEvent ev viewState+        = fromMaybe viewState $ updateViewStateWithEventMaybe ev viewState+++-- | Like 'updateViewStateWithEvent', but returns 'Nothing' if no update+--   was needed.+updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState+updateViewStateWithEventMaybe (EventKey key keyState keyMods pos) viewState+        | isCommand commands CRestore key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort = viewPortInit }++        | isCommand commands CBumpZoomOut key keyMods+        , keyState      == Down+        = Just $ controlZoomIn viewState++        | isCommand commands CBumpZoomIn key keyMods+        , keyState      == Down+        = Just $ controlZoomOut viewState++        | isCommand commands CBumpLeft key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort = motionBump port (20, 0) }++        | isCommand commands CBumpRight key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort = motionBump port (-20, 0) }++        | isCommand commands CBumpUp key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort = motionBump port (0, -20) }++        | isCommand commands CBumpDown key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort = motionBump port (0, 20) }++        | isCommand commands CBumpClockwise key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort +                                = port { viewPortRotate = viewPortRotate port + 5 } }++        | isCommand commands CBumpCClockwise key keyMods+        , keyState      == Down+        = Just $ viewState { viewStateViewPort +                                = port { viewPortRotate = viewPortRotate port - 5 } }++        | isCommand commands CTranslate key keyMods+        , keyState      == Down+        , not currentlyRotating+        = Just $ viewState { viewStateTranslateMark = Just pos }++        -- 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+        = Just $ viewState { viewStateTranslateMark = Nothing }++        | isCommand commands CRotate key keyMods+        , keyState      == Down+        , not currentlyTranslating+        = Just $ viewState { viewStateRotateMark = Just pos }++        -- 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+        = Just $ viewState { viewStateRotateMark = Nothing }++        | otherwise+        = Nothing+        where   commands                = viewStateCommands viewState+                port                    = viewStateViewPort viewState+                currentlyTranslating    = isJust $ viewStateTranslateMark viewState+                currentlyRotating       = isJust $ viewStateRotateMark viewState+++-- Note that only a translation or rotation applies, not both at the same time.+updateViewStateWithEventMaybe (EventMotion pos) viewState+ = motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus`+   motionRotate    (viewStateRotateMark    viewState) pos viewState+++-- | Zoom in a `ViewState` by the scale step.+controlZoomIn :: ViewState -> ViewState+controlZoomIn + viewState@ViewState +        { viewStateViewPort     = port+        , viewStateScaleStep    = scaleStep }+ = viewState +        { viewStateViewPort     +                = port { viewPortScale = viewPortScale port * scaleStep } }+++-- | Zoom out a `ViewState` by the scale step.+controlZoomOut :: ViewState -> ViewState+controlZoomOut + viewState@ViewState +        { viewStateViewPort     = port+        , viewStateScaleStep    = scaleStep }+ = viewState+        { viewStateViewPort     +                = port { viewPortScale = viewPortScale port / scaleStep } }+++-- | Offset a viewport.+motionBump :: ViewPort -> (Float, Float) -> ViewPort+motionBump+        port@ViewPort   +        { viewPortTranslate     = trans+        , viewPortScale         = scale+        , viewPortRotate        = r }+        (bumpX, bumpY)+ = port { viewPortTranslate = trans - o }+ where  offset  = (bumpX / scale, bumpY / scale)+        o       = rotateV (degToRad r) offset+++-- | Apply a translation to the `ViewState`.+motionTranslate +        :: Maybe (Float, Float) +        -> (Float, Float) +        -> ViewState -> Maybe ViewState++motionTranslate Nothing _ _ = Nothing+motionTranslate (Just (markX, markY)) (posX, posY) viewState+ = Just $ viewState+        { viewStateViewPort      = port { viewPortTranslate = trans - o }+        , viewStateTranslateMark = Just (posX, posY) }++ where  port    = viewStateViewPort viewState+        trans   = viewPortTranslate port+        scale   = viewPortScale port+        r       = viewPortRotate port+        dX      = markX - posX+        dY      = markY - posY+        offset  = (dX / scale, dY / scale)+        o       = rotateV (degToRad r) offset+++-- | Apply a rotation to the `ViewState`.+motionRotate +        :: Maybe (Float, Float) +        -> (Float, Float) +        -> ViewState -> Maybe ViewState++motionRotate Nothing _ _ = Nothing+motionRotate (Just (markX, _markY)) (posX, posY) viewState+ = Just $ viewState+        { viewStateViewPort     +                = port { viewPortRotate = rotate - rotateFactor * (posX - markX) }++        , viewStateRotateMark   = Just (posX, posY) }+ where  port            = viewStateViewPort viewState+        rotate          = viewPortRotate port+        rotateFactor    = viewStateRotateFactor viewState+

@@ -21,12 +21,6 @@ -- | Normalise an angle to be between 0 and 2*pi radians {-# INLINE normaliseAngle #-} normaliseAngle :: Float -> Float-normaliseAngle f-	| f < 0	-	= normaliseAngle (f + 2 * pi)-	-	| f > 2 * pi-	= normaliseAngle (f - 2 * pi)--	| otherwise-	= f+normaliseAngle f = f - 2 * pi * (fromIntegral . floor') (f / (2 * pi))+ where  floor' :: Float -> Int+        floor' x = fromIntegral (floor x :: Int)

@@ -16,7 +16,7 @@ import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color-import Graphics.Gloss.Internals.Interface.ViewPort+import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Simulate import Graphics.Gloss.Internals.Interface.Backend 

@@ -16,7 +16,7 @@ import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color-import Graphics.Gloss.Internals.Interface.ViewPort+import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Simulate import Graphics.Gloss.Internals.Interface.Backend 

@@ -4,21 +4,21 @@ where	 import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.ViewState+import Graphics.Gloss.Internals.Render.Common 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 Graphics.Gloss.Internals.Interface.ViewState.KeyMouse+import Graphics.Gloss.Internals.Interface.ViewState.Motion+import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing 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 Data.IORef+import Data.Functor ((<$>)) import Control.Monad import System.Mem import GHC.Float (double2Float)@@ -36,8 +36,7 @@ animateWithBackendIO backend pannable display backColor frameOp  = do	         -- -	viewSR		<- newIORef viewPortInit-	viewControlSR	<- newIORef VPC.stateInit+	viewSR		<- newIORef viewStateInit 	animateSR	<- newIORef AN.stateInit         renderS_        <- RS.stateInit 	renderSR	<- newIORef renderS_@@ -50,13 +49,12 @@ 		picture		<- frameOp (double2Float timeS)  		renderS		<- readIORef renderSR-		viewS		<- readIORef viewSR+		portS		<- viewStateViewPort <$> readIORef viewSR  		-- render the frame-		withViewPort+		renderAction 			backendRef-			viewS-			(renderPicture backendRef renderS viewS picture)+			(renderPicture backendRef renderS portS picture)  		-- perform GC every frame to try and avoid long pauses 		performGC@@ -67,11 +65,11 @@ 		, Callback.Display	(animateEnd   animateSR) 		, Callback.Idle		(\s -> postRedisplay s) 		, callback_exit () -		, callback_viewPort_motion   viewSR viewControlSR -		, callback_viewPort_reshape ]+		, callback_viewState_motion viewSR+		, callback_viewState_reshape ]                ++ (if pannable -                  then [callback_viewPort_keyMouse viewSR viewControlSR]+                  then [callback_viewState_keyMouse viewSR]                   else [])          createWindow backend display backColor callbacks

@@ -4,20 +4,20 @@ where	 import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.ViewState+import Graphics.Gloss.Internals.Render.Common 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 Graphics.Gloss.Internals.Interface.ViewState.KeyMouse+import Graphics.Gloss.Internals.Interface.ViewState.Motion+import Graphics.Gloss.Internals.Interface.ViewState.Reshape 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 Data.Functor   displayWithBackend@@ -29,19 +29,17 @@ 	-> IO ()  displayWithBackend backend displayMode background picture- =  do	viewSR		<- newIORef viewPortInit-	viewControlSR	<- newIORef VPC.stateInit+ =  do	viewSR		<- newIORef viewStateInit          renderS         <- RS.stateInit 	renderSR	<- newIORef renderS 	 	let renderFun backendRef = do-		view	<- readIORef viewSR+		port    <- viewStateViewPort <$> readIORef viewSR 		options	<- readIORef renderSR-	 	withViewPort+	 	renderAction 			backendRef-	 		view-			(renderPicture backendRef options view picture)+			(renderPicture backendRef options port picture)  	let callbacks 	     =	[ Callback.Display renderFun @@ -50,8 +48,8 @@ 		, callback_exit ()  		 		-- Viewport control with mouse-		, callback_viewPort_keyMouse viewSR viewControlSR -		, callback_viewPort_motion   viewSR viewControlSR -		, callback_viewPort_reshape ]+		, callback_viewState_keyMouse viewSR+		, callback_viewState_motion   viewSR+		, callback_viewState_reshape ]  	createWindow backend displayMode background callbacks

@@ -0,0 +1,52 @@+{-# LANGUAGE RankNTypes #-}+module Graphics.Gloss.Internals.Interface.Event+        ( Event (..)+	, keyMouseEvent+	, motionEvent )+where+import Data.IORef+import Data.Functor ((<$>))+import Graphics.Gloss.Internals.Interface.Backend++-- | Possible input events.+data Event+	= EventKey    Key KeyState Modifiers (Float, Float)+	| EventMotion (Float, Float)+	deriving (Eq, Show)++keyMouseEvent ::+	forall a . Backend a+	=> IORef a+	-> Key+	-> KeyState+	-> Modifiers+	-> (Int, Int)+	-> IO Event+keyMouseEvent backendRef key keyState modifiers pos+	= EventKey key keyState modifiers <$> convertPoint backendRef pos++motionEvent ::+	forall a . Backend a+	=> IORef a+	-> (Int, Int)+	-> IO Event+motionEvent backendRef pos+	= EventMotion <$> convertPoint backendRef pos++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 (px_, py_)		= pos+	let px			= fromIntegral px_+	let py			= sizeY - fromIntegral py_+	+	let px'			= px - sizeX / 2+	let py' 		= py - sizeY / 2+	let pos'		= (px', py')+	return pos'

@@ -2,17 +2,18 @@  module Graphics.Gloss.Internals.Interface.Game 	( playWithBackendIO-	, Event(..))+	, Event(..) ) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.ViewPort+import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Internals.Render.Picture-import Graphics.Gloss.Internals.Render.ViewPort+import Graphics.Gloss.Internals.Interface.Event 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.Reshape+import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle import qualified Graphics.Gloss.Internals.Interface.Callback		as Callback@@ -22,13 +23,6 @@ import Data.IORef import System.Mem --- | Possible input events.-data Event-	= EventKey    Key KeyState Modifiers (Float, Float)-	| EventMotion (Float, Float)-	deriving (Eq, Show)-- playWithBackendIO 	:: forall world a 	.  Backend a@@ -78,9 +72,8 @@ 		viewS		<- readIORef viewSR  		-- render the frame-		withViewPort+		renderAction 			backendRef-			viewS 	 	 	(renderPicture backendRef renderS viewS picture)   		-- perform garbage collection@@ -91,13 +84,13 @@ 		, Callback.Display 	displayFun 		, Callback.Display	(animateEnd   animateSR) 		, Callback.Idle		(callback_simulate_idle -						stateSR animateSR viewSR +						stateSR animateSR (readIORef viewSR) 						worldSR worldStart (\_ -> worldAdvance) 						singleStepTime) 		, callback_exit ()  		, callback_keyMouse worldSR viewSR worldHandleEvent 		, callback_motion   worldSR worldHandleEvent-		, callback_viewPort_reshape ]+		, callback_viewState_reshape ]  	createWindow backend display backgroundColor callbacks @@ -120,9 +113,9 @@ 	-> KeyboardMouseCallback  handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos- = do	pos'       <- convertPoint backendRef pos+ = do	ev         <- keyMouseEvent backendRef key keyState keyMods pos         world      <- readIORef worldRef-        world'     <- eventFn (EventKey key keyState keyMods pos') world+        world'     <- eventFn ev world         writeIORef worldRef world'  @@ -142,27 +135,7 @@ 	-> MotionCallback  handle_motion worldRef eventFn backendRef pos- = do   pos'     <- convertPoint backendRef pos+ = do   ev       <- motionEvent backendRef pos         world    <- readIORef worldRef-        world'   <- eventFn (EventMotion pos') world+        world'   <- eventFn ev world         writeIORef worldRef world'---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 (px_, py_)	= pos-	let px		= fromIntegral px_-	let py		= sizeY - fromIntegral py_-	-	let px'		= px - sizeX / 2-	let py' 	= py - sizeY / 2-	let pos'	= (px', py')-	return pos'-

@@ -6,22 +6,22 @@ import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture+import Graphics.Gloss.Data.ViewState+import Graphics.Gloss.Internals.Render.Common 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 Graphics.Gloss.Internals.Interface.ViewState.KeyMouse+import Graphics.Gloss.Internals.Interface.ViewState.Motion+import Graphics.Gloss.Internals.Interface.ViewState.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.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.State	        		as RS+import Data.Functor ((<$>)) import Data.IORef import System.Mem @@ -58,8 +58,7 @@ 	worldSR		<- newIORef worldStart  	-- make the initial GL view and render states-	viewSR		<- newIORef viewPortInit-	viewControlSR	<- newIORef VPC.stateInit+	viewSR		<- newIORef viewStateInit 	animateSR	<- newIORef AN.stateInit         renderS_        <- RS.stateInit 	renderSR	<- newIORef renderS_@@ -68,17 +67,16 @@ 	     = do 		-- convert the world to a picture 		world		<- readIORef worldSR+		port		<- viewStateViewPort <$> readIORef viewSR 		picture	        <- worldToPicture world-	+ 		-- display the picture in the current view 		renderS		<- readIORef renderSR-		viewS		<- readIORef viewSR  		-- render the frame-		withViewPort +		renderAction 			backendRef-			viewS-	 	 	(renderPicture backendRef renderS viewS picture)+	 	 	(renderPicture backendRef renderS port picture)   		-- perform garbage collection 		performGC@@ -88,12 +86,13 @@ 		, Callback.Display 	displayFun 		, Callback.Display	(animateEnd   animateSR) 		, Callback.Idle		(callback_simulate_idle -						stateSR animateSR viewSR +						stateSR animateSR+						(viewStateViewPort <$> readIORef viewSR) 						worldSR worldStart worldAdvance 						singleStepTime) 		, callback_exit () -		, callback_viewPort_keyMouse viewSR viewControlSR -		, callback_viewPort_motion   viewSR viewControlSR -		, callback_viewPort_reshape ]+		, callback_viewState_keyMouse viewSR+		, callback_viewState_motion   viewSR+		, callback_viewState_reshape ]  	createWindow backend display backgroundColor callbacks

@@ -4,7 +4,7 @@ module Graphics.Gloss.Internals.Interface.Simulate.Idle 	( callback_simulate_idle ) where-import Graphics.Gloss.Internals.Interface.ViewPort+import Graphics.Gloss.Data.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@@ -19,7 +19,10 @@ callback_simulate_idle 	:: IORef SM.State				-- ^ the simulation state 	-> IORef AN.State				-- ^ the animation statea-	-> IORef ViewPort				-- ^ the viewport state+	-> IO ViewPort+        -- ^ action to get the 'ViewPort'.  We don't use an 'IORef'+        -- directly because sometimes we hold a ref to a 'ViewPort' (in+        -- Game) and sometimes a ref to a 'ViewState'. 	-> IORef world					-- ^ the current world 	-> world					-- ^ the initial world 	-> (ViewPort -> Float -> world -> IO world) 	-- ^ fn to advance the world@@ -27,7 +30,7 @@ 							--	in single step mode 	-> IdleCallback 	-callback_simulate_idle simSR animateSR viewSR worldSR worldStart worldAdvance singleStepTime backendRef+callback_simulate_idle simSR animateSR viewSA worldSR worldStart worldAdvance singleStepTime backendRef  = {-# SCC "callbackIdle" #-}    do	simS		<- readIORef simSR 	let result@@ -35,10 +38,10 @@ 		= simulate_reset simSR worldSR worldStart  		| SM.stateRun   simS-		= simulate_run   simSR animateSR viewSR worldSR worldAdvance+		= simulate_run   simSR animateSR viewSA worldSR worldAdvance 		 		| SM.stateStep  simS-		= simulate_step  simSR viewSR worldSR worldAdvance singleStepTime+		= simulate_step  simSR viewSA worldSR worldAdvance singleStepTime 		 		| otherwise 		= \_ -> return ()@@ -63,15 +66,14 @@ simulate_run  	:: IORef SM.State 	-> IORef AN.State-	-> IORef ViewPort+	-> IO ViewPort 	-> IORef world 	-> (ViewPort -> Float -> world -> IO world) 	-> IdleCallback 	-simulate_run simSR _ viewSR worldSR worldAdvance backendRef- = do	+simulate_run simSR _ viewSA worldSR worldAdvance backendRef+ = do	viewS		<- viewSA 	simS		<- readIORef simSR-	viewS		<- readIORef viewSR 	worldS		<- readIORef worldSR  	-- get the elapsed time since the start simulation (wall clock)@@ -125,15 +127,14 @@ -- take a single step simulate_step  	:: IORef SM.State-	-> IORef ViewPort+	-> IO ViewPort 	-> IORef world 	-> (ViewPort -> Float -> world -> IO world)  	-> Float 	-> IdleCallback -simulate_step simSR viewSR worldSR worldAdvance singleStepTime backendRef- = do-	viewS		<- readIORef viewSR+simulate_step simSR viewSA worldSR worldAdvance singleStepTime backendRef+ = do	viewS		<- viewSA  	world		<- readIORef worldSR 	world'		<- worldAdvance viewS singleStepTime world 	

@@ -1,29 +0,0 @@---- | The 'ViewPort' represents the global transformation applied to the displayed picture.---	When the user pans, zooms, or rotates the display then this changes the 'ViewPort'.-module Graphics.Gloss.Internals.Interface.ViewPort-	( ViewPort(..)-	, viewPortInit )-where-	-data ViewPort-	= ViewPort { -	-- | Global translation.-	  viewPortTranslate	:: !(Float, Float)--	-- | Global rotation (in degrees).-	, viewPortRotate	:: !Float		--	-- | Global scaling (of both x and y coordinates).-	, viewPortScale		:: !Float		-	}-	-	--- | The initial state of the viewport.-viewPortInit :: ViewPort-viewPortInit-	= ViewPort-	{ viewPortTranslate	= (0, 0) -	, viewPortRotate	= 0-	, viewPortScale		= 1 -	}

@@ -1,101 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# OPTIONS -fno-warn-missing-signatures #-}-{-# LANGUAGE PatternGuards #-}--module Graphics.Gloss.Internals.Interface.ViewPort.Command-	( Command (..)-	, defaultCommandConfig-	, isCommand )-where-import Graphics.Gloss.Internals.Interface.Backend-import qualified Data.Map			as Map---- | The commands suported by the view controller-data Command-	= CRestore--	| CTranslate-	| CRotate--	-- bump zoom-	| CBumpZoomOut-	| CBumpZoomIn--	-- bump translate-	| CBumpLeft-	| CBumpRight-	| CBumpUp-	| CBumpDown--	-- bump rotate-	| CBumpClockwise-	| CBumpCClockwise-	deriving (Show, Eq, Ord)----- | The default commands-defaultCommandConfig- =	[ (CRestore, 	-		[ (Char 'r', 			Nothing) ])--	, (CTranslate,-		[ ( MouseButton LeftButton-		  , Just (Modifiers { shift = Up, ctrl = Up, alt = Up }))-		])-	-	, (CRotate,-		[ ( MouseButton RightButton-		  , Nothing)-		, ( MouseButton LeftButton-		  , Just (Modifiers { shift = Up, ctrl = Down, alt = Up }))-	 	])-	-	-- bump zoom-	, (CBumpZoomOut,	-		[ (MouseButton WheelDown,	Nothing)-		, (SpecialKey  KeyPageDown,	Nothing) ])--	, (CBumpZoomIn,-		[ (MouseButton WheelUp, 	Nothing)-		, (SpecialKey  KeyPageUp,	Nothing)] )-	-	-- bump translate-	, (CBumpLeft,-		[ (SpecialKey  KeyLeft,	        Nothing) ])--	, (CBumpRight,-		[ (SpecialKey  KeyRight,	Nothing) ])--	, (CBumpUp,-		[ (SpecialKey  KeyUp,		Nothing) ])--	, (CBumpDown,-		[ (SpecialKey  KeyDown,	        Nothing) ])--	-- bump rotate-	, (CBumpClockwise,-		[ (SpecialKey  KeyHome,	        Nothing) ])-	-	, (CBumpCClockwise,-		[ (SpecialKey  KeyEnd,	        Nothing) ])--	]---isCommand commands c key keyMods-	| Just csMatch		<- Map.lookup c commands-	= or $ map (isCommand2 c key keyMods) csMatch --	| otherwise-	= False--isCommand2 _ key keyMods cMatch-	| (keyC, mModsC)	<- cMatch-	, keyC == key-	, case mModsC of-		Nothing		-> True-		Just modsC 	-> modsC == keyMods-	= True-	-	| otherwise-	= False

@@ -1,46 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Graphics.Gloss.Internals.Interface.ViewPort.ControlState-	( State (..)-	, stateInit )-where-import Graphics.Gloss.Internals.Interface.ViewPort.Command-import Graphics.Gloss.Internals.Interface.Backend-import qualified Data.Map			as Map-import Data.Map					(Map)---- ViewControl State --------------------------------------------------------------------------------- | State for controlling the viewport.---	These are used by the viewport control component.-data State-	= State {-	-- | 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 [(Key, Maybe Modifiers)])--	-- | How much to scale the world by for each step of the mouse wheel.-	, stateScaleStep	:: !Float	-							-	-- | How many degrees to rotate the world by for each pixel of x motion.-	, stateRotateFactor	:: !Float--	-- | During viewport translation,-	--	where the mouse was clicked on the window.-	, stateTranslateMark	:: !(Maybe (Int, Int))--	-- | During viewport rotation,	-	--	where the mouse was clicked on the window-	, stateRotateMark	:: !(Maybe (Int, Int))-	}----- | The initial view state.-stateInit :: State-stateInit-	= State-	{ stateCommands		= Map.fromList defaultCommandConfig-	, stateScaleStep	= 0.85-	, stateRotateFactor	= 0.6-	, stateTranslateMark	= Nothing-	, stateRotateMark	= Nothing }

@@ -1,208 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE PatternGuards, RankNTypes #-}--module Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse-	(callback_viewPort_keyMouse)-where-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Internals.Interface.ViewPort-import Graphics.Gloss.Internals.Interface.ViewPort.Command-import Graphics.Gloss.Internals.Interface.Backend-import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState	as VPC-import Control.Monad-import Data.IORef-import Data.Maybe----- | Callback to handle keyboard and mouse button events---	for controlling the viewport.-callback_viewPort_keyMouse -	:: IORef ViewPort 	-- ^ ref to ViewPort state-	-> IORef VPC.State 	-- ^ ref to ViewPort Control state-	-> Callback--callback_viewPort_keyMouse portRef controlRef - 	= KeyMouse (viewPort_keyMouse portRef controlRef)---viewPort_keyMouse-	:: IORef ViewPort-	-> IORef VPC.State-	-> KeyboardMouseCallback--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"--}-        -- 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 currentlyTranslating currentlyRotating commands-	-- restore viewport-	| isCommand commands CRestore key keyMods-	, keyState	== Down-	= do	portRef `modifyIORef` \s -> s -			{ viewPortScale		= 1-			, viewPortTranslate	= (0, 0) -			, viewPortRotate	= 0 }-		postRedisplay stateRef--	-- zoom -----------------------------------------	-- zoom out-	| isCommand commands CBumpZoomOut key keyMods-	, keyState	== Down-	= do	controlZoomOut portRef controlRef-	        postRedisplay stateRef--	-- zoom in-	| isCommand commands CBumpZoomIn key keyMods-	, keyState	== Down-	= do	controlZoomIn portRef controlRef -	        postRedisplay stateRef-	-	-- bump --------------------------------------	-- bump left-	| isCommand commands CBumpLeft key keyMods-	, keyState	== Down-	= do	motionBump portRef (20, 0)-	        postRedisplay stateRef--	-- bump right-	| isCommand commands CBumpRight key keyMods-	, keyState	== Down-	= do	motionBump portRef (-20, 0)-	        postRedisplay stateRef--	-- bump up-	| isCommand commands CBumpUp key keyMods-	, keyState	== Down-	= do    motionBump portRef (0, 20)-	        postRedisplay stateRef--	-- bump down-	| isCommand commands CBumpDown key keyMods-	, keyState	== Down-	= do    motionBump portRef (0, -20)-	        postRedisplay stateRef--	-- bump clockwise-	| isCommand commands CBumpClockwise key keyMods-	, keyState	== Down-	= do	portRef `modifyIORef` \s -> s {-			viewPortRotate-				= (\r -> r + 5)-				$ viewPortRotate s }-		postRedisplay stateRef--	-- bump anti-clockwise-	| isCommand commands CBumpCClockwise key keyMods-	, keyState	== Down-	= do	portRef `modifyIORef` \s -> s {-			viewPortRotate-				= (\r -> r - 5)-				$ viewPortRotate s }-		postRedisplay stateRef-		-	-- translation ---------------------------------------	-- start-	| isCommand commands CTranslate key keyMods-	, keyState	== Down-	, not currentlyRotating-	= do	let (posX, posY)	= pos-		controlRef `modifyIORef` \s -> s { -			VPC.stateTranslateMark -		 		= Just (  posX-				  	, posY) }-		postRedisplay stateRef--	-- end-	-- 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 }-		postRedisplay stateRef--	-- rotation  ----------------------------------------	-- start-	| isCommand commands CRotate key keyMods-	, keyState	== Down-	, not currentlyTranslating-	= do	let (posX, posY)	= pos-		controlRef `modifyIORef` \s -> s { -			VPC.stateRotateMark -		 		= Just (  posX-				  	, posY) }-		postRedisplay stateRef--	-- end-	-- 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 }-		postRedisplay stateRef--	-- carry on-	| otherwise-	= return ()---controlZoomIn :: IORef ViewPort -> IORef VPC.State -> IO ()-controlZoomIn portRef controlRef- = do	scaleStep	<- controlRef `getsIORef` VPC.stateScaleStep-	portRef `modifyIORef` \s -> s { -	 	viewPortScale = viewPortScale s * scaleStep }---controlZoomOut :: IORef ViewPort -> IORef VPC.State -> IO ()-controlZoomOut portRef controlRef- = do	scaleStep	<- controlRef `getsIORef` VPC.stateScaleStep -	portRef `modifyIORef` \s -> s {-	 	viewPortScale = viewPortScale s / scaleStep }---motionBump :: IORef ViewPort -> (Float, Float) -> IO ()-motionBump-	portRef-	(bumpX, bumpY)- = do-	(transX, transY)-		<- portRef `getsIORef` viewPortTranslate--	scale	<- portRef `getsIORef` viewPortScale-	r	<- portRef `getsIORef` viewPortRotate--	let offset	= (bumpX / scale, bumpY / scale)--	let (oX, oY)	= rotateV (degToRad r) offset--	portRef `modifyIORef` \s -> s -		{ viewPortTranslate	-		   = 	( transX - oX-		 	, transY + oY) }-- -getsIORef :: IORef a -> (a -> r) -> IO r-getsIORef ref fun- = liftM fun $ readIORef ref

@@ -1,126 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}--module Graphics.Gloss.Internals.Interface.ViewPort.Motion-	(callback_viewPort_motion)-where-import Graphics.Gloss.Data.Vector-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.Rendering.OpenGL.GL					as GL-import Control.Monad	-import Data.IORef----- | Callback to handle keyboard and mouse button events---	for controlling the viewport.-callback_viewPort_motion -	:: IORef ViewPort 	-- ^ ref to ViewPort state-	-> IORef VPC.State 	-- ^ ref to ViewPort Control state-	-> Callback--callback_viewPort_motion portRef controlRef - 	= Motion (viewPort_motion portRef controlRef)--viewPort_motion-	:: IORef ViewPort-	-> IORef VPC.State-	-> MotionCallback-	-viewPort_motion-	portRef controlRef-	stateRef-	pos- = do---	putStr $ "motion pos = " ++ show pos ++ "\n"--	translateMark	<- controlRef `getsIORef` VPC.stateTranslateMark-	rotateMark	<- controlRef `getsIORef` VPC.stateRotateMark--	(case translateMark of-	 Nothing		-> return ()-	 Just (markX, markY)	-	  -> do-		motionTranslate-	  	  portRef controlRef-		  (fromIntegral markX, fromIntegral markY)-		  pos -		postRedisplay stateRef)---	(case rotateMark of-	 Nothing		-> return ()-	 Just (markX, markY)-	  -> do-		motionRotate-	  	  portRef controlRef-		  (fromIntegral markX, fromIntegral markY)-		  pos -		postRedisplay stateRef)---motionTranslate-	:: IORef ViewPort-        -> IORef VPC.State-        -> (GL.GLint, GL.GLint)-        -> (Int, Int)-	-> IO ()- -motionTranslate -	portRef controlRef-	(markX :: GL.GLint, markY :: GL.GLint)-	(posX, posY)- = do-	(transX, transY)-		<- portRef `getsIORef` viewPortTranslate--	scale	<- portRef `getsIORef` viewPortScale-	r	<- portRef `getsIORef` viewPortRotate--	let dX		= fromIntegral $ markX - (fromIntegral posX)-	let dY		= fromIntegral $ markY - (fromIntegral posY)--	let offset	= (dX / scale, dY / scale)--	let (oX, oY)	= rotateV (degToRad r) offset--	portRef `modifyIORef` \s -> s -		{ viewPortTranslate	-		   = 	( transX - oX-		 	, transY + oY) }-		-	controlRef `modifyIORef` \s -> s-		{ VPC.stateTranslateMark-		   =	Just (fromIntegral posX, fromIntegral posY) }---motionRotate-	:: IORef ViewPort-	-> IORef VPC.State-	-> (GL.GLint, GL.GLint)-	-> (Int, Int)-	-> IO ()--motionRotate -	portRef controlRef-	(markX :: GL.GLint, _markY :: GL.GLint)-	(posX, posY)- = do- 	rotate		<- portRef    `getsIORef` viewPortRotate-	rotateFactor	<- controlRef `getsIORef` VPC.stateRotateFactor-	-	portRef `modifyIORef` \s -> s -		{ viewPortRotate-		   = 	rotate + rotateFactor * fromIntegral ((fromIntegral posX) - markX) }-		-	controlRef `modifyIORef` \s -> s-		{ VPC.stateRotateMark-		   = 	Just (fromIntegral posX, fromIntegral posY) }---getsIORef :: IORef a -> (a -> r) -> IO r-getsIORef ref fun- = liftM fun $ readIORef ref

@@ -1,28 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Graphics.Gloss.Internals.Interface.ViewPort.Reshape-	(callback_viewPort_reshape)-where-import Graphics.Gloss.Internals.Interface.Callback-import Graphics.Gloss.Internals.Interface.Backend-import Graphics.Rendering.OpenGL			(($=))-import qualified Graphics.Rendering.OpenGL.GL		as GL----- | Callback to handle keyboard and mouse button events---	for controlling the viewport.-callback_viewPort_reshape :: Callback-callback_viewPort_reshape- 	= Reshape (viewPort_reshape)---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-                           , GL.Size (fromIntegral width) (fromIntegral height))-	postRedisplay stateRef

@@ -0,0 +1,32 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RankNTypes #-}++module Graphics.Gloss.Internals.Interface.ViewState.KeyMouse+	(callback_viewState_keyMouse)+where+import Graphics.Gloss.Data.ViewState+import Graphics.Gloss.Internals.Interface.Backend+import Graphics.Gloss.Internals.Interface.Event+import Data.IORef+++-- | Callback to handle keyboard and mouse button events+--	for controlling the 'ViewState'.+callback_viewState_keyMouse +	:: IORef ViewState+	-> Callback++callback_viewState_keyMouse viewStateRef+ 	= KeyMouse (viewState_keyMouse viewStateRef)+++viewState_keyMouse :: IORef ViewState -> KeyboardMouseCallback+viewState_keyMouse viewStateRef stateRef key keyState keyMods pos+ = do	viewState <- readIORef viewStateRef+	ev	  <- keyMouseEvent stateRef key keyState keyMods pos+        case updateViewStateWithEventMaybe ev viewState of+		Nothing -> return ()+		Just viewState' +                 -> do	viewStateRef `writeIORef` viewState'+			postRedisplay stateRef+

@@ -0,0 +1,34 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}++module Graphics.Gloss.Internals.Interface.ViewState.Motion+	(callback_viewState_motion)+where+import Graphics.Gloss.Data.ViewState+import Graphics.Gloss.Internals.Interface.Callback+import Graphics.Gloss.Internals.Interface.Backend+import Graphics.Gloss.Internals.Interface.Event+import Data.IORef+++-- | Callback to handle keyboard and mouse button events+--	for controlling the viewport.+callback_viewState_motion +	:: IORef ViewState+	-> Callback++callback_viewState_motion portRef+ 	= Motion (viewState_motion portRef)+++viewState_motion :: IORef ViewState -> MotionCallback+viewState_motion viewStateRef stateRef pos+ = do	viewState <- readIORef viewStateRef+	ev        <- motionEvent stateRef pos+        case updateViewStateWithEventMaybe ev viewState of+		Nothing -> return ()+		Just viewState' +                 -> do	viewStateRef `writeIORef` viewState'+			postRedisplay stateRef++

@@ -0,0 +1,28 @@+{-# OPTIONS_HADDOCK hide #-}++module Graphics.Gloss.Internals.Interface.ViewState.Reshape+	(callback_viewState_reshape)+where+import Graphics.Gloss.Internals.Interface.Callback+import Graphics.Gloss.Internals.Interface.Backend+import Graphics.Rendering.OpenGL			(($=))+import qualified Graphics.Rendering.OpenGL.GL		as GL+++-- | Callback to handle keyboard and mouse button events+--	for controlling the viewport.+callback_viewState_reshape :: Callback+callback_viewState_reshape+ 	= Reshape (viewState_reshape)+++viewState_reshape :: ReshapeCallback+viewState_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+                           , GL.Size (fromIntegral width) (fromIntegral height))+	postRedisplay stateRef

@@ -1,8 +1,11 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Render.Common where +import Graphics.Gloss.Internals.Interface.Backend+import	Graphics.Rendering.OpenGL					(($=)) import qualified Graphics.Rendering.OpenGL.GL	as GL import Unsafe.Coerce+import Data.IORef  -- | The OpenGL library doesn't seem to provide a nice way convert --	a Float to a GLfloat, even though they're the same thing@@ -19,3 +22,30 @@ gsizei :: Int -> GL.GLsizei {-# INLINE gsizei #-} gsizei x = unsafeCoerce x++-- | Perform a rendering action setting up the coords first+renderAction+	:: Backend a+	=> IORef a+	-> IO ()+	-> IO ()++renderAction backendRef action+ = do+ 	GL.matrixMode	$= GL.Projection+	GL.preservingMatrix+	 $ do+		-- setup the co-ordinate system+	 	GL.loadIdentity+		(sizeX, sizeY) 	<- getWindowDimensions backendRef+		let (sx, sy)	= (fromIntegral sizeX / 2, fromIntegral sizeY / 2)++		GL.ortho (-sx) sx (-sy) sy 0 (-100)+	+		-- draw the world+		GL.matrixMode 	$= GL.Modelview 0+		action++		GL.matrixMode	$= GL.Projection+	+	GL.matrixMode	$= GL.Modelview 0

@@ -7,8 +7,8 @@ where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Backend-import Graphics.Gloss.Internals.Interface.ViewPort import Graphics.Gloss.Internals.Render.State import Graphics.Gloss.Internals.Render.Common import Graphics.Gloss.Internals.Render.Circle@@ -58,8 +58,10 @@ 	setLineSmooth	(stateLineSmooth renderS) 	setBlendAlpha	(stateBlendAlpha renderS) 	+	-- Adjust the picture+	let picture'		= applyViewPortToPicture viewS picture         checkErrors "before drawPicture."-        drawPicture (viewPortScale viewS) picture+        drawPicture (viewPortScale viewS) picture'         checkErrors "after drawPicture."  

@@ -1,55 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-{-# 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	qualified Graphics.Rendering.OpenGL.GL				as GL--import	Data.IORef							(IORef)---- | Perform a rendering action whilst using the given viewport-withViewPort-	:: forall a . Backend a-	=> IORef a-	-> ViewPort 		-- ^ The viewport to use.-	-> IO () 		-- ^ The rendering action to perform.-	-> IO ()--withViewPort backendRef port action- = do- 	GL.matrixMode	$= GL.Projection-	GL.preservingMatrix-	 $ do-		-- setup the co-ordinate system-	 	GL.loadIdentity-		(sizeX, sizeY) 	<- getWindowDimensions backendRef-		let (sx, sy)	= (fromIntegral sizeX / 2, fromIntegral sizeY / 2)--		GL.ortho (-sx) sx (-sy) sy 0 (-100)-	-		-- draw the world-		GL.matrixMode 	$= GL.Modelview 0-		GL.preservingMatrix-		 $ do-			GL.loadIdentity-			let rotate :: GLfloat	= realToFrac $ viewPortRotate port-			let transX :: GLfloat	= realToFrac $ fst $ viewPortTranslate port-			let transY :: GLfloat   = realToFrac $ snd $ viewPortTranslate port-		 	let scale  :: GLfloat	= realToFrac $ viewPortScale port--			-- apply the global view transforms-			GL.scale     scale  scale  1-			GL.rotate    rotate (GL.Vector3 0 0 1)-			GL.translate (GL.Vector3 transX transY 0)--			-- call the client render action-			action --		GL.matrixMode	$= GL.Projection-	-	GL.matrixMode	$= GL.Modelview 0

@@ -1,4 +1,4 @@-Copyright (c) 2010-2012 Benjamin Lippmeier +Copyright (c) 2010-2013 Benjamin Lippmeier    Permission is hereby granted, free of charge, to any person  obtaining a copy of this software and associated documentation

@@ -1,5 +1,5 @@ Name:                gloss-Version:             1.7.8.4+Version:             1.8.0.1 License:             MIT License-file:        LICENSE Author:              Ben Lippmeier@@ -57,6 +57,8 @@         Graphics.Gloss.Data.QuadTree         Graphics.Gloss.Data.Color         Graphics.Gloss.Data.Picture+        Graphics.Gloss.Data.ViewPort+        Graphics.Gloss.Data.ViewState         Graphics.Gloss.Algorithms.RayCast         Graphics.Gloss.Interface.Pure.Display         Graphics.Gloss.Interface.Pure.Animate@@ -74,21 +76,18 @@         Graphics.Gloss.Internals.Interface.Callback         Graphics.Gloss.Internals.Interface.Common.Exit         Graphics.Gloss.Internals.Interface.Debug+        Graphics.Gloss.Internals.Interface.Event         Graphics.Gloss.Internals.Interface.Simulate.Idle         Graphics.Gloss.Internals.Interface.Simulate.State-        Graphics.Gloss.Internals.Interface.ViewPort-        Graphics.Gloss.Internals.Interface.ViewPort.Command-        Graphics.Gloss.Internals.Interface.ViewPort.ControlState-        Graphics.Gloss.Internals.Interface.ViewPort.KeyMouse-        Graphics.Gloss.Internals.Interface.ViewPort.Motion-        Graphics.Gloss.Internals.Interface.ViewPort.Reshape+        Graphics.Gloss.Internals.Interface.ViewState.KeyMouse+        Graphics.Gloss.Internals.Interface.ViewState.Motion+        Graphics.Gloss.Internals.Interface.ViewState.Reshape         Graphics.Gloss.Internals.Interface.Window         Graphics.Gloss.Internals.Render.Bitmap         Graphics.Gloss.Internals.Render.Circle         Graphics.Gloss.Internals.Render.Common         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@@ -98,6 +97,7 @@    Extensions:         DeriveDataTypeable+        PatternGuards    If flag(GLUT)     CPP-Options: -DWITHGLUT