content: {-# 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 (EventDrop _) _ = Nothing
  updateViewStateWithEventMaybe (EventPick _) _ = Nothing
  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
  