remove stroke from list stores when deleting all stroke points

This commit is contained in:
sheaf 2024-10-16 12:41:19 +02:00
parent d8c83140e7
commit 60b65a38e1
9 changed files with 359 additions and 185 deletions

View file

@ -14,6 +14,7 @@ import Data.Function
( on )
import Data.List
( uncons )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
( catMaybes, fromMaybe, isNothing )
import Data.String
@ -135,7 +136,7 @@ import MetaBrush.UI.InfoBar
import MetaBrush.UI.FileBar
( newFileTab, removeFileTab )
import MetaBrush.UI.StrokeTreeView
( applyDiffToListModel )
( applyDeletionToStrokeHierarchy, applyDiffToListModel )
import MetaBrush.UI.Viewport
( Viewport(..) )
import MetaBrush.Unique
@ -659,14 +660,29 @@ instance HandleAction Delete where
Nothing ->
pure Don'tModifyDoc
Just ( doc', affectedPoints, delStrokes ) -> do
-- TODO: only a hierarchy diff if there are
-- any deleted strokes.
let diff = HistoryDiff $ HierarchyDiff $
DeletePoints
{ deletedPoints = affectedPoints
, deletedStrokes = delStrokes
}
let delStrokeList = Map.toList delStrokes
diff = case NE.nonEmpty delStrokeList of
Nothing ->
HistoryDiff $ ContentDiff $ DeletePoints affectedPoints
Just delStrokesNE ->
let
-- TODO: here we are re-doing the deletion, but using 'applyChangeToLayerHierarchy'
-- as this gives us the child indices we need for the list model update.
-- It would be better to refactor this to avoid going around the houses.
( _hierarchy', deletedLayers ) =
applyDeletionToStrokeHierarchy
( strokeHierarchy $ documentContent doc )
-- NB: original doc, not doc'!
-- (we don't want to attempt to delete what has already been deleted)
( fmap (uncurry $ flip WithinParent) delStrokesNE )
in
HistoryDiff $ HierarchyDiff $
DeleteLayers
{ deletedPoints = affectedPoints
, deletedLayers
}
pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
-- TODO: handle deletion of layers by checking the current focus.
_ -> pure ()

View file

@ -113,6 +113,7 @@ import MetaBrush.Unique
( Unique )
import MetaBrush.GTK.Util
( withRGBA )
import MetaBrush.Layer (WithinParent(..))
--------------------------------------------------------------------------------
@ -253,7 +254,7 @@ getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
forStrokeHierarchy
( layerMetadata documentMetadata )
( strokeHierarchy documentContent )
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
( \ ( WithinParent _ uniq ) stroke ( StrokeMetadata { strokeVisible } ) -> do
when strokeVisible $
Writer.tell [ ( Just uniq, stroke ) ]
return PreserveStroke

View file

@ -2,16 +2,30 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.UI.StrokeTreeView where
module MetaBrush.UI.StrokeTreeView
( newLayersListModel
, newLayerView
, switchStrokeView
, applyDeletionToStrokeHierarchy
, applyChangeToLayerHierarchy
, applyDiffToListModel
, getSelectedItem
, DragSourceData(..)
)
where
-- base
import Control.Arrow
( second )
import Control.Monad
( unless, void, when )
import Data.Foldable
( for_ )
import Data.List
( elemIndex )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
( fromJust, isJust, isNothing )
import Data.Traversable
@ -65,6 +79,8 @@ import Data.Text
( Text )
-- MetaBrush
import Debug.Utils
( trace )
import MetaBrush.Application.Context
import MetaBrush.Application.UpdateDocument
import MetaBrush.Asset.Brushes
@ -76,8 +92,6 @@ import MetaBrush.Document.History
import MetaBrush.Layer
import MetaBrush.Stroke hiding ( Layer(..) )
import MetaBrush.Unique
import MetaBrush.Util
( (!) )
--------------------------------------------------------------------------------
@ -146,11 +160,12 @@ newLayersListModel ( Variables { .. } ) docUnique = do
mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar
mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar
store <- case mbDocStore of
Nothing -> do
Just store
| Just rootStore <- Map.lookup Root store
-> return rootStore
_ -> do
STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) )
return store0
Just store ->
return ( store ! Root )
return ( store, mbDocHist )
for_ mbDocHist $ \ activeDocHist -> do
@ -205,8 +220,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
-- Try to re-use an existing list store, if there is one.
mbOldChildStore <-
STM.atomically $ do
mbOldStore <-
Map.lookup ( Parent groupUnique ) . ( ! docUnique ) <$> STM.readTVar parStoresTVar
parStores <- STM.readTVar parStoresTVar
let mbOldStore =
Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores
when ( isNothing mbOldStore ) $
-- Take a lock to avoid creating multiple child stores
-- for the same group.
@ -759,7 +775,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
-- All we do is set the name and visibility of this layer/group.
let layerText = layerNames meta ! layerUnique layer
let mbLayerText = Map.lookup ( layerUnique layer ) ( layerNames meta )
layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta )
mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
@ -770,7 +786,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
GTK.widgetSetVisible checkButton True
GTK.checkButtonSetActive checkButton layerVisible
GTK.editableSetText layerLabel layerText
for_ mbLayerText $ GTK.editableSetText layerLabel
listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just layersListFactory )
return listView
@ -906,8 +922,8 @@ data LayerChange
, newIsGroup :: !Bool
, newSelected :: !( Maybe ChildLayer )
}
| Delete
{ deleteItem :: !ChildLayer
| DeleteItems
{ deleteItems :: !( NE.NonEmpty ChildLayer )
}
| SetBrush
{ setBrushStroke :: !ChildLayer
@ -1112,45 +1128,63 @@ applyChangeToLayerHierarchy change hierarchy =
, newIsGroup
}
)
Delete { deleteItem = WithinParent parUniq delUniq } ->
let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq )
!( !hierarchy'', mbHadChildren ) =
deleteLayerKey delUniq hierarchy'
in
( hierarchy''
, Map.empty
, Just $
DeleteLayer
{ delPosition = WithinParent parUniq childIx
, delUnique = delUniq
, delIsGroup = isJust mbHadChildren
}
)
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
DeleteItems { deleteItems } ->
let
oldStroke, newStroke :: Stroke
oldStroke = content hierarchy ! strokeUnique
newStroke = case setBrushName of
Just brushNm
| Just ( SomeBrush brush ) <- lookupBrush brushNm
-> setStrokeBrush ( Just brush ) oldStroke
_ -> setStrokeBrush Nothing oldStroke
strokeIx :: Word32
strokeIx =
let oldPar_cs = lookupChildren parUniq hierarchy
in fromIntegral $ fromJust $ elemIndex strokeUnique oldPar_cs
hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
!( !hierarchy', delLayers ) = applyDeletionToStrokeHierarchy hierarchy deleteItems
in
( hierarchy'
, Map.empty
, Just $
StrokeSetBrush
{ changedBrushStroke = WithinParent parUniq strokeIx
, newBrushName = setBrushName
}
, Just $ DeleteLayers mempty delLayers
)
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
case Map.lookup strokeUnique ( content hierarchy ) of
Just oldStroke
| Just oldPar_cs <- lookupChildren_maybe parUniq hierarchy
, Just strokeIx <- elemIndex strokeUnique oldPar_cs
->
let
newStroke :: Stroke
newStroke =
case setBrushName of
Just brushNm
| Just ( SomeBrush brush ) <- lookupBrush brushNm
-> setStrokeBrush ( Just brush ) oldStroke
_ -> setStrokeBrush Nothing oldStroke
hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
in
( hierarchy'
, Map.empty
, Just $
StrokeSetBrush
{ changedBrushStroke = WithinParent parUniq ( fromIntegral strokeIx )
, newBrushName = setBrushName
}
)
| otherwise
-> trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
, "could not find index within parent of stroke " ++ show strokeUnique
, "parent: " ++ show parUniq ])
( hierarchy, Map.empty, Nothing )
Nothing ->
trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
, "no content for stroke with unique " ++ show strokeUnique ])
( hierarchy, Map.empty, Nothing )
applyDeletionToStrokeHierarchy :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
where
go :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
go h (WithinParent parUniq delUniq NE.:| items) =
let !( !h', _ ) = removeLayerFromParent h ( parUniq, delUniq )
!( _, !childIx ) = removeLayerFromParent hierarchy0 ( parUniq, delUniq )
!( !h'', !mbChildren ) = deleteLayerKey delUniq h'
in second ( Map.insertWith (++) parUniq
[DeleteLayer { delPosition = childIx
, delUnique = delUniq
, delIsGroup = isJust mbChildren
}] ) $ ( case items of { [] -> ( h'', Map.empty )
; (i:is) -> ( go h'' (i NE.:| is) ) } )
-- | Apply a change to the 'ListModel' underlying the UI
-- representation of the layer hierarchy.
@ -1172,44 +1206,122 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
-- parent --> list store used to hold its children
--
-- and use that child list store to perform updates.
parStoreFromUniq <- ( ! docUnique ) <$> STM.readTVarIO parStoreTVar
case diff of
MoveLayer { srcPos = WithinParent srcPar srcIx
, dstPos = WithinParent dstPar dstIx } -> do
let srcStore = parStoreFromUniq ! srcPar
dstStore = parStoreFromUniq ! dstPar
case doOrUndo of
Do -> do
item <- fromJust <$> GIO.listModelGetItem srcStore srcIx
GIO.listStoreRemove srcStore srcIx
GIO.listStoreInsert dstStore dstIx item
Undo -> do
item <- fromJust <$> GIO.listModelGetItem dstStore dstIx
GIO.listStoreRemove dstStore dstIx
GIO.listStoreInsert srcStore srcIx item
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do
let dstStore = parStoreFromUniq ! dstPar
case doOrUndo of
Do -> do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
GIO.listStoreInsert dstStore dstIx item
Undo ->
GIO.listStoreRemove dstStore dstIx
DeleteLayer { delPosition = WithinParent srcPar srcIx, delUnique, delIsGroup } -> do
let srcStore = parStoreFromUniq ! srcPar
case doOrUndo of
Do -> GIO.listStoreRemove srcStore srcIx
Undo -> do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
GIO.listStoreInsert srcStore srcIx item
DeletePoints { deletedStrokes } ->
unless ( null deletedStrokes ) $
putStrLn "TODO: delete strokes"
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } -> do
let changedStrokeStore = parStoreFromUniq ! changedPar
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
mbParStoreFromUniq <- Map.lookup docUnique <$> STM.readTVarIO parStoreTVar
case mbParStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel'"
, "failed to look up list store map for document with unique " ++ show docUnique ]
Just parStoreFromUniq -> do
case diff of
MoveLayer { srcPos = WithinParent srcPar srcIx
, dstPos = WithinParent dstPar dstIx } ->
case Map.lookup srcPar parStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' MoveLayer"
, "failed to look up list store for source parent " ++ show srcPar ]
Just srcStore ->
case Map.lookup dstPar parStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' MoveLayer"
, "failed to look up list store for destination parent " ++ show dstPar ]
Just dstStore ->
case doOrUndo of
Do -> do
mbItem <- GIO.listModelGetItem srcStore srcIx
case mbItem of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' Do MoveLayer"
, "failed to get item at index " ++ show srcIx ]
Just item -> do
GIO.listStoreRemove srcStore srcIx
GIO.listStoreInsert dstStore dstIx item
Undo -> do
mbItem <- GIO.listModelGetItem dstStore dstIx
case mbItem of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' Undo MoveLayer"
, "failed to get item at index " ++ show dstIx ]
Just item -> do
GIO.listStoreRemove dstStore dstIx
GIO.listStoreInsert srcStore srcIx item
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } ->
case Map.lookup dstPar parStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' NewLayer"
, "failed to look up list store for parent " ++ show dstPar ]
Just dstStore ->
case doOrUndo of
Do -> do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
GIO.listStoreInsert dstStore dstIx item
Undo ->
GIO.listStoreRemove dstStore dstIx
DeleteLayers _delPts delLayers ->
Map.foldMapWithKey deleteLayersInParent delLayers
where
deleteLayersInParent _ [] = return ()
deleteLayersInParent srcPar (l:ls) =
case Map.lookup srcPar parStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' DeleteLayers"
, "failed to look up list store for parent " ++ show srcPar ]
Just srcStore ->
let sortedLays = NE.sortOn delPosition (l NE.:| ls)
in
if sequentialOn delPosition sortedLays
then do
(remLays, addLays) <-
case doOrUndo of
Do -> return ( fromIntegral ( length sortedLays ) , [] )
Undo -> do
newLays <- for sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup } ) -> do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
GObject.toObject item
return ( 0, NE.toList newLays )
GIO.listStoreSplice srcStore ( delPosition $ NE.head sortedLays ) remLays addLays
else case doOrUndo of
Do ->
-- Delete later items first, otherwise indexing is wrong.
for_ ( NE.reverse sortedLays ) $ \ ( DeleteLayer { delPosition = srcIx } ) ->
GIO.listStoreRemove srcStore srcIx
Undo ->
-- Insert earlier items first, otherwise indexing is wrong.
for_ sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup, delPosition = srcIx } ) -> do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
GIO.listStoreInsert srcStore srcIx item
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } ->
case Map.lookup changedPar parStoreFromUniq of
Nothing ->
putStrLn $ unlines
[ "internal error in 'applyDiffToListModel' StrokeSetBrush"
, "failed to look up list store for parent " ++ show changedPar ]
Just changedStrokeStore ->
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
sequentialOn :: forall a i. ( Num i, Ord i ) => ( a -> i ) -> NE.NonEmpty a -> Bool
sequentialOn f ( a NE.:| as ) = go ( f a ) as
where
go :: i -> [ a ] -> Bool
go _ [] = True
go i (b:bs)
| let j = f b
, j == i + 1
= go j bs
| otherwise
= False
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
-- moving one layer or group around.
@ -1251,13 +1363,22 @@ moveLayerUpdate src@( srcPar, srcUniq ) dst@( dstPar, _ ) hierarchy =
-- was found within its parent.
--
-- NB: does not delete the layer itself.
removeLayerFromParent :: StrokeHierarchy
removeLayerFromParent :: HasCallStack
=> StrokeHierarchy
-> ( Parent Unique, Unique )
-> ( StrokeHierarchy, Word32 )
removeLayerFromParent hierarchy ( parent, u ) =
let oldPar_cs = lookupChildren parent hierarchy
newChildren = filter ( /= u ) oldPar_cs
oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs
oldChildPos = case elemIndex u oldPar_cs of
Nothing -> error $ unlines
[ "internal error in 'removeLayerFromParent': could not find index within parent"
, "parent: " ++ show parent
, "child: " ++ show u
, "children of parent: " ++ show oldPar_cs
, "hierarchy: " ++ show hierarchy
]
Just i -> fromIntegral i
in ( insertGroup parent newChildren hierarchy, oldChildPos )
-- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated

