From 33280502f278456294acc3304f9ff3487d28188c Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Tue, 22 Dec 2020 20:59:33 -0800 Subject: [PATCH] Pan with wasd. Make low frame rates red. --- gui/GtkGui.hs | 65 +++++++++++++++------- gui/GuiInternals.hs | 129 ++++++++++++++++++++++++++++++++------------ 2 files changed, 141 insertions(+), 53 deletions(-) diff --git a/gui/GtkGui.hs b/gui/GtkGui.hs index ec2c9b1..0f390e3 100644 --- a/gui/GtkGui.hs +++ b/gui/GtkGui.hs @@ -18,9 +18,11 @@ module GtkGui (gtkMain) where import Control.Monad.IO.Class (MonadIO) import Data.GI.Base (AttrOp ((:=)), new) import Data.IORef (IORef, newIORef) +import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Text (Text) import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word16) import GHC.Word (Word32) import qualified GI.GLib as GLib import qualified GI.Gdk as Gdk @@ -29,8 +31,8 @@ import qualified GI.Gtk as Gtk import GuiInternals ( AppState, Inputs, - KeyEvent (AbortKey, TranslateKey, UndoKey, UnknownKey), - MouseButton (UnknownMouseButton), + KeyEvent (..), + MouseButton (..), backgroundPress, emptyAppState, emptyInputs, @@ -43,8 +45,22 @@ import GuiInternals ) --------- Constants ------------- -translateKey :: Text -translateKey = " " +keyStrings :: Map.Map Text KeyEvent +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 -- mouse button numbers via Enum, so order is important! @@ -100,20 +116,33 @@ backgroundPressCallback inputsRef stateRef eventButton = do backgroundPress inputsRef stateRef mouseButton rawMousePosition 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 inputsRef stateRef eventKey = do -- TODO May want to check that ctrl is pressed by checking that -- getEventKeyState is ModifierTypeControlMask. May also want to use -- Gdk.KEY_?. - key <- Gdk.getEventKeyString eventKey - let keyEvent = case key of - Nothing -> UnknownKey "" - Just "\SUB" -> UndoKey -- ctrl-z pressed - Just "\a" -> AbortKey -- ctrl-g - Just str -> - if - | str == translateKey -> TranslateKey - | otherwise -> UnknownKey str + -- + -- The KeyString is the character that was typed. This is affected + -- by the keyboard layout. + mKey <- Gdk.getEventKeyString eventKey + -- The hardware keycode is a number corresponding to a specific + -- physical key on the keyboard, so changing the keyboard layout has + -- no affect on the keycode. + keyCode <- Gdk.getEventKeyHardwareKeycode eventKey + -- putStrLn $ "key: " <> show mKey + -- putStrLn $ "keycode: " <> show keyCode + let keyEvent = decodeKey mKey keyCode + -- print keyEvent keyPress inputsRef stateRef keyEvent pure Gdk.EVENT_STOP @@ -122,11 +151,9 @@ keyReleaseCallback inputsRef eventKey = do -- TODO May want to check that ctrl is pressed by checking that -- getEventKeyState is ModifierTypeControlMask. May also want to use -- Gdk.KEY_?. - key <- Gdk.getEventKeyString eventKey - let keyEvent = - if - | key == Just translateKey -> TranslateKey - | otherwise -> UnknownKey "" + mKey <- Gdk.getEventKeyString eventKey + keyCode <- Gdk.getEventKeyHardwareKeycode eventKey + let keyEvent = decodeKey mKey keyCode keyRelease inputsRef keyEvent pure Gdk.EVENT_STOP @@ -183,7 +210,7 @@ startApp app = do _ <- GLib.timeoutAdd GLib.PRIORITY_DEFAULT - 1 + 2 -- milliseconds between callbacks (timeoutCallback inputsRef stateRef gdkWindow device backgroundArea) _ <- diff --git a/gui/GuiInternals.hs b/gui/GuiInternals.hs index 74ee5b0..b99cee0 100644 --- a/gui/GuiInternals.hs +++ b/gui/GuiInternals.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} @@ -39,7 +40,7 @@ import Data.List (find) -- import Debug.Trace (trace) import Data.Maybe (isNothing) -import Data.Text (Text) +import qualified Data.Set as Set import Data.Time.Clock.System (SystemTime (MkSystemTime)) import qualified Data.Tuple.Extra as Tuple import Foreign.Ptr (castPtr) @@ -52,6 +53,9 @@ import Graphics.Rendering.Cairo.Types (Cairo (Cairo)) minimumScale :: Double minimumScale = 0.1 +panSpeed :: Double +panSpeed = 2000 + -- Types -- | An Enum of mouse buttons, so order is important! @@ -66,8 +70,13 @@ data MouseButton data KeyEvent = UndoKey | AbortKey - | TranslateKey - | UnknownKey Text + | MouseTranslateKey + | MoveUp + | MoveLeft + | MoveDown + | MoveRight + | UnknownKey + deriving (Eq, Ord, Show) -- | This is not an enmum so that new types of nodes can be created at -- runtime. Everything of type (Double, Double) is either (width, @@ -163,7 +172,9 @@ data Inputs = Inputs _inPrevTime :: !SystemTime, _inEvents :: ![InputEvent], -- | 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". @@ -179,7 +190,7 @@ data AppState = AppState _asCurrentEdge :: !(Maybe Port), _asElements :: !(IntMap.IntMap Element), -- | 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 -- to add new HistoryEvents, do not add events directly. _asHistory :: ![Undoable HistoryEvent], @@ -312,7 +323,8 @@ emptyInputs = _inTime = MkSystemTime 0 0, _inPrevTime = MkSystemTime 0 0, _inEvents = mempty, - _inTranslation = Nothing + _inTranslation = Nothing, + _inPressedKeys = mempty } -- | Add a new HistoryEvent and reset _asUndoPosition. @@ -409,9 +421,12 @@ updateBackground _canvas inputsRef stateRef = do state <- Cairo.liftIO $ readIORef stateRef 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.showText ("fps=" <> show (_asFPSr state)) + Cairo.showText ("fps=" <> show fps) drawCurrentEdge (_inMouseXandY inputs) state drawEdges state traverse_ @@ -429,18 +444,26 @@ findElementByPosition elements (mouseX, mouseY) = && mouseY <= (y + height) 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 = - let (MkSystemTime seconds nanoseconds) = _inTime inputs - (MkSystemTime oldSeconds oldNanoseconds) = _inPrevTime inputs - secondsDiff = seconds - oldSeconds - nanosecondDiff = nanoseconds - oldNanoseconds - fps = - if secondsDiff == 0 - then fromIntegral (div (10 ^ (9 :: Int)) nanosecondDiff) - else 1 / fromIntegral secondsDiff + let fps :: Int + fps = round $ 1 / calcFrameTime inputs in if fps >= 200 - then fromIntegral $ div (truncate fps) 100 * (100 :: Int) + then div fps 100 * (100 :: Int) else fps clickOnNode :: @@ -576,10 +599,23 @@ processInputs let compose = foldr (.) id 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. updateState :: Inputs -> AppState -> AppState updateState - inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation} + inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation, _inPressedKeys} oldState@AppState {_asElements, _asMovingNode, _asTransform} = let -- Move the asMovingNode to MouseXandY newElements = case _asMovingNode of @@ -596,21 +632,27 @@ updateState ) (_unElemId nodeId) _asElements - newTransform = + mousePanTranslate = case _inTranslation of - Nothing -> _asTransform + Nothing -> _tTranslate _asTransform Just (Panning initialMousePosition initialTranslation) -> - _asTransform - { _tTranslate = - elementwiseOp - (+) - initialTranslation - (elementwiseOp (-) _inMouseXandY initialMousePosition) - } + elementwiseOp + (+) + initialTranslation + (elementwiseOp (-) _inMouseXandY initialMousePosition) + + newTranslate = + elementwiseOp + (+) + mousePanTranslate + ( keyPanAdjustment + (calcFrameTime inputs) + _inPressedKeys + ) in oldState { _asElements = newElements, _asFPSr = getFps inputs, - _asTransform = newTransform + _asTransform = _asTransform {_tTranslate = newTranslate} } ---------- Input Callbacks --------------------------------- @@ -681,11 +723,18 @@ addAbortAction inputsRef = do keyPress :: IORef Inputs -> IORef AppState -> KeyEvent -> IO () keyPress inputsRef stateRef keyEvent = do 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 UndoKey -> addUndoInputAction inputsRef AbortKey -> addAbortAction inputsRef - TranslateKey -> + MouseTranslateKey -> if | isNothing (_inTranslation inputs) -> writeIORef @@ -701,16 +750,28 @@ keyPress inputsRef stateRef keyEvent = do ) >> putStrLn "translate key pressed" | otherwise -> pure () - UnknownKey _ -> pure () + UnknownKey -> pure () + _ -> pure () pure () keyRelease :: IORef Inputs -> KeyEvent -> IO () keyRelease inputsRef keyEvent = do + modifyIORef' + inputsRef + ( \inputs -> + inputs + { _inPressedKeys = Set.delete keyEvent (_inPressedKeys inputs) + } + ) case keyEvent of - TranslateKey -> + MouseTranslateKey -> modifyIORef' inputsRef - (\inputs -> inputs {_inTranslation = Nothing}) + ( \inputs -> + inputs + { _inTranslation = Nothing + } + ) >> putStrLn "translate key released" _ -> pure ()