{-# 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 (EventDrop [String]
_) ViewState
_ = Maybe ViewState
forall a. Maybe a
Nothing
updateViewStateWithEventMaybe (EventPick [String]
_) ViewState
_ = Maybe ViewState
forall a. Maybe a
Nothing
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