View file

@ -42,6 +42,8 @@ import Data.Act
( Act(()), Torsor((-->)) )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
import Data.Sequence
( Seq )
@ -99,6 +101,7 @@ import MetaBrush.Records
import MetaBrush.Stroke
import MetaBrush.Unique
( Unique )
import MetaBrush.Layer (Parent, WithinParent (..))
--------------------------------------------------------------------------------
-- Subdivision.
@ -127,11 +130,11 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
stripData = bimapCurve ( \ _ -> () ) ( \ _ _ -> () )
subdivideStroke :: Unique -> Stroke -> StrokeMetadata
subdivideStroke :: WithinParent Unique -> Stroke -> StrokeMetadata
-> State
( Maybe Subdivision )
UpdateStroke
subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
subdivideStroke ( WithinParent _ u ) stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
mbPrevSubdivision <- State.get
let ( curves', subdivs ) =
Writer.runWriter $
@ -264,8 +267,8 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
where
Zoom { zoomFactor } = documentZoom documentMetadata
computeSelected :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
computeSelected strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
computeSelected :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
computeSelected ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
when ( strokeVisible ) $
Except.withExcept ( strokeUnique , ) $
bifoldSpline
@ -314,8 +317,8 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
inSelectionRange p =
squaredNorm ( c --> p :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
dragSelect :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
dragSelect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
when ( strokeVisible && not strokeLocked ) $
ibifoldSpline
( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
@ -449,8 +452,8 @@ selectRectangle selMode ( 2 x0 y0 ) ( 2 x1 y1 ) doc@( Document { documentC
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
selectRect :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
selectRect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
selectRect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
selectRect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
when strokeVisible $
Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
bifoldSpline
@ -507,8 +510,8 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
selPts :: StrokePoints
selPts = selectedPoints documentMetadata
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
updateStroke u stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
firstPointSel = FirstPoint `Set.member` strokeSelPts
( spline', ( modPts, _ ) ) =
@ -600,7 +603,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
--
-- Returns the updated document, together with info about how many points
-- and strokes were deleted.
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Set Unique )
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Map Unique ( Parent Unique ) )
deleteSelected doc@( Document { documentContent, documentMetadata } ) =
let
( newStrokes, ( delPts, delStrokes ) ) =
@ -620,8 +623,8 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
)
where
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Map Unique ( Parent Unique ) ) UpdateStroke
updateStroke ( WithinParent par u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
| not strokeVisible || strokeLocked
= return PreserveStroke
| otherwise
@ -637,10 +640,10 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
return PreserveStroke
else case mbSpline of
Nothing -> do
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.singleton u )
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.singleton u par )
return DeleteStroke
Just spline' -> do
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.empty )
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.empty )
return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
where
@ -776,8 +779,8 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
)
where
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
| not strokeVisible || strokeLocked || u /= dragStrokeUnique
= return PreserveStroke
| otherwise
@ -923,8 +926,8 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
zoom = documentZoom $ documentMetadata
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
updateStroke u
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
updateStroke ( WithinParent _ u )
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
( StrokeMetadata { strokeVisible, strokeLocked } )
| strokeVisible

