WIP on brush repo (does not compile)

This commit is contained in:
sheaf 2024-10-08 20:53:52 +02:00
parent b5b29f124a
commit e176676e45
3 changed files with 194 additions and 132 deletions

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

View file

@ -53,7 +53,7 @@ import qualified Data.GI.Base.Overloading as GI
-- lens
import Control.Lens
( over )
( ix, over )
-- stm
import qualified Control.Concurrent.STM.TVar as STM
@ -102,6 +102,17 @@ instance GI.DerivedGObject LayerItem where
objectInstanceInit _ _ = return Nothing
objectInterfaces = [ ]
--------------------------------------------------------------------------------
-- Drag and drop data --
------------------------
-- | Data passed in a drag-and-drop operation associated with the drag source.
data DragSourceData
= DragBrush { draggedBrushName :: !Text }
| DragLayerItem { draggedLayerItem :: !ChildLayer }
deriving stock ( Show, Eq )
--------------------------------------------------------------------------------
-- GTK TreeListModel --
-----------------------
@ -480,6 +491,7 @@ newLayerView uiElts@( UIElements { panelsBar = PanelsBar { layersScrolledWindow
GTK.singleSelectionSetSelected selModel rowPos
let dnd_sourceItem =
DragLayerItem $
WithinParent
{ parent = fmap snd srcPar
, item = srcUniq
@ -532,22 +544,37 @@ 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
dstPar <- getParent treeListRow
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
}
return True
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
dstPar <- getParent treeListRow
isDescendant <- isDescendantOf dragSrcUniq listItem
let mbDropIntoGroup
@ -880,6 +907,10 @@ data LayerChange
| Delete
{ deleteItem :: !ChildLayer
}
| SetBrush
{ setBrushStroke :: !ChildLayer
, setBrushName :: !Text
}
-- | Destination of a move operation.
data MoveDst
@ -1092,6 +1123,25 @@ applyChangeToLayerHierarchy change hierarchy =
, delIsGroup = isJust mbHadChildren
}
)
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
let
( hierarchy', strokeIx ) =
over ( field' @"documentContent"
. field' @"strokeHierarchy"
. field' @"content"
)
( setStrokeBrush brushName )
doc
in
( hierarchy'
, Map.empty
, Just $
StrokeSetBrush
{ changedBrushStroke = WithinParent parUniq strokeIx
, newBrushName = setBrushName
}
)
-- | Apply a change to the 'ListModel' underlying the UI
-- representation of the layer hierarchy.
@ -1148,6 +1198,9 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
DeletePoints { deletedStrokes } ->
unless ( null deletedStrokes ) $
putStrLn "TODO: delete strokes"
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } -> do
let changedStrokeStore = parStoreFromUniq ! changedPar
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
-- moving one layer or group around.

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 :: !Text
}
deriving stock ( Show, Generic )
deriving anyclass NFData