{-# 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
data Command
= CRestore
| CTranslate
| CRotate
| CScale
| CBumpZoomOut
| CBumpZoomIn
| CBumpLeft
| CBumpRight
| CBumpUp
| CBumpDown
| 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
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: 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
min :: Command -> Command -> Command
$cmin :: Command -> Command -> Command
max :: Command -> Command -> Command
$cmax :: Command -> Command -> Command
>= :: Command -> Command -> Bool
$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
compare :: Command -> Command -> Ordering
$ccompare :: Command -> Command -> Ordering
$cp1Ord :: Eq Command
Ord)
type CommandConfig = [(Command, [(Key, Maybe Modifiers)])]
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 :: KeyState -> KeyState -> KeyState -> Modifiers
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 :: KeyState -> KeyState -> KeyState -> Modifiers
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 :: KeyState -> KeyState -> KeyState -> Modifiers
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 :: KeyState -> KeyState -> KeyState -> Modifiers
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 :: KeyState -> KeyState -> KeyState -> Modifiers
Modifiers { shift :: KeyState
shift = KeyState
Up, ctrl :: KeyState
ctrl = KeyState
Down, alt :: KeyState
alt = KeyState
Up }))
])
, (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)] )
, (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) ])
, (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) ])
]
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
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
data ViewState
= ViewState {
ViewState -> Map Command [(Key, Maybe Modifiers)]
viewStateCommands :: !(Map Command [(Key, Maybe Modifiers)])
, ViewState -> Float
viewStateScaleStep :: !Float
, ViewState -> Float
viewStateRotateFactor :: !Float
, ViewState -> Float
viewStateScaleFactor :: !Float
, ViewState -> Maybe (Float, Float)
viewStateTranslateMark :: !(Maybe (Float, Float))
, ViewState -> Maybe (Float, Float)
viewStateRotateMark :: !(Maybe (Float, Float))
, ViewState -> Maybe (Float, Float)
viewStateScaleMark :: !(Maybe (Float, Float))
, ViewState -> ViewPort
viewStateViewPort :: ViewPort
}
viewStateInit :: ViewState
viewStateInit :: ViewState
viewStateInit
= CommandConfig -> ViewState
viewStateInitWithConfig CommandConfig
defaultCommandConfig
viewStateInitWithConfig :: CommandConfig -> ViewState
viewStateInitWithConfig :: CommandConfig -> ViewState
viewStateInitWithConfig CommandConfig
commandConfig
= ViewState :: Map Command [(Key, Maybe Modifiers)]
-> Float
-> Float
-> Float
-> Maybe (Float, Float)
-> Maybe (Float, Float)
-> Maybe (Float, Float)
-> ViewPort
-> ViewState
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 }
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
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 :: ViewPort
viewStateViewPort = ViewPort
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 :: ViewPort
viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
motionBump ViewPort
port (Float
20, Float
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 :: ViewPort
viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
motionBump ViewPort
port (-Float
20, Float
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 :: ViewPort
viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
motionBump ViewPort
port (Float
0, -Float
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 :: ViewPort
viewStateViewPort = ViewPort -> (Float, Float) -> ViewPort
motionBump ViewPort
port (Float
0, Float
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 :: ViewPort
viewStateViewPort
= ViewPort
port { viewPortRotate :: Float
viewPortRotate = ViewPort -> Float
viewPortRotate ViewPort
port Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
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 :: ViewPort
viewStateViewPort
= ViewPort
port { viewPortRotate :: Float
viewPortRotate = ViewPort -> Float
viewPortRotate ViewPort
port Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
5 } }
| 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 :: Maybe (Float, Float)
viewStateTranslateMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float, Float)
pos }
| 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 :: Maybe (Float, Float)
viewStateRotateMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float, Float)
pos }
| 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 :: Maybe (Float, Float)
viewStateScaleMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float, Float)
pos }
| KeyState
keyState KeyState -> KeyState -> Bool
forall a. Eq a => a -> a -> Bool
== KeyState
Up
= let killTranslate :: ViewState -> ViewState
killTranslate ViewState
vs = ViewState
vs { viewStateTranslateMark :: Maybe (Float, Float)
viewStateTranslateMark = Maybe (Float, Float)
forall a. Maybe a
Nothing }
killRotate :: ViewState -> ViewState
killRotate ViewState
vs = ViewState
vs { viewStateRotateMark :: Maybe (Float, Float)
viewStateRotateMark = Maybe (Float, Float)
forall a. Maybe a
Nothing }
killScale :: ViewState -> ViewState
killScale ViewState
vs = ViewState
vs { viewStateScaleMark :: Maybe (Float, Float)
viewStateScaleMark = Maybe (Float, Float)
forall a. Maybe a
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
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 (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 (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
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 :: ViewPort
viewStateViewPort
= ViewPort
port { viewPortScale :: Float
viewPortScale = ViewPort -> Float
viewPortScale ViewPort
port Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
scaleStep } }
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 :: ViewPort
viewStateViewPort
= ViewPort
port { viewPortScale :: Float
viewPortScale = ViewPort -> Float
viewPortScale ViewPort
port Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
scaleStep } }
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 :: (Float, Float)
viewPortTranslate = (Float, Float)
trans (Float, Float) -> (Float, Float) -> (Float, Float)
Pt.- (Float, Float)
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
motionTranslate
:: Maybe (Float, Float)
-> (Float, Float)
-> 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 :: ViewPort
viewStateViewPort = ViewPort
port { viewPortTranslate :: (Float, Float)
viewPortTranslate = (Float, Float)
trans (Float, Float) -> (Float, Float) -> (Float, Float)
Pt.- (Float, Float)
o }
, viewStateTranslateMark :: Maybe (Float, Float)
viewStateTranslateMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
posX, Float
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
motionRotate
:: Maybe (Float, Float)
-> (Float, Float)
-> 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 :: ViewPort
viewStateViewPort
= ViewPort
port { viewPortRotate :: Float
viewPortRotate = Float
rotate Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rotateFactor Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
posX Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
markX) }
, viewStateRotateMark :: Maybe (Float, Float)
viewStateRotateMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
posX, Float
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
motionScale
:: Maybe (Float, Float)
-> (Float, Float)
-> 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 :: ViewPort
viewStateViewPort
= let
ss :: Float
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
ss' = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0.01 Float
ss
in ViewPort
port { viewPortScale :: Float
viewPortScale = Float
ss' }
, viewStateScaleMark :: Maybe (Float, Float)
viewStateScaleMark = (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float
posX, Float
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