View file

@ -1,13 +1,17 @@
{-# LANGUAGE DuplicateRecordFields #-}
module MetaBrush.Document.Diff where
-- base
import qualified Data.List.NonEmpty as NE
import Data.Word
( Word32 )
import GHC.Generics
( Generic )
-- containers
import Data.Set
( Set )
import Data.Map.Strict
( Map )
-- deepseq
import Control.DeepSeq
@ -63,15 +67,10 @@ data HierarchyDiff
, newIsGroup :: !Bool
, newPosition :: !ChildLayerPosition
}
| DeleteLayer
{ delUnique :: !Unique
, delIsGroup :: !Bool
, delPosition :: !ChildLayerPosition
}
| DeletePoints
{ deletedPoints :: !StrokePoints
, deletedStrokes :: !( Set Unique )
}
| DeleteLayers
{ deletedPoints :: !StrokePoints
, deletedLayers :: !( Map ( Parent Unique ) [ DeleteLayer ] )
}
| MoveLayer
{ moveUnique :: !Unique
, srcPos :: !ChildLayerPosition
@ -84,6 +83,15 @@ data HierarchyDiff
deriving stock ( Show, Generic )
deriving anyclass NFData
data DeleteLayer
= DeleteLayer
{ delUnique :: !Unique
, delIsGroup :: !Bool
, delPosition :: !Word32
}
deriving stock ( Show, Generic )
deriving anyclass NFData
-- | A subdivision of a single stroke.
data Subdivision
= Subdivision
@ -123,6 +131,8 @@ data ContentDiff
}
| CloseStroke
{ closedStroke :: !Unique }
| DeletePoints
{ deletedPoints :: !StrokePoints }
| ContinueStroke
{ continuedStroke :: !Unique
, newSegment :: !( Spline Open () ( PointData () ) )

View file

@ -177,8 +177,8 @@ getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent =
where
zoom = documentZoom documentMetadata
findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
findAnchor :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
findAnchor ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
when ( strokeVisible && not strokeLocked ) $
findAnchorSpline strokeSpline
return PreserveStroke
@ -243,8 +243,8 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
where
updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
updateStroke :: forall s. WithinParent Unique -> Stroke -> ST s UpdateStroke
updateStroke ( WithinParent _ strokeUnique ) stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
| strokeUnique == anchorStroke anchor
, SOpen <- ssplineType @clo
, let prevSpline0 = coCache @RealWorld @s oldSpline

View file

@ -1,12 +1,11 @@
module MetaBrush.Layer where
-- base
import Data.Maybe
( fromJust )
import Data.Word
( Word32 )
import GHC.Generics
( Generically(..), Generic )
import GHC.Stack
-- containers
import Data.Map.Strict
@ -24,6 +23,8 @@ import Data.Text
( Text )
-- MetaBrush
import Debug.Utils
( trace )
import MetaBrush.Unique
( Unique )
@ -89,8 +90,15 @@ emptyHierarchy =
, content = Map.empty
}
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
lookupChildren p h = fromJust $ lookupChildren_maybe p h
lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ]
lookupChildren p h = case lookupChildren_maybe p h of
Nothing ->
trace ( unlines [ "internal error in 'lookupChildren'"
, "no data for parent " ++ show p
, ""
, "call stack: " ++ prettyCallStack callStack ]
) []
Just cs -> cs
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel

