From e176676e45fe9f22834a3a7c4a106e50e987ddd5 Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 8 Oct 2024 20:53:52 +0200 Subject: [PATCH] WIP on brush repo (does not compile) --- MetaBrush.cabal | 1 + src/app/MetaBrush/UI/StrokeTreeView.hs | 317 ++++++++++++--------- src/metabrushes/MetaBrush/Document/Diff.hs | 8 + 3 files changed, 194 insertions(+), 132 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 3e3690d..5b3ce46 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -241,6 +241,7 @@ executable MetaBrush , MetaBrush.Render.Document , MetaBrush.Render.Rulers , MetaBrush.Time + , MetaBrush.UI.BrushList , MetaBrush.UI.Coordinates , MetaBrush.UI.FileBar , MetaBrush.UI.InfoBar diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index baccb13..1384492 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -53,7 +53,7 @@ import qualified Data.GI.Base.Overloading as GI -- lens import Control.Lens - ( over ) + ( ix, over ) -- stm import qualified Control.Concurrent.STM.TVar as STM @@ -102,6 +102,17 @@ instance GI.DerivedGObject LayerItem where objectInstanceInit _ _ = return Nothing objectInterfaces = [ ] +-------------------------------------------------------------------------------- +-- Drag and drop data -- +------------------------ + +-- | Data passed in a drag-and-drop operation associated with the drag source. +data DragSourceData + = DragBrush { draggedBrushName :: !Text } + | DragLayerItem { draggedLayerItem :: !ChildLayer } + deriving stock ( Show, Eq ) + + -------------------------------------------------------------------------------- -- GTK TreeListModel -- ----------------------- @@ -480,10 +491,11 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow GTK.singleSelectionSetSelected selModel rowPos let dnd_sourceItem = - WithinParent - { parent = fmap snd srcPar - , item = srcUniq - } + DragLayerItem $ + WithinParent + { parent = fmap snd srcPar + , item = srcUniq + } val <- GDK.contentProviderNewForValue =<< GIO.toGValue ( GI.HValue dnd_sourceItem ) GTK.widgetAddCssClass layersScrolledWindow "dragging-item" @@ -532,147 +544,162 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow -- LayerID {} -> return True void $ GTK.onDropTargetDrop dropTarget $ \ val _x y -> do dropTargetCleanup - dropTgtUniq <- layerUnique <$> getLayerData listItem + dropTgt <- getLayerData listItem - GI.HValue dragSrc@( WithinParent { item = dragSrcUniq }) <- - GIO.fromGValue @( GI.HValue ChildLayer ) val + GI.HValue dnd_data <- GIO.fromGValue @( GI.HValue DragSourceData ) val mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem treeListRow <- case mbTreeListRow of Nothing -> error "newLayerView ListItem onSetup: no TreeListRow" Just r -> return r - - dstFlatIndex <- GTK.treeListRowGetPosition treeListRow - h <- GTK.widgetGetHeight expander - let droppedAbove = y < 0.5 * fromIntegral h - expanded <- GTK.treeListRowGetExpanded treeListRow - dstPar <- getParent treeListRow - isDescendant <- isDescendantOf dragSrcUniq listItem - let mbDropIntoGroup - | expanded - , not droppedAbove - , not isDescendant - = Just treeListRow - | otherwise - = Nothing - mbDropOutsideGroup - | dragSrcUniq == dropTgtUniq - , Parent par <- dstPar - , not droppedAbove - = Just par - | otherwise - = Nothing - - if isDescendant && isNothing mbDropOutsideGroup - then do - return False - else do - -- Compute the destination parent. - -- Usually, the destination parent is the parent of the drop target. - -- BUT: - -- 1. when dropping an item into the first position of an - -- expanded group, the destination parent is the drop target itself, - -- not the parent of the drop target. - -- 2. when an item is at the bottom of a group, dropping it on its - -- lower half moves the item out of the group, so the - -- destination parent is the grand-parent of the drop target. - ( dropDst, newPosInTree ) <- - if - -- (1) - | Just dstParRow <- mbDropIntoGroup - -> do - dstParFlatIndex <- GTK.treeListRowGetPosition dstParRow - return $ - ( MoveToTopOfGroup dropTgtUniq - , dstParFlatIndex + 1 - ) - -- (2) - | Just ( dstParRow, dstParUniq ) <- mbDropOutsideGroup - -> do - grandPar <- getParent dstParRow - return $ - ( MoveItemOutsideGroupIfLastItemInGroup - { itemUnique = dropTgtUniq - , parentUnique = dstParUniq - , grandParentUnique = fmap snd grandPar - , itemExpanded = expanded - } - , dstFlatIndex + 1 - ) - | otherwise - -> do - return $ - ( MoveAboveOrBelow - { moveDstItem = - WithinParent - { parent = fmap snd dstPar - , item = dropTgtUniq - } - , moveAbove = droppedAbove + case dnd_data of + DragBrush brushName -> do + case dropTgt of + GroupLayer {} -> + return False + StrokeLayer tgtStrokeUnique -> do + updateLayerHierarchy vars $ + DoLayerChange $ + SetBrush + { setBrushStroke = WithinParent ( fmap snd dstPar ) tgtStrokeUnique + , setBrushName = brushName } - , if droppedAbove then dstFlatIndex else dstFlatIndex + 1 - ) + return True - -- Compute the position that the item we are moving will have - -- at the end of the move. - -- - -- First, we compute whether we moved up or down. - -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'), - -- at the end of the drag-and-drop operation, because TreeExpander nodes - -- might have expanded/collapsed in the meantime. - mbSelModel <- GTK.listViewGetModel listView - case mbSelModel of - Nothing -> return False - Just selModel0 -> do - selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0 - layersListModel - <- GTK.unsafeCastTo GTK.TreeListModel =<< fmap fromJust ( GTK.singleSelectionGetModel selModel ) + DragLayerItem dragSrc@( WithinParent { item = dragSrcUniq }) -> do + let dropTgtUniq = layerUnique dropTgt + dstFlatIndex <- GTK.treeListRowGetPosition treeListRow + h <- GTK.widgetGetHeight expander + let droppedAbove = y < 0.5 * fromIntegral h + expanded <- GTK.treeListRowGetExpanded treeListRow - mbSelItem <- GTK.singleSelectionGetSelectedItem selModel - mbSelIx <- for mbSelItem $ \ selItem -> do - selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem - GTK.treeListRowGetPosition selRow + isDescendant <- isDescendantOf dragSrcUniq listItem - -- Now compute the final destination position. - mbDstPosAfterShift <- - case mbSelIx of - Nothing -> - return Nothing - Just selIx - -- If we moved up, simply use the destination position. - | selIx >= newPosInTree - -> return $ Just newPosInTree - | otherwise - -> do - -- If we moved down, we need to substract the number of items - -- moved. Note that this depends on which TreeExpander nodes - -- are expanded. - mbSelRow <- GTK.treeListModelGetRow layersListModel selIx - case mbSelRow of - Nothing -> return Nothing - Just selRow0 -> do - selRow <- GTK.unsafeCastTo GTK.TreeListRow selRow0 - nbDescendants <- getNbExpandedDescendants layersListModel selRow - return $ - if newPosInTree < nbDescendants - then Nothing - else Just $ newPosInTree - nbDescendants + let mbDropIntoGroup + | expanded + , not droppedAbove + , not isDescendant + = Just treeListRow + | otherwise + = Nothing + mbDropOutsideGroup + | dragSrcUniq == dropTgtUniq + , Parent par <- dstPar + , not droppedAbove + = Just par + | otherwise + = Nothing - updateLayerHierarchy vars $ - DoLayerChange $ - Move - { moveSrc = dragSrc - , moveDst = dropDst - } + if isDescendant && isNothing mbDropOutsideGroup + then do + return False + else do + -- Compute the destination parent. + -- Usually, the destination parent is the parent of the drop target. + -- BUT: + -- 1. when dropping an item into the first position of an + -- expanded group, the destination parent is the drop target itself, + -- not the parent of the drop target. + -- 2. when an item is at the bottom of a group, dropping it on its + -- lower half moves the item out of the group, so the + -- destination parent is the grand-parent of the drop target. + ( dropDst, newPosInTree ) <- + if + -- (1) + | Just dstParRow <- mbDropIntoGroup + -> do + dstParFlatIndex <- GTK.treeListRowGetPosition dstParRow + return $ + ( MoveToTopOfGroup dropTgtUniq + , dstParFlatIndex + 1 + ) + -- (2) + | Just ( dstParRow, dstParUniq ) <- mbDropOutsideGroup + -> do + grandPar <- getParent dstParRow + return $ + ( MoveItemOutsideGroupIfLastItemInGroup + { itemUnique = dropTgtUniq + , parentUnique = dstParUniq + , grandParentUnique = fmap snd grandPar + , itemExpanded = expanded + } + , dstFlatIndex + 1 + ) + | otherwise + -> do + return $ + ( MoveAboveOrBelow + { moveDstItem = + WithinParent + { parent = fmap snd dstPar + , item = dropTgtUniq + } + , moveAbove = droppedAbove + } + , if droppedAbove then dstFlatIndex else dstFlatIndex + 1 + ) - -- After moving, update the selected item to be the moved item. - case mbDstPosAfterShift of - Nothing -> return () - Just dstPos -> - GTK.singleSelectionSetSelected selModel dstPos - return True + -- Compute the position that the item we are moving will have + -- at the end of the move. + -- + -- First, we compute whether we moved up or down. + -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'), + -- at the end of the drag-and-drop operation, because TreeExpander nodes + -- might have expanded/collapsed in the meantime. + mbSelModel <- GTK.listViewGetModel listView + case mbSelModel of + Nothing -> return False + Just selModel0 -> do + selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0 + layersListModel + <- GTK.unsafeCastTo GTK.TreeListModel =<< fmap fromJust ( GTK.singleSelectionGetModel selModel ) + + mbSelItem <- GTK.singleSelectionGetSelectedItem selModel + mbSelIx <- for mbSelItem $ \ selItem -> do + selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem + GTK.treeListRowGetPosition selRow + + -- Now compute the final destination position. + mbDstPosAfterShift <- + case mbSelIx of + Nothing -> + return Nothing + Just selIx + -- If we moved up, simply use the destination position. + | selIx >= newPosInTree + -> return $ Just newPosInTree + | otherwise + -> do + -- If we moved down, we need to substract the number of items + -- moved. Note that this depends on which TreeExpander nodes + -- are expanded. + mbSelRow <- GTK.treeListModelGetRow layersListModel selIx + case mbSelRow of + Nothing -> return Nothing + Just selRow0 -> do + selRow <- GTK.unsafeCastTo GTK.TreeListRow selRow0 + nbDescendants <- getNbExpandedDescendants layersListModel selRow + return $ + if newPosInTree < nbDescendants + then Nothing + else Just $ newPosInTree - nbDescendants + + updateLayerHierarchy vars $ + DoLayerChange $ + Move + { moveSrc = dragSrc + , moveDst = dropDst + } + + -- After moving, update the selected item to be the moved item. + case mbDstPosAfterShift of + Nothing -> return () + Just dstPos -> + GTK.singleSelectionSetSelected selModel dstPos + return True void $ GTK.onDropTargetEnter dropTarget $ \ _x y -> do GTK.widgetAddCssClass expander "drag-over" @@ -880,6 +907,10 @@ data LayerChange | Delete { deleteItem :: !ChildLayer } + | SetBrush + { setBrushStroke :: !ChildLayer + , setBrushName :: !Text + } -- | Destination of a move operation. data MoveDst @@ -1092,6 +1123,25 @@ applyChangeToLayerHierarchy change hierarchy = , delIsGroup = isJust mbHadChildren } ) + SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } -> + let + ( hierarchy', strokeIx ) = + over ( field' @"documentContent" + . field' @"strokeHierarchy" + . field' @"content" + ) + ( setStrokeBrush brushName ) + doc + + in + ( hierarchy' + , Map.empty + , Just $ + StrokeSetBrush + { changedBrushStroke = WithinParent parUniq strokeIx + , newBrushName = setBrushName + } + ) -- | Apply a change to the 'ListModel' underlying the UI -- representation of the layer hierarchy. @@ -1148,6 +1198,9 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do 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 -- | Update the 'StrokeHierarchy' after a drag-and-drop operation, -- moving one layer or group around. diff --git a/src/metabrushes/MetaBrush/Document/Diff.hs b/src/metabrushes/MetaBrush/Document/Diff.hs index 49434ee..7be416c 100644 --- a/src/metabrushes/MetaBrush/Document/Diff.hs +++ b/src/metabrushes/MetaBrush/Document/Diff.hs @@ -13,6 +13,10 @@ import Data.Set import Control.DeepSeq ( NFData(..) ) +-- text +import Data.Text + ( Text ) + -- brush-strokes import Math.Bezier.Spline import Math.Linear @@ -73,6 +77,10 @@ data HierarchyDiff , srcPos :: !ChildLayerPosition , dstPos :: !ChildLayerPosition } + | StrokeSetBrush + { changedBrushStroke :: !ChildLayerPosition + , newBrushName :: !Text + } deriving stock ( Show, Generic ) deriving anyclass NFData