    {-# 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