    module Graphics.Gloss.Data.ViewState
            ( Command      (..)
            , CommandConfig
            , defaultCommandConfig
            , ViewState     (..)
            , viewStateInit
            , viewStateInitWithConfig
            , updateViewStateWithEvent
            , updateViewStateWithEventMaybe)
    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
            | CScale

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

            , (CScale,
                    [ ( MouseButton LeftButton
                      , Just (Modifiers { shift = Up, ctrl = Down, alt = Up }))

                    , ( MouseButton RightButton
                      , Just (Modifiers { shift = Up, ctrl = Up,   alt = Up }))
                    ])

            , (CRotate,
                    [ ( MouseButton LeftButton
                      , Just (Modifiers { shift = Up, ctrl = Up,   alt = Down }))

                    , ( MouseButton RightButton
                      , 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

            -- | Ratio to scale the world by for each pixel of y motion.
            , viewStateScaleFactor          :: !Float

            -- | During viewport translation,
            --      where the mouse was clicked on the window to start the translate.
            , viewStateTranslateMark        :: !(Maybe (Float, Float))

            -- | During viewport rotation,
            --      where the mouse was clicked on the window to starte the rotate.
            , viewStateRotateMark           :: !(Maybe (Float, Float))

            -- | During viewport scale,
            --      where the mouse was clicked on the window to start the scale.
            , viewStateScaleMark            :: !(Maybe (Float, Float))

            -- | The current viewport.
            , 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
            , viewStateScaleFactor          = 0.01
            , viewStateTranslateMark        = Nothing
            , viewStateRotateMark           = Nothing
            , viewStateScaleMark            = 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 } }

            -- Start Translation.
            | isCommand commands CTranslate key keyMods
            , keyState      == Down
            , not  $ currentlyRotating    || currentlyScaling
            = Just $ viewState { viewStateTranslateMark = Just pos }

            -- Start Rotation.
            | isCommand commands CRotate key keyMods
            , keyState      == Down
            , not  $ currentlyTranslating || currentlyScaling
            = Just $ viewState { viewStateRotateMark = Just pos }

            -- Start Scale.
            | isCommand commands CScale key keyMods
            , keyState      == Down
            , not  $ currentlyTranslating || currentlyRotating
            = Just $ viewState { viewStateScaleMark  = Just pos }

            -- Kill current translate/rotate/scale command when the mouse button
            -- is released.
            | keyState      == Up
            = let   killTranslate vs = vs { viewStateTranslateMark = Nothing }
                    killRotate    vs = vs { viewStateRotateMark    = Nothing }
                    killScale     vs = vs { viewStateScaleMark     = Nothing }
              in  Just
                    $ (if currentlyTranslating then killTranslate else id)
                    $ (if currentlyRotating    then killRotate    else id)
                    $ (if currentlyScaling     then killScale     else id)
                    $ viewState

            | otherwise
            = Nothing
            where   commands                = viewStateCommands viewState
                    port                    = viewStateViewPort viewState
                    currentlyTranslating    = isJust $ viewStateTranslateMark viewState
                    currentlyRotating       = isJust $ viewStateRotateMark    viewState
                    currentlyScaling        = isJust $ viewStateScaleMark     viewState

    -- Note that only a translation or rotation applies, not both at the same time.
    updateViewStateWithEventMaybe (EventMotion pos) viewState
     = motionScale     (viewStateScaleMark     viewState) pos viewState `mplus`
       motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus`
       motionRotate    (viewStateRotateMark    viewState) pos viewState

    updateViewStateWithEventMaybe (EventResize _) _
     = Nothing

    -- | 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)         -- Location of first mark.
            -> (Float, Float)               -- Current position.
            -> 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)         -- Location of first mark.
            -> (Float, Float)               -- Current position.
            -> 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

    -- | Apply a scale to the `ViewState`.
    motionScale
            :: Maybe (Float, Float)         -- Location of first mark.
            -> (Float, Float)               -- Current position.
            -> ViewState -> Maybe ViewState

    motionScale Nothing _ _ = Nothing
    motionScale (Just (_markX, markY)) (posX, posY) viewState
     = Just $ viewState
            { viewStateViewPort
              = let   -- Limit the amount of downward scaling so it maxes
                      -- out at 1 percent of the original. There's not much
                      -- point scaling down to no pixels, or going negative
                      -- so that the image is inverted.
                      ss      = if posY > markY
                                    then scale - scale * (scaleFactor * (posY  - markY))
                                    else scale + scale * (scaleFactor * (markY - posY))

                      ss'     = max 0.01 ss
                in    port { viewPortScale = ss' }

            , viewStateScaleMark    = Just (posX, posY) }
     where  port            = viewStateViewPort viewState
            scale           = viewPortScale port
            scaleFactor     = viewStateScaleFactor viewState