mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
brush list view: first steps
This commit is contained in:
sheaf
parent
b5b29f124a
commit
c1d6dd4151
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
190
src/app/MetaBrush/UI/BrushList.hs
Normal 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
|
||||
|
|
@ -25,9 +25,9 @@ import MetaBrush.GTK.Util
|
|||
|
||||
data PanelsBar
|
||||
= PanelsBar
|
||||
{ layersScrolledWindow
|
||||
{ layersScrolledWindow, brushesScrolledWindow
|
||||
:: !GTK.ScrolledWindow
|
||||
, brushesPanelBox, transformPanelBox, historyPanelBox
|
||||
, transformPanelBox, historyPanelBox
|
||||
:: !GTK.Box
|
||||
}
|
||||
|
||||
|
|
@ -45,16 +45,17 @@ 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
|
||||
|
||||
|
|
@ -66,35 +67,33 @@ createPanelBar panelBox = do
|
|||
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 layersScrolledWindow ( Just strokesTab )
|
||||
void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
|
||||
void $ GTK.notebookAppendPage panels2 historyPanelBox ( Just historyTab )
|
||||
|
||||
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 layersScrolledWindow True
|
||||
GTK.notebookSetTabDetachable panels2 layersScrolledWindow True
|
||||
GTK.notebookSetTabReorderable panels2 transformPanelBox True
|
||||
GTK.notebookSetTabDetachable panels2 transformPanelBox True
|
||||
GTK.notebookSetTabReorderable panels2 historyPanelBox True
|
||||
GTK.notebookSetTabDetachable panels2 historyPanelBox 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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
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,22 +546,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 +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.
|
||||
|
|
|
|||
|
|
@ -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,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 () )
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
Loading…
Reference in a new issue