ViewState.hs

{-# 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 (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 gloss 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 gloss 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 {
        -- | 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.
          viewStateCommands             :: !(Map Command [(Key, Maybe Modifiers)])

        -- | How much to scale the world by for each step of the mouse wheel.
        , viewStateScaleStep            :: !Float

        -- | How many degrees to rotate the world by for each pixel of x motion.
        , viewStateRotateFactor         :: !Float

        -- | Ratio to scale the world by for each pixel of y motion.
        , viewStateScaleFactor          :: !Float

        -- | During viewport translation,
        --      where the mouse was clicked on the window to start the translate.
        , viewStateTranslateMark        :: !(Maybe (Float, Float))

        -- | During viewport rotation,
        --      where the mouse was clicked on the window to starte the rotate.
        , viewStateRotateMark           :: !(Maybe (Float, Float))

        -- | During viewport scale,
        --      where the mouse was clicked on the window to start the scale.
        , viewStateScaleMark            :: !(Maybe (Float, Float))

        -- | The current viewport.
        , viewStateViewPort             :: 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