brush list view: first steps

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

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 */
+/* Style when dragging layer item over the top part of an item */
-.drag-top.layer-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 */
+/* Style when dragging layer item over the bottom part of an item */
-.drag-bot.layer-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;

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

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

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 panels1 ( Just "Top panel" )
-  GTK.notebookSetGroupName panels2 ( Just "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" )
+  strokesTab   <- GTK.labelNew ( Just "Strokes"   )
-  brushesTab   <- GTK.labelNew ( Just "Brushes" )
+  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_ [ layersScrolledWindow, brushesScrolledWindow ] \ w -> widgetAddClass w "panel"
-  for_ [ brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
+  for_ [ transformPanelBox, historyPanelBox ] \ panel -> do
     widgetAddClass panel "panel"
 
-  void $ GTK.notebookAppendPage panels1   layersScrolledWindow ( Just strokesTab )
+  void $ GTK.notebookAppendPage panels1 brushesScrolledWindow ( Just brushesTab )
-  void $ GTK.notebookAppendPage panels1   brushesPanelBox      ( Just brushesTab )
+  void $ GTK.notebookAppendPage panels1 historyPanelBox       ( Just historyTab )
 
-  void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
+  void $ GTK.notebookAppendPage panels2 layersScrolledWindow  ( Just strokesTab )
-  void $ GTK.notebookAppendPage panels2   historyPanelBox ( Just   historyTab )
+  void $ GTK.notebookAppendPage panels2 transformPanelBox     ( Just transformTab )
 
-  GTK.notebookSetTabReorderable panels1   layersScrolledWindow True
+  GTK.notebookSetTabReorderable panels1 brushesScrolledWindow True
-  GTK.notebookSetTabDetachable  panels1   layersScrolledWindow True
+  GTK.notebookSetTabDetachable  panels1 brushesScrolledWindow True
-  GTK.notebookSetTabReorderable panels1   brushesPanelBox True
+  GTK.notebookSetTabReorderable panels1 historyPanelBox       True
-  GTK.notebookSetTabDetachable  panels1   brushesPanelBox True
+  GTK.notebookSetTabDetachable  panels1 historyPanelBox       True
 
-  GTK.notebookSetTabReorderable panels2 transformPanelBox True
+  GTK.notebookSetTabReorderable panels2 layersScrolledWindow True
-  GTK.notebookSetTabDetachable  panels2 transformPanelBox True
+  GTK.notebookSetTabDetachable  panels2 layersScrolledWindow True
-  GTK.notebookSetTabReorderable panels2   historyPanelBox True
+  GTK.notebookSetTabReorderable panels2 transformPanelBox    True
-  GTK.notebookSetTabDetachable  panels2   historyPanelBox 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
+    PanelsBar { layersScrolledWindow, brushesScrolledWindow
-              , brushesPanelBox, transformPanelBox, historyPanelBox
+              , transformPanelBox, historyPanelBox
               }

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
+                DragLayerItem $
-                  { parent = fmap snd srcPar
+                  WithinParent
-                  , item = srcUniq
+                    { 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 }) <-
+          GI.HValue dnd_data <- GIO.fromGValue @( GI.HValue DragSourceData ) val
-            GIO.fromGValue @( GI.HValue ChildLayer ) 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
+          case dnd_data of
-                | expanded
+            DragBrush brushName -> do
-                , not droppedAbove
+              case dropTgt of
-                , not isDescendant
+                GroupLayer {} ->
-                = Just treeListRow
+                  return False
-                | otherwise
+                StrokeLayer tgtStrokeUnique -> do
-                = Nothing
+                  updateLayerHierarchy vars $
-              mbDropOutsideGroup
+                    DoLayerChange $
-                | dragSrcUniq == dropTgtUniq
+                      SetBrush
-                , Parent par <- dstPar
+                        { setBrushStroke =  WithinParent ( fmap snd dstPar ) tgtStrokeUnique
-                , not droppedAbove
+                        , setBrushName   = brushName
-                = 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
                         }
-                    , if droppedAbove then dstFlatIndex else dstFlatIndex + 1
+                  return True
-                    )
 
-            -- Compute the position that the item we are moving will have
+            DragLayerItem dragSrc@( WithinParent { item = dragSrcUniq }) -> do
-            -- at the end of the move.
+              let dropTgtUniq = layerUnique dropTgt
-            --
+              dstFlatIndex <- GTK.treeListRowGetPosition treeListRow
-            -- First, we compute whether we moved up or down.
+              h <- GTK.widgetGetHeight expander
-            -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'),
+              let droppedAbove = y < 0.5 * fromIntegral h
-            -- at the end of the drag-and-drop operation, because TreeExpander nodes
+              expanded <- GTK.treeListRowGetExpanded treeListRow
-            -- 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
+              isDescendant <- isDescendantOf dragSrcUniq listItem
-                mbSelIx <- for mbSelItem $ \ selItem -> do
-                  selRow <- GTK.unsafeCastTo GTK.TreeListRow selItem
-                  GTK.treeListRowGetPosition selRow
 
-                -- Now compute the final destination position.
+              let mbDropIntoGroup
-                mbDstPosAfterShift <-
+                    | expanded
-                  case mbSelIx of
+                    , not droppedAbove
-                    Nothing ->
+                    , not isDescendant
-                      return Nothing
+                    = Just treeListRow
-                    Just selIx
+                    | otherwise
-                      -- If we moved up, simply use the destination position.
+                    = Nothing
-                      | selIx >= newPosInTree
+                  mbDropOutsideGroup
-                      -> return $ Just newPosInTree
+                    | dragSrcUniq == dropTgtUniq
-                      | otherwise
+                    , Parent par <- dstPar
-                      -> do
+                    , not droppedAbove
-                      -- If we moved down, we need to substract the number of items
+                    = Just par
-                      -- moved. Note that this depends on which TreeExpander nodes
+                    | otherwise
-                      -- are expanded.
+                    = Nothing
-                      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 $
+              if isDescendant && isNothing mbDropOutsideGroup
-                  DoLayerChange $
+              then do
-                    Move
+                return False
-                      { moveSrc = dragSrc
+              else do
-                      , moveDst = dropDst
+                -- 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.
+                -- Compute the position that the item we are moving will have
-                case mbDstPosAfterShift of
+                -- at the end of the move.
-                  Nothing -> return ()
+                --
-                  Just dstPos ->
+                -- First, we compute whether we moved up or down.
-                    GTK.singleSelectionSetSelected selModel dstPos
+                -- NB: we need to compute the source item position now (using 'treeListRowGetPosition'),
-                return True
+                -- 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.

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
 

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 () )

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 }