{-# 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 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 Map Command [(Key, Maybe Modifiers)]
commands Command
c Key
key Modifiers
keyMods
        | Just [(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 Command
_ Key
key Modifiers
keyMods (Key, Maybe Modifiers)
cMatch
        | (Key
keyC, 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
                Maybe Modifiers
Nothing         -> Bool
True
                Just 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
        = ViewState :: 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            = Float
0.85
        , viewStateRotateFactor :: Float
viewStateRotateFactor         = Float
0.6
        , viewStateScaleFactor :: Float
viewStateScaleFactor          = Float
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 Event
ev 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 KeyState
keyState Modifiers
keyMods (Float, Float)
pos) 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 (Float
20, Float
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 (-Float
20, Float
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 (Float
0, -Float
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 (Float
0, Float
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
+ Float
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
- Float
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 ViewState
vs = ViewState
vs { viewStateTranslateMark :: Maybe (Float, Float)
viewStateTranslateMark = Maybe (Float, Float)
forall a. Maybe a
Nothing }
                killRotate :: ViewState -> ViewState
killRotate    ViewState
vs = ViewState
vs { viewStateRotateMark :: Maybe (Float, Float)
viewStateRotateMark    = Maybe (Float, Float)
forall a. Maybe a
Nothing }
                killScale :: ViewState -> ViewState
killScale     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 (Float, Float)
pos) 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 (Int, Int)
_) ViewState
_
 = 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 }
        (Float
bumpX, 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 Maybe (Float, Float)
Nothing (Float, Float)
_ ViewState
_ = Maybe ViewState
forall a. Maybe a
Nothing
motionTranslate (Just (Float
markX, Float
markY)) (Float
posX, Float
posY) 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 Maybe (Float, Float)
Nothing (Float, Float)
_ ViewState
_ = Maybe ViewState
forall a. Maybe a
Nothing
motionRotate (Just (Float
markX, Float
_markY)) (Float
posX, Float
posY) 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 Maybe (Float, Float)
Nothing (Float, Float)
_ ViewState
_ = Maybe ViewState
forall a. Maybe a
Nothing
motionScale (Just (Float
_markX, Float
markY)) (Float
posX, Float
posY) 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 Float
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