diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 0d29572..a52f525 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -24,6 +24,8 @@ import Data.Int ( Int32 ) import Data.Maybe ( catMaybes, listToMaybe ) +import Data.Traversable + ( for ) import Data.Word ( Word32 ) @@ -43,7 +45,7 @@ import Data.Sequence import qualified Data.Sequence as Seq ( fromList ) import qualified Data.Set as Set - ( insert, delete ) + ( delete, insert ) -- directory import System.Directory @@ -79,7 +81,7 @@ import qualified Control.Concurrent.STM.TVar as STM import Data.Text ( Text ) import qualified Data.Text as Text - ( pack ) + ( intercalate, pack ) -- MetaBrush import Math.Bezier.Stroke @@ -107,8 +109,8 @@ import MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle , dragMoveSelect - , translateSelection - , deleteSelected + , UpdateInfo(..) + , translateSelection, deleteSelected ) import MetaBrush.Document.Serialise ( saveDocument, loadDocument ) @@ -337,7 +339,8 @@ instance HandleAction Close where CloseThis unique -> do mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars ) mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar - pure ( ( \ doc currDoc -> ( doc, documentUnique currDoc == unique ) ) <$> mbDoc <*> mbCurrentDoc ) + 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 ) @@ -514,12 +517,29 @@ instance HandleAction Delete where Selection -> modifyingCurrentDocument uiElts vars \ doc -> do let - newDoc :: Document - docChanged :: Bool - ( newDoc, docChanged ) = deleteSelected mode doc - if docChanged - then pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange newDoc ) - else pure Don'tModifyDoc + 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 () ------------------- @@ -691,7 +711,8 @@ instance HandleAction MouseClick where 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 + ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- + getOrCreateDrawAnchor uniqueSupply pos doc STM.writeTVar partialPathTVar ( Just $ PartialPath { partialStartPos = anchorPt @@ -700,7 +721,14 @@ instance HandleAction MouseClick where , firstPoint = True } ) - pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) + 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 } ) @@ -715,12 +743,14 @@ instance HandleAction MouseClick where | 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 ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) + 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 @@ -779,12 +809,17 @@ instance HandleAction MouseRelease where case mbHoldPos of Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do - newDoc <- case guideAction of + case guideAction of CreateGuide ruler | createGuide - -> addGuide uniqueSupply ruler pos doc + -> do + newDocument <- addGuide uniqueSupply ruler pos doc + let + changeText :: Text + changeText = "Create guide" + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) | otherwise - -> pure doc + -> pure Don'tModifyDoc where createGuide :: Bool createGuide @@ -794,13 +829,26 @@ instance HandleAction MouseRelease where && y <= viewportHeight MoveGuide guideUnique | keepGuide - -> pure $ - over - ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" ) - ( ( holdStartPos --> pos :: Vector2D Double ) • ) - doc + -> 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 - -> pure $ set ( field' @"documentContent" . field' @"guides" . at guideUnique ) Nothing doc + -> 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 ) @@ -810,7 +858,6 @@ instance HandleAction MouseRelease where && ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0) && x <= viewportWidth && y <= viewportHeight - pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) _ -> do tool <- STM.readTVar toolTVar @@ -825,13 +872,33 @@ instance HandleAction MouseRelease where Just hold | DragMoveHold pos0 <- hold , pos0 /= pos - , let - newDoc :: Document - docChanged :: Bool - ( newDoc, docChanged ) = translateSelection mode ( pos0 --> pos ) doc - -> if docChanged - then pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) - else pure Don'tModifyDoc + -> 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 ) @@ -865,7 +932,7 @@ instance HandleAction MouseRelease where = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) | otherwise = ( pos, Nothing, Nothing ) - ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc + ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc if not firstPoint && anchorsAreComplementary anchor otherAnchor -- Close path. then do @@ -886,7 +953,11 @@ instance HandleAction MouseRelease where pure $ ControlPoint cp ( PointData Normal Empty ) , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) ] - pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc ) + newDocument :: Document + newDocument = addToAnchor anchor newSegment doc + changeText :: Text + changeText = "Close stroke" + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) else if firstPoint -- Continue current partial path. @@ -912,7 +983,11 @@ instance HandleAction MouseRelease where pure $ ControlPoint cp ( PointData Normal Empty ) , Just ( PathPoint pathPoint ( PointData Normal Empty ) ) ] - pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc ) + 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 () @@ -1001,7 +1076,10 @@ instance HandleAction KeyboardPress where GDK.KEY_Escape -> handleAction uiElts vars Quit - GDK.KEY_Return -> handleAction uiElts vars Confirm + confirm + | confirm == GDK.KEY_Return + || confirm == GDK.KEY_space + -> handleAction uiElts vars Confirm ctrl | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index 14b4857..b72433e 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -80,37 +80,28 @@ getOrCreateDrawAnchor :: UniqueSupply -> Point2D Double -> Document - -> STM ( Document, DrawAnchor, Point2D Double ) + -> STM ( Document, DrawAnchor, Point2D Double, Maybe Text ) getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of -- Anchor found: use it. ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do - let - newDoc' :: Document - newDoc' = - set ( field' @"documentContent" . field' @"latestChange" ) - ( "Continue stroke " <> anchorName ) - newDoc - pure ( newDoc', anchor, anchorPt ) + pure ( newDoc, anchor, anchorPt, Just anchorName ) -- No anchor found: start a new stroke (on a new stroke layer). ( newDoc, Nothing ) -> do uniq <- freshUnique uniqueSupply let newDoc' :: Document newDoc' - = over ( field' @"documentContent" ) - ( over ( field' @"strokes" ) - ( Stroke - { strokeName = "Stroke " <> uniqueText uniq - , strokeVisible = True - , strokeUnique = uniq - , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) - } - : ) - . set ( field' @"latestChange" ) "Begin new stroke" - ) - $ newDoc - pure ( newDoc', AnchorAtEnd uniq, c ) + = over ( field' @"documentContent" . field' @"strokes" ) + ( Stroke + { strokeName = "Stroke " <> uniqueText uniq + , strokeVisible = True + , strokeUnique = uniq + , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) + } + : ) + newDoc + pure ( newDoc', AnchorAtEnd uniq, c, Nothing ) where -- Deselect all points, and try to find a valid anchor for drawing -- (a path start/end point at mouse click point). diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 5c6e114..7c4c0a7 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -12,20 +13,22 @@ module MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle , DragMoveSelect(..), dragMoveSelect - , translateSelection - , deleteSelected + , UpdateInfo(..) + , translateSelection, deleteSelected ) where -- base -import Control.Arrow - ( first ) import Control.Category ( (>>>) ) import Data.Functor ( ($>) ) import Data.Functor.Identity ( runIdentity ) +import Data.Monoid + ( Sum(..) ) +import GHC.Generics + ( Generic ) -- acts import Data.Act @@ -34,6 +37,14 @@ import Data.Act -- containers import Data.Sequence ( Seq(..) ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( insert ) + +-- generic-data +import Generic.Data + ( Generically(..) ) -- generic-lens import Data.Generics.Product.Fields @@ -58,7 +69,7 @@ import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.State.Strict ( StateT(..) - , State, runState, evalState, get, put + , State, runState, evalState, get, put, modify' ) -- MetaBrush @@ -76,6 +87,8 @@ import MetaBrush.Document ) import MetaBrush.UI.ToolBar ( Mode(..) ) +import MetaBrush.Unique + ( Unique ) -------------------------------------------------------------------------------- @@ -273,75 +286,104 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) | not isVisible = False | otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax +data UpdateInfo + = UpdateInfo + { pathPointsAffected :: !( Sum Int ) + , controlPointsAffected :: !( Sum Int ) + , strokesAffected :: !( Set Unique ) + } + deriving stock ( Show, Generic ) + deriving ( Semigroup, Monoid ) + via Generically UpdateInfo + +recordPointUpdate :: Unique -> StrokePoint d -> State UpdateInfo () +recordPointUpdate uniq ( PathPoint {} ) = modify' + ( over ( field' @"pathPointsAffected" ) (<>1) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) +recordPointUpdate uniq ( ControlPoint {} ) = modify' + ( over ( field' @"controlPointsAffected" ) (<>1) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + -- | Translate all selected points by the given vector. -translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, Bool ) +-- +-- Returns the updated doucment, together with info about how many points were translated. +translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, UpdateInfo ) translateSelection mode t doc = - ( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + ( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc where - updateStroke :: Stroke -> State Bool Stroke - updateStroke stroke@( Stroke { strokeVisible } ) + updateStroke :: Stroke -> State UpdateInfo Stroke + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) | not strokeVisible = pure stroke | Brush <- mode = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse ) - updateStrokePoint + ( updateStrokePoint strokeUnique ) stroke | otherwise = ( field' @"strokePoints" . traverse ) - updateStrokePoint + ( updateStrokePoint strokeUnique ) stroke - updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> State Bool ( StrokePoint pt ) - updateStrokePoint pt + updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt ) + updateStrokePoint uniq pt | Selected <- view _selection pt - = put True + = recordPointUpdate uniq pt $> pt { coords = t • coords pt } | otherwise = pure pt -- | Delete the selected points. -deleteSelected :: Mode -> Document -> ( Document, Bool ) -deleteSelected mode doc - = first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) ) - $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc +-- +-- Returns the updated document, together with info about how many points were deleted. +deleteSelected :: Mode -> Document -> ( Document, UpdateInfo ) +deleteSelected mode doc = ( newDoc, updateInfo ) where - updateStroke :: Stroke -> TardisT Bool Bool ( State Bool ) Stroke - updateStroke stroke@( Stroke { strokeVisible } ) + + newDoc :: Document + updateInfo :: UpdateInfo + ( ( newDoc, _ ), updateInfo ) + = runIdentity . ( `runStateT` mempty ) . ( `Tardis.runTardisT` ( False, False ) ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + + updateStroke :: Stroke -> TardisT Bool Bool ( State UpdateInfo ) Stroke + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) | not strokeVisible = pure stroke | Brush <- mode = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) - updateStrokePoints + ( updateStrokePoints strokeUnique ) stroke | otherwise = ( field' @"strokePoints" ) - updateStrokePoints + ( updateStrokePoints strokeUnique ) stroke updateStrokePoints :: forall pt . HasType FocusState pt - => Seq ( StrokePoint pt ) - -> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) ) - updateStrokePoints Empty = pure Empty - updateStrokePoints ( p :<| ps ) = case p of + => Unique -> Seq ( StrokePoint pt ) + -> TardisT Bool Bool ( State UpdateInfo ) ( Seq ( StrokePoint pt ) ) + updateStrokePoints _ Empty = pure Empty + updateStrokePoints uniq ( p :<| ps ) = case p of PathPoint {} | Selected <- selectionState -> do Tardis.sendPast True Tardis.sendFuture True - lift $ put True - updateStrokePoints ps + lift ( recordPointUpdate uniq p ) + updateStrokePoints uniq ps | otherwise -> do Tardis.sendPast False Tardis.sendFuture False - ( p :<| ) <$> updateStrokePoints ps + ( p :<| ) <$> updateStrokePoints uniq ps _ -> do prevPathPointDeleted <- Tardis.getPast nextPathPointDeleted <- Tardis.getFuture - rest <- updateStrokePoints ps + rest <- updateStrokePoints uniq ps let -- Control point must be deleted: -- - if it is selected, @@ -350,9 +392,15 @@ deleteSelected mode doc -- -- Need to be lazy in "nextPathPointDeleted" to avoid looping. res :: Seq ( StrokePoint pt ) - res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted - then rest - else p :<| rest + stateAction :: State UpdateInfo () + ( res, stateAction ) + | selectionState == Selected + || prevPathPointDeleted + || nextPathPointDeleted + = ( rest, recordPointUpdate uniq p ) + | otherwise + = ( p :<| rest, pure () ) + lift stateAction pure res where selectionState :: FocusState diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index f87d4d5..8e16e69 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module MetaBrush.Document.SubdivideStroke @@ -28,6 +30,10 @@ import Data.Generics.Product.Fields import Data.Group ( invert ) +-- text +import Data.Text + ( Text ) + -- transformers import Control.Monad.Trans.State.Strict ( State, runState, put ) @@ -51,110 +57,106 @@ import MetaBrush.UI.ToolBar -------------------------------------------------------------------------------- -- | Subdivide a path at the given center, provided a path indeed lies there. -subdivide :: Mode -> Point2D Double -> Document -> Maybe Document -subdivide mode c doc@( Document { zoomFactor } ) - | subdivOccurred - = Just updatedDoc - | otherwise - = Nothing - where +subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text ) +subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc + where + updatedDoc :: Document + mbSubdivLoc :: Maybe Text + ( updatedDoc, mbSubdivLoc ) + = ( `runState` Nothing ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) + updateStroke + doc - updatedDoc :: Document - subdivOccurred :: Bool - ( updatedDoc, subdivOccurred ) - = ( `runState` False ) - $ ( field' @"documentContent" . field' @"strokes" . traverse ) - updateStroke - doc + updateStroke :: Stroke -> State ( Maybe Text ) Stroke + updateStroke stroke@( Stroke { strokeVisible, strokeName } ) + | Brush <- mode + = ( field' @"strokePoints" . traverse ) + ( \ spt -> + ( field' @"pointData" . field' @"brushShape" ) + ( subdivideStroke strokeVisible ( "brush shape of stroke " <> strokeName ) ( MkVector2D $ coords spt ) ) + spt + ) + stroke + | otherwise + = ( field' @"strokePoints" ) + ( subdivideStroke strokeVisible ( "stroke " <> strokeName ) ( Vector2D 0 0 ) ) + stroke - updateStroke :: Stroke -> State Bool Stroke - updateStroke stroke@( Stroke { strokeVisible } ) - | Brush <- mode - = ( field' @"strokePoints" . traverse ) - ( \ spt -> - ( field' @"pointData" . field' @"brushShape" ) - ( subdivideStroke strokeVisible ( MkVector2D $ coords spt ) ) - spt - ) - stroke - | otherwise - = ( field' @"strokePoints" ) - ( subdivideStroke strokeVisible ( Vector2D 0 0 ) ) - stroke - - subdivideStroke - :: forall pt - . Show pt - => Bool - -> Vector2D Double - -> Seq ( StrokePoint pt ) - -> State Bool ( Seq ( StrokePoint pt ) ) - subdivideStroke False _ pts = pure pts - subdivideStroke True _ Empty = pure Empty - subdivideStroke True offset ( spt :<| spts ) = go spt spts - where - go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State Bool ( Seq ( StrokePoint pt ) ) - go sp0 Empty = pure ( sp0 :<| Empty ) - -- Line. - go sp0 ( sp1 :<| sps ) - | PathPoint {} <- sp1 - , let - p0, p1, s :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 - sqDist :: Double - sqDist = quadrance @( Vector2D Double ) c ( offset • s ) - = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then do - put True + subdivideStroke + :: forall pt + . Show pt + => Bool + -> Text + -> Vector2D Double + -> Seq ( StrokePoint pt ) + -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) + subdivideStroke False _ _ pts = pure pts + subdivideStroke True _ _ Empty = pure Empty + subdivideStroke True txt offset ( spt :<| spts ) = go spt spts + where + go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) + go sp0 Empty = pure ( sp0 :<| Empty ) + -- Line. + go sp0 ( sp1 :<| sps ) + | PathPoint {} <- sp1 + , let + p0, p1, s :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 + sqDist :: Double + sqDist = quadrance @( Vector2D Double ) c ( offset • s ) + = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then do + put ( Just txt ) + -- TODO: interpolate brush instead of using these arbitrary intermediate points + pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps ) + else ( sp0 :<| ) <$> go sp1 sps + -- Quadratic Bézier curve. + go sp0 ( sp1 :<| sp2 :<| sps ) + | ControlPoint {} <- sp1 + , PathPoint {} <- sp2 + , let + p0, p1, p2, s :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + bez :: Quadratic.Bezier ( Point2D Double ) + bez = Quadratic.Bezier {..} + sqDist :: Double + Min ( Arg sqDist ( t, s ) ) + = Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) + = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then case Quadratic.subdivide @( Vector2D Double ) bez t of + ( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do + put ( Just txt ) -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps ) - else ( sp0 :<| ) <$> go sp1 sps - -- Quadratic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sps ) - | ControlPoint {} <- sp1 - , PathPoint {} <- sp2 - , let - p0, p1, p2, s :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - bez :: Quadratic.Bezier ( Point2D Double ) - bez = Quadratic.Bezier {..} - sqDist :: Double - Min ( Arg sqDist ( t, s ) ) - = Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) - = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Quadratic.subdivide @( Vector2D Double ) bez t of - ( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do - put True - -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps ) - else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps - -- Cubic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) - | ControlPoint {} <- sp1 - , ControlPoint {} <- sp2 - , PathPoint {} <- sp3 - , let - p0, p1, p2, p3, s :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - p3 = coords sp3 - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier {..} - Min ( Arg sqDist ( t, s ) ) - = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) - = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Cubic.subdivide @( Vector2D Double ) bez t of - ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do - put True - -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure - ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s } - :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps - ) - else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps - go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) + pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps ) + else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps + -- Cubic Bézier curve. + go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) + | ControlPoint {} <- sp1 + , ControlPoint {} <- sp2 + , PathPoint {} <- sp3 + , let + p0, p1, p2, p3, s :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + p3 = coords sp3 + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier {..} + Min ( Arg sqDist ( t, s ) ) + = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) + = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then case Cubic.subdivide @( Vector2D Double ) bez t of + ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do + put ( Just txt ) + -- TODO: interpolate brush instead of using these arbitrary intermediate points + pure + ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s } + :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps + ) + else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps + go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index 4ca1e0a..c90be69 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -103,7 +103,7 @@ withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument var data DocChange = TrivialChange { newDocument :: !Document } - | HistoryChange { newDocument :: !Document } + | HistoryChange { newDocument :: !Document, changeText :: !Text } data DocumentUpdate = CloseDocument @@ -168,15 +168,17 @@ modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) unique ) pure ( pure () ) - UpdateDocumentTo ( TrivialChange newDoc ) -> do + UpdateDocumentTo ( TrivialChange { newDocument } ) -> do STM.modifyTVar' openDocumentsTVar - ( Map.adjust ( set ( field' @"present" ) newDoc ) unique ) + ( Map.adjust ( set ( field' @"present" ) newDocument ) unique ) coerce ( updateUIAction uiElts vars ) - UpdateDocumentTo ( HistoryChange newDoc ) -> do + UpdateDocumentTo ( HistoryChange { newDocument, changeText } ) -> do STM.modifyTVar' openDocumentsTVar ( Map.adjust ( newFutureStep maxHistSize - $ set ( field' @"documentContent" . field' @"unsavedChanges" ) True newDoc + . set ( field' @"documentContent" . field' @"unsavedChanges" ) True + . set ( field' @"documentContent" . field' @"latestChange" ) changeText + $ newDocument ) unique ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index acc6f5a..f9a244a 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -46,8 +46,8 @@ handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler ) -- Keyboard events - void $ GTK.afterWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) - void $ GTK.afterWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) + void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) + void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) -- Window quit void $ GTK.onWidgetDestroy window ( quitEverything window ) @@ -129,10 +129,10 @@ handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool handleKeyboardPressEvent elts vars evt = do keyCode <- GDK.getEventKeyKeyval evt handleAction elts vars ( KeyboardPress keyCode ) - pure True + pure False -- allow the default handler to run handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool handleKeyboardReleaseEvent elts vars evt = do keyCode <- GDK.getEventKeyKeyval evt handleAction elts vars ( KeyboardRelease keyCode ) - pure True + pure False -- allow the default handler to run diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 21707aa..d9bc9fd 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -367,9 +367,9 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do --------------------------------------------------------- -- Actions - _ <- GTK.onButtonClicked closeButton ( quitEverything window ) - _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) - _ <- GTK.onButtonClicked fullscreenButton do + _ <- GTK.onButtonClicked closeButton ( quitEverything window ) + _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) + _ <- GTK.onButtonClicked fullscreenButton do Just gdkWindow <- GTK.widgetGetWindow window windowState <- GDK.windowGetState gdkWindow if GDK.WindowStateFullscreen `elem` windowState