ViewState.hs

{-# 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 (Show, Eq, Ord)


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


{-| The default commands.  Left click pans, wheel zooms, right click
  rotates, "r" key resets.
-}
defaultCommandConfig :: CommandConfig
defaultCommandConfig =
  [
    ( CRestore
    , [(Char 'r', Nothing)]
    )
  ,
    ( CTranslate
    ,
      [
        ( MouseButton LeftButton
        , Just (Modifiers{shift = Up, ctrl = Up, alt = Up})
        )
      ]
    )
  ,
    ( CScale
    ,
      [
        ( MouseButton LeftButton
        , Just (Modifiers{shift = Up, ctrl = Down, alt = Up})
        )
      ,
        ( MouseButton RightButton
        , Just (Modifiers{shift = Up, ctrl = Up, alt = Up})
        )
      ]
    )
  ,
    ( CRotate
    ,
      [
        ( MouseButton LeftButton
        , Just (Modifiers{shift = Up, ctrl = Up, alt = Down})
        )
      ,
        ( MouseButton RightButton
        , Just (Modifiers{shift = Up, ctrl = Down, alt = Up})
        )
      ]
    )
  , -- bump zoom

    ( CBumpZoomOut
    ,
      [ (MouseButton WheelDown, Nothing)
      , (SpecialKey KeyPageDown, Nothing)
      ]
    )
  ,
    ( CBumpZoomIn
    ,
      [ (MouseButton WheelUp, Nothing)
      , (SpecialKey KeyPageUp, Nothing)
      ]
    )
  , -- bump translate

    ( CBumpLeft
    , [(SpecialKey KeyLeft, Nothing)]
    )
  ,
    ( CBumpRight
    , [(SpecialKey KeyRight, Nothing)]
    )
  ,
    ( CBumpUp
    , [(SpecialKey KeyUp, Nothing)]
    )
  ,
    ( CBumpDown
    , [(SpecialKey KeyDown, Nothing)]
    )
  , -- bump rotate

    ( CBumpClockwise
    , [(SpecialKey KeyHome, Nothing)]
    )
  ,
    ( CBumpCClockwise
    , [(SpecialKey KeyEnd, Nothing)]
    )
  ]


-- | Check if the provided key combination is some brillo viewport command.
isCommand
  :: Map Command [(Key, Maybe Modifiers)]
  -> Command
  -> Key
  -> Modifiers
  -> Bool
isCommand commands c key keyMods
  | Just csMatch <- Map.lookup c commands =
      or $ map (isCommand2 c key keyMods) csMatch
  | otherwise =
      False


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


-- ViewControl State -----------------------------------------------------------

{-| State for controlling the viewport.
     These are used by the viewport control component.
-}
data ViewState
  = ViewState
  { 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.
  , viewStateScaleStep :: !Float
  -- ^ How much to scale the world by for each step of the mouse wheel.
  , viewStateRotateFactor :: !Float
  -- ^ How many degrees to rotate the world by for each pixel of x motion.
  , viewStateScaleFactor :: !Float
  -- ^ Ratio to scale the world by for each pixel of y motion.
  , viewStateTranslateMark :: !(Maybe (Float, Float))
  -- ^ During viewport translation,
  --      where the mouse was clicked on the window to start the translate.
  , viewStateRotateMark :: !(Maybe (Float, Float))
  -- ^ During viewport rotation,
  --      where the mouse was clicked on the window to starte the rotate.
  , viewStateScaleMark :: !(Maybe (Float, Float))
  -- ^ During viewport scale,
  --      where the mouse was clicked on the window to start the scale.
  , viewStateViewPort :: ViewPort
  -- ^ The current viewport.
  }


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


-- | Initial view state, with user defined config.
viewStateInitWithConfig :: CommandConfig -> ViewState
viewStateInitWithConfig commandConfig =
  ViewState
    { viewStateCommands = Map.fromList commandConfig
    , viewStateScaleStep = 0.85
    , viewStateRotateFactor = 0.6
    , viewStateScaleFactor = 0.01
    , viewStateTranslateMark = Nothing
    , viewStateRotateMark = Nothing
    , viewStateScaleMark = Nothing
    , viewStateViewPort = viewPortInit
    }


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


{-| Like 'updateViewStateWithEvent', but returns 'Nothing' if no update
  was needed.
-}
updateViewStateWithEventMaybe :: Event -> ViewState -> Maybe ViewState
updateViewStateWithEventMaybe (EventKey key keyState keyMods pos) viewState
  | isCommand commands CRestore key keyMods
  , keyState == Down =
      Just $ viewState{viewStateViewPort = viewPortInit}
  | isCommand commands CBumpZoomOut key keyMods
  , keyState == Down =
      Just $ controlZoomIn viewState
  | isCommand commands CBumpZoomIn key keyMods
  , keyState == Down =
      Just $ controlZoomOut viewState
  | isCommand commands CBumpLeft key keyMods
  , keyState == Down =
      Just $ viewState{viewStateViewPort = motionBump port (20, 0)}
  | isCommand commands CBumpRight key keyMods
  , keyState == Down =
      Just $ viewState{viewStateViewPort = motionBump port (-20, 0)}
  | isCommand commands CBumpUp key keyMods
  , keyState == Down =
      Just $ viewState{viewStateViewPort = motionBump port (0, -20)}
  | isCommand commands CBumpDown key keyMods
  , keyState == Down =
      Just $ viewState{viewStateViewPort = motionBump port (0, 20)}
  | isCommand commands CBumpClockwise key keyMods
  , keyState == Down =
      Just $
        viewState
          { viewStateViewPort =
              port{viewPortRotate = viewPortRotate port + 5}
          }
  | isCommand commands CBumpCClockwise key keyMods
  , keyState == Down =
      Just $
        viewState
          { viewStateViewPort =
              port{viewPortRotate = viewPortRotate port - 5}
          }
  -- Start Translation.
  | isCommand commands CTranslate key keyMods
  , keyState == Down
  , not $ currentlyRotating || currentlyScaling =
      Just $ viewState{viewStateTranslateMark = Just pos}
  -- Start Rotation.
  | isCommand commands CRotate key keyMods
  , keyState == Down
  , not $ currentlyTranslating || currentlyScaling =
      Just $ viewState{viewStateRotateMark = Just pos}
  -- Start Scale.
  | isCommand commands CScale key keyMods
  , keyState == Down
  , not $ currentlyTranslating || currentlyRotating =
      Just $ viewState{viewStateScaleMark = Just pos}
  -- Kill current translate/rotate/scale command when the mouse button
  -- is released.
  | keyState == Up =
      let killTranslate vs = vs{viewStateTranslateMark = Nothing}
          killRotate vs = vs{viewStateRotateMark = Nothing}
          killScale vs = vs{viewStateScaleMark = Nothing}
      in  Just $
            (if currentlyTranslating then killTranslate else id) $
              (if currentlyRotating then killRotate else id) $
                (if currentlyScaling then killScale else id) $
                  viewState
  | otherwise =
      Nothing
  where
    commands = viewStateCommands viewState
    port = viewStateViewPort viewState
    currentlyTranslating = isJust $ viewStateTranslateMark viewState
    currentlyRotating = isJust $ viewStateRotateMark viewState
    currentlyScaling = isJust $ viewStateScaleMark viewState

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


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


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


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


-- | Apply a translation to the `ViewState`.
motionTranslate
  :: Maybe (Float, Float) -- Location of first mark.
  -> (Float, Float) -- Current position.
  -> ViewState
  -> Maybe ViewState
motionTranslate Nothing _ _ = Nothing
motionTranslate (Just (markX, markY)) (posX, posY) viewState =
  Just $
    viewState
      { viewStateViewPort = port{viewPortTranslate = trans Pt.- o}
      , viewStateTranslateMark = Just (posX, posY)
      }
  where
    port = viewStateViewPort viewState
    trans = viewPortTranslate port
    scale = viewPortScale port
    r = viewPortRotate port
    dX = markX - posX
    dY = markY - posY
    offset = (dX / scale, dY / scale)
    o = rotateV (degToRad r) offset


-- | Apply a rotation to the `ViewState`.
motionRotate
  :: Maybe (Float, Float) -- Location of first mark.
  -> (Float, Float) -- Current position.
  -> ViewState
  -> Maybe ViewState
motionRotate Nothing _ _ = Nothing
motionRotate (Just (markX, _markY)) (posX, posY) viewState =
  Just $
    viewState
      { viewStateViewPort =
          port{viewPortRotate = rotate - rotateFactor * (posX - markX)}
      , viewStateRotateMark = Just (posX, posY)
      }
  where
    port = viewStateViewPort viewState
    rotate = viewPortRotate port
    rotateFactor = viewStateRotateFactor viewState


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

            ss' = max 0.01 ss
          in
            port{viewPortScale = ss'}
      , viewStateScaleMark = Just (posX, posY)
      }
  where
    port = viewStateViewPort viewState
    scale = viewPortScale port
    scaleFactor = viewStateScaleFactor viewState