mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 02:40:28 +03:00
Pan with wasd. Make low frame rates red.
This commit is contained in:
parent
4658494972
commit
33280502f2
@ -18,9 +18,11 @@ module GtkGui (gtkMain) where
|
|||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Data.GI.Base (AttrOp ((:=)), new)
|
import Data.GI.Base (AttrOp ((:=)), new)
|
||||||
import Data.IORef (IORef, newIORef)
|
import Data.IORef (IORef, newIORef)
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock.System (getSystemTime)
|
import Data.Time.Clock.System (getSystemTime)
|
||||||
|
import Data.Word (Word16)
|
||||||
import GHC.Word (Word32)
|
import GHC.Word (Word32)
|
||||||
import qualified GI.GLib as GLib
|
import qualified GI.GLib as GLib
|
||||||
import qualified GI.Gdk as Gdk
|
import qualified GI.Gdk as Gdk
|
||||||
@ -29,8 +31,8 @@ import qualified GI.Gtk as Gtk
|
|||||||
import GuiInternals
|
import GuiInternals
|
||||||
( AppState,
|
( AppState,
|
||||||
Inputs,
|
Inputs,
|
||||||
KeyEvent (AbortKey, TranslateKey, UndoKey, UnknownKey),
|
KeyEvent (..),
|
||||||
MouseButton (UnknownMouseButton),
|
MouseButton (..),
|
||||||
backgroundPress,
|
backgroundPress,
|
||||||
emptyAppState,
|
emptyAppState,
|
||||||
emptyInputs,
|
emptyInputs,
|
||||||
@ -43,8 +45,22 @@ import GuiInternals
|
|||||||
)
|
)
|
||||||
|
|
||||||
--------- Constants -------------
|
--------- Constants -------------
|
||||||
translateKey :: Text
|
keyStrings :: Map.Map Text KeyEvent
|
||||||
translateKey = " "
|
keyStrings =
|
||||||
|
Map.fromList
|
||||||
|
[ ("\SUB", UndoKey), -- ctrl-z
|
||||||
|
("\a", AbortKey) -- ctrl-g
|
||||||
|
]
|
||||||
|
|
||||||
|
keyCodes :: Map.Map Word16 KeyEvent
|
||||||
|
keyCodes =
|
||||||
|
Map.fromList
|
||||||
|
[ (25, MoveUp), -- qwerty w
|
||||||
|
(38, MoveLeft), -- querty a
|
||||||
|
(39, MoveDown), -- querty s
|
||||||
|
(40, MoveRight), -- querty d
|
||||||
|
(65, MouseTranslateKey) -- spacebar
|
||||||
|
]
|
||||||
|
|
||||||
-- | A mapping between mouse button names and the GTK
|
-- | A mapping between mouse button names and the GTK
|
||||||
-- mouse button numbers via Enum, so order is important!
|
-- mouse button numbers via Enum, so order is important!
|
||||||
@ -100,20 +116,33 @@ backgroundPressCallback inputsRef stateRef eventButton = do
|
|||||||
backgroundPress inputsRef stateRef mouseButton rawMousePosition
|
backgroundPress inputsRef stateRef mouseButton rawMousePosition
|
||||||
pure Gdk.EVENT_STOP
|
pure Gdk.EVENT_STOP
|
||||||
|
|
||||||
|
decodeKey :: Maybe Text -> Word16 -> KeyEvent
|
||||||
|
decodeKey mKeyStr keyCode =
|
||||||
|
case mKeyStr of
|
||||||
|
Nothing -> UnknownKey
|
||||||
|
Just keyStr -> case Map.lookup keyStr keyStrings of
|
||||||
|
Just e -> e
|
||||||
|
Nothing -> case Map.lookup keyCode keyCodes of
|
||||||
|
Just e -> e
|
||||||
|
Nothing -> UnknownKey
|
||||||
|
|
||||||
keyPressCallback :: IORef Inputs -> IORef AppState -> Gdk.EventKey -> IO Bool
|
keyPressCallback :: IORef Inputs -> IORef AppState -> Gdk.EventKey -> IO Bool
|
||||||
keyPressCallback inputsRef stateRef eventKey = do
|
keyPressCallback inputsRef stateRef eventKey = do
|
||||||
-- TODO May want to check that ctrl is pressed by checking that
|
-- TODO May want to check that ctrl is pressed by checking that
|
||||||
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
||||||
-- Gdk.KEY_?.
|
-- Gdk.KEY_?.
|
||||||
key <- Gdk.getEventKeyString eventKey
|
--
|
||||||
let keyEvent = case key of
|
-- The KeyString is the character that was typed. This is affected
|
||||||
Nothing -> UnknownKey ""
|
-- by the keyboard layout.
|
||||||
Just "\SUB" -> UndoKey -- ctrl-z pressed
|
mKey <- Gdk.getEventKeyString eventKey
|
||||||
Just "\a" -> AbortKey -- ctrl-g
|
-- The hardware keycode is a number corresponding to a specific
|
||||||
Just str ->
|
-- physical key on the keyboard, so changing the keyboard layout has
|
||||||
if
|
-- no affect on the keycode.
|
||||||
| str == translateKey -> TranslateKey
|
keyCode <- Gdk.getEventKeyHardwareKeycode eventKey
|
||||||
| otherwise -> UnknownKey str
|
-- putStrLn $ "key: " <> show mKey
|
||||||
|
-- putStrLn $ "keycode: " <> show keyCode
|
||||||
|
let keyEvent = decodeKey mKey keyCode
|
||||||
|
-- print keyEvent
|
||||||
keyPress inputsRef stateRef keyEvent
|
keyPress inputsRef stateRef keyEvent
|
||||||
pure Gdk.EVENT_STOP
|
pure Gdk.EVENT_STOP
|
||||||
|
|
||||||
@ -122,11 +151,9 @@ keyReleaseCallback inputsRef eventKey = do
|
|||||||
-- TODO May want to check that ctrl is pressed by checking that
|
-- TODO May want to check that ctrl is pressed by checking that
|
||||||
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
-- getEventKeyState is ModifierTypeControlMask. May also want to use
|
||||||
-- Gdk.KEY_?.
|
-- Gdk.KEY_?.
|
||||||
key <- Gdk.getEventKeyString eventKey
|
mKey <- Gdk.getEventKeyString eventKey
|
||||||
let keyEvent =
|
keyCode <- Gdk.getEventKeyHardwareKeycode eventKey
|
||||||
if
|
let keyEvent = decodeKey mKey keyCode
|
||||||
| key == Just translateKey -> TranslateKey
|
|
||||||
| otherwise -> UnknownKey ""
|
|
||||||
keyRelease inputsRef keyEvent
|
keyRelease inputsRef keyEvent
|
||||||
pure Gdk.EVENT_STOP
|
pure Gdk.EVENT_STOP
|
||||||
|
|
||||||
@ -183,7 +210,7 @@ startApp app = do
|
|||||||
_ <-
|
_ <-
|
||||||
GLib.timeoutAdd
|
GLib.timeoutAdd
|
||||||
GLib.PRIORITY_DEFAULT
|
GLib.PRIORITY_DEFAULT
|
||||||
1
|
2 -- milliseconds between callbacks
|
||||||
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
||||||
|
|
||||||
_ <-
|
_ <-
|
||||||
|
@ -5,6 +5,7 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PartialTypeSignatures #-}
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
@ -39,7 +40,7 @@ import Data.List (find)
|
|||||||
-- import Debug.Trace (trace)
|
-- import Debug.Trace (trace)
|
||||||
|
|
||||||
import Data.Maybe (isNothing)
|
import Data.Maybe (isNothing)
|
||||||
import Data.Text (Text)
|
import qualified Data.Set as Set
|
||||||
import Data.Time.Clock.System (SystemTime (MkSystemTime))
|
import Data.Time.Clock.System (SystemTime (MkSystemTime))
|
||||||
import qualified Data.Tuple.Extra as Tuple
|
import qualified Data.Tuple.Extra as Tuple
|
||||||
import Foreign.Ptr (castPtr)
|
import Foreign.Ptr (castPtr)
|
||||||
@ -52,6 +53,9 @@ import Graphics.Rendering.Cairo.Types (Cairo (Cairo))
|
|||||||
minimumScale :: Double
|
minimumScale :: Double
|
||||||
minimumScale = 0.1
|
minimumScale = 0.1
|
||||||
|
|
||||||
|
panSpeed :: Double
|
||||||
|
panSpeed = 2000
|
||||||
|
|
||||||
-- Types
|
-- Types
|
||||||
|
|
||||||
-- | An Enum of mouse buttons, so order is important!
|
-- | An Enum of mouse buttons, so order is important!
|
||||||
@ -66,8 +70,13 @@ data MouseButton
|
|||||||
data KeyEvent
|
data KeyEvent
|
||||||
= UndoKey
|
= UndoKey
|
||||||
| AbortKey
|
| AbortKey
|
||||||
| TranslateKey
|
| MouseTranslateKey
|
||||||
| UnknownKey Text
|
| MoveUp
|
||||||
|
| MoveLeft
|
||||||
|
| MoveDown
|
||||||
|
| MoveRight
|
||||||
|
| UnknownKey
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
-- | This is not an enmum so that new types of nodes can be created at
|
-- | This is not an enmum so that new types of nodes can be created at
|
||||||
-- runtime. Everything of type (Double, Double) is either (width,
|
-- runtime. Everything of type (Double, Double) is either (width,
|
||||||
@ -163,7 +172,9 @@ data Inputs = Inputs
|
|||||||
_inPrevTime :: !SystemTime,
|
_inPrevTime :: !SystemTime,
|
||||||
_inEvents :: ![InputEvent],
|
_inEvents :: ![InputEvent],
|
||||||
-- | If Something, then a translation is occuring.
|
-- | If Something, then a translation is occuring.
|
||||||
_inTranslation :: !(Maybe Panning)
|
_inTranslation :: !(Maybe Panning),
|
||||||
|
-- | All keys currently being pressed.
|
||||||
|
_inPressedKeys :: !(Set.Set KeyEvent)
|
||||||
}
|
}
|
||||||
|
|
||||||
-- TODO Consider extracting History and UndoPosition into their own "object".
|
-- TODO Consider extracting History and UndoPosition into their own "object".
|
||||||
@ -179,7 +190,7 @@ data AppState = AppState
|
|||||||
_asCurrentEdge :: !(Maybe Port),
|
_asCurrentEdge :: !(Maybe Port),
|
||||||
_asElements :: !(IntMap.IntMap Element),
|
_asElements :: !(IntMap.IntMap Element),
|
||||||
-- | FPS rounded down to nearest hundred if over 200 fps.
|
-- | FPS rounded down to nearest hundred if over 200 fps.
|
||||||
_asFPSr :: !Double,
|
_asFPSr :: !Int,
|
||||||
-- | A full history of the state of the app. Use addHistoryEvent
|
-- | A full history of the state of the app. Use addHistoryEvent
|
||||||
-- to add new HistoryEvents, do not add events directly.
|
-- to add new HistoryEvents, do not add events directly.
|
||||||
_asHistory :: ![Undoable HistoryEvent],
|
_asHistory :: ![Undoable HistoryEvent],
|
||||||
@ -312,7 +323,8 @@ emptyInputs =
|
|||||||
_inTime = MkSystemTime 0 0,
|
_inTime = MkSystemTime 0 0,
|
||||||
_inPrevTime = MkSystemTime 0 0,
|
_inPrevTime = MkSystemTime 0 0,
|
||||||
_inEvents = mempty,
|
_inEvents = mempty,
|
||||||
_inTranslation = Nothing
|
_inTranslation = Nothing,
|
||||||
|
_inPressedKeys = mempty
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Add a new HistoryEvent and reset _asUndoPosition.
|
-- | Add a new HistoryEvent and reset _asUndoPosition.
|
||||||
@ -409,9 +421,12 @@ updateBackground _canvas inputsRef stateRef = do
|
|||||||
|
|
||||||
state <- Cairo.liftIO $ readIORef stateRef
|
state <- Cairo.liftIO $ readIORef stateRef
|
||||||
inputs <- Cairo.liftIO $ readIORef inputsRef
|
inputs <- Cairo.liftIO $ readIORef inputsRef
|
||||||
Cairo.setSourceRGB 1 1 1
|
let fps = _asFPSr state
|
||||||
|
if fps >= 120
|
||||||
|
then Cairo.setSourceRGB 1 1 1
|
||||||
|
else Cairo.setSourceRGB 1 0 0
|
||||||
Cairo.moveTo 10 10
|
Cairo.moveTo 10 10
|
||||||
Cairo.showText ("fps=" <> show (_asFPSr state))
|
Cairo.showText ("fps=" <> show fps)
|
||||||
drawCurrentEdge (_inMouseXandY inputs) state
|
drawCurrentEdge (_inMouseXandY inputs) state
|
||||||
drawEdges state
|
drawEdges state
|
||||||
traverse_
|
traverse_
|
||||||
@ -429,18 +444,26 @@ findElementByPosition elements (mouseX, mouseY) =
|
|||||||
&& mouseY <= (y + height)
|
&& mouseY <= (y + height)
|
||||||
in find mouseInElement (IntMap.toList elements)
|
in find mouseInElement (IntMap.toList elements)
|
||||||
|
|
||||||
getFps :: Inputs -> Double
|
-- | Time between steps in seconds.
|
||||||
|
calcFrameTime :: Inputs -> Double
|
||||||
|
calcFrameTime Inputs {_inTime, _inPrevTime} =
|
||||||
|
frameTime
|
||||||
|
where
|
||||||
|
nanoToSecond nanoSecond = fromIntegral nanoSecond / (10 ^ (9 :: Int))
|
||||||
|
frameTime =
|
||||||
|
fromIntegral secondsDiff + nanosecondDiff
|
||||||
|
(MkSystemTime seconds nanoseconds) = _inTime
|
||||||
|
(MkSystemTime oldSeconds oldNanoseconds) = _inPrevTime
|
||||||
|
secondsDiff = seconds - oldSeconds
|
||||||
|
-- nanoseconds in MkSystemTime are unsigned, so they can not be directly subtracted.
|
||||||
|
nanosecondDiff = nanoToSecond nanoseconds - nanoToSecond oldNanoseconds
|
||||||
|
|
||||||
|
getFps :: Inputs -> Int
|
||||||
getFps inputs =
|
getFps inputs =
|
||||||
let (MkSystemTime seconds nanoseconds) = _inTime inputs
|
let fps :: Int
|
||||||
(MkSystemTime oldSeconds oldNanoseconds) = _inPrevTime inputs
|
fps = round $ 1 / calcFrameTime inputs
|
||||||
secondsDiff = seconds - oldSeconds
|
|
||||||
nanosecondDiff = nanoseconds - oldNanoseconds
|
|
||||||
fps =
|
|
||||||
if secondsDiff == 0
|
|
||||||
then fromIntegral (div (10 ^ (9 :: Int)) nanosecondDiff)
|
|
||||||
else 1 / fromIntegral secondsDiff
|
|
||||||
in if fps >= 200
|
in if fps >= 200
|
||||||
then fromIntegral $ div (truncate fps) 100 * (100 :: Int)
|
then div fps 100 * (100 :: Int)
|
||||||
else fps
|
else fps
|
||||||
|
|
||||||
clickOnNode ::
|
clickOnNode ::
|
||||||
@ -576,10 +599,23 @@ processInputs
|
|||||||
let compose = foldr (.) id
|
let compose = foldr (.) id
|
||||||
in compose (fmap (processInput inputs) _inEvents) oldState
|
in compose (fmap (processInput inputs) _inEvents) oldState
|
||||||
|
|
||||||
|
-- The amount by which to adjust the translation when the panning keys
|
||||||
|
-- are pressed.
|
||||||
|
keyPanAdjustment :: Double -> Set.Set KeyEvent -> (Double, Double)
|
||||||
|
keyPanAdjustment frameTime pressedKeys = (xAdjust, yAdjust)
|
||||||
|
where
|
||||||
|
moveAmount = frameTime * panSpeed
|
||||||
|
moveLeft = if Set.member MoveLeft pressedKeys then moveAmount else 0
|
||||||
|
moveRight = if Set.member MoveRight pressedKeys then (- moveAmount) else 0
|
||||||
|
moveUp = if Set.member MoveUp pressedKeys then moveAmount else 0
|
||||||
|
moveDown = if Set.member MoveDown pressedKeys then (- moveAmount) else 0
|
||||||
|
xAdjust = moveLeft + moveRight
|
||||||
|
yAdjust = moveUp + moveDown
|
||||||
|
|
||||||
-- | Update the state based on the inputs and the old state.
|
-- | Update the state based on the inputs and the old state.
|
||||||
updateState :: Inputs -> AppState -> AppState
|
updateState :: Inputs -> AppState -> AppState
|
||||||
updateState
|
updateState
|
||||||
inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation}
|
inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation, _inPressedKeys}
|
||||||
oldState@AppState {_asElements, _asMovingNode, _asTransform} =
|
oldState@AppState {_asElements, _asMovingNode, _asTransform} =
|
||||||
let -- Move the asMovingNode to MouseXandY
|
let -- Move the asMovingNode to MouseXandY
|
||||||
newElements = case _asMovingNode of
|
newElements = case _asMovingNode of
|
||||||
@ -596,21 +632,27 @@ updateState
|
|||||||
)
|
)
|
||||||
(_unElemId nodeId)
|
(_unElemId nodeId)
|
||||||
_asElements
|
_asElements
|
||||||
newTransform =
|
mousePanTranslate =
|
||||||
case _inTranslation of
|
case _inTranslation of
|
||||||
Nothing -> _asTransform
|
Nothing -> _tTranslate _asTransform
|
||||||
Just (Panning initialMousePosition initialTranslation) ->
|
Just (Panning initialMousePosition initialTranslation) ->
|
||||||
_asTransform
|
elementwiseOp
|
||||||
{ _tTranslate =
|
(+)
|
||||||
elementwiseOp
|
initialTranslation
|
||||||
(+)
|
(elementwiseOp (-) _inMouseXandY initialMousePosition)
|
||||||
initialTranslation
|
|
||||||
(elementwiseOp (-) _inMouseXandY initialMousePosition)
|
newTranslate =
|
||||||
}
|
elementwiseOp
|
||||||
|
(+)
|
||||||
|
mousePanTranslate
|
||||||
|
( keyPanAdjustment
|
||||||
|
(calcFrameTime inputs)
|
||||||
|
_inPressedKeys
|
||||||
|
)
|
||||||
in oldState
|
in oldState
|
||||||
{ _asElements = newElements,
|
{ _asElements = newElements,
|
||||||
_asFPSr = getFps inputs,
|
_asFPSr = getFps inputs,
|
||||||
_asTransform = newTransform
|
_asTransform = _asTransform {_tTranslate = newTranslate}
|
||||||
}
|
}
|
||||||
|
|
||||||
---------- Input Callbacks ---------------------------------
|
---------- Input Callbacks ---------------------------------
|
||||||
@ -681,11 +723,18 @@ addAbortAction inputsRef = do
|
|||||||
keyPress :: IORef Inputs -> IORef AppState -> KeyEvent -> IO ()
|
keyPress :: IORef Inputs -> IORef AppState -> KeyEvent -> IO ()
|
||||||
keyPress inputsRef stateRef keyEvent = do
|
keyPress inputsRef stateRef keyEvent = do
|
||||||
state <- readIORef stateRef
|
state <- readIORef stateRef
|
||||||
inputs <- readIORef inputsRef
|
preKeyPressedInputs <- readIORef inputsRef
|
||||||
|
let inputs =
|
||||||
|
preKeyPressedInputs
|
||||||
|
{ _inPressedKeys =
|
||||||
|
Set.insert keyEvent (_inPressedKeys preKeyPressedInputs)
|
||||||
|
}
|
||||||
|
writeIORef inputsRef inputs
|
||||||
|
print (_inPressedKeys inputs)
|
||||||
case keyEvent of
|
case keyEvent of
|
||||||
UndoKey -> addUndoInputAction inputsRef
|
UndoKey -> addUndoInputAction inputsRef
|
||||||
AbortKey -> addAbortAction inputsRef
|
AbortKey -> addAbortAction inputsRef
|
||||||
TranslateKey ->
|
MouseTranslateKey ->
|
||||||
if
|
if
|
||||||
| isNothing (_inTranslation inputs) ->
|
| isNothing (_inTranslation inputs) ->
|
||||||
writeIORef
|
writeIORef
|
||||||
@ -701,16 +750,28 @@ keyPress inputsRef stateRef keyEvent = do
|
|||||||
)
|
)
|
||||||
>> putStrLn "translate key pressed"
|
>> putStrLn "translate key pressed"
|
||||||
| otherwise -> pure ()
|
| otherwise -> pure ()
|
||||||
UnknownKey _ -> pure ()
|
UnknownKey -> pure ()
|
||||||
|
_ -> pure ()
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
keyRelease :: IORef Inputs -> KeyEvent -> IO ()
|
keyRelease :: IORef Inputs -> KeyEvent -> IO ()
|
||||||
keyRelease inputsRef keyEvent = do
|
keyRelease inputsRef keyEvent = do
|
||||||
|
modifyIORef'
|
||||||
|
inputsRef
|
||||||
|
( \inputs ->
|
||||||
|
inputs
|
||||||
|
{ _inPressedKeys = Set.delete keyEvent (_inPressedKeys inputs)
|
||||||
|
}
|
||||||
|
)
|
||||||
case keyEvent of
|
case keyEvent of
|
||||||
TranslateKey ->
|
MouseTranslateKey ->
|
||||||
modifyIORef'
|
modifyIORef'
|
||||||
inputsRef
|
inputsRef
|
||||||
(\inputs -> inputs {_inTranslation = Nothing})
|
( \inputs ->
|
||||||
|
inputs
|
||||||
|
{ _inTranslation = Nothing
|
||||||
|
}
|
||||||
|
)
|
||||||
>> putStrLn "translate key released"
|
>> putStrLn "translate key released"
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user