mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
538 lines
20 KiB
Haskell
538 lines
20 KiB
Haskell
|
{-# LANGUAGE BangPatterns #-}
|
||
|
|
{-# LANGUAGE BlockArguments #-}
|
||
|
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE DerivingStrategies #-}
|
||
|
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE LambdaCase #-}
|
||
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
||
|
|
{-# LANGUAGE PatternSynonyms #-}
|
||
|
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
|
{-# LANGUAGE TypeApplications #-}
|
||
|
|
{-# LANGUAGE TypeOperators #-}
|
||
|
|
{-# LANGUAGE UndecidableInstances #-}
|
||
|
|
|
||
|
|
module MetaBrush.Action
|
||
|
|
( Actions, HandleAction(..)
|
||
|
|
, handleActions, signalAction, quitEverything
|
||
|
|
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
||
|
|
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
-- base
|
||
|
|
import Control.Monad
|
||
|
|
( guard, unless, void )
|
||
|
|
import Data.Foldable
|
||
|
|
( for_, traverse_ )
|
||
|
|
import Data.Maybe
|
||
|
|
( catMaybes )
|
||
|
|
import Data.Word
|
||
|
|
( Word32 )
|
||
|
|
|
||
|
|
-- acts
|
||
|
|
import Data.Act
|
||
|
|
( Act
|
||
|
|
( (•) )
|
||
|
|
, Torsor
|
||
|
|
( (-->) )
|
||
|
|
)
|
||
|
|
|
||
|
|
-- containers
|
||
|
|
import qualified Data.Map as Map
|
||
|
|
( lookup )
|
||
|
|
import Data.Sequence
|
||
|
|
( Seq(..) )
|
||
|
|
import qualified Data.Sequence as Seq
|
||
|
|
( fromList )
|
||
|
|
import qualified Data.Set as Set
|
||
|
|
( insert, delete )
|
||
|
|
|
||
|
|
-- gi-gdk
|
||
|
|
import qualified GI.Gdk as GDK
|
||
|
|
|
||
|
|
-- gi-gtk
|
||
|
|
import qualified GI.Gtk as GTK
|
||
|
|
|
||
|
|
-- haskus-utils-variant
|
||
|
|
import Haskus.Utils.Variant
|
||
|
|
( V, pattern V, ReduceVariant, reduceVariant
|
||
|
|
, type (:<)
|
||
|
|
)
|
||
|
|
|
||
|
|
-- stm
|
||
|
|
import Control.Concurrent.STM
|
||
|
|
( STM )
|
||
|
|
import qualified Control.Concurrent.STM as STM
|
||
|
|
( atomically, retry )
|
||
|
|
import qualified Control.Concurrent.STM.TQueue as STM
|
||
|
|
( TQueue, flushTQueue, writeTQueue )
|
||
|
|
import qualified Control.Concurrent.STM.TVar as STM
|
||
|
|
( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
|
||
|
|
|
||
|
|
-- MetaBrush
|
||
|
|
import Math.Bezier.Stroke
|
||
|
|
( StrokePoint(..) )
|
||
|
|
import Math.Module
|
||
|
|
( Module((*^)) )
|
||
|
|
import Math.Vector2D
|
||
|
|
( Point2D(..), Vector2D(..) )
|
||
|
|
import MetaBrush.Context
|
||
|
|
( UIElements(..), Variables(..)
|
||
|
|
, Modifier(..), modifierKey
|
||
|
|
, HoldAction(..), PartialPath(..)
|
||
|
|
, withCurrentDocument, modifyingCurrentDocument
|
||
|
|
)
|
||
|
|
import MetaBrush.Document
|
||
|
|
( Document(..)
|
||
|
|
, PointData(..), FocusState(..)
|
||
|
|
)
|
||
|
|
import MetaBrush.Document.Draw
|
||
|
|
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
|
||
|
|
import MetaBrush.Document.Selection
|
||
|
|
( SelectionMode(..), selectionMode
|
||
|
|
, selectAt, selectRectangle
|
||
|
|
, dragMoveSelect
|
||
|
|
, translateSelection
|
||
|
|
, deleteSelected
|
||
|
|
)
|
||
|
|
import MetaBrush.UI.Coordinates
|
||
|
|
( toViewportCoordinates )
|
||
|
|
import MetaBrush.UI.InfoBar
|
||
|
|
( updateInfoBar )
|
||
|
|
import MetaBrush.UI.FileBar
|
||
|
|
( TabLocation(..), newFileTab )
|
||
|
|
import MetaBrush.UI.ToolBar
|
||
|
|
( Tool(..) )
|
||
|
|
|
||
|
|
import Debug.Trace
|
||
|
|
|
||
|
|
--------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
type Actions = [ MouseMove, MouseClick, MouseRelease, Scroll, KeyboardPress, KeyboardRelease ]
|
||
|
|
|
||
|
|
class HandleAction action where
|
||
|
|
handleAction :: UIElements -> Variables -> action -> IO ()
|
||
|
|
|
||
|
|
instance ReduceVariant HandleAction actions => HandleAction ( V actions ) where
|
||
|
|
handleAction elts vars = reduceVariant @HandleAction ( handleAction elts vars )
|
||
|
|
|
||
|
|
handleActions :: ( Show action, HandleAction action ) => STM.TQueue action -> UIElements -> Variables -> IO Bool
|
||
|
|
handleActions actionTQueue elts vars = do
|
||
|
|
actions <- STM.atomically $ STM.flushTQueue actionTQueue
|
||
|
|
|
||
|
|
--actions <- STM.atomically do
|
||
|
|
-- actions <- STM.flushTQueue actionTQueue
|
||
|
|
-- if null actions
|
||
|
|
-- then STM.retry
|
||
|
|
-- else pure actions
|
||
|
|
traverse_ ( handleAction elts vars ) actions
|
||
|
|
pure True
|
||
|
|
|
||
|
|
signalAction :: action :< actions => STM.TQueue ( V actions ) -> action -> STM ()
|
||
|
|
signalAction tqueue = STM.writeTQueue tqueue . V
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- Quitting --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
quitEverything :: GTK.Window -> IO ()
|
||
|
|
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
|
||
|
|
|
||
|
|
--------------------
|
||
|
|
-- Mouse movement --
|
||
|
|
--------------------
|
||
|
|
|
||
|
|
data MouseMove = MouseMove ( Point2D Double )
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction MouseMove where
|
||
|
|
handleAction
|
||
|
|
( UIElements { viewportDrawingArea, infoBar } )
|
||
|
|
vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
|
||
|
|
( MouseMove ( Point2D x y ) )
|
||
|
|
= do
|
||
|
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||
|
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||
|
|
void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do
|
||
|
|
modifiers <- STM.readTVar modifiersTVar
|
||
|
|
let
|
||
|
|
toViewport :: Point2D Double -> Point2D Double
|
||
|
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||
|
|
pos :: Point2D Double
|
||
|
|
pos = toViewport ( Point2D x y )
|
||
|
|
STM.writeTVar mousePosTVar ( Just pos )
|
||
|
|
----------------------------------------------------------
|
||
|
|
-- With the pen tool, keeping control pressed while moving the mouse
|
||
|
|
-- moves the partial control point (if one exists).
|
||
|
|
tool <- STM.readTVar toolTVar
|
||
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||
|
|
case tool of
|
||
|
|
Pen
|
||
|
|
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||
|
|
, Just pp <- mbPartialPath
|
||
|
|
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
updateInfoBar viewportDrawingArea infoBar vars
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
|
||
|
|
-----------------
|
||
|
|
-- Mouse click --
|
||
|
|
-----------------
|
||
|
|
|
||
|
|
data MouseClick = MouseClick Word32 ( Point2D Double )
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction MouseClick where
|
||
|
|
handleAction
|
||
|
|
( UIElements { viewportDrawingArea } )
|
||
|
|
vars@( Variables { .. } )
|
||
|
|
( MouseClick button mouseClickCoords )
|
||
|
|
= case button of
|
||
|
|
|
||
|
|
-- Left mouse button.
|
||
|
|
1 -> do
|
||
|
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||
|
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||
|
|
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||
|
|
let
|
||
|
|
toViewport :: Point2D Double -> Point2D Double
|
||
|
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||
|
|
pos :: Point2D Double
|
||
|
|
pos = toViewport mouseClickCoords
|
||
|
|
STM.writeTVar mousePosTVar ( Just pos )
|
||
|
|
modifiers <- STM.readTVar modifiersTVar
|
||
|
|
tool <- STM.readTVar toolTVar
|
||
|
|
mode <- STM.readTVar modeTVar
|
||
|
|
case tool of
|
||
|
|
-- Selection mode mouse hold:
|
||
|
|
--
|
||
|
|
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
|
||
|
|
-- - If not holding shift or alt:
|
||
|
|
-- - if mouse click selected an object, initiate a drag move,
|
||
|
|
-- - otherwise, initiate a rectangular selection.
|
||
|
|
Selection ->
|
||
|
|
case selectionMode modifiers of
|
||
|
|
-- Drag move: not holding shift or alt, click has selected something.
|
||
|
|
New
|
||
|
|
| Just newDoc <- dragMoveSelect mode pos doc
|
||
|
|
-> do
|
||
|
|
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
|
||
|
|
pure ( Just newDoc )
|
||
|
|
-- Rectangular selection.
|
||
|
|
_ -> do
|
||
|
|
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
|
||
|
|
pure Nothing
|
||
|
|
|
||
|
|
-- Pen tool: start or continue a drawing operation.
|
||
|
|
Pen -> do
|
||
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||
|
|
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
||
|
|
case mbPartialPath of
|
||
|
|
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
||
|
|
Nothing -> do
|
||
|
|
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
|
||
|
|
STM.writeTVar partialPathTVar
|
||
|
|
( Just $ PartialPath
|
||
|
|
{ partialStartPos = anchorPt
|
||
|
|
, partialControlPoint = Nothing
|
||
|
|
, partialPathAnchor = drawAnchor
|
||
|
|
, firstPoint = True
|
||
|
|
}
|
||
|
|
)
|
||
|
|
pure ( Just newDoc )
|
||
|
|
-- Path already started: indicate that we are continuing a path.
|
||
|
|
Just pp -> do
|
||
|
|
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||
|
|
pure Nothing
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
|
||
|
|
-- Right mouse button: end partial path.
|
||
|
|
3 -> do
|
||
|
|
STM.atomically $ STM.writeTVar partialPathTVar Nothing
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
|
||
|
|
-- Other mouse buttons: ignored (for the moment at least).
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
|
||
|
|
-------------------
|
||
|
|
-- Mouse release --
|
||
|
|
-------------------
|
||
|
|
|
||
|
|
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction MouseRelease where
|
||
|
|
handleAction
|
||
|
|
( UIElements { viewportDrawingArea } )
|
||
|
|
vars@( Variables { .. } )
|
||
|
|
( MouseRelease button ( Point2D x y ) )
|
||
|
|
= case button of
|
||
|
|
|
||
|
|
-- Left mouse button.
|
||
|
|
1 -> do
|
||
|
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||
|
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||
|
|
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||
|
|
let
|
||
|
|
toViewport :: Point2D Double -> Point2D Double
|
||
|
|
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||
|
|
pos :: Point2D Double
|
||
|
|
pos = toViewport ( Point2D x y )
|
||
|
|
STM.writeTVar mousePosTVar ( Just pos )
|
||
|
|
modifiers <- STM.readTVar modifiersTVar
|
||
|
|
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
||
|
|
tool <- STM.readTVar toolTVar
|
||
|
|
mode <- STM.readTVar modeTVar
|
||
|
|
|
||
|
|
case tool of
|
||
|
|
|
||
|
|
Selection -> do
|
||
|
|
let
|
||
|
|
selMode :: SelectionMode
|
||
|
|
selMode = selectionMode modifiers
|
||
|
|
case mbHoldPos of
|
||
|
|
Just hold
|
||
|
|
| DragMoveHold pos0 <- hold
|
||
|
|
, pos0 /= pos
|
||
|
|
-> pure . Just $ translateSelection mode ( pos0 --> pos ) doc
|
||
|
|
| SelectionHold pos0 <- hold
|
||
|
|
, pos0 /= pos
|
||
|
|
-> pure . Just $ selectRectangle mode selMode pos0 pos doc
|
||
|
|
_ -> pure . Just $ selectAt mode selMode pos doc
|
||
|
|
|
||
|
|
Pen -> do
|
||
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||
|
|
case mbPartialPath of
|
||
|
|
-- Normal pen mode mouse click should have created an anchor.
|
||
|
|
-- If no anchor exists, then just ignore the mouse release event.
|
||
|
|
Nothing -> pure Nothing
|
||
|
|
-- Mouse click release possibilities:
|
||
|
|
--
|
||
|
|
-- - click was on complementary draw stroke draw anchor to close the path,
|
||
|
|
-- - release at same point as click: finish current segment,
|
||
|
|
-- - release at different point as click: finish current segment, adding a control point.
|
||
|
|
Just
|
||
|
|
( PartialPath
|
||
|
|
{ partialStartPos = p1
|
||
|
|
, partialControlPoint = mbCp2
|
||
|
|
, partialPathAnchor = anchor
|
||
|
|
, firstPoint
|
||
|
|
}
|
||
|
|
) -> do
|
||
|
|
let
|
||
|
|
pathPoint :: Point2D Double
|
||
|
|
mbControlPoint :: Maybe ( Point2D Double )
|
||
|
|
partialControlPoint :: Maybe ( Point2D Double )
|
||
|
|
( pathPoint, mbControlPoint, partialControlPoint )
|
||
|
|
| Just ( DrawHold holdPos ) <- mbHoldPos
|
||
|
|
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
|
||
|
|
| otherwise
|
||
|
|
= ( pos, Nothing, Nothing )
|
||
|
|
( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||
|
|
if not firstPoint && anchorsAreComplementary anchor otherAnchor
|
||
|
|
-- Close path.
|
||
|
|
then do
|
||
|
|
STM.writeTVar partialPathTVar Nothing
|
||
|
|
let
|
||
|
|
newSegment :: Seq ( StrokePoint PointData )
|
||
|
|
newSegment
|
||
|
|
= Seq.fromList
|
||
|
|
$ catMaybes
|
||
|
|
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
|
||
|
|
, do
|
||
|
|
cp <- mbCp2
|
||
|
|
guard ( cp /= p1 )
|
||
|
|
pure $ ControlPoint cp ( PointData Normal Empty )
|
||
|
|
, do
|
||
|
|
cp <- mbControlPoint
|
||
|
|
guard ( cp /= otherAnchorPt )
|
||
|
|
pure $ ControlPoint cp ( PointData Normal Empty )
|
||
|
|
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
|
||
|
|
]
|
||
|
|
pure ( Just $ addToAnchor anchor newSegment doc )
|
||
|
|
else
|
||
|
|
if firstPoint
|
||
|
|
-- Continue current partial path.
|
||
|
|
then do
|
||
|
|
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
|
||
|
|
pure Nothing
|
||
|
|
-- Finish current partial path.
|
||
|
|
else do
|
||
|
|
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
|
||
|
|
let
|
||
|
|
newSegment :: Seq ( StrokePoint PointData )
|
||
|
|
newSegment
|
||
|
|
= Seq.fromList
|
||
|
|
$ catMaybes
|
||
|
|
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
|
||
|
|
, do
|
||
|
|
cp <- mbCp2
|
||
|
|
guard ( cp /= p1 )
|
||
|
|
pure $ ControlPoint cp ( PointData Normal Empty )
|
||
|
|
, do
|
||
|
|
cp <- mbControlPoint
|
||
|
|
guard ( cp /= pathPoint )
|
||
|
|
pure $ ControlPoint cp ( PointData Normal Empty )
|
||
|
|
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
|
||
|
|
]
|
||
|
|
pure ( Just $ addToAnchor anchor newSegment doc )
|
||
|
|
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
|
||
|
|
-- Other mouse buttons: ignored (for the moment at least).
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
---------------
|
||
|
|
-- Scrolling --
|
||
|
|
---------------
|
||
|
|
|
||
|
|
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction Scroll where
|
||
|
|
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||
|
|
|
||
|
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||
|
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||
|
|
|
||
|
|
unless ( dx == 0 && dy == 0 ) do
|
||
|
|
STM.atomically $ modifyingCurrentDocument vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||
|
|
modifiers <- STM.readTVar modifiersTVar
|
||
|
|
let
|
||
|
|
toViewport :: Point2D Double -> Point2D Double
|
||
|
|
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
|
||
|
|
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
|
||
|
|
mousePos :: Point2D Double
|
||
|
|
mousePos = toViewport ( Point2D x y )
|
||
|
|
newDoc :: Document
|
||
|
|
newDoc
|
||
|
|
-- Zooming using 'Control'.
|
||
|
|
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||
|
|
= let
|
||
|
|
newZoomFactor :: Double
|
||
|
|
newZoomFactor
|
||
|
|
| dy > 0
|
||
|
|
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
|
||
|
|
| otherwise
|
||
|
|
= min 256 ( oldZoomFactor * sqrt 2 )
|
||
|
|
newCenter :: Point2D Double
|
||
|
|
newCenter
|
||
|
|
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
|
||
|
|
• oldCenter
|
||
|
|
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
|
||
|
|
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||
|
|
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
|
||
|
|
= let
|
||
|
|
newCenter :: Point2D Double
|
||
|
|
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
|
||
|
|
in doc { viewportCenter = newCenter }
|
||
|
|
-- Vertical scrolling.
|
||
|
|
| otherwise
|
||
|
|
= let
|
||
|
|
newCenter :: Point2D Double
|
||
|
|
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
|
||
|
|
in doc { viewportCenter = newCenter }
|
||
|
|
finalZoomFactor :: Double
|
||
|
|
finalZoomFactor = zoomFactor newDoc
|
||
|
|
finalCenter :: Point2D Double
|
||
|
|
finalCenter = viewportCenter newDoc
|
||
|
|
toFinalViewport :: Point2D Double -> Point2D Double
|
||
|
|
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
|
||
|
|
finalMousePos :: Point2D Double
|
||
|
|
finalMousePos = toFinalViewport ( Point2D x y )
|
||
|
|
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||
|
|
pure ( Just newDoc )
|
||
|
|
updateInfoBar viewportDrawingArea infoBar vars
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
|
||
|
|
--------------------
|
||
|
|
-- Keyboard press --
|
||
|
|
--------------------
|
||
|
|
|
||
|
|
data KeyboardPress = KeyboardPress Word32
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction KeyboardPress where
|
||
|
|
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
|
||
|
|
|
||
|
|
modifiers <- STM.atomically do
|
||
|
|
!modifiers <- STM.readTVar modifiersTVar
|
||
|
|
for_ ( modifierKey keyCode ) \ modifier ->
|
||
|
|
( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
|
||
|
|
pure modifiers
|
||
|
|
|
||
|
|
case keyCode of
|
||
|
|
|
||
|
|
GDK.KEY_Escape -> quitEverything window
|
||
|
|
|
||
|
|
GDK.KEY_Return -> do
|
||
|
|
tool <- STM.readTVarIO toolTVar
|
||
|
|
case tool of
|
||
|
|
-- End ongoing drawing on pressing enter key.
|
||
|
|
Pen -> do
|
||
|
|
STM.atomically $ STM.writeTVar partialPathTVar Nothing
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
GDK.KEY_Delete -> do
|
||
|
|
tool <- STM.readTVarIO toolTVar
|
||
|
|
mode <- STM.readTVarIO modeTVar
|
||
|
|
case tool of
|
||
|
|
-- Delete selected points on pressing 'Delete'.
|
||
|
|
Selection -> do
|
||
|
|
STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
ctrl
|
||
|
|
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
|
||
|
|
-> do
|
||
|
|
----------------------------------------------------------
|
||
|
|
-- With the pen tool, pressing control moves
|
||
|
|
-- the partial point control point to the mouse position.
|
||
|
|
tool <- STM.readTVarIO toolTVar
|
||
|
|
mbMousePos <- STM.readTVarIO mousePosTVar
|
||
|
|
mbPartialPath <- STM.readTVarIO partialPathTVar
|
||
|
|
case tool of
|
||
|
|
Pen
|
||
|
|
| Just mp <- mbMousePos
|
||
|
|
, Just pp <- mbPartialPath
|
||
|
|
-> do
|
||
|
|
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
|
||
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
GDK.KEY_F1 -> do
|
||
|
|
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||
|
|
for_ mbActiveDoc \ i -> do
|
||
|
|
docs <- STM.readTVarIO openDocumentsTVar
|
||
|
|
for_ ( Map.lookup i docs ) \ doc -> do
|
||
|
|
writeFile "log.txt" ( show doc <> "\n\n" )
|
||
|
|
|
||
|
|
-- Create a new document with Ctrl+N
|
||
|
|
n
|
||
|
|
| ( n == GDK.KEY_n || n == GDK.KEY_N )
|
||
|
|
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||
|
|
->
|
||
|
|
newFileTab
|
||
|
|
vars
|
||
|
|
window title fileBar viewportDrawingArea infoBar
|
||
|
|
Nothing
|
||
|
|
AfterCurrentTab
|
||
|
|
|
||
|
|
_ -> pure ()
|
||
|
|
|
||
|
|
----------------------
|
||
|
|
-- Keyboard release --
|
||
|
|
----------------------
|
||
|
|
|
||
|
|
data KeyboardRelease = KeyboardRelease Word32
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
instance HandleAction KeyboardRelease where
|
||
|
|
handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
|
||
|
|
for_ ( modifierKey keyCode ) \ modifier -> do
|
||
|
|
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )
|