mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
997 lines
34 KiB
Haskell
997 lines
34 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module MetaBrush.Action where
|
|
|
|
-- base
|
|
import Control.Monad
|
|
( guard, when, unless, void )
|
|
import Data.Foldable
|
|
( for_ )
|
|
import Data.Int
|
|
( Int32 )
|
|
import Data.Maybe
|
|
( catMaybes, listToMaybe )
|
|
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 )
|
|
|
|
-- directory
|
|
import System.Directory
|
|
( doesDirectoryExist, listDirectory )
|
|
|
|
-- filepath
|
|
import System.FilePath
|
|
( (</>), (<.>), takeExtension )
|
|
|
|
-- generic-lens
|
|
import Data.Generics.Product.Fields
|
|
( field' )
|
|
|
|
-- gi-gdk
|
|
import qualified GI.Gdk as GDK
|
|
|
|
-- gi-gtk
|
|
import qualified GI.Gtk as GTK
|
|
|
|
-- lens
|
|
import Control.Lens
|
|
( over, set )
|
|
import Control.Lens.At
|
|
( ix, at )
|
|
|
|
-- stm
|
|
import qualified Control.Concurrent.STM as STM
|
|
( atomically )
|
|
import qualified Control.Concurrent.STM.TVar as STM
|
|
( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
|
|
|
|
-- text
|
|
import Data.Text
|
|
( Text )
|
|
|
|
-- MetaBrush
|
|
import Math.Bezier.Stroke
|
|
( StrokePoint(..) )
|
|
import Math.Module
|
|
( Module((*^)) )
|
|
import Math.Vector2D
|
|
( Point2D(..), Vector2D(..) )
|
|
import MetaBrush.Context
|
|
( UIElements(..), Variables(..)
|
|
, Modifier(..), modifierKey
|
|
, HoldAction(..), GuideAction(..), PartialPath(..)
|
|
, currentDocument, withCurrentDocument
|
|
, PureDocModification(..), DocModification(..)
|
|
, modifyingCurrentDocument
|
|
, updateTitle
|
|
)
|
|
import MetaBrush.Document
|
|
( Document(..), Guide(..)
|
|
, PointData(..), FocusState(..)
|
|
)
|
|
import MetaBrush.Document.Draw
|
|
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
|
|
import MetaBrush.Document.Guide
|
|
( selectGuide, addGuide )
|
|
import MetaBrush.Document.Selection
|
|
( SelectionMode(..), selectionMode
|
|
, selectAt, selectRectangle
|
|
, dragMoveSelect
|
|
, translateSelection
|
|
, deleteSelected
|
|
)
|
|
import MetaBrush.Document.Serialise
|
|
( saveDocument, loadDocument )
|
|
import MetaBrush.Document.SubdivideStroke
|
|
( subdivide )
|
|
import MetaBrush.UI.Coordinates
|
|
( toViewportCoordinates )
|
|
import MetaBrush.UI.InfoBar
|
|
( updateInfoBar )
|
|
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
|
( TabLocation(..), newFileTab, removeFileTab )
|
|
import MetaBrush.UI.Menu
|
|
( MenuItem(..), Menu(..), ViewMenu(..) )
|
|
import MetaBrush.UI.ToolBar
|
|
( Tool(..) )
|
|
import MetaBrush.UI.Viewport
|
|
( Viewport(..), Ruler(..) )
|
|
import MetaBrush.Unique
|
|
( Unique )
|
|
import MetaBrush.Util
|
|
( widgetAddClass, widgetAddClasses )
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
class HandleAction action where
|
|
handleAction :: UIElements -> Variables -> action -> IO ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- General actions
|
|
|
|
instance HandleAction () where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
--------------
|
|
-- New file --
|
|
--------------
|
|
|
|
data NewFile = NewFile TabLocation
|
|
deriving stock Show
|
|
|
|
instance HandleAction NewFile where
|
|
handleAction uiElts vars ( NewFile tabLoc ) =
|
|
newFileTab uiElts vars Nothing tabLoc
|
|
|
|
---------------
|
|
-- Open file --
|
|
---------------
|
|
|
|
data OpenFile = OpenFile TabLocation
|
|
deriving stock Show
|
|
|
|
instance HandleAction OpenFile where
|
|
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFile tabLoc ) = do
|
|
fileChooser <-
|
|
GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
|
|
GTK.FileChooserActionOpen
|
|
( Just "Open" )
|
|
( Just "Cancel" )
|
|
GTK.fileChooserSetSelectMultiple fileChooser True
|
|
GTK.nativeDialogSetModal fileChooser True
|
|
fileFilter <- GTK.fileFilterNew
|
|
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
|
|
GTK.fileFilterAddPattern fileFilter "*.mb"
|
|
GTK.fileChooserAddFilter fileChooser fileFilter
|
|
void $ GTK.nativeDialogRun fileChooser
|
|
filePaths <- GTK.fileChooserGetFilenames fileChooser
|
|
for_ filePaths \ filePath -> do
|
|
mbDoc <- loadDocument uniqueSupply filePath
|
|
case mbDoc of
|
|
Left _errMessage -> pure () -- TODO: show warning dialog?
|
|
Right doc -> do
|
|
newFileTab uiElts vars ( Just doc ) tabLoc
|
|
|
|
-----------------
|
|
-- Open folder --
|
|
-----------------
|
|
|
|
data OpenFolder = OpenFolder TabLocation
|
|
deriving stock Show
|
|
|
|
instance HandleAction OpenFolder where
|
|
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFolder tabLoc ) = do
|
|
fileChooser <-
|
|
GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
|
|
GTK.FileChooserActionSelectFolder
|
|
( Just "Select Folder" )
|
|
( Just "Cancel" )
|
|
GTK.fileChooserSetSelectMultiple fileChooser True
|
|
GTK.nativeDialogSetModal fileChooser True
|
|
void $ GTK.nativeDialogRun fileChooser
|
|
folderPaths <- GTK.fileChooserGetFilenames fileChooser
|
|
for_ folderPaths \ folderPath -> do
|
|
exists <- doesDirectoryExist folderPath
|
|
when exists do
|
|
filePaths <- listDirectory folderPath
|
|
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
|
|
mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
|
|
case mbDoc of
|
|
Left _errMessage -> pure () -- TODO: show warning dialog?
|
|
Right doc -> do
|
|
newFileTab uiElts vars ( Just doc ) tabLoc
|
|
pure ()
|
|
|
|
---------------
|
|
-- Save file --
|
|
---------------
|
|
|
|
data Save = Save
|
|
deriving stock Show
|
|
|
|
instance HandleAction Save where
|
|
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
|
|
save uiElts vars True
|
|
|
|
save :: UIElements -> Variables -> Bool -> IO ()
|
|
save uiElts vars keepOpen = do
|
|
mbDoc <- STM.atomically $ currentDocument vars
|
|
for_ mbDoc \case
|
|
doc@( Document { mbFilePath, unsavedChanges } )
|
|
| Nothing <- mbFilePath
|
|
-> saveAs uiElts vars keepOpen
|
|
| False <- unsavedChanges
|
|
-> pure ()
|
|
| Just filePath <- mbFilePath
|
|
-> modifyingCurrentDocument uiElts vars \ _ -> do
|
|
let
|
|
doc' :: Document
|
|
doc' = doc { unsavedChanges = False }
|
|
if keepOpen
|
|
then
|
|
pure $ UpdateDocToAndThen
|
|
( Just doc' )
|
|
( saveDocument filePath doc' )
|
|
else
|
|
pure $ UpdateDocToAndThen Nothing ( saveDocument filePath doc' )
|
|
|
|
-------------
|
|
-- Save as --
|
|
-------------
|
|
|
|
data SaveAs = SaveAs
|
|
deriving stock Show
|
|
|
|
instance HandleAction SaveAs where
|
|
handleAction uiElts vars _ = saveAs uiElts vars True
|
|
|
|
saveAs :: UIElements -> Variables -> Bool -> IO ()
|
|
saveAs uiElts vars keepOpen = do
|
|
mbSavePath <- askForSavePath uiElts
|
|
for_ mbSavePath \ savePath -> do
|
|
modifyingCurrentDocument uiElts vars \ doc -> do
|
|
let
|
|
doc' :: Document
|
|
doc' = doc { mbFilePath = Just savePath, unsavedChanges = False }
|
|
if keepOpen
|
|
then
|
|
pure $ UpdateDocToAndThen
|
|
( Just doc' )
|
|
( saveDocument savePath doc' )
|
|
else
|
|
pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )
|
|
|
|
askForSavePath :: UIElements -> IO ( Maybe FilePath )
|
|
askForSavePath ( UIElements {..} ) = do
|
|
fileChooser <-
|
|
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
|
|
GTK.FileChooserActionSave
|
|
( Just "Save" )
|
|
( Just "Cancel" )
|
|
GTK.nativeDialogSetModal fileChooser True
|
|
GTK.fileChooserSetDoOverwriteConfirmation fileChooser True
|
|
fileFilter <- GTK.fileFilterNew
|
|
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
|
|
GTK.fileFilterAddPattern fileFilter "*.mb"
|
|
GTK.fileChooserAddFilter fileChooser fileFilter
|
|
void $ GTK.nativeDialogRun fileChooser
|
|
fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
|
|
where
|
|
fullFilePath :: FilePath -> FilePath
|
|
fullFilePath fp
|
|
| ".mb" <- takeExtension fp
|
|
= fp
|
|
| otherwise
|
|
= fp <.> "mb"
|
|
|
|
-----------
|
|
-- Close --
|
|
-----------
|
|
|
|
data Close
|
|
= CloseActive -- ^ Close active document.
|
|
| CloseThis -- ^ Close a specific tab.
|
|
{ docToClose :: Unique }
|
|
deriving stock Show
|
|
|
|
pattern JustClose, SaveAndClose, CancelClose :: Int32
|
|
pattern JustClose = 1
|
|
pattern SaveAndClose = 2
|
|
pattern CancelClose = 3
|
|
|
|
instance HandleAction Close where
|
|
handleAction
|
|
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
|
vars@( Variables {..} )
|
|
close = do
|
|
mbDoc <- case close of
|
|
CloseActive -> STM.atomically ( currentDocument vars )
|
|
CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
|
case mbDoc of
|
|
Nothing -> pure () -- could show a warning message
|
|
Just ( Document { displayName, documentUnique, unsavedChanges } )
|
|
| unsavedChanges
|
|
-> do
|
|
dialog <- GTK.new GTK.MessageDialog []
|
|
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
|
|
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
|
|
GTK.setWindowResizable dialog False
|
|
GTK.setWindowDecorated dialog False
|
|
GTK.windowSetTransientFor dialog ( Just window )
|
|
GTK.windowSetModal dialog True
|
|
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
|
|
closeButton <- GTK.dialogAddButton dialog "Close" JustClose
|
|
saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
|
|
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
|
|
GTK.dialogSetDefaultResponse dialog 1
|
|
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
|
choice <- GTK.dialogRun dialog
|
|
GTK.widgetDestroy dialog
|
|
case choice of
|
|
JustClose -> closeDocument documentUnique
|
|
SaveAndClose -> save uiElts vars False
|
|
_ -> pure ()
|
|
| otherwise
|
|
-> closeDocument documentUnique
|
|
|
|
where
|
|
closeDocument :: Unique -> IO ()
|
|
closeDocument unique = do
|
|
removeFileTab vars unique
|
|
updateTitle window title Nothing
|
|
updateInfoBar viewportDrawingArea infoBar vars
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
|
|
|
---------------------
|
|
-- Switch document --
|
|
---------------------
|
|
|
|
data SwitchTo = SwitchTo Unique
|
|
deriving stock Show
|
|
|
|
instance HandleAction SwitchTo where
|
|
handleAction
|
|
( UIElements { viewport = Viewport {..}, .. } )
|
|
vars@( Variables {..} )
|
|
( SwitchTo newUnique ) = do
|
|
mbNewDocAndTab <- STM.atomically do
|
|
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
|
newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
|
|
newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
|
|
pure ( (,) <$> newDoc <*> newTab )
|
|
case mbNewDocAndTab of
|
|
Nothing -> updateTitle window title Nothing
|
|
Just ( Document {..}, tab ) -> do
|
|
updateTitle window title ( Just ( displayName, unsavedChanges ) )
|
|
updateInfoBar viewportDrawingArea infoBar vars
|
|
GTK.widgetQueueDraw tab
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
|
|
|
--------------
|
|
-- Quitting --
|
|
--------------
|
|
|
|
data Quit = Quit
|
|
deriving stock Show
|
|
|
|
instance HandleAction Quit where
|
|
handleAction ( UIElements { window } ) _ _ = quitEverything window
|
|
|
|
quitEverything :: GTK.Window -> IO ()
|
|
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
|
|
|
|
----------
|
|
-- Undo --
|
|
----------
|
|
|
|
data Undo = Undo
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Undo where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
----------
|
|
-- Redo --
|
|
----------
|
|
|
|
data Redo = Redo
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Redo where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
---------------------
|
|
-- Discard changes --
|
|
---------------------
|
|
|
|
data DiscardChanges = DiscardChanges
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction DiscardChanges where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
---------
|
|
-- Cut --
|
|
---------
|
|
|
|
data Cut = Cut
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Cut where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
----------
|
|
-- Copy --
|
|
----------
|
|
|
|
data Copy = Copy
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Copy where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
-----------
|
|
-- Paste --
|
|
-----------
|
|
|
|
data Paste = Paste
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Paste where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
---------------
|
|
-- Duplicate --
|
|
---------------
|
|
|
|
data Duplicate = Duplicate
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction Duplicate where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
------------
|
|
-- Delete --
|
|
------------
|
|
|
|
data Delete = Delete
|
|
deriving stock Show
|
|
|
|
instance HandleAction Delete where
|
|
handleAction
|
|
uiElts
|
|
vars@( Variables { toolTVar, modeTVar } )
|
|
_
|
|
= do
|
|
tool <- STM.readTVarIO toolTVar
|
|
mode <- STM.readTVarIO modeTVar
|
|
case tool of
|
|
-- Delete selected points on pressing 'Delete'.
|
|
Selection
|
|
-> modifyingCurrentDocument uiElts vars \ doc ->
|
|
pure ( UpdateDocTo $ Just ( deleteSelected mode doc ) )
|
|
_ -> pure ()
|
|
|
|
-------------------
|
|
-- Toggle guides --
|
|
-------------------
|
|
|
|
data ToggleGuides = ToggleGuides
|
|
deriving stock Show
|
|
|
|
instance HandleAction ToggleGuides where
|
|
handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { showGuidesTVar } ) _ = do
|
|
guidesWereShown <- STM.atomically do
|
|
guidesWereShown <- STM.readTVar showGuidesTVar
|
|
STM.writeTVar showGuidesTVar ( not guidesWereShown )
|
|
pure guidesWereShown
|
|
let
|
|
newText :: Text
|
|
newText
|
|
| guidesWereShown = "Show guides"
|
|
| otherwise = "Hide guides"
|
|
GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
|
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
|
GTK.widgetQueueDraw drawingArea
|
|
|
|
------------
|
|
-- Confirm --
|
|
------------
|
|
|
|
data Confirm = Confirm
|
|
deriving stock Show
|
|
|
|
instance HandleAction Confirm where
|
|
handleAction
|
|
( UIElements { viewport = Viewport {..} } )
|
|
( Variables {..} )
|
|
_
|
|
= 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 ()
|
|
|
|
----------------
|
|
-- About page --
|
|
----------------
|
|
|
|
data About = About
|
|
deriving stock Show
|
|
|
|
-- TODO
|
|
instance HandleAction About where
|
|
handleAction _ _ _ = pure ()
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Input actions
|
|
|
|
--------------------
|
|
-- Mouse movement --
|
|
--------------------
|
|
|
|
data MouseMove = MouseMove ( Point2D Double )
|
|
deriving stock Show
|
|
|
|
instance HandleAction MouseMove where
|
|
handleAction
|
|
( UIElements { viewport = Viewport {..}, .. } )
|
|
vars@( Variables {..} )
|
|
( 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
|
|
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
|
GTK.widgetQueueDraw drawingArea
|
|
|
|
-----------------
|
|
-- Mouse click --
|
|
-----------------
|
|
|
|
data ActionOrigin
|
|
= ViewportOrigin
|
|
| RulerOrigin Ruler
|
|
deriving stock Show
|
|
|
|
data MouseClickType
|
|
= SingleClick
|
|
| DoubleClick
|
|
deriving stock Show
|
|
|
|
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
|
|
deriving stock Show
|
|
|
|
instance HandleAction MouseClick where
|
|
handleAction
|
|
uiElts@( UIElements { viewport = Viewport {..} } )
|
|
vars@( Variables {..} )
|
|
( MouseClick actionOrigin ty button mouseClickCoords )
|
|
= case button of
|
|
|
|
-- Left mouse button.
|
|
1 -> do
|
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
|
modifyingCurrentDocument uiElts 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 )
|
|
case actionOrigin of
|
|
|
|
ViewportOrigin -> case ty of
|
|
|
|
SingleClick -> do
|
|
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 ( UpdateDocTo $ Just newDoc )
|
|
-- Rectangular selection.
|
|
_ -> do
|
|
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
|
|
pure Don'tModifyDoc
|
|
|
|
-- 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 ( UpdateDocTo $ Just newDoc )
|
|
-- Path already started: indicate that we are continuing a path.
|
|
Just pp -> do
|
|
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
|
pure Don'tModifyDoc
|
|
|
|
DoubleClick -> do
|
|
tool <- STM.readTVar toolTVar
|
|
mode <- STM.readTVar modeTVar
|
|
modifs <- STM.readTVar modifiersTVar
|
|
case tool of
|
|
Selection
|
|
| null modifs
|
|
-> do
|
|
STM.writeTVar mouseHoldTVar Nothing
|
|
let
|
|
mbSubdivide :: Maybe Document
|
|
mbSubdivide = subdivide mode pos doc
|
|
case mbSubdivide of
|
|
Nothing -> pure Don'tModifyDoc
|
|
Just newDoc -> pure ( UpdateDocTo $ Just newDoc )
|
|
|
|
-- Ignore double click event otherwise.
|
|
_ -> pure Don'tModifyDoc
|
|
|
|
RulerOrigin ruler -> do
|
|
showGuides <- STM.readTVar showGuidesTVar
|
|
when showGuides do
|
|
let
|
|
mbGuide :: Maybe Guide
|
|
mbGuide = selectGuide pos doc
|
|
guideAction :: GuideAction
|
|
guideAction
|
|
| Just guide <- mbGuide
|
|
= MoveGuide ( guideUnique guide )
|
|
| otherwise
|
|
= CreateGuide ruler
|
|
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
|
|
pure Don'tModifyDoc
|
|
|
|
-- 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
|
|
uiElts@( UIElements { viewport = Viewport {..} } )
|
|
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
|
|
modifyingCurrentDocument uiElts 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
|
|
|
|
case mbHoldPos of
|
|
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
|
|
newDoc <- case guideAction of
|
|
CreateGuide ruler
|
|
| createGuide
|
|
-> addGuide uniqueSupply ruler pos doc
|
|
| otherwise
|
|
-> pure doc
|
|
where
|
|
createGuide :: Bool
|
|
createGuide
|
|
= x >= 0
|
|
&& y >= 0
|
|
&& x <= viewportWidth
|
|
&& y <= viewportHeight
|
|
MoveGuide guideUnique
|
|
| keepGuide
|
|
-> pure $
|
|
over
|
|
( field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
|
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
|
doc
|
|
| otherwise
|
|
-> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc
|
|
where
|
|
l, t :: Double
|
|
Point2D l t = toViewport ( Point2D 0 0 )
|
|
keepGuide :: Bool
|
|
keepGuide
|
|
= ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
|
|
&& ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
|
|
&& x <= viewportWidth
|
|
&& y <= viewportHeight
|
|
pure ( UpdateDocTo ( Just newDoc ) )
|
|
|
|
_ -> do
|
|
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 ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
|
|
| SelectionHold pos0 <- hold
|
|
, pos0 /= pos
|
|
-> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
|
|
_ -> pure ( UpdateDocTo $ 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 Don'tModifyDoc
|
|
-- 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 ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
|
|
else
|
|
if firstPoint
|
|
-- Continue current partial path.
|
|
then do
|
|
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
|
|
pure Don'tModifyDoc
|
|
-- 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 ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc )
|
|
|
|
-- 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
|
|
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
|
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
|
|
modifyingCurrentDocument uiElts 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 ( UpdateDocTo $ Just newDoc )
|
|
updateInfoBar viewportDrawingArea infoBar vars
|
|
|
|
--------------------
|
|
-- Keyboard press --
|
|
--------------------
|
|
|
|
data KeyboardPress = KeyboardPress Word32
|
|
deriving stock Show
|
|
|
|
instance HandleAction KeyboardPress where
|
|
handleAction
|
|
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
|
vars@( Variables {..} )
|
|
( KeyboardPress keyCode ) = do
|
|
|
|
for_ ( modifierKey keyCode ) \ modifier ->
|
|
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier )
|
|
|
|
case keyCode of
|
|
|
|
GDK.KEY_Escape -> handleAction uiElts vars Quit
|
|
|
|
GDK.KEY_Return -> handleAction uiElts vars Confirm
|
|
|
|
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 ()
|
|
|
|
_ -> 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 )
|