{-# LANGUAGE BangPatterns #-} {-# 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 ( catMaybes, 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 Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq ( fromList ) 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.Stroke ( StrokePoint(..) ) 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(..) ) import MetaBrush.Document.Draw ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) import MetaBrush.Document ( Guide(..), selectedGuide, addGuide ) import MetaBrush.Document.History ( DocumentHistory(..), newHistory , back, fwd ) import MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle , dragMoveSelect , UpdateInfo(..) , translateSelection, deleteSelected ) 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(..) ) 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 mbDoc <- loadDocument uniqueSupply filePath 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 mbDoc <- loadDocument uniqueSupply ( folderPath filePath ) 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 ) 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 <- 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 -> do 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 { viewport = Viewport {..}, .. } ) 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@( UIElements { viewport = Viewport {..}, .. } ) 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@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars data Redo = Redo deriving stock Show instance HandleAction Redo where handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO () updateHistory f uiElts@( UIElements {..} ) 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'. Selection -> modifyingCurrentDocument uiElts vars \ doc -> do let newDocument :: Document updateInfo :: UpdateInfo ( newDocument, updateInfo ) = deleteSelected mode 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 ) 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 ( UpdateDoc . UpdateDocumentTo . TrivialChange $ 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 ( 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 mode <- STM.readTVar modeTVar modifs <- STM.readTVar modifiersTVar case tool of Selection | null modifs -> do STM.writeTVar mouseHoldTVar Nothing case subdivide mode 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 tool of Selection -> do let selMode :: SelectionMode selMode = selectionMode modifiers case mbHoldPos of Just hold | DragMoveHold pos0 <- hold , pos0 /= pos -> do let vec :: Vector2D Double vec = pos0 --> pos newDocument :: Document updateInfo :: UpdateInfo ( newDocument, updateInfo ) = translateSelection mode vec doc case updateInfo of UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } | null strokesAffected -> pure Don'tModifyDoc | let ppMv, cpMv, changeText :: Text ppMv | pathPointsAffected == 0 = "" | otherwise = Text.pack ( show pathPointsAffected ) <> " path points" cpMv | controlPointsAffected == 0 = "" | otherwise = Text.pack ( show controlPointsAffected ) <> " control points" changeText = "Translate " <> Text.intercalate " and" [ ppMv, cpMv ] <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes" -> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} ) | SelectionHold pos0 <- hold , pos0 /= pos -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc ) _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ 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 ) ) ] 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 :: 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 ) ) ] 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 ) \ modifier -> STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier ) 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 ) \ modifier -> do STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )