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/assets/theme.css b/assets/theme.css index 69a6bcc..ccf8b17 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -522,7 +522,7 @@ indent { color: black; } -.layer-item { +.layer-item, .brush-item { color: @plain; background-color: @active; border: 0px solid @bg; @@ -536,7 +536,7 @@ indent { padding-left: 3px; } -:selected .layer-item { +:selected .layer-item, :selected .brush-item { color: black; background-color: @contrast; border: 0px solid @contrast; @@ -550,22 +550,33 @@ indent { .drag-over.layer-item { } -/* Style when dragging over the top part of an item */ -.drag-top.layer-item { +/* Style when dragging layer item over the top part of an item */ +.dragging-item .drag-top.layer-item { border-top: 2px solid @highlight; margin-top: -2px; box-shadow: inset 0 8px 6px -6px @highlight; } -/* Style when dragging over the bottom part of an item */ -.drag-bot.layer-item { +/* Style when dragging layer item over the bottom part of an item */ +.dragging-item .drag-bot.layer-item { border-bottom: 2px solid @highlight; margin-bottom: -2px; box-shadow: inset 0 -8px 6px -6px @highlight; } +/* Style when dragging brush over an item */ +.dragging-brush .drag-top.layer-item, .dragging-brush .drag-bot.layer-item { + border-top: 2px solid @brushStroke; + border-bottom: 2px solid @brushStroke; + border-left: 0px; + border-right: 0px; + margin-top: -2px; + margin-bottom: -2px; + background-color: @brushStroke; +} + /* Style for item being dragged */ .dragged.layer-item { background-color: @bg; diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 5112613..a23c9fd 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -105,6 +105,8 @@ import MetaBrush.Render.Document import MetaBrush.Render.Rulers ( renderRuler ) import MetaBrush.Stroke +import MetaBrush.UI.BrushList + ( newBrushView ) import MetaBrush.UI.FileBar ( FileBar(..), createFileBar ) import MetaBrush.UI.InfoBar @@ -113,7 +115,7 @@ import MetaBrush.UI.Menu ( createMenuBar, createMenuActions ) import MetaBrush.UI.Panels import MetaBrush.UI.StrokeTreeView - ( newLayerView ) + ( DragSourceData(..), newLayerView ) import MetaBrush.UI.ToolBar ( Tool(..), Mode(..), createToolBar ) import MetaBrush.UI.Viewport @@ -474,6 +476,14 @@ runApplication application = do ( layersScrolledWindow panelsBar ) ( Just strokesListView ) + --------------------------------------------------------- + -- Brushes view + + brushesListView <- newBrushView window DragBrush + GTK.scrolledWindowSetChild + ( brushesScrolledWindow panelsBar ) + ( Just brushesListView ) + GTK.boxAppend mainView fileBarBox GTK.boxAppend mainView viewportGrid GTK.boxAppend mainView infoBarArea diff --git a/src/app/MetaBrush/UI/BrushList.hs b/src/app/MetaBrush/UI/BrushList.hs new file mode 100644 index 0000000..d0a3d93 --- /dev/null +++ b/src/app/MetaBrush/UI/BrushList.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module MetaBrush.UI.BrushList + ( newBrushListModel + , newBrushView + , getSelectedBrush + ) + where + +-- base +import Control.Monad + ( void ) +import Data.IORef + ( newIORef, atomicWriteIORef, readIORef ) +import Data.Maybe + ( fromMaybe ) +import Data.Typeable + ( Typeable ) + +-- gi-gdk +import qualified GI.Gdk as GDK + +-- gi-gio +import qualified GI.Gio as GIO + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- haskell-gi-base +import qualified Data.GI.Base as GI +import qualified Data.GI.Base.GValue as GI + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( toLower ) + +-- unordered-containers +import qualified Data.HashMap.Strict as HashMap + +-- MetaBrush +import qualified MetaBrush.Asset.Brushes as Brushes + ( brushes ) + +-------------------------------------------------------------------------------- +-- GTK StringList -- +-------------------- + +-- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold +-- the given brush names. +newBrushListModel :: [ Text ] -> IO GTK.SingleSelection +newBrushListModel brushNames = do + + stringList <- GTK.stringListNew ( Just brushNames ) + + selectionModel <- GI.withManagedPtr stringList $ \ slPtr -> + GI.withNewObject slPtr $ \ slCopy -> + GTK.singleSelectionNew ( Just slCopy ) + + return selectionModel + +------------------ +-- GTK ListView -- +------------------ + +-- | Create a new 'GTK.ListView' that displays brush names. +newBrushView :: Typeable dnd_data + => GTK.ApplicationWindow + -> ( Maybe Text -> dnd_data ) + -- ^ drag and drop data for the brush + -> IO GTK.ListView +newBrushView rootWindow mkDND_data = mdo + + brushListModel <- newBrushListModel ( "No brush" : HashMap.keys Brushes.brushes ) + + brushesListFactory <- GTK.signalListItemFactoryNew + + dragPosRef <- newIORef ( 0, 0 ) + + -- Connect to "setup" signal to create generic widgets for viewing brush names. + _ <- GTK.onSignalListItemFactorySetup brushesListFactory $ \ listItem0 -> do + + listItem <- GTK.unsafeCastTo GTK.ListItem listItem0 + GTK.listItemSetFocusable listItem False + + brushBox <- GTK.boxNew GTK.OrientationHorizontal 10 + GTK.listItemSetChild listItem ( Just brushBox ) + GTK.widgetAddCssClass brushBox "brush-item" + + brushLabel <- GTK.labelNew ( Nothing @Text ) + GTK.boxAppend brushBox brushLabel + + ---------------- + -- DragSource -- + ---------------- + + -- Connect signals for starting a drag from this widget. + dragSource <- GTK.dragSourceNew + GTK.dragSourceSetActions dragSource [ GDK.DragActionCopy ] + + void $ GTK.onDragSourcePrepare dragSource $ \ x y -> do + atomicWriteIORef dragPosRef ( x, y ) + brushName <- getBrushName listItem + val <- GDK.contentProviderNewForValue =<< GIO.toGValue ( GI.HValue $ mkDND_data brushName ) + GTK.widgetAddCssClass rootWindow "dragging-brush" + return $ Just val + void $ GTK.onDragSourceDragBegin dragSource $ \ _drag -> do + ( x, y ) <- readIORef dragPosRef + paintable <- GTK.widgetPaintableNew ( Just brushBox ) + GTK.dragSourceSetIcon ?self ( Just paintable ) ( round x ) ( round y ) + GTK.widgetAddCssClass brushBox "dragged-brush" + -- TODO: add "dragged" class for all descendants as well. + void $ GTK.onDragSourceDragCancel dragSource $ \ _drag _reason -> do + GTK.widgetRemoveCssClass rootWindow "dragging-brush" + GTK.widgetRemoveCssClass brushBox "dragged-brush" + return True + -- ^^^^ Important. Setting this to 'False' stops GDK + -- from properly clearing the drag cursor. + void $ GTK.onDragSourceDragEnd dragSource $ \ _drag _deleteData -> do + GTK.widgetRemoveCssClass rootWindow "dragging-brush" + GTK.widgetRemoveCssClass brushBox "dragged-brush" + + GTK.widgetAddController brushBox dragSource + + -- Connect to "bind" signal to modify the generic widget to display the data for this list item. + _ <- GTK.onSignalListItemFactoryBind brushesListFactory $ \ listItem0 -> do + + listItem <- GTK.unsafeCastTo GTK.ListItem listItem0 + brushName <- getBrushName listItem + + mbBrushBox <- GTK.listItemGetChild listItem + brushBox <- + case mbBrushBox of + Nothing -> error "brushList onBind: list item has no child" + Just box0 -> GTK.unsafeCastTo GTK.Box box0 + + mbBrushLabel <- GTK.widgetGetFirstChild brushBox + brushLabel <- + case mbBrushLabel of + Nothing -> error "brushList onBind: brush box has no child" + Just lbl0 -> GTK.unsafeCastTo GTK.Label lbl0 + + GTK.labelSetLabel brushLabel ( fromMaybe "no brush" brushName ) + + listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just brushesListFactory ) + + GTK.listViewSetModel listView ( Just brushListModel ) + + return listView + +getBrushName :: GTK.ListItem -> IO ( Maybe Text ) +getBrushName listItem = do + mbStrObj <- GTK.listItemGetItem listItem + case mbStrObj of + Nothing -> error "getBrushName: ListItem has no item" + Just strObj0 -> do + strObj <- GTK.unsafeCastTo GTK.StringObject strObj0 + str <- GTK.stringObjectGetString strObj + return $ + if str == "" || Text.toLower str == "no brush" + then Nothing + else Just str + +-- | Get the name of the selected brush in the 'ListView', if any. +getSelectedBrush :: GTK.ListView -> IO ( Maybe Text ) +getSelectedBrush layersView = do + mbSelectionModel <- GTK.listViewGetModel layersView + case mbSelectionModel of + Nothing -> error "getSelectedBrush: no SelectionModel" + Just selModel0 -> do + selModel <- GTK.unsafeCastTo GTK.SingleSelection selModel0 + mbRow <- GTK.singleSelectionGetSelectedItem selModel + case mbRow of + Nothing -> return Nothing + Just row0 -> do + row <- GTK.unsafeCastTo GTK.TreeListRow row0 + mbItem <- GTK.treeListRowGetItem row + case mbItem of + Nothing -> error "getSelectedBrush: row has no item" + Just item0 -> do + strObj <- GTK.unsafeCastTo GTK.StringObject item0 + str <- GTK.stringObjectGetString strObj + return $ + if str == "" || Text.toLower str == "no brush" + then Nothing + else Just str diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index ce7b716..3506b17 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -25,9 +25,9 @@ import MetaBrush.GTK.Util data PanelsBar = PanelsBar - { layersScrolledWindow + { layersScrolledWindow, brushesScrolledWindow :: !GTK.ScrolledWindow - , brushesPanelBox, transformPanelBox, historyPanelBox + , transformPanelBox, historyPanelBox :: !GTK.Box } @@ -45,56 +45,55 @@ createPanelBar panelBox = do panels1 <- GTK.notebookNew panels2 <- GTK.notebookNew - GTK.notebookSetGroupName panels1 ( Just "Panel" ) - GTK.notebookSetGroupName panels2 ( Just "Panel" ) + GTK.notebookSetGroupName panels1 ( Just "Top panel" ) + GTK.notebookSetGroupName panels2 ( Just "Bottom panel" ) GTK.panedSetStartChild pane1 ( Just panels1 ) GTK.panedSetEndChild pane1 ( Just panels2 ) layersScrolledWindow <- GTK.scrolledWindowNew GTK.scrolledWindowSetPolicy layersScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic + brushesScrolledWindow <- GTK.scrolledWindowNew + GTK.scrolledWindowSetPolicy brushesScrolledWindow GTK.PolicyTypeNever GTK.PolicyTypeAutomatic - brushesPanelBox <- GTK.boxNew GTK.OrientationVertical 0 transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0 historyPanelBox <- GTK.boxNew GTK.OrientationVertical 0 - strokesTab <- GTK.labelNew ( Just "Strokes" ) - brushesTab <- GTK.labelNew ( Just "Brushes" ) + strokesTab <- GTK.labelNew ( Just "Strokes" ) + brushesTab <- GTK.labelNew ( Just "Brushes" ) transformTab <- GTK.labelNew ( Just "Transform" ) - historyTab <- GTK.labelNew ( Just "History" ) + historyTab <- GTK.labelNew ( Just "History" ) for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do widgetAddClasses tab [ "plain", "text", "panelTab" ] - widgetAddClass layersScrolledWindow "panel" - for_ [ brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do + for_ [ layersScrolledWindow, brushesScrolledWindow ] \ w -> widgetAddClass w "panel" + for_ [ transformPanelBox, historyPanelBox ] \ panel -> do widgetAddClass panel "panel" - void $ GTK.notebookAppendPage panels1 layersScrolledWindow ( Just strokesTab ) - void $ GTK.notebookAppendPage panels1 brushesPanelBox ( Just brushesTab ) + void $ GTK.notebookAppendPage panels1 brushesScrolledWindow ( Just brushesTab ) + void $ GTK.notebookAppendPage panels1 historyPanelBox ( Just historyTab ) - void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab ) - void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab ) + void $ GTK.notebookAppendPage panels2 layersScrolledWindow ( Just strokesTab ) + void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab ) - GTK.notebookSetTabReorderable panels1 layersScrolledWindow True - GTK.notebookSetTabDetachable panels1 layersScrolledWindow True - GTK.notebookSetTabReorderable panels1 brushesPanelBox True - GTK.notebookSetTabDetachable panels1 brushesPanelBox True + GTK.notebookSetTabReorderable panels1 brushesScrolledWindow True + GTK.notebookSetTabDetachable panels1 brushesScrolledWindow True + GTK.notebookSetTabReorderable panels1 historyPanelBox True + GTK.notebookSetTabDetachable panels1 historyPanelBox True - GTK.notebookSetTabReorderable panels2 transformPanelBox True - GTK.notebookSetTabDetachable panels2 transformPanelBox True - GTK.notebookSetTabReorderable panels2 historyPanelBox True - GTK.notebookSetTabDetachable panels2 historyPanelBox True + GTK.notebookSetTabReorderable panels2 layersScrolledWindow True + GTK.notebookSetTabDetachable panels2 layersScrolledWindow True + GTK.notebookSetTabReorderable panels2 transformPanelBox True + GTK.notebookSetTabDetachable panels2 transformPanelBox True - brushesContent <- GTK.labelNew ( Just "Brushes tab content..." ) transformContent <- GTK.labelNew ( Just "Transform tab content..." ) historyContent <- GTK.labelNew ( Just "History tab content..." ) - GTK.boxAppend brushesPanelBox brushesContent GTK.boxAppend transformPanelBox transformContent GTK.boxAppend historyPanelBox historyContent return $ - PanelsBar { layersScrolledWindow - , brushesPanelBox, transformPanelBox, historyPanelBox + PanelsBar { layersScrolledWindow, brushesScrolledWindow + , transformPanelBox, historyPanelBox } diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index baccb13..801f14a 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -67,12 +67,14 @@ import Data.Text -- MetaBrush import MetaBrush.Application.Context import MetaBrush.Application.UpdateDocument +import MetaBrush.Asset.Brushes + ( lookupBrush ) +import MetaBrush.Brush import MetaBrush.Document import MetaBrush.Document.Diff import MetaBrush.Document.History import MetaBrush.Layer import MetaBrush.Stroke hiding ( Layer(..) ) -import MetaBrush.UI.Panels ( PanelsBar(..) ) import MetaBrush.Unique import MetaBrush.Util ( (!) ) @@ -102,6 +104,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 :: !( Maybe Text ) } + | DragLayerItem { draggedLayerItem :: !ChildLayer } + deriving stock ( Show, Eq ) + + -------------------------------------------------------------------------------- -- GTK TreeListModel -- ----------------------- @@ -386,7 +399,7 @@ getLayerViewWidget expander = do -- | Create a new 'GTK.ListView' that displays 'LayerItem's. newLayerView :: UIElements -> Variables -> IO GTK.ListView -newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow } } ) vars = mdo +newLayerView uiElts@( UIElements { window } ) vars = mdo layersListFactory <- GTK.signalListItemFactoryNew @@ -480,13 +493,14 @@ 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" + GTK.widgetAddCssClass window "dragging-item" return $ Just val void $ GTK.onDragSourceDragBegin dragSource $ \ _drag -> do @@ -501,13 +515,13 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow GTK.widgetAddCssClass expander "dragged" -- TODO: add "dragged" class for all descendants as well. void $ GTK.onDragSourceDragCancel dragSource $ \ _drag _reason -> do - GTK.widgetRemoveCssClass layersScrolledWindow "dragging-item" + GTK.widgetRemoveCssClass window "dragging-item" GTK.widgetRemoveCssClass expander "dragged" return True -- ^^^^ Important. Setting this to 'False' stops GDK -- from properly clearing the drag cursor. void $ GTK.onDragSourceDragEnd dragSource $ \ _drag _deleteData -> do - GTK.widgetRemoveCssClass layersScrolledWindow "dragging-item" + GTK.widgetRemoveCssClass window "dragging-item" GTK.widgetRemoveCssClass expander "dragged" ---------------- @@ -532,147 +546,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 +909,10 @@ data LayerChange | Delete { deleteItem :: !ChildLayer } + | SetBrush + { setBrushStroke :: !ChildLayer + , setBrushName :: !( Maybe Text ) + } -- | Destination of a move operation. data MoveDst @@ -1092,6 +1125,31 @@ applyChangeToLayerHierarchy change hierarchy = , delIsGroup = isJust mbHadChildren } ) + SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } -> + 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 ) } + 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 +1206,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..d6cd123 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 :: !( Maybe Text ) + } deriving stock ( Show, Generic ) deriving anyclass NFData diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index 1fe8e5c..f942529 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -15,8 +15,6 @@ import Control.Monad.ST ( RealWorld, ST, runST ) import Data.Foldable ( for_ ) -import Data.Functor.Identity - ( Identity(..) ) import GHC.Generics ( Generic ) import GHC.TypeLits @@ -59,8 +57,6 @@ import Math.Linear ( ℝ(..) ) -- MetaBrush -import MetaBrush.Assert - ( assert ) import MetaBrush.Brush ( NamedBrush(..) ) import MetaBrush.Document @@ -72,9 +68,6 @@ import MetaBrush.Stroke import MetaBrush.Unique ( Unique, UniqueSupply, freshUnique ) -import Unsafe.Coerce - ( unsafeCoerce ) - -------------------------------------------------------------------------------- -- | A draw anchor, to continue drawing from one end of an existing stroke. @@ -233,7 +226,7 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) }) | strokeUnique == anchorStroke anchor , SOpen <- ssplineType @clo - , let prevSpline0 = co @RealWorld @s oldSpline + , let prevSpline0 = coCache @RealWorld @s oldSpline = do finalSpline <- if anchorIsAtEnd anchor @@ -270,14 +263,10 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent return ( 0, prevSpline0 ) newSpline' <- newCaches ( \ i -> i0 - fromIntegral i - 1 ) ( brushParams ( splineStart prevSpline ) ) ( reverseSpline newSpline ) return $ newSpline' <> prevSpline - return $ UpdateStrokeTo ( stroke { strokeSpline = co @s @RealWorld finalSpline } ) + return $ UpdateStrokeTo ( stroke { strokeSpline = coCache @s @RealWorld finalSpline } ) | otherwise = return PreserveStroke -{-# NOINLINE co #-} -co :: forall s t brushParams. Spline Open ( CurveData s ) ( PointData brushParams ) -> Spline Open ( CurveData t ) ( PointData brushParams ) -co = unsafeCoerce - newCaches :: ( Int -> Rational ) -> brushParams -> Spline Open () ( PointData () ) diff --git a/src/metabrushes/MetaBrush/Stroke.hs b/src/metabrushes/MetaBrush/Stroke.hs index 258f6fb..b0b0ea7 100644 --- a/src/metabrushes/MetaBrush/Stroke.hs +++ b/src/metabrushes/MetaBrush/Stroke.hs @@ -7,7 +7,7 @@ module MetaBrush.Stroke where import Control.Arrow ( (***) ) import Control.Monad.ST - ( RealWorld ) + ( ST, RealWorld, runST ) import Data.Coerce ( coerce ) import Data.Foldable @@ -22,6 +22,8 @@ import GHC.Stack ( HasCallStack ) import GHC.TypeLits ( Symbol ) +import Unsafe.Coerce + ( unsafeCoerce ) -- acts import Data.Act @@ -65,10 +67,10 @@ import qualified Control.Monad.Trans.State.Strict as State -- brush-strokes import Math.Bezier.Spline ( Spline(..), KnownSplineType - , PointType(..) + , PointType(..), bitraverseSpline, bitraverseCurve ) import Math.Bezier.Stroke - ( CachedStroke ) + ( CachedStroke, newCache ) import Math.Module ( Module ( origin, (^+^), (^-^), (*^) ) @@ -181,6 +183,31 @@ overStrokeSpline -> Stroke -> Stroke overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) ) +setStrokeBrush + :: ( Maybe ( NamedBrush brushFields ) ) + -> Stroke -> Stroke +setStrokeBrush brush + ( Stroke { strokeSpline = ( oldStrokeSpline :: StrokeSpline clo pointParams ) } ) = + -- Invalidate all of the cached brush strokes. + let spline' :: ST s ( Spline clo ( CurveData s ) ( PointData pointParams ) ) + spline' = bitraverseSpline + ( \ _ -> bitraverseCurve invalidateCurve ( const return ) ) + return + oldStrokeSpline + in + Stroke + { strokeSpline = runST $ coCache <$> spline' + , strokeBrush = brush } + where + invalidateCurve :: CurveData RealWorld -> ST s ( CurveData s ) + invalidateCurve crv = do + noCache <- newCache + return $ crv { cachedStroke = noCache } + +{-# NOINLINE coCache #-} +coCache :: forall s t clo ptData. Spline clo ( CurveData s ) ptData -> Spline clo ( CurveData t ) ptData +coCache = unsafeCoerce + instance Act ( T ( ℝ 2 ) ) ( PointData params ) where v • ( dat@( PointData { pointCoords = p } ) ) = dat { pointCoords = v • p }