hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-27 09:24:08 +00:00
Code Issues Actions Projects Releases Wiki Activity

add change descriptions for document history

Browse source 
* fix issue with accelerator key press handler
  overriding the application's key press handler
  * fix not being able to close tabs when no document is active
This commit is contained in:
sheaf 2020-09-10 21:50:35 +02:00
parent 7e8c2e10d1
commit dc11c1af15
7 changed files with 332 additions and 211 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

158
src/app/MetaBrush/Action.hs
View file

@ -24,6 +24,8 @@ import Data.Int
( Int32 ) ( Int32 )
import Data.Maybe import Data.Maybe
( catMaybes, listToMaybe ) ( catMaybes, listToMaybe )
import Data.Traversable
( for )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
@ -43,7 +45,7 @@ import Data.Sequence
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( fromList ) ( fromList )
import qualified Data.Set as Set import qualified Data.Set as Set
( insert, delete ) ( delete, insert )
-- directory -- directory
import System.Directory import System.Directory
@ -79,7 +81,7 @@ import qualified Control.Concurrent.STM.TVar as STM
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text import qualified Data.Text as Text
( pack ) ( intercalate, pack )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke import Math.Bezier.Stroke
@ -107,8 +109,8 @@ import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode
, selectAt, selectRectangle , selectAt, selectRectangle
, dragMoveSelect , dragMoveSelect
, translateSelection , UpdateInfo(..)
, deleteSelected , translateSelection, deleteSelected
) )
import MetaBrush.Document.Serialise import MetaBrush.Document.Serialise
( saveDocument, loadDocument ) ( saveDocument, loadDocument )
@ -337,7 +339,8 @@ instance HandleAction Close where
CloseThis unique -> do CloseThis unique -> do
mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars ) mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar 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 case mbDoc of
Nothing -> pure () -- could show a warning message Nothing -> pure () -- could show a warning message
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc ) Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
@ -514,12 +517,29 @@ instance HandleAction Delete where
Selection Selection
-> modifyingCurrentDocument uiElts vars \ doc -> do -> modifyingCurrentDocument uiElts vars \ doc -> do
let let
newDoc :: Document newDocument :: Document
docChanged :: Bool updateInfo :: UpdateInfo
( newDoc, docChanged ) = deleteSelected mode doc ( newDocument, updateInfo ) = deleteSelected mode doc
if docChanged case updateInfo of
then pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange newDoc ) UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
else pure Don'tModifyDoc | 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 () _ -> pure ()
------------------- -------------------
@ -691,7 +711,8 @@ instance HandleAction MouseClick where
case mbPartialPath of case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do Nothing -> do
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar STM.writeTVar partialPathTVar
( Just $ PartialPath ( Just $ PartialPath
{ partialStartPos = anchorPt { partialStartPos = anchorPt
@ -700,7 +721,14 @@ instance HandleAction MouseClick where
, firstPoint = True , 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. -- Path already started: indicate that we are continuing a path.
Just pp -> do Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
@ -715,12 +743,14 @@ instance HandleAction MouseClick where
| null modifs | null modifs
-> do -> do
STM.writeTVar mouseHoldTVar Nothing STM.writeTVar mouseHoldTVar Nothing
let case subdivide mode pos doc of
mbSubdivide :: Maybe Document Nothing ->
mbSubdivide = subdivide mode pos doc pure Don'tModifyDoc
case mbSubdivide of Just ( newDocument, loc ) -> do
Nothing -> pure Don'tModifyDoc let
Just newDoc -> pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) changeText :: Text
changeText = "Subdivide " <> loc
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange { .. } )
-- Ignore double click event otherwise. -- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc _ -> pure Don'tModifyDoc
@ -779,12 +809,17 @@ instance HandleAction MouseRelease where
case mbHoldPos of case mbHoldPos of
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
newDoc <- case guideAction of case guideAction of
CreateGuide ruler CreateGuide ruler
| createGuide | createGuide
-> addGuide uniqueSupply ruler pos doc -> do
newDocument <- addGuide uniqueSupply ruler pos doc
let
changeText :: Text
changeText = "Create guide"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
| otherwise | otherwise
-> pure doc -> pure Don'tModifyDoc
where where
createGuide :: Bool createGuide :: Bool
createGuide createGuide
@ -794,13 +829,26 @@ instance HandleAction MouseRelease where
&& y <= viewportHeight && y <= viewportHeight
MoveGuide guideUnique MoveGuide guideUnique
| keepGuide | keepGuide
-> pure $ -> let
over newDocument :: Document
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" ) newDocument =
( ( holdStartPos --> pos :: Vector2D Double ) • ) over
doc ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
( ( holdStartPos --> pos :: Vector2D Double ) • )
doc
changeText :: Text
changeText = "Move guide"
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
| otherwise | 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 where
l, t :: Double l, t :: Double
Point2D l t = toViewport ( Point2D 0 0 ) 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) && ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
&& x <= viewportWidth && x <= viewportWidth
&& y <= viewportHeight && y <= viewportHeight
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
_ -> do _ -> do
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
@ -825,13 +872,33 @@ instance HandleAction MouseRelease where
Just hold Just hold
| DragMoveHold pos0 <- hold | DragMoveHold pos0 <- hold
, pos0 /= pos , pos0 /= pos
, let -> do
newDoc :: Document let
docChanged :: Bool vec :: Vector2D Double
( newDoc, docChanged ) = translateSelection mode ( pos0 --> pos ) doc vec = pos0 --> pos
-> if docChanged newDocument :: Document
then pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc ) updateInfo :: UpdateInfo
else pure Don'tModifyDoc ( 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 | SelectionHold pos0 <- hold
, pos0 /= pos , pos0 /= pos
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc ) -> 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 ) = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise | otherwise
= ( pos, Nothing, Nothing ) = ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path. -- Close path.
then do then do
@ -886,7 +953,11 @@ instance HandleAction MouseRelease where
pure $ ControlPoint cp ( PointData Normal Empty ) pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( 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 else
if firstPoint if firstPoint
-- Continue current partial path. -- Continue current partial path.
@ -912,7 +983,11 @@ instance HandleAction MouseRelease where
pure $ ControlPoint cp ( PointData Normal Empty ) pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( 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). -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()
@ -1001,7 +1076,10 @@ instance HandleAction KeyboardPress where
GDK.KEY_Escape -> handleAction uiElts vars Quit 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
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R

33
src/app/MetaBrush/Document/Draw.hs
View file

@ -80,37 +80,28 @@ getOrCreateDrawAnchor
:: UniqueSupply :: UniqueSupply
-> Point2D Double -> Point2D Double
-> Document -> Document
-> STM ( Document, DrawAnchor, Point2D Double ) -> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of
-- Anchor found: use it. -- Anchor found: use it.
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
let pure ( newDoc, anchor, anchorPt, Just anchorName )
newDoc' :: Document
newDoc' =
set ( field' @"documentContent" . field' @"latestChange" )
( "Continue stroke " <> anchorName )
newDoc
pure ( newDoc', anchor, anchorPt )
-- No anchor found: start a new stroke (on a new stroke layer). -- No anchor found: start a new stroke (on a new stroke layer).
( newDoc, Nothing ) -> do ( newDoc, Nothing ) -> do
uniq <- freshUnique uniqueSupply uniq <- freshUnique uniqueSupply
let let
newDoc' :: Document newDoc' :: Document
newDoc' newDoc'
= over ( field' @"documentContent" ) = over ( field' @"documentContent" . field' @"strokes" )
( over ( field' @"strokes" ) ( Stroke
( Stroke { strokeName = "Stroke " <> uniqueText uniq
{ strokeName = "Stroke " <> uniqueText uniq , strokeVisible = True
, strokeVisible = True , strokeUnique = uniq
, strokeUnique = uniq , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) }
} : )
: ) newDoc
. set ( field' @"latestChange" ) "Begin new stroke" pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
)
$ newDoc
pure ( newDoc', AnchorAtEnd uniq, c )
where where
-- Deselect all points, and try to find a valid anchor for drawing -- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point). -- (a path start/end point at mouse click point).

116
src/app/MetaBrush/Document/Selection.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
@ -12,20 +13,22 @@ module MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode
, selectAt, selectRectangle , selectAt, selectRectangle
, DragMoveSelect(..), dragMoveSelect , DragMoveSelect(..), dragMoveSelect
, translateSelection , UpdateInfo(..)
, deleteSelected , translateSelection, deleteSelected
) )
where where
-- base -- base
import Control.Arrow
( first )
import Control.Category import Control.Category
( (>>>) ) ( (>>>) )
import Data.Functor import Data.Functor
( ($>) ) ( ($>) )
import Data.Functor.Identity import Data.Functor.Identity
( runIdentity ) ( runIdentity )
import Data.Monoid
( Sum(..) )
import GHC.Generics
( Generic )
-- acts -- acts
import Data.Act import Data.Act
@ -34,6 +37,14 @@ import Data.Act
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import Data.Set
( Set )
import qualified Data.Set as Set
( insert )
-- generic-data
import Generic.Data
( Generically(..) )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
@ -58,7 +69,7 @@ import Control.Monad.Trans.Class
( lift ) ( lift )
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
( StateT(..) ( StateT(..)
, State, runState, evalState, get, put , State, runState, evalState, get, put, modify'
) )
-- MetaBrush -- MetaBrush
@ -76,6 +87,8 @@ import MetaBrush.Document
) )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
import MetaBrush.Unique
( Unique )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -273,75 +286,104 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
| not isVisible = False | not isVisible = False
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax | 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. -- | 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 = translateSelection mode t doc =
( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc ( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where where
updateStroke :: Stroke -> State Bool Stroke updateStroke :: Stroke -> State UpdateInfo Stroke
updateStroke stroke@( Stroke { strokeVisible } ) updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
| not strokeVisible | not strokeVisible
= pure stroke = pure stroke
| Brush <- mode | Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse ) = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse )
updateStrokePoint ( updateStrokePoint strokeUnique )
stroke stroke
| otherwise | otherwise
= ( field' @"strokePoints" . traverse ) = ( field' @"strokePoints" . traverse )
updateStrokePoint ( updateStrokePoint strokeUnique )
stroke stroke
updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> State Bool ( StrokePoint pt ) updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt )
updateStrokePoint pt updateStrokePoint uniq pt
| Selected <- view _selection pt | Selected <- view _selection pt
= put True = recordPointUpdate uniq pt
$> pt { coords = t • coords pt } $> pt { coords = t • coords pt }
| otherwise | otherwise
= pure pt = pure pt
-- | Delete the selected points. -- | Delete the selected points.
deleteSelected :: Mode -> Document -> ( Document, Bool ) --
deleteSelected mode doc -- Returns the updated document, together with info about how many points were deleted.
= first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) ) deleteSelected :: Mode -> Document -> ( Document, UpdateInfo )
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc deleteSelected mode doc = ( newDoc, updateInfo )
where 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 | not strokeVisible
= pure stroke = pure stroke
| Brush <- mode | Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
updateStrokePoints ( updateStrokePoints strokeUnique )
stroke stroke
| otherwise | otherwise
= ( field' @"strokePoints" ) = ( field' @"strokePoints" )
updateStrokePoints ( updateStrokePoints strokeUnique )
stroke stroke
updateStrokePoints updateStrokePoints
:: forall pt :: forall pt
. HasType FocusState pt . HasType FocusState pt
=> Seq ( StrokePoint pt ) => Unique -> Seq ( StrokePoint pt )
-> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) ) -> TardisT Bool Bool ( State UpdateInfo ) ( Seq ( StrokePoint pt ) )
updateStrokePoints Empty = pure Empty updateStrokePoints _ Empty = pure Empty
updateStrokePoints ( p :<| ps ) = case p of updateStrokePoints uniq ( p :<| ps ) = case p of
PathPoint {} PathPoint {}
| Selected <- selectionState | Selected <- selectionState
-> do -> do
Tardis.sendPast True Tardis.sendPast True
Tardis.sendFuture True Tardis.sendFuture True
lift $ put True lift ( recordPointUpdate uniq p )
updateStrokePoints ps updateStrokePoints uniq ps
| otherwise | otherwise
-> do -> do
Tardis.sendPast False Tardis.sendPast False
Tardis.sendFuture False Tardis.sendFuture False
( p :<| ) <$> updateStrokePoints ps ( p :<| ) <$> updateStrokePoints uniq ps
_ -> do _ -> do
prevPathPointDeleted <- Tardis.getPast prevPathPointDeleted <- Tardis.getPast
nextPathPointDeleted <- Tardis.getFuture nextPathPointDeleted <- Tardis.getFuture
rest <- updateStrokePoints ps rest <- updateStrokePoints uniq ps
let let
-- Control point must be deleted: -- Control point must be deleted:
-- - if it is selected, -- - if it is selected,
@ -350,9 +392,15 @@ deleteSelected mode doc
-- --
-- Need to be lazy in "nextPathPointDeleted" to avoid looping. -- Need to be lazy in "nextPathPointDeleted" to avoid looping.
res :: Seq ( StrokePoint pt ) res :: Seq ( StrokePoint pt )
res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted stateAction :: State UpdateInfo ()
then rest ( res, stateAction )
else p :<| rest | selectionState == Selected
|| prevPathPointDeleted
|| nextPathPointDeleted
= ( rest, recordPointUpdate uniq p )
| otherwise
= ( p :<| rest, pure () )
lift stateAction
pure res pure res
where where
selectionState :: FocusState selectionState :: FocusState

