    {-# LANGUAGE PatternGuards #-}

    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)
    import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt

    -- | 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 (Int -> Command -> ShowS
    [Command] -> ShowS
    Command -> String
    (Int -> Command -> ShowS)
    -> (Command -> String) -> ([Command] -> ShowS) -> Show Command
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [Command] -> ShowS
    $cshowList :: [Command] -> ShowS
    show :: Command -> String
    $cshow :: Command -> String
    showsPrec :: Int -> Command -> ShowS
    $cshowsPrec :: Int -> Command -> ShowS
    Show, Command -> Command -> Bool
    (Command -> Command -> Bool)
    -> (Command -> Command -> Bool) -> Eq Command
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Command -> Command -> Bool
    $c/= :: Command -> Command -> Bool
    == :: Command -> Command -> Bool
    $c== :: Command -> Command -> Bool
    Eq, Eq Command
    Eq Command =>
    (Command -> Command -> Ordering)
    -> (Command -> Command -> Bool)
    -> (Command -> Command -> Bool)
    -> (Command -> Command -> Bool)
    -> (Command -> Command -> Bool)
    -> (Command -> Command -> Command)
    -> (Command -> Command -> Command)
    -> Ord Command
    Command -> Command -> Bool
    Command -> Command -> Ordering
    Command -> Command -> Command
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    min :: Command -> Command -> Command
    $cmin :: Command -> Command -> Command
    max :: Command -> Command -> Command
    $cmax :: Command -> Command -> Command
    >= :: Command -> Command -> Bool
    $c>= :: Command -> Command -> Bool
    > :: Command -> Command -> Bool
    $c> :: Command -> Command -> Bool
    <= :: Command -> Command -> Bool
    $c<= :: Command -> Command -> Bool
    < :: Command -> Command -> Bool
    $c< :: Command -> Command -> Bool
    compare :: Command -> Command -> Ordering
    $ccompare :: Command -> Command -> Ordering
    $cp1Ord :: Eq Command
    Ord)

    type CommandConfig = [(Command, [(Key, Maybe Modifiers)])]

    -- | The default commands.  Left click pans, wheel zooms, right click
    --   rotates, "r" key resets.
    defaultCommandConfig :: CommandConfig
    defaultCommandConfig :: CommandConfig
    defaultCommandConfig
     =      [ (Command
    CRestore,
                    [ (Char -> Key
    Char 'r',                    Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CTranslate,
                    [ ( MouseButton -> Key
    MouseButton MouseButton
    LeftButton
                      , Modifiers -> Maybe Modifiers
    forall a. a -> Maybe a
    Just (Modifiers :: KeyState -> KeyState -> KeyState -> Modifiers
    Modifiers { shift :: KeyState
    shift = KeyState
    Up, ctrl :: KeyState
    ctrl = KeyState
    Up,   alt :: KeyState
    alt = KeyState
    Up }))
                    ])

            , (Command
    CScale,
                    [ ( MouseButton -> Key
    MouseButton MouseButton
    LeftButton
                      , Modifiers -> Maybe Modifiers
    forall a. a -> Maybe a
    Just (Modifiers :: KeyState -> KeyState -> KeyState -> Modifiers
    Modifiers { shift :: KeyState
    shift = KeyState
    Up, ctrl :: KeyState
    ctrl = KeyState
    Down, alt :: KeyState
    alt = KeyState
    Up }))

                    , ( MouseButton -> Key
    MouseButton MouseButton
    RightButton
                      , Modifiers -> Maybe Modifiers
    forall a. a -> Maybe a
    Just (Modifiers :: KeyState -> KeyState -> KeyState -> Modifiers
    Modifiers { shift :: KeyState
    shift = KeyState
    Up, ctrl :: KeyState
    ctrl = KeyState
    Up,   alt :: KeyState
    alt = KeyState
    Up }))
                    ])

            , (Command
    CRotate,
                    [ ( MouseButton -> Key
    MouseButton MouseButton
    LeftButton
                      , Modifiers -> Maybe Modifiers
    forall a. a -> Maybe a
    Just (Modifiers :: KeyState -> KeyState -> KeyState -> Modifiers
    Modifiers { shift :: KeyState
    shift = KeyState
    Up, ctrl :: KeyState
    ctrl = KeyState
    Up,   alt :: KeyState
    alt = KeyState
    Down }))

                    , ( MouseButton -> Key
    MouseButton MouseButton
    RightButton
                      , Modifiers -> Maybe Modifiers
    forall a. a -> Maybe a
    Just (Modifiers :: KeyState -> KeyState -> KeyState -> Modifiers
    Modifiers { shift :: KeyState
    shift = KeyState
    Up, ctrl :: KeyState
    ctrl = KeyState
    Down, alt :: KeyState
    alt = KeyState
    Up }))
                    ])

            -- bump zoom
            , (Command
    CBumpZoomOut,
                    [ (MouseButton -> Key
    MouseButton MouseButton
    WheelDown,       Maybe Modifiers
    forall a. Maybe a
    Nothing)
                    , (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyPageDown,     Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CBumpZoomIn,
                    [ (MouseButton -> Key
    MouseButton MouseButton
    WheelUp,         Maybe Modifiers
    forall a. Maybe a
    Nothing)
                    , (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyPageUp,       Maybe Modifiers
    forall a. Maybe a
    Nothing)] )

            -- bump translate
            , (Command
    CBumpLeft,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyLeft,         Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CBumpRight,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyRight,        Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CBumpUp,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyUp,           Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CBumpDown,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyDown,         Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            -- bump rotate
            , (Command
    CBumpClockwise,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyHome,         Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            , (Command
    CBumpCClockwise,
                    [ (SpecialKey -> Key
    SpecialKey  SpecialKey
    KeyEnd,          Maybe Modifiers
    forall a. Maybe a
    Nothing) ])

            ]

    -- | Check if the provided key combination is some gloss viewport command.
    isCommand
            :: Map Command [(Key, Maybe Modifiers)]
            -> Command -> Key -> Modifiers -> Bool

    isCommand :: Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand commands :: Map Command [(Key, Maybe Modifiers)]
    commands c :: Command
    c key :: Key
    key keyMods :: Modifiers
    keyMods
            | Just csMatch :: [(Key, Maybe Modifiers)]
    csMatch          <- Command
    -> Map Command [(Key, Maybe Modifiers)]
    -> Maybe [(Key, Maybe Modifiers)]
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Command
    c Map Command [(Key, Maybe Modifiers)]
    commands
            = [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or ([Bool] -> Bool) -> [Bool] -> Bool
    forall a b. (a -> b) -> a -> b
    $ ((Key, Maybe Modifiers) -> Bool)
    -> [(Key, Maybe Modifiers)] -> [Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map (Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool
    isCommand2 Command
    c Key
    key Modifiers
    keyMods) [(Key, Maybe Modifiers)]
    csMatch

            | Bool
    otherwise
            = Bool
    False

    -- | Check if the provided key combination is some gloss viewport command.
    isCommand2 :: Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool
    isCommand2 :: Command -> Key -> Modifiers -> (Key, Maybe Modifiers) -> Bool
    isCommand2 _ key :: Key
    key keyMods :: Modifiers
    keyMods cMatch :: (Key, Maybe Modifiers)
    cMatch
            | (keyC :: Key
    keyC, mModsC :: Maybe Modifiers
    mModsC)        <- (Key, Maybe Modifiers)
    cMatch
            , Key
    keyC Key -> Key -> Bool
    forall a. Eq a => a -> a -> Bool
    == Key
    key
            , case Maybe Modifiers
    mModsC of
                    Nothing         -> Bool
    True
                    Just modsC :: Modifiers
    modsC      -> Modifiers
    modsC Modifiers -> Modifiers -> Bool
    forall a. Eq a => a -> a -> Bool
    == Modifiers
    keyMods
            = Bool
    True

            | Bool
    otherwise
            = Bool
    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.
              ViewState -> Map Command [(Key, Maybe Modifiers)]
    viewStateCommands             :: !(Map Command [(Key, Maybe Modifiers)])

            -- | How much to scale the world by for each step of the mouse wheel.
            , ViewState -> Float
    viewStateScaleStep            :: !Float

            -- | How many degrees to rotate the world by for each pixel of x motion.
            , ViewState -> Float
    viewStateRotateFactor         :: !Float

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

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

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

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

            -- | The current viewport.
            , ViewState -> ViewPort
    viewStateViewPort             :: ViewPort
            }

    -- | The initial view state.
    viewStateInit :: ViewState
    viewStateInit :: ViewState
    viewStateInit
            = CommandConfig -> ViewState
    viewStateInitWithConfig CommandConfig
    defaultCommandConfig

    -- | Initial view state, with user defined config.
    viewStateInitWithConfig :: CommandConfig -> ViewState
    viewStateInitWithConfig :: CommandConfig -> ViewState
    viewStateInitWithConfig commandConfig :: CommandConfig
    commandConfig
            = $WViewState :: Map Command [(Key, Maybe Modifiers)]
    -> Float
    -> Float
    -> Float
    -> Maybe (Float, Float)
    -> Maybe (Float, Float)
    -> Maybe (Float, Float)
    -> ViewPort
    -> ViewState
    ViewState
            { viewStateCommands :: Map Command [(Key, Maybe Modifiers)]
    viewStateCommands             = CommandConfig -> Map Command [(Key, Maybe Modifiers)]
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList CommandConfig
    commandConfig
            , viewStateScaleStep :: Float
    viewStateScaleStep            = 0.85
            , viewStateRotateFactor :: Float
    viewStateRotateFactor         = 0.6
            , viewStateScaleFactor :: Float
    viewStateScaleFactor          = 0.01
            , viewStateTranslateMark :: Maybe (Float, Float)
    viewStateTranslateMark        = Maybe (Float, Float)
    forall a. Maybe a
    Nothing
            , viewStateRotateMark :: Maybe (Float, Float)
    viewStateRotateMark           = Maybe (Float, Float)
    forall a. Maybe a
    Nothing
            , viewStateScaleMark :: Maybe (Float, Float)
    viewStateScaleMark            = Maybe (Float, Float)
    forall a. Maybe a
    Nothing
            , viewStateViewPort :: ViewPort
    viewStateViewPort             = ViewPort
    viewPortInit }

    -- | Apply an event to a `ViewState`.
    updateViewStateWithEvent :: Event -> ViewState -> ViewState
    updateViewStateWithEvent :: Event -> ViewState -> ViewState
    updateViewStateWithEvent ev :: Event
    ev viewState :: ViewState
    viewState
            = ViewState -> Maybe ViewState -> ViewState
    forall a. a -> Maybe a -> a
    fromMaybe ViewState
    viewState (Maybe ViewState -> ViewState) -> Maybe ViewState -> ViewState
    forall a b. (a -> b) -> a -> b
    $ Event -> ViewState -> Maybe ViewState
    updateViewStateWithEventMaybe Event
    ev ViewState
    viewState

    -- | Like 'updateViewStateWithEvent', but returns 'Nothing' if no update
    --   was needed.
    updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState
    updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState
    updateViewStateWithEventMaybe (EventKey key :: Key
    key keyState :: KeyState
    keyState keyMods :: Modifiers
    keyMods pos :: (Float, Float)
    pos) viewState :: ViewState
    viewState
            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CRestore Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort = ViewPort
    viewPortInit }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpZoomOut Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState -> ViewState
    controlZoomIn ViewState
    viewState

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpZoomIn Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState -> ViewState
    controlZoomOut ViewState
    viewState

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpLeft Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
    motionBump ViewPort
    port (20, 0) }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpRight Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
    motionBump ViewPort
    port (-20, 0) }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpUp Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
    motionBump ViewPort
    port (0, -20) }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpDown Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
    motionBump ViewPort
    port (0, 20) }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpClockwise Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort
                                    = ViewPort
    port { viewPortRotate :: Float
    viewPortRotate = ViewPort -> Float
    viewPortRotate ViewPort
    port Float -> Float -> Float
    forall a. Num a => a -> a -> a
    + 5 } }

            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CBumpCClockwise Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateViewPort :: ViewPort
    viewStateViewPort
                                    = ViewPort
    port { viewPortRotate :: Float
    viewPortRotate = ViewPort -> Float
    viewPortRotate ViewPort
    port Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - 5 } }

            -- Start Translation.
            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CTranslate Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            , Bool -> Bool
    not  (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Bool
    currentlyRotating    Bool -> Bool -> Bool
    || Bool
    currentlyScaling
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateTranslateMark :: Maybe (Float, Float)
    viewStateTranslateMark = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float, Float)
    pos }

            -- Start Rotation.
            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CRotate Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            , Bool -> Bool
    not  (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Bool
    currentlyTranslating Bool -> Bool -> Bool
    || Bool
    currentlyScaling
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateRotateMark :: Maybe (Float, Float)
    viewStateRotateMark = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float, Float)
    pos }

            -- Start Scale.
            | Map Command [(Key, Maybe Modifiers)]
    -> Command -> Key -> Modifiers -> Bool
    isCommand Map Command [(Key, Maybe Modifiers)]
    commands Command
    CScale Key
    key Modifiers
    keyMods
            , KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Down
            , Bool -> Bool
    not  (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Bool
    currentlyTranslating Bool -> Bool -> Bool
    || Bool
    currentlyRotating
            = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState { viewStateScaleMark :: Maybe (Float, Float)
    viewStateScaleMark  = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float, Float)
    pos }

            -- Kill current translate/rotate/scale command when the mouse button
            -- is released.
            | KeyState
    keyState      KeyState -> KeyState -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyState
    Up
            = let   killTranslate :: ViewState -> ViewState
    killTranslate vs :: ViewState
    vs = ViewState
    vs { viewStateTranslateMark :: Maybe (Float, Float)
    viewStateTranslateMark = Maybe (Float, Float)
    forall a. Maybe a
    Nothing }
                    killRotate :: ViewState -> ViewState
    killRotate    vs :: ViewState
    vs = ViewState
    vs { viewStateRotateMark :: Maybe (Float, Float)
    viewStateRotateMark    = Maybe (Float, Float)
    forall a. Maybe a
    Nothing }
                    killScale :: ViewState -> ViewState
    killScale     vs :: ViewState
    vs = ViewState
    vs { viewStateScaleMark :: Maybe (Float, Float)
    viewStateScaleMark     = Maybe (Float, Float)
    forall a. Maybe a
    Nothing }
              in  ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just
                    (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ (if Bool
    currentlyTranslating then ViewState -> ViewState
    killTranslate else ViewState -> ViewState
    forall a. a -> a
    id)
                    (ViewState -> ViewState) -> ViewState -> ViewState
    forall a b. (a -> b) -> a -> b
    $ (if Bool
    currentlyRotating    then ViewState -> ViewState
    killRotate    else ViewState -> ViewState
    forall a. a -> a
    id)
                    (ViewState -> ViewState) -> ViewState -> ViewState
    forall a b. (a -> b) -> a -> b
    $ (if Bool
    currentlyScaling     then ViewState -> ViewState
    killScale     else ViewState -> ViewState
    forall a. a -> a
    id)
                    (ViewState -> ViewState) -> ViewState -> ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState

            | Bool
    otherwise
            = Maybe ViewState
    forall a. Maybe a
    Nothing
            where   commands :: Map Command [(Key, Maybe Modifiers)]
    commands                = ViewState -> Map Command [(Key, Maybe Modifiers)]
    viewStateCommands ViewState
    viewState
                    port :: ViewPort
    port                    = ViewState -> ViewPort
    viewStateViewPort ViewState
    viewState
                    currentlyTranslating :: Bool
    currentlyTranslating    = Maybe (Float, Float) -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe (Float, Float) -> Bool) -> Maybe (Float, Float) -> Bool
    forall a b. (a -> b) -> a -> b
    $ ViewState -> Maybe (Float, Float)
    viewStateTranslateMark ViewState
    viewState
                    currentlyRotating :: Bool
    currentlyRotating       = Maybe (Float, Float) -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe (Float, Float) -> Bool) -> Maybe (Float, Float) -> Bool
    forall a b. (a -> b) -> a -> b
    $ ViewState -> Maybe (Float, Float)
    viewStateRotateMark    ViewState
    viewState
                    currentlyScaling :: Bool
    currentlyScaling        = Maybe (Float, Float) -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe (Float, Float) -> Bool) -> Maybe (Float, Float) -> Bool
    forall a b. (a -> b) -> a -> b
    $ ViewState -> Maybe (Float, Float)
    viewStateScaleMark     ViewState
    viewState

    -- Note that only a translation or rotation applies, not both at the same time.
    updateViewStateWithEventMaybe (EventMotion pos :: (Float, Float)
    pos) viewState :: ViewState
    viewState
     = Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionScale     (ViewState -> Maybe (Float, Float)
    viewStateScaleMark     ViewState
    viewState) (Float, Float)
    pos ViewState
    viewState Maybe ViewState -> Maybe ViewState -> Maybe ViewState
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus`
       Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionTranslate (ViewState -> Maybe (Float, Float)
    viewStateTranslateMark ViewState
    viewState) (Float, Float)
    pos ViewState
    viewState Maybe ViewState -> Maybe ViewState -> Maybe ViewState
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus`
       Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionRotate    (ViewState -> Maybe (Float, Float)
    viewStateRotateMark    ViewState
    viewState) (Float, Float)
    pos ViewState
    viewState

    updateViewStateWithEventMaybe (EventResize _) _
     = Maybe ViewState
    forall a. Maybe a
    Nothing

    -- | Zoom in a `ViewState` by the scale step.
    controlZoomIn :: ViewState -> ViewState
    controlZoomIn :: ViewState -> ViewState
    controlZoomIn
     viewState :: ViewState
    viewState@ViewState
            { viewStateViewPort :: ViewState -> ViewPort
    viewStateViewPort     = ViewPort
    port
            , viewStateScaleStep :: ViewState -> Float
    viewStateScaleStep    = Float
    scaleStep }
     = ViewState
    viewState
            { viewStateViewPort :: ViewPort
    viewStateViewPort
                    = ViewPort
    port { viewPortScale :: Float
    viewPortScale = ViewPort -> Float
    viewPortScale ViewPort
    port Float -> Float -> Float
    forall a. Fractional a => a -> a -> a
    / Float
    scaleStep } }

    -- | Zoom out a `ViewState` by the scale step.
    controlZoomOut :: ViewState -> ViewState
    controlZoomOut :: ViewState -> ViewState
    controlZoomOut
     viewState :: ViewState
    viewState@ViewState
            { viewStateViewPort :: ViewState -> ViewPort
    viewStateViewPort     = ViewPort
    port
            , viewStateScaleStep :: ViewState -> Float
    viewStateScaleStep    = Float
    scaleStep }
     = ViewState
    viewState
            { viewStateViewPort :: ViewPort
    viewStateViewPort
                    = ViewPort
    port { viewPortScale :: Float
    viewPortScale = ViewPort -> Float
    viewPortScale ViewPort
    port Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * Float
    scaleStep } }

    -- | Offset a viewport.
    motionBump :: ViewPort -> (Float, Float) -> ViewPort
    motionBump :: ViewPort -> (Float, Float) -> ViewPort
    motionBump
            port :: ViewPort
    port@ViewPort
            { viewPortTranslate :: ViewPort -> (Float, Float)
    viewPortTranslate     = (Float, Float)
    trans
            , viewPortScale :: ViewPort -> Float
    viewPortScale         = Float
    scale
            , viewPortRotate :: ViewPort -> Float
    viewPortRotate        = Float
    r }
            (bumpX :: Float
    bumpX, bumpY :: Float
    bumpY)
     = ViewPort
    port { viewPortTranslate :: (Float, Float)
    viewPortTranslate = (Float, Float)
    trans (Float, Float) -> (Float, Float) -> (Float, Float)
    Pt.- (Float, Float)
    o }
     where  offset :: (Float, Float)
    offset  = (Float
    bumpX Float -> Float -> Float
    forall a. Fractional a => a -> a -> a
    / Float
    scale, Float
    bumpY Float -> Float -> Float
    forall a. Fractional a => a -> a -> a
    / Float
    scale)
            o :: (Float, Float)
    o       = Float -> (Float, Float) -> (Float, Float)
    rotateV (Float -> Float
    degToRad Float
    r) (Float, Float)
    offset

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

    motionTranslate :: Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionTranslate Nothing _ _ = Maybe ViewState
    forall a. Maybe a
    Nothing
    motionTranslate (Just (markX :: Float
    markX, markY :: Float
    markY)) (posX :: Float
    posX, posY :: Float
    posY) viewState :: ViewState
    viewState
     = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState
            { viewStateViewPort :: ViewPort
    viewStateViewPort      = ViewPort
    port { viewPortTranslate :: (Float, Float)
    viewPortTranslate = (Float, Float)
    trans (Float, Float) -> (Float, Float) -> (Float, Float)
    Pt.- (Float, Float)
    o }
            , viewStateTranslateMark :: Maybe (Float, Float)
    viewStateTranslateMark = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float
    posX, Float
    posY) }

     where  port :: ViewPort
    port    = ViewState -> ViewPort
    viewStateViewPort ViewState
    viewState
            trans :: (Float, Float)
    trans   = ViewPort -> (Float, Float)
    viewPortTranslate ViewPort
    port
            scale :: Float
    scale   = ViewPort -> Float
    viewPortScale ViewPort
    port
            r :: Float
    r       = ViewPort -> Float
    viewPortRotate ViewPort
    port
            dX :: Float
    dX      = Float
    markX Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    posX
            dY :: Float
    dY      = Float
    markY Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    posY
            offset :: (Float, Float)
    offset  = (Float
    dX Float -> Float -> Float
    forall a. Fractional a => a -> a -> a
    / Float
    scale, Float
    dY Float -> Float -> Float
    forall a. Fractional a => a -> a -> a
    / Float
    scale)
            o :: (Float, Float)
    o       = Float -> (Float, Float) -> (Float, Float)
    rotateV (Float -> Float
    degToRad Float
    r) (Float, Float)
    offset

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

    motionRotate :: Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionRotate Nothing _ _ = Maybe ViewState
    forall a. Maybe a
    Nothing
    motionRotate (Just (markX :: Float
    markX, _markY :: Float
    _markY)) (posX :: Float
    posX, posY :: Float
    posY) viewState :: ViewState
    viewState
     = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState
            { viewStateViewPort :: ViewPort
    viewStateViewPort
                    = ViewPort
    port { viewPortRotate :: Float
    viewPortRotate = Float
    rotate Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    rotateFactor Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * (Float
    posX Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    markX) }

            , viewStateRotateMark :: Maybe (Float, Float)
    viewStateRotateMark   = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float
    posX, Float
    posY) }
     where  port :: ViewPort
    port            = ViewState -> ViewPort
    viewStateViewPort ViewState
    viewState
            rotate :: Float
    rotate          = ViewPort -> Float
    viewPortRotate ViewPort
    port
            rotateFactor :: Float
    rotateFactor    = ViewState -> Float
    viewStateRotateFactor ViewState
    viewState

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

    motionScale :: Maybe (Float, Float)
    -> (Float, Float) -> ViewState -> Maybe ViewState
    motionScale Nothing _ _ = Maybe ViewState
    forall a. Maybe a
    Nothing
    motionScale (Just (_markX :: Float
    _markX, markY :: Float
    markY)) (posX :: Float
    posX, posY :: Float
    posY) viewState :: ViewState
    viewState
     = ViewState -> Maybe ViewState
    forall a. a -> Maybe a
    Just (ViewState -> Maybe ViewState) -> ViewState -> Maybe ViewState
    forall a b. (a -> b) -> a -> b
    $ ViewState
    viewState
            { viewStateViewPort :: ViewPort
    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 :: Float
    ss      = if Float
    posY Float -> Float -> Bool
    forall a. Ord a => a -> a -> Bool
    > Float
    markY
                                    then Float
    scale Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    scale Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * (Float
    scaleFactor Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * (Float
    posY  Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    markY))
                                    else Float
    scale Float -> Float -> Float
    forall a. Num a => a -> a -> a
    + Float
    scale Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * (Float
    scaleFactor Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * (Float
    markY Float -> Float -> Float
    forall a. Num a => a -> a -> a
    - Float
    posY))

                      ss' :: Float
    ss'     = Float -> Float -> Float
    forall a. Ord a => a -> a -> a
    max 0.01 Float
    ss
                in    ViewPort
    port { viewPortScale :: Float
    viewPortScale = Float
    ss' }

            , viewStateScaleMark :: Maybe (Float, Float)
    viewStateScaleMark    = (Float, Float) -> Maybe (Float, Float)
    forall a. a -> Maybe a
    Just (Float
    posX, Float
    posY) }
     where  port :: ViewPort
    port            = ViewState -> ViewPort
    viewStateViewPort ViewState
    viewState
            scale :: Float
    scale           = ViewPort -> Float
    viewPortScale ViewPort
    port
            scaleFactor :: Float
    scaleFactor     = ViewState -> Float
    viewStateScaleFactor ViewState
    viewState