From c124aa27ef4750708740e7f9c8331d9d5adda507 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Sun, 6 Dec 2020 02:06:35 -0800 Subject: [PATCH] Press space to pan. --- gui/Main.hs | 88 +++++++++++++++++++++++++++++++++++++++++++++-------- todo.md | 8 +++-- 2 files changed, 81 insertions(+), 15 deletions(-) diff --git a/gui/Main.hs b/gui/Main.hs index 1e79fee..5cc87e1 100644 --- a/gui/Main.hs +++ b/gui/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,11 +17,12 @@ import Control.Monad.Trans.Reader (runReaderT) import Data.Coerce (Coercible) import Data.Foldable (traverse_) import Data.GI.Base (AttrOp ((:=)), new, withManagedPtr) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import qualified Data.IntMap.Strict as IntMap -- import qualified GI.GdkPixbuf as GP import Data.List (find) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isNothing) +import Data.Text (Text) import Data.Time.Clock.System (SystemTime (MkSystemTime), getSystemTime) import qualified Data.Tuple.Extra as Tuple import Foreign.Ptr (castPtr) @@ -41,6 +43,9 @@ minimumScale = 0.1 nodeSize :: (Double, Double) nodeSize = (100, 40) +translateKey :: Text +translateKey = " " + -- Types -- | A simple 2d transformation. See transform below for @@ -53,7 +58,7 @@ data Transform = Transform -- behaviour, although it would be cool if negative values -- produced a flip across both the X and Y axes. _tScale :: !Double, - -- (x, y) + -- | (x, y) _tTranslate :: !(Double, Double) } @@ -111,11 +116,21 @@ data Element = Element _elZ :: Int } +-- | When the translation key is first pressed, these values contain +-- the mouse position and (_tTranslate . _asTransform) at that moment. +data Panning = Panning + { _panMouse :: !(Double, Double), + _panTranslation :: !(Double, Double) + } + deriving (Eq, Ord, Show) + data Inputs = Inputs { _inMouseXandY :: !(Double, Double), _inTime :: SystemTime, _inPrevTime :: SystemTime, - _inEvents :: [InputEvent] + _inEvents :: [InputEvent], + -- | If Something, then a translation is occuring. + _inTranslation :: !(Maybe Panning) } -- TODO Consider extracting History and UndoPosition into their own "object". @@ -186,7 +201,8 @@ emptyInputs = { _inMouseXandY = (0, 0), _inTime = MkSystemTime 0 0, _inPrevTime = MkSystemTime 0 0, - _inEvents = mempty + _inEvents = mempty, + _inTranslation = Nothing } -- | Add a new HistoryEvent and reset _asUndoPosition. @@ -269,7 +285,9 @@ updateBackground _canvas stateRef = do Cairo.moveTo 10 10 Cairo.showText ("fps=" <> show (_asFPSr stateVal)) Cairo.setSourceRGB 1 0 0 - traverse_ (drawNode (_asTransform stateVal)) (IntMap.toList (_asElements stateVal)) + traverse_ + (drawNode (_asTransform stateVal)) + (IntMap.toList (_asElements stateVal)) findElementByPosition :: IntMap.IntMap Element -> (Double, Double) -> Maybe (Int, Element) @@ -390,7 +408,7 @@ processInputs -- | Update the state based on the inputs and the old state. updateState :: Inputs -> AppState -> AppState updateState - inputs@Inputs {_inMouseXandY, _inEvents} + inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation} oldState@AppState {_asElements, _asMovingNode, _asTransform} = let -- Move the asMovingNode to MouseXandY newElements = case _asMovingNode of @@ -407,9 +425,21 @@ updateState ) (_unElemId nodeId) _asElements + newTransform = + case _inTranslation of + Nothing -> _asTransform + Just (Panning initialMousePosition initialTranslation) -> + _asTransform + { _tTranslate = + elementwiseOp + (+) + initialTranslation + (elementwiseOp (-) _inMouseXandY initialMousePosition) + } in oldState { _asElements = newElements, - _asFPSr = getFps inputs + _asFPSr = getFps inputs, + _asTransform = newTransform } timeoutCallback :: @@ -523,25 +553,56 @@ addScaleAdjustAction scaleDelta inputsRef = do modifyIORef' inputsRef (addEvent (ScaleAdjustEvent scaleDelta)) pure () -keyPress :: IORef Inputs -> Gdk.EventKey -> IO Bool -keyPress inputsRef eventKey = do +keyPress :: IORef Inputs -> IORef AppState -> Gdk.EventKey -> IO Bool +keyPress 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 + state <- readIORef stateRef + inputs <- readIORef inputsRef case key of Just "\SUB" -> addUndoInputAction inputsRef -- ctrl-z pressed Just "\a" -> addAbortAction inputsRef -- ctrl-g - -- _ -> print key + Just str -> + if + | str == translateKey && isNothing (_inTranslation inputs) -> + writeIORef + inputsRef + ( inputs + { _inTranslation = + Just + ( Panning + (_inMouseXandY inputs) + (_tTranslate (_asTransform state)) + ) + } + ) + >> putStrLn "translate key pressed" + | otherwise -> pure () _ -> pure () pure Gdk.EVENT_STOP +keyRelease :: IORef Inputs -> Gdk.EventKey -> IO Bool +keyRelease 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 + if + | key == Just translateKey -> + modifyIORef' + inputsRef + (\inputs -> inputs {_inTranslation = Nothing}) + >> putStrLn "translate key released" + | otherwise -> pure () + pure Gdk.EVENT_STOP + scroll :: IORef Inputs -> Gdk.EventScroll -> IO Bool scroll inputsRef scrollEvent = do -- scale in (zooming in) is negative (usually -1), scale out -- (zooming out) is positive (usually 1) deltaY <- Gdk.getEventScrollDeltaY scrollEvent - print ("scroll y: " <> show deltaY) if deltaY /= 0.0 then addScaleAdjustAction (1 - (0.2 * deltaY)) inputsRef else pure () @@ -596,7 +657,8 @@ startApp app = do (timeoutCallback inputsRef stateRef gdkWindow device backgroundArea) _ <- Gtk.onWidgetButtonPressEvent backgroundArea (backgroundPress inputsRef stateRef) - _ <- Gtk.onWidgetKeyPressEvent window (keyPress inputsRef) + _ <- Gtk.onWidgetKeyPressEvent window (keyPress inputsRef stateRef) + _ <- Gtk.onWidgetKeyReleaseEvent window (keyRelease inputsRef) _ <- Gtk.onWidgetScrollEvent window (scroll inputsRef) #showAll window diff --git a/todo.md b/todo.md index 4ccae6d..23e41ba 100644 --- a/todo.md +++ b/todo.md @@ -1,7 +1,6 @@ # Todo ## GUI Todo Now -* Add panning ## Non-GUI Todo Now * Redesign case icon to avoid non-locality. @@ -9,8 +8,13 @@ * Add command line flags for color style, embedding, and whether to draw arrowheads. * Add wiki pages discussing: Why a visual language?, History of Glance, How to contribute, Code guide [code style, ...], etc.. -## Todo Later +## GUI Todo Later +* Connect nodes with lines * Display the undo state in the app [Bug #14](https://github.com/rgleichman/glance/issues/14) +* Scale based on mouse position +* Extract out GUI interface code (GTK and GDK) into a module. +* Refactor to make code extensible (e.g. records of functions instead of enums) +* Click a button that shows an image of the mouse and keyboard controls in a new window. ### Testing todos * Fix the arrowheads being too big for SyntaxGraph drawings.