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 ) ( on )
import Data.List import Data.List
( uncons ) ( uncons )
import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
( catMaybes, fromMaybe, isNothing ) ( catMaybes, fromMaybe, isNothing )
import Data.String import Data.String
@ -135,7 +136,7 @@ import MetaBrush.UI.InfoBar
import MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( newFileTab, removeFileTab ) ( newFileTab, removeFileTab )
import MetaBrush.UI.StrokeTreeView import MetaBrush.UI.StrokeTreeView
( applyDiffToListModel ) ( applyDeletionToStrokeHierarchy, applyDiffToListModel )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..) ) ( Viewport(..) )
import MetaBrush.Unique import MetaBrush.Unique
@ -659,14 +660,29 @@ instance HandleAction Delete where
Nothing -> Nothing ->
pure Don'tModifyDoc pure Don'tModifyDoc
Just ( doc', affectedPoints, delStrokes ) -> do Just ( doc', affectedPoints, delStrokes ) -> do
-- TODO: only a hierarchy diff if there are let delStrokeList = Map.toList delStrokes
-- any deleted strokes. diff = case NE.nonEmpty delStrokeList of
let diff = HistoryDiff $ HierarchyDiff $ Nothing ->
DeletePoints HistoryDiff $ ContentDiff $ DeletePoints affectedPoints
{ deletedPoints = affectedPoints Just delStrokesNE ->
, deletedStrokes = delStrokes 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 ) pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
-- TODO: handle deletion of layers by checking the current focus. -- TODO: handle deletion of layers by checking the current focus.
_ -> pure () _ -> pure ()

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -1,12 +1,11 @@
module MetaBrush.Layer where module MetaBrush.Layer where
-- base -- base
import Data.Maybe
( fromJust )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import GHC.Generics import GHC.Generics
( Generically(..), Generic ) ( Generically(..), Generic )
import GHC.Stack
-- containers -- containers
import Data.Map.Strict import Data.Map.Strict
@ -24,6 +23,8 @@ import Data.Text
( Text ) ( Text )
-- MetaBrush -- MetaBrush
import Debug.Utils
( trace )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
@ -89,8 +90,15 @@ emptyHierarchy =
, content = Map.empty , content = Map.empty
} }
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ] lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ]
lookupChildren p h = fromJust $ lookupChildren_maybe p h 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 :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel

View file

@ -14,10 +14,11 @@ import Data.Foldable
( foldr' ) ( foldr' )
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Maybe
( mapMaybe )
import GHC.Generics import GHC.Generics
( Generic, Generic1 ) ( Generic, Generic1 )
import GHC.Stack import GHC.Stack
( HasCallStack )
import GHC.TypeLits import GHC.TypeLits
( Symbol ) ( Symbol )
import Unsafe.Coerce import Unsafe.Coerce
@ -75,17 +76,17 @@ import Math.Module
) )
import Math.Linear import Math.Linear
( (..), T(..) ) ( (..), T(..) )
import Debug.Utils
( trace )
-- MetaBrush -- MetaBrush
import MetaBrush.Brush import MetaBrush.Brush
( NamedBrush, PointFields ) ( NamedBrush, PointFields )
import MetaBrush.Layer import MetaBrush.Layer
( Hierarchy(..), LayerMetadata(..), emptyHierarchy ) ( Hierarchy(..), LayerMetadata(..), emptyHierarchy, WithinParent (..), Parent (..) )
import MetaBrush.Records import MetaBrush.Records
import MetaBrush.Unique import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique ) ( Unique, UniqueSupply, freshUnique )
import MetaBrush.Util
( (!) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -274,44 +275,56 @@ forStrokeHierarchy
. ( HasCallStack, Applicative f ) . ( HasCallStack, Applicative f )
=> LayerMetadata => LayerMetadata
-> StrokeHierarchy -> StrokeHierarchy
-> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke ) -> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
-> f StrokeHierarchy -> f StrokeHierarchy
forStrokeHierarchy forStrokeHierarchy
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f = ( 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 where
insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
PreserveStroke -> old PreserveStroke -> old
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes ) UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
DeleteStroke -> DeleteStroke ->
let newStrokes = Map.delete u oldStrokes let newStrokes = Map.delete u oldStrokes
in case mbPar of in case mbPar of
Nothing -> Root ->
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
Just par -> Parent par ->
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes 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 = g par ( vis, lock ) u acc =
let vis' = vis && not ( u `Set.member` invisibleLayers ) let vis' = vis && not ( u `Set.member` invisibleLayers )
lock' = lock || u `Set.member` lockedLayers lock' = lock || u `Set.member` lockedLayers
in in
case Map.lookup u ( groups hierarchy0 ) of case Map.lookup u ( groups hierarchy0 ) of
Nothing -> Nothing ->
let case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of
meta = ( Just strokeName, Just oldStroke ) ->
StrokeMetadata let
{ strokeName = layerNames ! u meta =
, strokeVisible = vis' StrokeMetadata
, strokeLocked = lock' { strokeName
} , strokeVisible = vis'
in , strokeLocked = lock'
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta }
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 -> 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 deriving stock Show
strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers
strokeHierarchyLayers strokeHierarchyLayers
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
( Hierarchy topLevel hierarchy content ) = map go topLevel ( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel
where where
go :: Unique -> Layer go :: Unique -> Maybe Layer
go layerUnique = go layerUnique =
let let
layerName = layerNames ! layerUnique
layerVisible = not $ layerUnique `Set.member` invisibleLayers layerVisible = not $ layerUnique `Set.member` invisibleLayers
layerLocked = layerUnique `Set.member` lockedLayers layerLocked = layerUnique `Set.member` lockedLayers
in in
case Map.lookup layerUnique hierarchy of case Map.lookup layerUnique hierarchy of
Nothing -> Nothing
StrokeLayer | Just layerName <- Map.lookup layerUnique layerNames
{ layerName, layerVisible, layerLocked , Just layerStroke <- Map.lookup layerUnique content
, layerStroke = content ! layerUnique ->
} Just $
Just cs -> StrokeLayer
GroupLayer { layerName, layerVisible, layerLocked, layerStroke }
{ layerName, layerVisible, layerLocked | otherwise
, groupChildren = map go cs -> 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 #-} {-# INLINEABLE layersStrokeHierarchy #-}
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy ) layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )

View file

@ -1,25 +1,8 @@
module MetaBrush.Util module MetaBrush.Util
( Exists(..) ( Exists(..) )
, (!)
)
where where
-- base
import GHC.Stack
( HasCallStack )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Exists c where data Exists c where
Exists :: c a => a -> Exists c 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