View file

@ -14,10 +14,11 @@ import Data.Foldable
( foldr' )
import Data.Functor.Identity
( Identity(..) )
import Data.Maybe
( mapMaybe )
import GHC.Generics
( Generic, Generic1 )
import GHC.Stack
( HasCallStack )
import GHC.TypeLits
( Symbol )
import Unsafe.Coerce
@ -75,17 +76,17 @@ import Math.Module
)
import Math.Linear
( (..), T(..) )
import Debug.Utils
( trace )
-- MetaBrush
import MetaBrush.Brush
( NamedBrush, PointFields )
import MetaBrush.Layer
( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
( Hierarchy(..), LayerMetadata(..), emptyHierarchy, WithinParent (..), Parent (..) )
import MetaBrush.Records
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique )
import MetaBrush.Util
( (!) )
--------------------------------------------------------------------------------
@ -274,44 +275,56 @@ forStrokeHierarchy
. ( HasCallStack, Applicative f )
=> LayerMetadata
-> StrokeHierarchy
-> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
-> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
-> f StrokeHierarchy
forStrokeHierarchy
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
foldr' ( g Root ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
where
insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
PreserveStroke -> old
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
DeleteStroke ->
let newStrokes = Map.delete u oldStrokes
in case mbPar of
Nothing ->
Root ->
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
Just par ->
Parent par ->
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
g :: Parent Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
g par ( vis, lock ) u acc =
let vis' = vis && not ( u `Set.member` invisibleLayers )
lock' = lock || u `Set.member` lockedLayers
in
case Map.lookup u ( groups hierarchy0 ) of
Nothing ->
let
meta =
StrokeMetadata
{ strokeName = layerNames ! u
, strokeVisible = vis'
, strokeLocked = lock'
}
in
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of
( Just strokeName, Just oldStroke ) ->
let
meta =
StrokeMetadata
{ strokeName
, strokeVisible = vis'
, strokeLocked = lock'
}
in
insertMaybe par u <$> acc <*> f ( WithinParent par u ) oldStroke meta
_ ->
trace
( unlines
[ "internal error in 'forStrokeHierarchy'"
, "failed to look up stroke with unique " ++ show u
, ""
, "call stack: " ++ prettyCallStack callStack
]
) acc
Just ds ->
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
foldr' ( g ( Parent u ) ( vis', lock' ) ) acc ds
--------------------------------------------------------------------------------
@ -338,29 +351,48 @@ data Layer
}
deriving stock Show
strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers
strokeHierarchyLayers
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
( Hierarchy topLevel hierarchy content ) = map go topLevel
( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel
where
go :: Unique -> Layer
go :: Unique -> Maybe Layer
go layerUnique =
let
layerName = layerNames ! layerUnique
layerVisible = not $ layerUnique `Set.member` invisibleLayers
layerLocked = layerUnique `Set.member` lockedLayers
in
case Map.lookup layerUnique hierarchy of
Nothing ->
StrokeLayer
{ layerName, layerVisible, layerLocked
, layerStroke = content ! layerUnique
}
Just cs ->
GroupLayer
{ layerName, layerVisible, layerLocked
, groupChildren = map go cs
}
Nothing
| Just layerName <- Map.lookup layerUnique layerNames
, Just layerStroke <- Map.lookup layerUnique content
->
Just $
StrokeLayer
{ layerName, layerVisible, layerLocked, layerStroke }
| otherwise
-> trace
( unlines [ "internal error in 'strokeHierarchyLayers"
, "could not retrieve data for layer with unique: " ++ show layerUnique
, ""
, "call stack: " ++ prettyCallStack callStack
]
) Nothing
Just cs
| Just layerName <- Map.lookup layerUnique layerNames
-> Just $
GroupLayer
{ layerName, layerVisible, layerLocked
, groupChildren = mapMaybe go cs
}
| otherwise
-> trace
( unlines [ "internal error in 'strokeHierarchyLayers"
, "could not retrieve data for group with unique: " ++ show layerUnique
, ""
, "call stack: " ++ prettyCallStack callStack
]
) Nothing
{-# INLINEABLE layersStrokeHierarchy #-}
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )

View file

@ -1,25 +1,8 @@
module MetaBrush.Util
( Exists(..)
, (!)
)
( Exists(..) )
where
-- base
import GHC.Stack
( HasCallStack )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
--------------------------------------------------------------------------------
data Exists c where
Exists :: c a => a -> Exists c
infixl 9 !
(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a
m ! k = case Map.lookup k m of
Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k
Just a -> a