mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 10:20:27 +03:00
Press space to pan.
This commit is contained in:
parent
f86a90f9d9
commit
c124aa27ef
88
gui/Main.hs
88
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
|
||||
|
8
todo.md
8
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.
|
||||
|
Loading…
Reference in New Issue
Block a user