210
src/app/MetaBrush/Document/SubdivideStroke.hs
View file

@ -1,7 +1,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.SubdivideStroke module MetaBrush.Document.SubdivideStroke
@ -28,6 +30,10 @@ import Data.Generics.Product.Fields
import Data.Group import Data.Group
( invert ) ( invert )
-- text
import Data.Text
( Text )
-- transformers -- transformers
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
( State, runState, put ) ( 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 a path at the given center, provided a path indeed lies there.
subdivide :: Mode -> Point2D Double -> Document -> Maybe Document subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text )
subdivide mode c doc@( Document { zoomFactor } ) subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
| subdivOccurred where
= Just updatedDoc updatedDoc :: Document
| otherwise mbSubdivLoc :: Maybe Text
= Nothing ( updatedDoc, mbSubdivLoc )
where = ( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke
doc
updatedDoc :: Document updateStroke :: Stroke -> State ( Maybe Text ) Stroke
subdivOccurred :: Bool updateStroke stroke@( Stroke { strokeVisible, strokeName } )
( updatedDoc, subdivOccurred ) | Brush <- mode
= ( `runState` False ) = ( field' @"strokePoints" . traverse )
$ ( field' @"documentContent" . field' @"strokes" . traverse ) ( \ spt ->
updateStroke ( field' @"pointData" . field' @"brushShape" )
doc ( 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 subdivideStroke
updateStroke stroke@( Stroke { strokeVisible } ) :: forall pt
| Brush <- mode . Show pt
= ( field' @"strokePoints" . traverse ) => Bool
( \ spt -> -> Text
( field' @"pointData" . field' @"brushShape" ) -> Vector2D Double
( subdivideStroke strokeVisible ( MkVector2D $ coords spt ) ) -> Seq ( StrokePoint pt )
spt -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
) subdivideStroke False _ _ pts = pure pts
stroke subdivideStroke True _ _ Empty = pure Empty
| otherwise subdivideStroke True txt offset ( spt :<| spts ) = go spt spts
= ( field' @"strokePoints" ) where
( subdivideStroke strokeVisible ( Vector2D 0 0 ) ) go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
stroke go sp0 Empty = pure ( sp0 :<| Empty )
-- Line.
subdivideStroke go sp0 ( sp1 :<| sps )
:: forall pt | PathPoint {} <- sp1
. Show pt , let
=> Bool p0, p1, s :: Point2D Double
-> Vector2D Double p0 = coords sp0
-> Seq ( StrokePoint pt ) p1 = coords sp1
-> State Bool ( Seq ( StrokePoint pt ) ) s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
subdivideStroke False _ pts = pure pts sqDist :: Double
subdivideStroke True _ Empty = pure Empty sqDist = quadrance @( Vector2D Double ) c ( offset • s )
subdivideStroke True offset ( spt :<| spts ) = go spt spts = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
where then do
go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State Bool ( Seq ( StrokePoint pt ) ) put ( Just txt )
go sp0 Empty = pure ( sp0 :<| Empty ) -- TODO: interpolate brush instead of using these arbitrary intermediate points
-- Line. pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
go sp0 ( sp1 :<| sps ) else ( sp0 :<| ) <$> go sp1 sps
| PathPoint {} <- sp1 -- Quadratic Bézier curve.
, let go sp0 ( sp1 :<| sp2 :<| sps )
p0, p1, s :: Point2D Double | ControlPoint {} <- sp1
p0 = coords sp0 , PathPoint {} <- sp2
p1 = coords sp1 , let
s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 p0, p1, p2, s :: Point2D Double
sqDist :: Double p0 = coords sp0
sqDist = quadrance @( Vector2D Double ) c ( offset • s ) p1 = coords sp1
= if sqDist * zoomFactor ^ ( 2 :: Int ) < 16 p2 = coords sp2
then do bez :: Quadratic.Bezier ( Point2D Double )
put True 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 -- TODO: interpolate brush instead of using these arbitrary intermediate points
pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps ) pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
else ( sp0 :<| ) <$> go sp1 sps else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
-- Quadratic Bézier curve. -- Cubic Bézier curve.
go sp0 ( sp1 :<| sp2 :<| sps ) go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
| ControlPoint {} <- sp1 | ControlPoint {} <- sp1
, PathPoint {} <- sp2 , ControlPoint {} <- sp2
, let , PathPoint {} <- sp3
p0, p1, p2, s :: Point2D Double , let
p0 = coords sp0 p0, p1, p2, p3, s :: Point2D Double
p1 = coords sp1 p0 = coords sp0
p2 = coords sp2 p1 = coords sp1
bez :: Quadratic.Bezier ( Point2D Double ) p2 = coords sp2
bez = Quadratic.Bezier {..} p3 = coords sp3
sqDist :: Double bez :: Cubic.Bezier ( Point2D Double )
Min ( Arg sqDist ( t, s ) ) bez = Cubic.Bezier {..}
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) Min ( Arg sqDist ( t, s ) )
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
then case Quadratic.subdivide @( Vector2D Double ) bez t of = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do then case Cubic.subdivide @( Vector2D Double ) bez t of
put True ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
-- TODO: interpolate brush instead of using these arbitrary intermediate points put ( Just txt )
pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps ) -- TODO: interpolate brush instead of using these arbitrary intermediate points
else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps pure
-- Cubic Bézier curve. ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
| ControlPoint {} <- sp1 )
, ControlPoint {} <- sp2 else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
, PathPoint {} <- sp3 go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
, 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 ) )

