{-# LANGUAGE PatternGuards #-}

module Brillo.Data.ViewState (
  Command (..),
  CommandConfig,
  defaultCommandConfig,
  ViewState (..),
  viewStateInit,
  viewStateInitWithConfig,
  updateViewStateWithEvent,
  updateViewStateWithEventMaybe,
)
where

import Brillo.Data.Point.Arithmetic qualified as Pt
import Brillo.Data.Vector
import Brillo.Data.ViewPort
import Brillo.Geometry.Angle
import Brillo.Internals.Interface.Backend
import Brillo.Internals.Interface.Event
import Control.Monad (mplus)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe


-- | 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
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: 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
$ccompare :: Command -> Command -> Ordering
compare :: Command -> Command -> Ordering
$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
>= :: Command -> Command -> Bool
$cmax :: Command -> Command -> Command
max :: Command -> Command -> Command
$cmin :: Command -> Command -> Command
min :: Command -> Command -> 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{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{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{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{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{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 brillo 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 brillo 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
  { ViewState -> Map Command [(Key, Maybe Modifiers)]
viewStateCommands :: !(Map Command [(Key, Maybe Modifiers)])
  -- ^ 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 -> Float
viewStateScaleStep :: !Float
  -- ^ How much to scale the world by for each step of the mouse wheel.
  , ViewState -> Float
viewStateRotateFactor :: !Float
  -- ^ How many degrees to rotate the world by for each pixel of x motion.
  , ViewState -> Float
viewStateScaleFactor :: !Float
  -- ^ Ratio to scale the world by for each pixel of y motion.
  , ViewState -> Maybe (Float, Float)
viewStateTranslateMark :: !(Maybe (Float, Float))
  -- ^ During viewport translation,
  --      where the mouse was clicked on the window to start the translate.
  , ViewState -> Maybe (Float, Float)
viewStateRotateMark :: !(Maybe (Float, Float))
  -- ^ During viewport rotation,
  --      where the mouse was clicked on the window to starte the rotate.
  , ViewState -> Maybe (Float, Float)
viewStateScaleMark :: !(Maybe (Float, Float))
  -- ^ During viewport scale,
  --      where the mouse was clicked on the window to start the scale.
  , ViewState -> ViewPort
viewStateViewPort :: ViewPort
  -- ^ The current 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
    { 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 = 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 = motionBump 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 = motionBump 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 = motionBump 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 = motionBump 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 =
              port{viewPortRotate = viewPortRotate port + 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 =
              port{viewPortRotate = viewPortRotate port - 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 = Just 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 = Just 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 = Just 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 = Nothing}
          killRotate :: ViewState -> ViewState
killRotate ViewState
vs = ViewState
vs{viewStateRotateMark = Nothing}
          killScale :: ViewState -> ViewState
killScale ViewState
vs = ViewState
vs{viewStateScaleMark = 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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 =
          port{viewPortScale = viewPortScale port / 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 =
          port{viewPortScale = viewPortScale port * 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 = trans Pt.- 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 = port{viewPortTranslate = trans Pt.- o}
      , viewStateTranslateMark = Just (posX, 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 =
          port{viewPortRotate = rotate - rotateFactor * (posX - markX)}
      , viewStateRotateMark = Just (posX, 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 =
          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 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 -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0.01 Float
ss
          in
            port{viewPortScale = ss'}
      , viewStateScaleMark = Just (posX, 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