hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

brush list view: first steps

Browse source
This commit is contained in:
sheaf 2024-10-09 16:57:08 +02:00
parent b5b29f124a
commit c1d6dd4151
9 changed files with 481 additions and 185 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

@ -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

23
assets/theme.css
View file

@ -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;

12
src/app/MetaBrush/Application.hs
View file

@ -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

190
src/app/MetaBrush/UI/BrushList.hs Normal file
View file

@ -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

51
src/app/MetaBrush/UI/Panels.hs
View file

@ -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
}

333
src/app/MetaBrush/UI/StrokeTreeView.hs
View file

@ -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.

8
src/metabrushes/MetaBrush/Document/Diff.hs
View file

@ -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

15
src/metabrushes/MetaBrush/Draw.hs
View file

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

33
src/metabrushes/MetaBrush/Stroke.hs
View file

@ -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 }