12
src/app/MetaBrush/Document/Update.hs
View file

@ -103,7 +103,7 @@ withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument var
data DocChange data DocChange
= TrivialChange { newDocument :: !Document } = TrivialChange { newDocument :: !Document }
| HistoryChange { newDocument :: !Document } | HistoryChange { newDocument :: !Document, changeText :: !Text }
data DocumentUpdate data DocumentUpdate
= CloseDocument = CloseDocument
@ -168,15 +168,17 @@ modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } )
unique unique
) )
pure ( pure () ) pure ( pure () )
UpdateDocumentTo ( TrivialChange newDoc ) -> do UpdateDocumentTo ( TrivialChange { newDocument } ) -> do
STM.modifyTVar' openDocumentsTVar STM.modifyTVar' openDocumentsTVar
( Map.adjust ( set ( field' @"present" ) newDoc ) unique ) ( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
coerce ( updateUIAction uiElts vars ) coerce ( updateUIAction uiElts vars )
UpdateDocumentTo ( HistoryChange newDoc ) -> do UpdateDocumentTo ( HistoryChange { newDocument, changeText } ) -> do
STM.modifyTVar' openDocumentsTVar STM.modifyTVar' openDocumentsTVar
( Map.adjust ( Map.adjust
( newFutureStep maxHistSize ( newFutureStep maxHistSize
$ set ( field' @"documentContent" . field' @"unsavedChanges" ) True newDoc . set ( field' @"documentContent" . field' @"unsavedChanges" ) True
. set ( field' @"documentContent" . field' @"latestChange" ) changeText
$ newDocument
) )
unique unique
) )

8
src/app/MetaBrush/Event.hs
View file

@ -46,8 +46,8 @@ handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler ) afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler )
-- Keyboard events -- Keyboard events
void $ GTK.afterWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
void $ GTK.afterWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
-- Window quit -- Window quit
void $ GTK.onWidgetDestroy window ( quitEverything window ) void $ GTK.onWidgetDestroy window ( quitEverything window )
@ -129,10 +129,10 @@ handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
handleKeyboardPressEvent elts vars evt = do handleKeyboardPressEvent elts vars evt = do
keyCode <- GDK.getEventKeyKeyval evt keyCode <- GDK.getEventKeyKeyval evt
handleAction elts vars ( KeyboardPress keyCode ) handleAction elts vars ( KeyboardPress keyCode )
pure True pure False -- allow the default handler to run
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent elts vars evt = do handleKeyboardReleaseEvent elts vars evt = do
keyCode <- GDK.getEventKeyKeyval evt keyCode <- GDK.getEventKeyKeyval evt
handleAction elts vars ( KeyboardRelease keyCode ) handleAction elts vars ( KeyboardRelease keyCode )
pure True pure False -- allow the default handler to run

6
src/app/MetaBrush/UI/Menu.hs
View file

@ -367,9 +367,9 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
--------------------------------------------------------- ---------------------------------------------------------
-- Actions -- Actions
_ <- GTK.onButtonClicked closeButton ( quitEverything window ) _ <- GTK.onButtonClicked closeButton ( quitEverything window )
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
_ <- GTK.onButtonClicked fullscreenButton do _ <- GTK.onButtonClicked fullscreenButton do
Just gdkWindow <- GTK.widgetGetWindow window Just gdkWindow <- GTK.widgetGetWindow window
windowState <- GDK.windowGetState gdkWindow windowState <- GDK.windowGetState gdkWindow
if GDK.WindowStateFullscreen `elem` windowState if GDK.WindowStateFullscreen `elem` windowState