mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +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 FlexibleContexts #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
@ -16,11 +17,12 @@ import Control.Monad.Trans.Reader (runReaderT)
|
|||||||
import Data.Coerce (Coercible)
|
import Data.Coerce (Coercible)
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Data.GI.Base (AttrOp ((:=)), new, withManagedPtr)
|
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 Data.IntMap.Strict as IntMap
|
||||||
-- import qualified GI.GdkPixbuf as GP
|
-- import qualified GI.GdkPixbuf as GP
|
||||||
import Data.List (find)
|
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 Data.Time.Clock.System (SystemTime (MkSystemTime), getSystemTime)
|
||||||
import qualified Data.Tuple.Extra as Tuple
|
import qualified Data.Tuple.Extra as Tuple
|
||||||
import Foreign.Ptr (castPtr)
|
import Foreign.Ptr (castPtr)
|
||||||
@ -41,6 +43,9 @@ minimumScale = 0.1
|
|||||||
nodeSize :: (Double, Double)
|
nodeSize :: (Double, Double)
|
||||||
nodeSize = (100, 40)
|
nodeSize = (100, 40)
|
||||||
|
|
||||||
|
translateKey :: Text
|
||||||
|
translateKey = " "
|
||||||
|
|
||||||
-- Types
|
-- Types
|
||||||
|
|
||||||
-- | A simple 2d transformation. See transform below for
|
-- | A simple 2d transformation. See transform below for
|
||||||
@ -53,7 +58,7 @@ data Transform = Transform
|
|||||||
-- behaviour, although it would be cool if negative values
|
-- behaviour, although it would be cool if negative values
|
||||||
-- produced a flip across both the X and Y axes.
|
-- produced a flip across both the X and Y axes.
|
||||||
_tScale :: !Double,
|
_tScale :: !Double,
|
||||||
-- (x, y)
|
-- | (x, y)
|
||||||
_tTranslate :: !(Double, Double)
|
_tTranslate :: !(Double, Double)
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -111,11 +116,21 @@ data Element = Element
|
|||||||
_elZ :: Int
|
_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
|
data Inputs = Inputs
|
||||||
{ _inMouseXandY :: !(Double, Double),
|
{ _inMouseXandY :: !(Double, Double),
|
||||||
_inTime :: SystemTime,
|
_inTime :: SystemTime,
|
||||||
_inPrevTime :: 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".
|
-- TODO Consider extracting History and UndoPosition into their own "object".
|
||||||
@ -186,7 +201,8 @@ emptyInputs =
|
|||||||
{ _inMouseXandY = (0, 0),
|
{ _inMouseXandY = (0, 0),
|
||||||
_inTime = MkSystemTime 0 0,
|
_inTime = MkSystemTime 0 0,
|
||||||
_inPrevTime = MkSystemTime 0 0,
|
_inPrevTime = MkSystemTime 0 0,
|
||||||
_inEvents = mempty
|
_inEvents = mempty,
|
||||||
|
_inTranslation = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Add a new HistoryEvent and reset _asUndoPosition.
|
-- | Add a new HistoryEvent and reset _asUndoPosition.
|
||||||
@ -269,7 +285,9 @@ updateBackground _canvas stateRef = do
|
|||||||
Cairo.moveTo 10 10
|
Cairo.moveTo 10 10
|
||||||
Cairo.showText ("fps=" <> show (_asFPSr stateVal))
|
Cairo.showText ("fps=" <> show (_asFPSr stateVal))
|
||||||
Cairo.setSourceRGB 1 0 0
|
Cairo.setSourceRGB 1 0 0
|
||||||
traverse_ (drawNode (_asTransform stateVal)) (IntMap.toList (_asElements stateVal))
|
traverse_
|
||||||
|
(drawNode (_asTransform stateVal))
|
||||||
|
(IntMap.toList (_asElements stateVal))
|
||||||
|
|
||||||
findElementByPosition ::
|
findElementByPosition ::
|
||||||
IntMap.IntMap Element -> (Double, Double) -> Maybe (Int, Element)
|
IntMap.IntMap Element -> (Double, Double) -> Maybe (Int, Element)
|
||||||
@ -390,7 +408,7 @@ processInputs
|
|||||||
-- | 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}
|
inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation}
|
||||||
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
|
||||||
@ -407,9 +425,21 @@ updateState
|
|||||||
)
|
)
|
||||||
(_unElemId nodeId)
|
(_unElemId nodeId)
|
||||||
_asElements
|
_asElements
|
||||||
|
newTransform =
|
||||||
|
case _inTranslation of
|
||||||
|
Nothing -> _asTransform
|
||||||
|
Just (Panning initialMousePosition initialTranslation) ->
|
||||||
|
_asTransform
|
||||||
|
{ _tTranslate =
|
||||||
|
elementwiseOp
|
||||||
|
(+)
|
||||||
|
initialTranslation
|
||||||
|
(elementwiseOp (-) _inMouseXandY initialMousePosition)
|
||||||
|
}
|
||||||
in oldState
|
in oldState
|
||||||
{ _asElements = newElements,
|
{ _asElements = newElements,
|
||||||
_asFPSr = getFps inputs
|
_asFPSr = getFps inputs,
|
||||||
|
_asTransform = newTransform
|
||||||
}
|
}
|
||||||
|
|
||||||
timeoutCallback ::
|
timeoutCallback ::
|
||||||
@ -523,25 +553,56 @@ addScaleAdjustAction scaleDelta inputsRef = do
|
|||||||
modifyIORef' inputsRef (addEvent (ScaleAdjustEvent scaleDelta))
|
modifyIORef' inputsRef (addEvent (ScaleAdjustEvent scaleDelta))
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
keyPress :: IORef Inputs -> Gdk.EventKey -> IO Bool
|
keyPress :: IORef Inputs -> IORef AppState -> Gdk.EventKey -> IO Bool
|
||||||
keyPress inputsRef eventKey = do
|
keyPress 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
|
key <- Gdk.getEventKeyString eventKey
|
||||||
|
state <- readIORef stateRef
|
||||||
|
inputs <- readIORef inputsRef
|
||||||
case key of
|
case key of
|
||||||
Just "\SUB" -> addUndoInputAction inputsRef -- ctrl-z pressed
|
Just "\SUB" -> addUndoInputAction inputsRef -- ctrl-z pressed
|
||||||
Just "\a" -> addAbortAction inputsRef -- ctrl-g
|
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 ()
|
||||||
pure Gdk.EVENT_STOP
|
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 :: IORef Inputs -> Gdk.EventScroll -> IO Bool
|
||||||
scroll inputsRef scrollEvent = do
|
scroll inputsRef scrollEvent = do
|
||||||
-- scale in (zooming in) is negative (usually -1), scale out
|
-- scale in (zooming in) is negative (usually -1), scale out
|
||||||
-- (zooming out) is positive (usually 1)
|
-- (zooming out) is positive (usually 1)
|
||||||
deltaY <- Gdk.getEventScrollDeltaY scrollEvent
|
deltaY <- Gdk.getEventScrollDeltaY scrollEvent
|
||||||
print ("scroll y: " <> show deltaY)
|
|
||||||
if deltaY /= 0.0
|
if deltaY /= 0.0
|
||||||
then addScaleAdjustAction (1 - (0.2 * deltaY)) inputsRef
|
then addScaleAdjustAction (1 - (0.2 * deltaY)) inputsRef
|
||||||
else pure ()
|
else pure ()
|
||||||
@ -596,7 +657,8 @@ startApp app = do
|
|||||||
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
||||||
|
|
||||||
_ <- Gtk.onWidgetButtonPressEvent backgroundArea (backgroundPress inputsRef stateRef)
|
_ <- 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)
|
_ <- Gtk.onWidgetScrollEvent window (scroll inputsRef)
|
||||||
|
|
||||||
#showAll window
|
#showAll window
|
||||||
|
8
todo.md
8
todo.md
@ -1,7 +1,6 @@
|
|||||||
# Todo
|
# Todo
|
||||||
|
|
||||||
## GUI Todo Now
|
## GUI Todo Now
|
||||||
* Add panning
|
|
||||||
|
|
||||||
## Non-GUI Todo Now
|
## Non-GUI Todo Now
|
||||||
* Redesign case icon to avoid non-locality.
|
* 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 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..
|
* 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)
|
* 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
|
### Testing todos
|
||||||
* Fix the arrowheads being too big for SyntaxGraph drawings.
|
* Fix the arrowheads being too big for SyntaxGraph drawings.
|
||||||
|
Loading…
Reference in New Issue
Block a user