diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index bf350a6..44ca0e9 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -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 () diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 3afa395..afbe667 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index e1d8776..ab5e6c6 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index b289cf2..d4c433c 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Document/Diff.hs b/src/metabrushes/MetaBrush/Document/Diff.hs index d6cd123..47eca4e 100644 --- a/src/metabrushes/MetaBrush/Document/Diff.hs +++ b/src/metabrushes/MetaBrush/Document/Diff.hs @@ -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 () ) ) diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index fea2a9d..366a576 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Layer.hs b/src/metabrushes/MetaBrush/Layer.hs index 3f585a9..84da821 100644 --- a/src/metabrushes/MetaBrush/Layer.hs +++ b/src/metabrushes/MetaBrush/Layer.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs index 7eac60f..0a1b10e 100644 --- a/src/metabrushes/MetaBrush/Stroke.hs +++ b/src/metabrushes/MetaBrush/Stroke.hs @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Util.hs b/src/metabrushes/MetaBrush/Util.hs index 01c4ea6..e3b7260 100644 --- a/src/metabrushes/MetaBrush/Util.hs +++ b/src/metabrushes/MetaBrush/Util.hs @@ -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 \ No newline at end of file