mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
1e4bb4bddc
* each stroke stores the brushes it uses by reference,
so that one can interactively edit brushes
and see the strokes be updated in real-time
* when writing to a file, we retrive the brush code
from the reference, and include that information statically
1109 lines
41 KiB
Haskell
1109 lines
41 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module MetaBrush.Action where
|
|
|
|
-- base
|
|
import Control.Monad
|
|
( guard, when, unless, void )
|
|
import Data.Foldable
|
|
( for_, sequenceA_ )
|
|
import Data.Int
|
|
( Int32 )
|
|
import Data.Maybe
|
|
( listToMaybe )
|
|
import Data.Traversable
|
|
( for )
|
|
import Data.Word
|
|
( Word32 )
|
|
|
|
-- acts
|
|
import Data.Act
|
|
( Act
|
|
( (•) )
|
|
, Torsor
|
|
( (-->) )
|
|
)
|
|
|
|
-- containers
|
|
import qualified Data.Map as Map
|
|
( insert, lookup )
|
|
import qualified Data.Set as Set
|
|
( delete, insert )
|
|
|
|
-- 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 )
|
|
import qualified Data.Text as Text
|
|
( intercalate, pack )
|
|
|
|
-- MetaBrush
|
|
import Math.Bezier.Spline
|
|
( Spline(..), SplineType(Open)
|
|
, catMaybesSpline
|
|
)
|
|
import Math.Bezier.Stroke
|
|
( CachedStroke(..) )
|
|
import Math.Module
|
|
( Module((*^)) )
|
|
import Math.Vector2D
|
|
( Point2D(..), Vector2D(..) )
|
|
import MetaBrush.Context
|
|
( UIElements(..), Variables(..)
|
|
, Modifier(..), modifierKey
|
|
, HoldAction(..), GuideAction(..), PartialPath(..)
|
|
)
|
|
import MetaBrush.Document
|
|
( Document(..), DocumentContent(..), PointData(..), FocusState(..)
|
|
, Guide(..), selectedGuide, addGuide
|
|
)
|
|
import MetaBrush.Document.Draw
|
|
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
|
|
import MetaBrush.Document.History
|
|
( DocumentHistory(..), newHistory
|
|
, back, fwd
|
|
)
|
|
import MetaBrush.Document.Selection
|
|
( SelectionMode(..), selectionMode
|
|
, selectAt, selectRectangle
|
|
, DragMoveSelect(..), dragMoveSelect
|
|
, UpdateInfo(..)
|
|
, deleteSelected
|
|
, dragUpdate
|
|
)
|
|
import MetaBrush.Document.Serialise
|
|
( saveDocument, loadDocument )
|
|
import MetaBrush.Document.SubdivideStroke
|
|
( subdivide )
|
|
import MetaBrush.Document.Update
|
|
( activeDocument, withActiveDocument
|
|
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
|
|
, modifyingCurrentDocument
|
|
, updateUIAction, updateHistoryState
|
|
)
|
|
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(..), Mode(..) )
|
|
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 False 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
|
|
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
|
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
|
|
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
|
case mbDoc of
|
|
Left errMessage -> warningDialog window filePath errMessage
|
|
Right doc -> do
|
|
let
|
|
newDocHist :: DocumentHistory
|
|
newDocHist = newHistory doc
|
|
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
|
|
updateHistoryState uiElts ( Just newDocHist )
|
|
|
|
warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO ()
|
|
warningDialog window filePath errMess = do
|
|
dialog <- GTK.new GTK.MessageDialog []
|
|
GTK.setMessageDialogText dialog
|
|
( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
|
|
GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
|
|
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 "OK" 1
|
|
widgetAddClass closeButton "dialogButton"
|
|
_ <- GTK.dialogRun dialog
|
|
GTK.widgetDestroy dialog
|
|
|
|
-----------------
|
|
-- 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
|
|
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
|
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
|
|
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
|
case mbDoc of
|
|
Left errMessage -> warningDialog window filePath errMessage
|
|
Right doc -> do
|
|
let
|
|
newDocHist :: DocumentHistory
|
|
newDocHist = newHistory doc
|
|
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
|
|
updateHistoryState uiElts ( Just newDocHist )
|
|
|
|
---------------
|
|
-- Save file --
|
|
---------------
|
|
|
|
data Save = Save
|
|
deriving stock Show
|
|
|
|
instance HandleAction Save where
|
|
handleAction uiElts vars _ =
|
|
save uiElts vars True
|
|
|
|
save :: UIElements -> Variables -> Bool -> IO ()
|
|
save uiElts vars keepOpen = do
|
|
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
|
for_ mbDoc \case
|
|
doc@( Document { mbFilePath, documentContent } )
|
|
| Nothing <- mbFilePath
|
|
-> saveAs uiElts vars keepOpen
|
|
| False <- unsavedChanges documentContent
|
|
-> pure ()
|
|
| Just filePath <- mbFilePath
|
|
-> modifyingCurrentDocument uiElts vars \ _ -> do
|
|
let
|
|
modif :: DocumentUpdate
|
|
modif = if keepOpen then SaveDocument Nothing else CloseDocument
|
|
pure $ UpdateDocAndThen modif ( 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 ->
|
|
modifyingCurrentDocument uiElts vars \ doc -> do
|
|
let
|
|
modif :: DocumentUpdate
|
|
modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
|
|
pure $ UpdateDocAndThen modif ( 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 {..} )
|
|
vars@( Variables {..} )
|
|
close = do
|
|
mbDoc <- case close of
|
|
CloseActive -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
|
|
CloseThis unique -> do
|
|
mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
|
mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
|
for mbDoc \ doc ->
|
|
pure ( doc, maybe False ( ( == unique ) . documentUnique ) mbCurrentDoc )
|
|
case mbDoc of
|
|
Nothing -> pure () -- could show a warning message
|
|
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
|
|
| unsavedChanges documentContent
|
|
-> 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 isActiveDoc documentUnique
|
|
SaveAndClose -> save uiElts vars False
|
|
_ -> pure ()
|
|
| otherwise
|
|
-> closeDocument isActiveDoc documentUnique
|
|
|
|
where
|
|
closeDocument :: Bool -> Unique -> IO ()
|
|
closeDocument isActiveDoc unique = do
|
|
removeFileTab vars unique
|
|
when isActiveDoc do
|
|
uiUpdateAction <- STM.atomically do
|
|
STM.writeTVar activeDocumentTVar Nothing
|
|
uiUpdateAction <- updateUIAction uiElts vars
|
|
pure do
|
|
uiUpdateAction
|
|
updateHistoryState uiElts Nothing
|
|
uiUpdateAction
|
|
|
|
---------------------
|
|
-- Switch document --
|
|
---------------------
|
|
|
|
data SwitchTo = SwitchTo Unique
|
|
deriving stock Show
|
|
|
|
instance HandleAction SwitchTo where
|
|
handleAction
|
|
uiElts
|
|
vars@( Variables {..} )
|
|
( SwitchTo newUnique ) = do
|
|
uiUpdateAction <- STM.atomically do
|
|
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
|
mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
|
|
uiUpdateAction <- updateUIAction uiElts vars
|
|
pure do
|
|
uiUpdateAction
|
|
updateHistoryState uiElts mbHist
|
|
uiUpdateAction
|
|
|
|
--------------
|
|
-- 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 & Redo --
|
|
----------------
|
|
|
|
data Undo = Undo
|
|
deriving stock Show
|
|
|
|
instance HandleAction Undo where
|
|
handleAction uiElts vars _ = updateHistory back uiElts vars
|
|
|
|
|
|
data Redo = Redo
|
|
deriving stock Show
|
|
|
|
instance HandleAction Redo where
|
|
handleAction uiElts vars _ = updateHistory fwd uiElts vars
|
|
|
|
updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
|
|
updateHistory f uiElts vars@( Variables {..} ) = do
|
|
uiUpdateAction <- STM.atomically do
|
|
mbUnique <- STM.readTVar activeDocumentTVar
|
|
case mbUnique of
|
|
Nothing -> pure ( pure () )
|
|
Just unique -> do
|
|
mbDocHistory <- Map.lookup unique <$> STM.readTVar openDocumentsTVar
|
|
case mbDocHistory of
|
|
Nothing -> pure ( pure () )
|
|
Just docHistory -> do
|
|
let
|
|
newDocHistory :: DocumentHistory
|
|
newDocHistory = f docHistory
|
|
STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory )
|
|
uiUpdateAction <- updateUIAction uiElts vars
|
|
pure do
|
|
updateHistoryState uiElts ( Just newDocHistory )
|
|
uiUpdateAction
|
|
uiUpdateAction
|
|
|
|
---------
|
|
-- 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' in path mode.
|
|
Selection
|
|
| PathMode <- mode
|
|
-> modifyingCurrentDocument uiElts vars \ doc -> do
|
|
let
|
|
newDocument :: Document
|
|
updateInfo :: UpdateInfo
|
|
( newDocument, updateInfo ) = deleteSelected doc
|
|
case updateInfo of
|
|
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
|
| null strokesAffected
|
|
-> pure Don'tModifyDoc
|
|
| let
|
|
ppDel, cpDel, changeText :: Text
|
|
ppDel
|
|
| pathPointsAffected == 0
|
|
= ""
|
|
| otherwise
|
|
= Text.pack ( show pathPointsAffected ) <> " path points"
|
|
cpDel
|
|
| controlPointsAffected == 0
|
|
= ""
|
|
| otherwise
|
|
= Text.pack ( show controlPointsAffected ) <> " control points"
|
|
changeText =
|
|
"Delete " <> Text.intercalate " and" [ ppDel, cpDel ]
|
|
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
|
-> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
|
|
_ -> 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
|
|
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( 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 ()
|
|
pure do
|
|
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
|
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
|
GTK.widgetQueueDraw drawingArea
|
|
sequenceA_ uiUpdateAction
|
|
|
|
-----------------
|
|
-- 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 )
|
|
mode <- STM.readTVar modeTVar
|
|
case mode of
|
|
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
|
|
_ ->
|
|
case actionOrigin of
|
|
|
|
ViewportOrigin -> case ty of
|
|
|
|
SingleClick -> do
|
|
modifiers <- STM.readTVar modifiersTVar
|
|
tool <- STM.readTVar toolTVar
|
|
|
|
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 ( dragMove, newDoc ) <- dragMoveSelect pos doc
|
|
-> do
|
|
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
|
|
case dragMove of
|
|
ClickedOnSelected ->
|
|
pure Don'tModifyDoc
|
|
ClickedOnUnselected ->
|
|
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
|
ClickedOnCurve {} ->
|
|
pure Don'tModifyDoc
|
|
-- 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
|
|
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
|
|
getOrCreateDrawAnchor uniqueSupply pos doc
|
|
STM.writeTVar partialPathTVar
|
|
( Just $ PartialPath
|
|
{ partialStartPos = anchorPt
|
|
, partialControlPoint = Nothing
|
|
, partialPathAnchor = drawAnchor
|
|
, firstPoint = True
|
|
}
|
|
)
|
|
case mbExistingAnchorName of
|
|
Nothing ->
|
|
let
|
|
changeText :: Text
|
|
changeText = "Begin new stroke"
|
|
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
Just _ ->
|
|
pure Don'tModifyDoc
|
|
-- 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
|
|
modifs <- STM.readTVar modifiersTVar
|
|
case tool of
|
|
Selection
|
|
| PathMode <- mode
|
|
, null modifs
|
|
-> do
|
|
STM.writeTVar mouseHoldTVar Nothing
|
|
case subdivide pos doc of
|
|
Nothing ->
|
|
pure Don'tModifyDoc
|
|
Just ( newDocument, loc ) -> do
|
|
let
|
|
changeText :: Text
|
|
changeText = "Subdivide " <> loc
|
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
|
|
-- Ignore double click event otherwise.
|
|
_ -> pure Don'tModifyDoc
|
|
|
|
RulerOrigin ruler -> do
|
|
showGuides <- STM.readTVar showGuidesTVar
|
|
when showGuides do
|
|
let
|
|
mbGuide :: Maybe Guide
|
|
mbGuide = selectedGuide 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
|
|
case guideAction of
|
|
CreateGuide ruler
|
|
| createGuide
|
|
-> do
|
|
newDocument <- addGuide uniqueSupply ruler pos doc
|
|
let
|
|
changeText :: Text
|
|
changeText = "Create guide"
|
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
| otherwise
|
|
-> pure Don'tModifyDoc
|
|
where
|
|
createGuide :: Bool
|
|
createGuide
|
|
= x >= 0
|
|
&& y >= 0
|
|
&& x <= viewportWidth
|
|
&& y <= viewportHeight
|
|
MoveGuide guideUnique
|
|
| keepGuide
|
|
-> let
|
|
newDocument :: Document
|
|
newDocument =
|
|
over
|
|
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
|
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
|
doc
|
|
changeText :: Text
|
|
changeText = "Move guide"
|
|
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
| otherwise
|
|
-> let
|
|
newDocument :: Document
|
|
newDocument =
|
|
set ( field' @"documentContent" . field' @"guides" . at guideUnique )
|
|
Nothing
|
|
doc
|
|
changeText :: Text
|
|
changeText = "Delete guide"
|
|
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
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
|
|
|
|
_ -> do
|
|
tool <- STM.readTVar toolTVar
|
|
mode <- STM.readTVar modeTVar
|
|
case mode of
|
|
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
|
|
_ ->
|
|
case tool of
|
|
|
|
Selection -> do
|
|
let
|
|
selMode :: SelectionMode
|
|
selMode = selectionMode modifiers
|
|
case mbHoldPos of
|
|
Just hold
|
|
| DragMoveHold { holdStartPos = pos0, dragAction } <- hold
|
|
, pos0 /= pos
|
|
-> let
|
|
alternateMode :: Bool
|
|
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
|
in case dragUpdate pos0 pos dragAction alternateMode doc of
|
|
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
|
|
Nothing -> pure Don'tModifyDoc
|
|
| SelectionHold pos0 <- hold
|
|
, pos0 /= pos
|
|
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
|
|
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt 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 :: Spline Open CachedStroke ( PointData () )
|
|
newSegment = catMaybesSpline ( CachedStroke Nothing )
|
|
( PointData p1 Normal () )
|
|
( do
|
|
cp <- mbCp2
|
|
guard ( cp /= p1 )
|
|
pure ( PointData cp Normal () )
|
|
)
|
|
( do
|
|
cp <- mbControlPoint
|
|
guard ( cp /= otherAnchorPt )
|
|
pure ( PointData cp Normal () )
|
|
)
|
|
( PointData otherAnchorPt Normal () )
|
|
newDocument :: Document
|
|
newDocument = addToAnchor anchor newSegment doc
|
|
changeText :: Text
|
|
changeText = "Close stroke"
|
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
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 :: Spline Open CachedStroke ( PointData () )
|
|
newSegment = catMaybesSpline ( CachedStroke Nothing )
|
|
( PointData p1 Normal () )
|
|
( do
|
|
cp <- mbCp2
|
|
guard ( cp /= p1 )
|
|
pure ( PointData cp Normal () )
|
|
)
|
|
( do
|
|
cp <- mbControlPoint
|
|
guard ( cp /= pathPoint )
|
|
pure ( PointData cp Normal () )
|
|
)
|
|
( PointData pathPoint Normal () )
|
|
newDocument :: Document
|
|
newDocument = addToAnchor anchor newSegment doc
|
|
changeText :: Text
|
|
changeText = "Continue stroke"
|
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
|
|
|
-- 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 ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
|
|
|
--------------------
|
|
-- 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 )
|
|
( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
|
|
|
|
case keyCode of
|
|
|
|
GDK.KEY_Escape -> handleAction uiElts vars Quit
|
|
|
|
confirm
|
|
| confirm == GDK.KEY_Return
|
|
|| confirm == GDK.KEY_space
|
|
-> 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 )
|
|
( STM.atomically . STM.modifyTVar' modifiersTVar . Set.delete )
|