mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
remove stroke from list stores when deleting all stroke points
This commit is contained in:
parent
d8c83140e7
commit
60b65a38e1
|
@ -14,6 +14,7 @@ import Data.Function
|
||||||
( on )
|
( on )
|
||||||
import Data.List
|
import Data.List
|
||||||
( uncons )
|
( uncons )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( catMaybes, fromMaybe, isNothing )
|
( catMaybes, fromMaybe, isNothing )
|
||||||
import Data.String
|
import Data.String
|
||||||
|
@ -135,7 +136,7 @@ import MetaBrush.UI.InfoBar
|
||||||
import MetaBrush.UI.FileBar
|
import MetaBrush.UI.FileBar
|
||||||
( newFileTab, removeFileTab )
|
( newFileTab, removeFileTab )
|
||||||
import MetaBrush.UI.StrokeTreeView
|
import MetaBrush.UI.StrokeTreeView
|
||||||
( applyDiffToListModel )
|
( applyDeletionToStrokeHierarchy, applyDiffToListModel )
|
||||||
import MetaBrush.UI.Viewport
|
import MetaBrush.UI.Viewport
|
||||||
( Viewport(..) )
|
( Viewport(..) )
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
|
@ -659,14 +660,29 @@ instance HandleAction Delete where
|
||||||
Nothing ->
|
Nothing ->
|
||||||
pure Don'tModifyDoc
|
pure Don'tModifyDoc
|
||||||
Just ( doc', affectedPoints, delStrokes ) -> do
|
Just ( doc', affectedPoints, delStrokes ) -> do
|
||||||
-- TODO: only a hierarchy diff if there are
|
let delStrokeList = Map.toList delStrokes
|
||||||
-- any deleted strokes.
|
diff = case NE.nonEmpty delStrokeList of
|
||||||
let diff = HistoryDiff $ HierarchyDiff $
|
Nothing ->
|
||||||
DeletePoints
|
HistoryDiff $ ContentDiff $ DeletePoints affectedPoints
|
||||||
{ deletedPoints = affectedPoints
|
Just delStrokesNE ->
|
||||||
, deletedStrokes = delStrokes
|
let
|
||||||
}
|
-- TODO: here we are re-doing the deletion, but using 'applyChangeToLayerHierarchy'
|
||||||
|
-- as this gives us the child indices we need for the list model update.
|
||||||
|
-- It would be better to refactor this to avoid going around the houses.
|
||||||
|
( _hierarchy', deletedLayers ) =
|
||||||
|
applyDeletionToStrokeHierarchy
|
||||||
|
( strokeHierarchy $ documentContent doc )
|
||||||
|
-- NB: original doc, not doc'!
|
||||||
|
-- (we don't want to attempt to delete what has already been deleted)
|
||||||
|
( fmap (uncurry $ flip WithinParent) delStrokesNE )
|
||||||
|
in
|
||||||
|
HistoryDiff $ HierarchyDiff $
|
||||||
|
DeleteLayers
|
||||||
|
{ deletedPoints = affectedPoints
|
||||||
|
, deletedLayers
|
||||||
|
}
|
||||||
pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
|
pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
|
||||||
|
|
||||||
-- TODO: handle deletion of layers by checking the current focus.
|
-- TODO: handle deletion of layers by checking the current focus.
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
||||||
|
|
|
@ -113,6 +113,7 @@ import MetaBrush.Unique
|
||||||
( Unique )
|
( Unique )
|
||||||
import MetaBrush.GTK.Util
|
import MetaBrush.GTK.Util
|
||||||
( withRGBA )
|
( withRGBA )
|
||||||
|
import MetaBrush.Layer (WithinParent(..))
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -253,7 +254,7 @@ getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
|
||||||
forStrokeHierarchy
|
forStrokeHierarchy
|
||||||
( layerMetadata documentMetadata )
|
( layerMetadata documentMetadata )
|
||||||
( strokeHierarchy documentContent )
|
( strokeHierarchy documentContent )
|
||||||
( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
|
( \ ( WithinParent _ uniq ) stroke ( StrokeMetadata { strokeVisible } ) -> do
|
||||||
when strokeVisible $
|
when strokeVisible $
|
||||||
Writer.tell [ ( Just uniq, stroke ) ]
|
Writer.tell [ ( Just uniq, stroke ) ]
|
||||||
return PreserveStroke
|
return PreserveStroke
|
||||||
|
|
|
@ -2,16 +2,30 @@
|
||||||
{-# LANGUAGE OverloadedLabels #-}
|
{-# LANGUAGE OverloadedLabels #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecursiveDo #-}
|
{-# LANGUAGE RecursiveDo #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module MetaBrush.UI.StrokeTreeView where
|
module MetaBrush.UI.StrokeTreeView
|
||||||
|
( newLayersListModel
|
||||||
|
, newLayerView
|
||||||
|
, switchStrokeView
|
||||||
|
, applyDeletionToStrokeHierarchy
|
||||||
|
, applyChangeToLayerHierarchy
|
||||||
|
, applyDiffToListModel
|
||||||
|
, getSelectedItem
|
||||||
|
, DragSourceData(..)
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Control.Arrow
|
||||||
|
( second )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( unless, void, when )
|
( unless, void, when )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.List
|
import Data.List
|
||||||
( elemIndex )
|
( elemIndex )
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( fromJust, isJust, isNothing )
|
( fromJust, isJust, isNothing )
|
||||||
import Data.Traversable
|
import Data.Traversable
|
||||||
|
@ -65,6 +79,8 @@ import Data.Text
|
||||||
( Text )
|
( Text )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
import Debug.Utils
|
||||||
|
( trace )
|
||||||
import MetaBrush.Application.Context
|
import MetaBrush.Application.Context
|
||||||
import MetaBrush.Application.UpdateDocument
|
import MetaBrush.Application.UpdateDocument
|
||||||
import MetaBrush.Asset.Brushes
|
import MetaBrush.Asset.Brushes
|
||||||
|
@ -76,8 +92,6 @@ import MetaBrush.Document.History
|
||||||
import MetaBrush.Layer
|
import MetaBrush.Layer
|
||||||
import MetaBrush.Stroke hiding ( Layer(..) )
|
import MetaBrush.Stroke hiding ( Layer(..) )
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
import MetaBrush.Util
|
|
||||||
( (!) )
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -146,11 +160,12 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
||||||
mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar
|
mbDocHist <- Map.lookup docUnique <$> STM.readTVar openDocumentsTVar
|
||||||
mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar
|
mbDocStore <- Map.lookup docUnique <$> STM.readTVar parStoresTVar
|
||||||
store <- case mbDocStore of
|
store <- case mbDocStore of
|
||||||
Nothing -> do
|
Just store
|
||||||
|
| Just rootStore <- Map.lookup Root store
|
||||||
|
-> return rootStore
|
||||||
|
_ -> do
|
||||||
STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) )
|
STM.modifyTVar' parStoresTVar ( Map.insert docUnique ( Map.singleton Root store0 ) )
|
||||||
return store0
|
return store0
|
||||||
Just store ->
|
|
||||||
return ( store ! Root )
|
|
||||||
return ( store, mbDocHist )
|
return ( store, mbDocHist )
|
||||||
|
|
||||||
for_ mbDocHist $ \ activeDocHist -> do
|
for_ mbDocHist $ \ activeDocHist -> do
|
||||||
|
@ -205,8 +220,9 @@ newLayersListModel ( Variables { .. } ) docUnique = do
|
||||||
-- Try to re-use an existing list store, if there is one.
|
-- Try to re-use an existing list store, if there is one.
|
||||||
mbOldChildStore <-
|
mbOldChildStore <-
|
||||||
STM.atomically $ do
|
STM.atomically $ do
|
||||||
mbOldStore <-
|
parStores <- STM.readTVar parStoresTVar
|
||||||
Map.lookup ( Parent groupUnique ) . ( ! docUnique ) <$> STM.readTVar parStoresTVar
|
let mbOldStore =
|
||||||
|
Map.lookup ( Parent groupUnique ) =<< Map.lookup docUnique parStores
|
||||||
when ( isNothing mbOldStore ) $
|
when ( isNothing mbOldStore ) $
|
||||||
-- Take a lock to avoid creating multiple child stores
|
-- Take a lock to avoid creating multiple child stores
|
||||||
-- for the same group.
|
-- for the same group.
|
||||||
|
@ -759,7 +775,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
|
|
||||||
-- All we do is set the name and visibility of this layer/group.
|
-- All we do is set the name and visibility of this layer/group.
|
||||||
|
|
||||||
let layerText = layerNames meta ! layerUnique layer
|
let mbLayerText = Map.lookup ( layerUnique layer ) ( layerNames meta )
|
||||||
layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta )
|
layerVisible = not $ Set.member ( layerUnique layer ) ( invisibleLayers meta )
|
||||||
|
|
||||||
mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
|
mbTreeListRow <- traverse ( GTK.unsafeCastTo GTK.TreeListRow ) =<< GTK.listItemGetItem listItem
|
||||||
|
@ -770,7 +786,7 @@ newLayerView uiElts@( UIElements { window } ) vars = mdo
|
||||||
|
|
||||||
GTK.widgetSetVisible checkButton True
|
GTK.widgetSetVisible checkButton True
|
||||||
GTK.checkButtonSetActive checkButton layerVisible
|
GTK.checkButtonSetActive checkButton layerVisible
|
||||||
GTK.editableSetText layerLabel layerText
|
for_ mbLayerText $ GTK.editableSetText layerLabel
|
||||||
|
|
||||||
listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just layersListFactory )
|
listView <- GTK.listViewNew ( Nothing @GTK.SingleSelection ) ( Just layersListFactory )
|
||||||
return listView
|
return listView
|
||||||
|
@ -906,8 +922,8 @@ data LayerChange
|
||||||
, newIsGroup :: !Bool
|
, newIsGroup :: !Bool
|
||||||
, newSelected :: !( Maybe ChildLayer )
|
, newSelected :: !( Maybe ChildLayer )
|
||||||
}
|
}
|
||||||
| Delete
|
| DeleteItems
|
||||||
{ deleteItem :: !ChildLayer
|
{ deleteItems :: !( NE.NonEmpty ChildLayer )
|
||||||
}
|
}
|
||||||
| SetBrush
|
| SetBrush
|
||||||
{ setBrushStroke :: !ChildLayer
|
{ setBrushStroke :: !ChildLayer
|
||||||
|
@ -1112,45 +1128,63 @@ applyChangeToLayerHierarchy change hierarchy =
|
||||||
, newIsGroup
|
, newIsGroup
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
Delete { deleteItem = WithinParent parUniq delUniq } ->
|
DeleteItems { deleteItems } ->
|
||||||
let !( !hierarchy', childIx ) = removeLayerFromParent hierarchy ( parUniq, delUniq )
|
|
||||||
!( !hierarchy'', mbHadChildren ) =
|
|
||||||
deleteLayerKey delUniq hierarchy'
|
|
||||||
in
|
|
||||||
( hierarchy''
|
|
||||||
, Map.empty
|
|
||||||
, Just $
|
|
||||||
DeleteLayer
|
|
||||||
{ delPosition = WithinParent parUniq childIx
|
|
||||||
, delUnique = delUniq
|
|
||||||
, delIsGroup = isJust mbHadChildren
|
|
||||||
}
|
|
||||||
)
|
|
||||||
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
|
|
||||||
let
|
let
|
||||||
oldStroke, newStroke :: Stroke
|
!( !hierarchy', delLayers ) = applyDeletionToStrokeHierarchy hierarchy deleteItems
|
||||||
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
|
in
|
||||||
( hierarchy'
|
( hierarchy'
|
||||||
, Map.empty
|
, Map.empty
|
||||||
, Just $
|
, Just $ DeleteLayers mempty delLayers
|
||||||
StrokeSetBrush
|
|
||||||
{ changedBrushStroke = WithinParent parUniq strokeIx
|
|
||||||
, newBrushName = setBrushName
|
|
||||||
}
|
|
||||||
)
|
)
|
||||||
|
SetBrush { setBrushStroke = WithinParent parUniq strokeUnique, setBrushName } ->
|
||||||
|
case Map.lookup strokeUnique ( content hierarchy ) of
|
||||||
|
Just oldStroke
|
||||||
|
| Just oldPar_cs <- lookupChildren_maybe parUniq hierarchy
|
||||||
|
, Just strokeIx <- elemIndex strokeUnique oldPar_cs
|
||||||
|
->
|
||||||
|
let
|
||||||
|
newStroke :: Stroke
|
||||||
|
newStroke =
|
||||||
|
case setBrushName of
|
||||||
|
Just brushNm
|
||||||
|
| Just ( SomeBrush brush ) <- lookupBrush brushNm
|
||||||
|
-> setStrokeBrush ( Just brush ) oldStroke
|
||||||
|
_ -> setStrokeBrush Nothing oldStroke
|
||||||
|
hierarchy' = hierarchy { content = Map.insert strokeUnique newStroke ( content hierarchy ) }
|
||||||
|
in
|
||||||
|
( hierarchy'
|
||||||
|
, Map.empty
|
||||||
|
, Just $
|
||||||
|
StrokeSetBrush
|
||||||
|
{ changedBrushStroke = WithinParent parUniq ( fromIntegral strokeIx )
|
||||||
|
, newBrushName = setBrushName
|
||||||
|
}
|
||||||
|
)
|
||||||
|
| otherwise
|
||||||
|
-> trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
|
||||||
|
, "could not find index within parent of stroke " ++ show strokeUnique
|
||||||
|
, "parent: " ++ show parUniq ])
|
||||||
|
( hierarchy, Map.empty, Nothing )
|
||||||
|
Nothing ->
|
||||||
|
trace ( unlines [ "internal error in 'applyChangeToLayerHierarchy' SetBrush"
|
||||||
|
, "no content for stroke with unique " ++ show strokeUnique ])
|
||||||
|
( hierarchy, Map.empty, Nothing )
|
||||||
|
|
||||||
|
|
||||||
|
applyDeletionToStrokeHierarchy :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
|
||||||
|
applyDeletionToStrokeHierarchy hierarchy0 = go hierarchy0
|
||||||
|
where
|
||||||
|
go :: StrokeHierarchy -> NE.NonEmpty ChildLayer -> ( StrokeHierarchy, Map (Parent Unique) [DeleteLayer] )
|
||||||
|
go h (WithinParent parUniq delUniq NE.:| items) =
|
||||||
|
let !( !h', _ ) = removeLayerFromParent h ( parUniq, delUniq )
|
||||||
|
!( _, !childIx ) = removeLayerFromParent hierarchy0 ( parUniq, delUniq )
|
||||||
|
!( !h'', !mbChildren ) = deleteLayerKey delUniq h'
|
||||||
|
in second ( Map.insertWith (++) parUniq
|
||||||
|
[DeleteLayer { delPosition = childIx
|
||||||
|
, delUnique = delUniq
|
||||||
|
, delIsGroup = isJust mbChildren
|
||||||
|
}] ) $ ( case items of { [] -> ( h'', Map.empty )
|
||||||
|
; (i:is) -> ( go h'' (i NE.:| is) ) } )
|
||||||
|
|
||||||
-- | Apply a change to the 'ListModel' underlying the UI
|
-- | Apply a change to the 'ListModel' underlying the UI
|
||||||
-- representation of the layer hierarchy.
|
-- representation of the layer hierarchy.
|
||||||
|
@ -1172,44 +1206,122 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
|
||||||
-- parent --> list store used to hold its children
|
-- parent --> list store used to hold its children
|
||||||
--
|
--
|
||||||
-- and use that child list store to perform updates.
|
-- and use that child list store to perform updates.
|
||||||
parStoreFromUniq <- ( ! docUnique ) <$> STM.readTVarIO parStoreTVar
|
|
||||||
case diff of
|
mbParStoreFromUniq <- Map.lookup docUnique <$> STM.readTVarIO parStoreTVar
|
||||||
MoveLayer { srcPos = WithinParent srcPar srcIx
|
case mbParStoreFromUniq of
|
||||||
, dstPos = WithinParent dstPar dstIx } -> do
|
Nothing ->
|
||||||
let srcStore = parStoreFromUniq ! srcPar
|
putStrLn $ unlines
|
||||||
dstStore = parStoreFromUniq ! dstPar
|
[ "internal error in 'applyDiffToListModel'"
|
||||||
case doOrUndo of
|
, "failed to look up list store map for document with unique " ++ show docUnique ]
|
||||||
Do -> do
|
Just parStoreFromUniq -> do
|
||||||
item <- fromJust <$> GIO.listModelGetItem srcStore srcIx
|
case diff of
|
||||||
GIO.listStoreRemove srcStore srcIx
|
MoveLayer { srcPos = WithinParent srcPar srcIx
|
||||||
GIO.listStoreInsert dstStore dstIx item
|
, dstPos = WithinParent dstPar dstIx } ->
|
||||||
Undo -> do
|
case Map.lookup srcPar parStoreFromUniq of
|
||||||
item <- fromJust <$> GIO.listModelGetItem dstStore dstIx
|
Nothing ->
|
||||||
GIO.listStoreRemove dstStore dstIx
|
putStrLn $ unlines
|
||||||
GIO.listStoreInsert srcStore srcIx item
|
[ "internal error in 'applyDiffToListModel' MoveLayer"
|
||||||
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } -> do
|
, "failed to look up list store for source parent " ++ show srcPar ]
|
||||||
let dstStore = parStoreFromUniq ! dstPar
|
Just srcStore ->
|
||||||
case doOrUndo of
|
case Map.lookup dstPar parStoreFromUniq of
|
||||||
Do -> do
|
Nothing ->
|
||||||
item <- GI.new LayerItem []
|
putStrLn $ unlines
|
||||||
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
|
[ "internal error in 'applyDiffToListModel' MoveLayer"
|
||||||
GIO.listStoreInsert dstStore dstIx item
|
, "failed to look up list store for destination parent " ++ show dstPar ]
|
||||||
Undo ->
|
Just dstStore ->
|
||||||
GIO.listStoreRemove dstStore dstIx
|
case doOrUndo of
|
||||||
DeleteLayer { delPosition = WithinParent srcPar srcIx, delUnique, delIsGroup } -> do
|
Do -> do
|
||||||
let srcStore = parStoreFromUniq ! srcPar
|
mbItem <- GIO.listModelGetItem srcStore srcIx
|
||||||
case doOrUndo of
|
case mbItem of
|
||||||
Do -> GIO.listStoreRemove srcStore srcIx
|
Nothing ->
|
||||||
Undo -> do
|
putStrLn $ unlines
|
||||||
item <- GI.new LayerItem []
|
[ "internal error in 'applyDiffToListModel' Do MoveLayer"
|
||||||
GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
, "failed to get item at index " ++ show srcIx ]
|
||||||
GIO.listStoreInsert srcStore srcIx item
|
Just item -> do
|
||||||
DeletePoints { deletedStrokes } ->
|
GIO.listStoreRemove srcStore srcIx
|
||||||
unless ( null deletedStrokes ) $
|
GIO.listStoreInsert dstStore dstIx item
|
||||||
putStrLn "TODO: delete strokes"
|
Undo -> do
|
||||||
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } -> do
|
mbItem <- GIO.listModelGetItem dstStore dstIx
|
||||||
let changedStrokeStore = parStoreFromUniq ! changedPar
|
case mbItem of
|
||||||
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
|
Nothing ->
|
||||||
|
putStrLn $ unlines
|
||||||
|
[ "internal error in 'applyDiffToListModel' Undo MoveLayer"
|
||||||
|
, "failed to get item at index " ++ show dstIx ]
|
||||||
|
Just item -> do
|
||||||
|
GIO.listStoreRemove dstStore dstIx
|
||||||
|
GIO.listStoreInsert srcStore srcIx item
|
||||||
|
NewLayer { newPosition = WithinParent dstPar dstIx, newUnique, newIsGroup } ->
|
||||||
|
case Map.lookup dstPar parStoreFromUniq of
|
||||||
|
Nothing ->
|
||||||
|
putStrLn $ unlines
|
||||||
|
[ "internal error in 'applyDiffToListModel' NewLayer"
|
||||||
|
, "failed to look up list store for parent " ++ show dstPar ]
|
||||||
|
Just dstStore ->
|
||||||
|
case doOrUndo of
|
||||||
|
Do -> do
|
||||||
|
item <- GI.new LayerItem []
|
||||||
|
GI.gobjectSetPrivateData item ( Just $ if newIsGroup then GroupLayer newUnique else StrokeLayer newUnique )
|
||||||
|
GIO.listStoreInsert dstStore dstIx item
|
||||||
|
Undo ->
|
||||||
|
GIO.listStoreRemove dstStore dstIx
|
||||||
|
DeleteLayers _delPts delLayers ->
|
||||||
|
Map.foldMapWithKey deleteLayersInParent delLayers
|
||||||
|
where
|
||||||
|
deleteLayersInParent _ [] = return ()
|
||||||
|
deleteLayersInParent srcPar (l:ls) =
|
||||||
|
case Map.lookup srcPar parStoreFromUniq of
|
||||||
|
Nothing ->
|
||||||
|
putStrLn $ unlines
|
||||||
|
[ "internal error in 'applyDiffToListModel' DeleteLayers"
|
||||||
|
, "failed to look up list store for parent " ++ show srcPar ]
|
||||||
|
Just srcStore ->
|
||||||
|
let sortedLays = NE.sortOn delPosition (l NE.:| ls)
|
||||||
|
in
|
||||||
|
if sequentialOn delPosition sortedLays
|
||||||
|
then do
|
||||||
|
(remLays, addLays) <-
|
||||||
|
case doOrUndo of
|
||||||
|
Do -> return ( fromIntegral ( length sortedLays ) , [] )
|
||||||
|
Undo -> do
|
||||||
|
newLays <- for sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup } ) -> do
|
||||||
|
item <- GI.new LayerItem []
|
||||||
|
GI.gobjectSetPrivateData item
|
||||||
|
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
||||||
|
GObject.toObject item
|
||||||
|
return ( 0, NE.toList newLays )
|
||||||
|
GIO.listStoreSplice srcStore ( delPosition $ NE.head sortedLays ) remLays addLays
|
||||||
|
else case doOrUndo of
|
||||||
|
Do ->
|
||||||
|
-- Delete later items first, otherwise indexing is wrong.
|
||||||
|
for_ ( NE.reverse sortedLays ) $ \ ( DeleteLayer { delPosition = srcIx } ) ->
|
||||||
|
GIO.listStoreRemove srcStore srcIx
|
||||||
|
Undo ->
|
||||||
|
-- Insert earlier items first, otherwise indexing is wrong.
|
||||||
|
for_ sortedLays $ \ ( DeleteLayer { delUnique, delIsGroup, delPosition = srcIx } ) -> do
|
||||||
|
item <- GI.new LayerItem []
|
||||||
|
GI.gobjectSetPrivateData item
|
||||||
|
( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
|
||||||
|
GIO.listStoreInsert srcStore srcIx item
|
||||||
|
StrokeSetBrush { changedBrushStroke = WithinParent changedPar changedIx } ->
|
||||||
|
case Map.lookup changedPar parStoreFromUniq of
|
||||||
|
Nothing ->
|
||||||
|
putStrLn $ unlines
|
||||||
|
[ "internal error in 'applyDiffToListModel' StrokeSetBrush"
|
||||||
|
, "failed to look up list store for parent " ++ show changedPar ]
|
||||||
|
Just changedStrokeStore ->
|
||||||
|
GIO.listModelItemsChanged changedStrokeStore changedIx 0 0
|
||||||
|
|
||||||
|
sequentialOn :: forall a i. ( Num i, Ord i ) => ( a -> i ) -> NE.NonEmpty a -> Bool
|
||||||
|
sequentialOn f ( a NE.:| as ) = go ( f a ) as
|
||||||
|
where
|
||||||
|
go :: i -> [ a ] -> Bool
|
||||||
|
go _ [] = True
|
||||||
|
go i (b:bs)
|
||||||
|
| let j = f b
|
||||||
|
, j == i + 1
|
||||||
|
= go j bs
|
||||||
|
| otherwise
|
||||||
|
= False
|
||||||
|
|
||||||
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
|
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
|
||||||
-- moving one layer or group around.
|
-- moving one layer or group around.
|
||||||
|
@ -1251,13 +1363,22 @@ moveLayerUpdate src@( srcPar, srcUniq ) dst@( dstPar, _ ) hierarchy =
|
||||||
-- was found within its parent.
|
-- was found within its parent.
|
||||||
--
|
--
|
||||||
-- NB: does not delete the layer itself.
|
-- NB: does not delete the layer itself.
|
||||||
removeLayerFromParent :: StrokeHierarchy
|
removeLayerFromParent :: HasCallStack
|
||||||
|
=> StrokeHierarchy
|
||||||
-> ( Parent Unique, Unique )
|
-> ( Parent Unique, Unique )
|
||||||
-> ( StrokeHierarchy, Word32 )
|
-> ( StrokeHierarchy, Word32 )
|
||||||
removeLayerFromParent hierarchy ( parent, u ) =
|
removeLayerFromParent hierarchy ( parent, u ) =
|
||||||
let oldPar_cs = lookupChildren parent hierarchy
|
let oldPar_cs = lookupChildren parent hierarchy
|
||||||
newChildren = filter ( /= u ) oldPar_cs
|
newChildren = filter ( /= u ) oldPar_cs
|
||||||
oldChildPos = fromIntegral $ fromJust $ elemIndex u oldPar_cs
|
oldChildPos = case elemIndex u oldPar_cs of
|
||||||
|
Nothing -> error $ unlines
|
||||||
|
[ "internal error in 'removeLayerFromParent': could not find index within parent"
|
||||||
|
, "parent: " ++ show parent
|
||||||
|
, "child: " ++ show u
|
||||||
|
, "children of parent: " ++ show oldPar_cs
|
||||||
|
, "hierarchy: " ++ show hierarchy
|
||||||
|
]
|
||||||
|
Just i -> fromIntegral i
|
||||||
in ( insertGroup parent newChildren hierarchy, oldChildPos )
|
in ( insertGroup parent newChildren hierarchy, oldChildPos )
|
||||||
|
|
||||||
-- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated
|
-- | Add a layer to a parent in the 'StrokeHierarchy', returning the updated
|
||||||
|
|
|
@ -42,6 +42,8 @@ import Data.Act
|
||||||
( Act((•)), Torsor((-->)) )
|
( Act((•)), Torsor((-->)) )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
|
import Data.Map.Strict
|
||||||
|
( Map )
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Sequence
|
import Data.Sequence
|
||||||
( Seq )
|
( Seq )
|
||||||
|
@ -99,6 +101,7 @@ import MetaBrush.Records
|
||||||
import MetaBrush.Stroke
|
import MetaBrush.Stroke
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
( Unique )
|
( Unique )
|
||||||
|
import MetaBrush.Layer (Parent, WithinParent (..))
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Subdivision.
|
-- Subdivision.
|
||||||
|
@ -127,11 +130,11 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
|
||||||
stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
|
stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
|
||||||
stripData = bimapCurve ( \ _ -> () ) ( \ _ _ -> () )
|
stripData = bimapCurve ( \ _ -> () ) ( \ _ _ -> () )
|
||||||
|
|
||||||
subdivideStroke :: Unique -> Stroke -> StrokeMetadata
|
subdivideStroke :: WithinParent Unique -> Stroke -> StrokeMetadata
|
||||||
-> State
|
-> State
|
||||||
( Maybe Subdivision )
|
( Maybe Subdivision )
|
||||||
UpdateStroke
|
UpdateStroke
|
||||||
subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
subdivideStroke ( WithinParent _ u ) stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||||
mbPrevSubdivision <- State.get
|
mbPrevSubdivision <- State.get
|
||||||
let ( curves', subdivs ) =
|
let ( curves', subdivs ) =
|
||||||
Writer.runWriter $
|
Writer.runWriter $
|
||||||
|
@ -264,8 +267,8 @@ selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
|
||||||
where
|
where
|
||||||
Zoom { zoomFactor } = documentZoom documentMetadata
|
Zoom { zoomFactor } = documentZoom documentMetadata
|
||||||
|
|
||||||
computeSelected :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
|
computeSelected :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
|
||||||
computeSelected strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
computeSelected ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||||
when ( strokeVisible ) $
|
when ( strokeVisible ) $
|
||||||
Except.withExcept ( strokeUnique , ) $
|
Except.withExcept ( strokeUnique , ) $
|
||||||
bifoldSpline
|
bifoldSpline
|
||||||
|
@ -314,8 +317,8 @@ dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
|
||||||
inSelectionRange p =
|
inSelectionRange p =
|
||||||
squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||||
|
|
||||||
dragSelect :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
|
dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
|
||||||
dragSelect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||||
when ( strokeVisible && not strokeLocked ) $
|
when ( strokeVisible && not strokeLocked ) $
|
||||||
ibifoldSpline
|
ibifoldSpline
|
||||||
( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
|
( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
|
||||||
|
@ -449,8 +452,8 @@ selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentC
|
||||||
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
|
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
|
||||||
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
|
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
|
||||||
|
|
||||||
selectRect :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
selectRect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||||
selectRect strokeUnique ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
selectRect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
|
||||||
when strokeVisible $
|
when strokeVisible $
|
||||||
Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
|
Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
|
||||||
bifoldSpline
|
bifoldSpline
|
||||||
|
@ -507,8 +510,8 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
||||||
selPts :: StrokePoints
|
selPts :: StrokePoints
|
||||||
selPts = selectedPoints documentMetadata
|
selPts = selectedPoints documentMetadata
|
||||||
|
|
||||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||||
updateStroke u stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||||
let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
|
let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
|
||||||
firstPointSel = FirstPoint `Set.member` strokeSelPts
|
firstPointSel = FirstPoint `Set.member` strokeSelPts
|
||||||
( spline', ( modPts, _ ) ) =
|
( spline', ( modPts, _ ) ) =
|
||||||
|
@ -600,7 +603,7 @@ translateSelection t doc@( Document { documentContent, documentMetadata } ) =
|
||||||
--
|
--
|
||||||
-- Returns the updated document, together with info about how many points
|
-- Returns the updated document, together with info about how many points
|
||||||
-- and strokes were deleted.
|
-- and strokes were deleted.
|
||||||
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Set Unique )
|
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Map Unique ( Parent Unique ) )
|
||||||
deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
||||||
let
|
let
|
||||||
( newStrokes, ( delPts, delStrokes ) ) =
|
( newStrokes, ( delPts, delStrokes ) ) =
|
||||||
|
@ -620,8 +623,8 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke
|
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Map Unique ( Parent Unique ) ) UpdateStroke
|
||||||
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
updateStroke ( WithinParent par u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||||
| not strokeVisible || strokeLocked
|
| not strokeVisible || strokeLocked
|
||||||
= return PreserveStroke
|
= return PreserveStroke
|
||||||
| otherwise
|
| otherwise
|
||||||
|
@ -637,10 +640,10 @@ deleteSelected doc@( Document { documentContent, documentMetadata } ) =
|
||||||
return PreserveStroke
|
return PreserveStroke
|
||||||
else case mbSpline of
|
else case mbSpline of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.singleton u )
|
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.singleton u par )
|
||||||
return DeleteStroke
|
return DeleteStroke
|
||||||
Just spline' -> do
|
Just spline' -> do
|
||||||
Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.empty )
|
Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.empty )
|
||||||
return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
|
return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
|
||||||
|
|
||||||
where
|
where
|
||||||
|
@ -776,8 +779,8 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
|
||||||
updateStroke u stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||||
| not strokeVisible || strokeLocked || u /= dragStrokeUnique
|
| not strokeVisible || strokeLocked || u /= dragStrokeUnique
|
||||||
= return PreserveStroke
|
= return PreserveStroke
|
||||||
| otherwise
|
| otherwise
|
||||||
|
@ -923,8 +926,8 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
|
|
||||||
zoom = documentZoom $ documentMetadata
|
zoom = documentZoom $ documentMetadata
|
||||||
|
|
||||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
||||||
updateStroke u
|
updateStroke ( WithinParent _ u )
|
||||||
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
|
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
|
||||||
( StrokeMetadata { strokeVisible, strokeLocked } )
|
( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||||
| strokeVisible
|
| strokeVisible
|
||||||
|
|
|
@ -1,13 +1,17 @@
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
|
||||||
module MetaBrush.Document.Diff where
|
module MetaBrush.Document.Diff where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
import Data.Word
|
||||||
|
( Word32 )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic )
|
( Generic )
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Set
|
import Data.Map.Strict
|
||||||
( Set )
|
( Map )
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
|
@ -63,15 +67,10 @@ data HierarchyDiff
|
||||||
, newIsGroup :: !Bool
|
, newIsGroup :: !Bool
|
||||||
, newPosition :: !ChildLayerPosition
|
, newPosition :: !ChildLayerPosition
|
||||||
}
|
}
|
||||||
| DeleteLayer
|
| DeleteLayers
|
||||||
{ delUnique :: !Unique
|
{ deletedPoints :: !StrokePoints
|
||||||
, delIsGroup :: !Bool
|
, deletedLayers :: !( Map ( Parent Unique ) [ DeleteLayer ] )
|
||||||
, delPosition :: !ChildLayerPosition
|
}
|
||||||
}
|
|
||||||
| DeletePoints
|
|
||||||
{ deletedPoints :: !StrokePoints
|
|
||||||
, deletedStrokes :: !( Set Unique )
|
|
||||||
}
|
|
||||||
| MoveLayer
|
| MoveLayer
|
||||||
{ moveUnique :: !Unique
|
{ moveUnique :: !Unique
|
||||||
, srcPos :: !ChildLayerPosition
|
, srcPos :: !ChildLayerPosition
|
||||||
|
@ -84,6 +83,15 @@ data HierarchyDiff
|
||||||
deriving stock ( Show, Generic )
|
deriving stock ( Show, Generic )
|
||||||
deriving anyclass NFData
|
deriving anyclass NFData
|
||||||
|
|
||||||
|
data DeleteLayer
|
||||||
|
= DeleteLayer
|
||||||
|
{ delUnique :: !Unique
|
||||||
|
, delIsGroup :: !Bool
|
||||||
|
, delPosition :: !Word32
|
||||||
|
}
|
||||||
|
deriving stock ( Show, Generic )
|
||||||
|
deriving anyclass NFData
|
||||||
|
|
||||||
-- | A subdivision of a single stroke.
|
-- | A subdivision of a single stroke.
|
||||||
data Subdivision
|
data Subdivision
|
||||||
= Subdivision
|
= Subdivision
|
||||||
|
@ -123,6 +131,8 @@ data ContentDiff
|
||||||
}
|
}
|
||||||
| CloseStroke
|
| CloseStroke
|
||||||
{ closedStroke :: !Unique }
|
{ closedStroke :: !Unique }
|
||||||
|
| DeletePoints
|
||||||
|
{ deletedPoints :: !StrokePoints }
|
||||||
| ContinueStroke
|
| ContinueStroke
|
||||||
{ continuedStroke :: !Unique
|
{ continuedStroke :: !Unique
|
||||||
, newSegment :: !( Spline Open () ( PointData () ) )
|
, newSegment :: !( Spline Open () ( PointData () ) )
|
||||||
|
|
|
@ -177,8 +177,8 @@ getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent =
|
||||||
where
|
where
|
||||||
zoom = documentZoom documentMetadata
|
zoom = documentZoom documentMetadata
|
||||||
|
|
||||||
findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
|
findAnchor :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
|
||||||
findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
findAnchor ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
|
||||||
when ( strokeVisible && not strokeLocked ) $
|
when ( strokeVisible && not strokeLocked ) $
|
||||||
findAnchorSpline strokeSpline
|
findAnchorSpline strokeSpline
|
||||||
return PreserveStroke
|
return PreserveStroke
|
||||||
|
@ -243,8 +243,8 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent
|
||||||
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
|
in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
|
||||||
where
|
where
|
||||||
|
|
||||||
updateStroke :: forall s. Unique -> Stroke -> ST s UpdateStroke
|
updateStroke :: forall s. WithinParent Unique -> Stroke -> ST s UpdateStroke
|
||||||
updateStroke strokeUnique stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
|
updateStroke ( WithinParent _ strokeUnique ) stroke@( Stroke { strokeSpline = ( oldSpline :: StrokeSpline clo brushParams ) })
|
||||||
| strokeUnique == anchorStroke anchor
|
| strokeUnique == anchorStroke anchor
|
||||||
, SOpen <- ssplineType @clo
|
, SOpen <- ssplineType @clo
|
||||||
, let prevSpline0 = coCache @RealWorld @s oldSpline
|
, let prevSpline0 = coCache @RealWorld @s oldSpline
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
module MetaBrush.Layer where
|
module MetaBrush.Layer where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Data.Maybe
|
|
||||||
( fromJust )
|
|
||||||
import Data.Word
|
import Data.Word
|
||||||
( Word32 )
|
( Word32 )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generically(..), Generic )
|
( Generically(..), Generic )
|
||||||
|
import GHC.Stack
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import Data.Map.Strict
|
import Data.Map.Strict
|
||||||
|
@ -24,6 +23,8 @@ import Data.Text
|
||||||
( Text )
|
( Text )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
import Debug.Utils
|
||||||
|
( trace )
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
( Unique )
|
( Unique )
|
||||||
|
|
||||||
|
@ -89,8 +90,15 @@ emptyHierarchy =
|
||||||
, content = Map.empty
|
, content = Map.empty
|
||||||
}
|
}
|
||||||
|
|
||||||
lookupChildren :: Parent Unique -> Hierarchy a -> [ Unique ]
|
lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ]
|
||||||
lookupChildren p h = fromJust $ lookupChildren_maybe p h
|
lookupChildren p h = case lookupChildren_maybe p h of
|
||||||
|
Nothing ->
|
||||||
|
trace ( unlines [ "internal error in 'lookupChildren'"
|
||||||
|
, "no data for parent " ++ show p
|
||||||
|
, ""
|
||||||
|
, "call stack: " ++ prettyCallStack callStack ]
|
||||||
|
) []
|
||||||
|
Just cs -> cs
|
||||||
|
|
||||||
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
|
lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ]
|
||||||
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel
|
lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel
|
||||||
|
|
|
@ -14,10 +14,11 @@ import Data.Foldable
|
||||||
( foldr' )
|
( foldr' )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( Identity(..) )
|
( Identity(..) )
|
||||||
|
import Data.Maybe
|
||||||
|
( mapMaybe )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1 )
|
( Generic, Generic1 )
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
( HasCallStack )
|
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
( Symbol )
|
( Symbol )
|
||||||
import Unsafe.Coerce
|
import Unsafe.Coerce
|
||||||
|
@ -75,17 +76,17 @@ import Math.Module
|
||||||
)
|
)
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..) )
|
( ℝ(..), T(..) )
|
||||||
|
import Debug.Utils
|
||||||
|
( trace )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( NamedBrush, PointFields )
|
( NamedBrush, PointFields )
|
||||||
import MetaBrush.Layer
|
import MetaBrush.Layer
|
||||||
( Hierarchy(..), LayerMetadata(..), emptyHierarchy )
|
( Hierarchy(..), LayerMetadata(..), emptyHierarchy, WithinParent (..), Parent (..) )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
( Unique, UniqueSupply, freshUnique )
|
( Unique, UniqueSupply, freshUnique )
|
||||||
import MetaBrush.Util
|
|
||||||
( (!) )
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -274,44 +275,56 @@ forStrokeHierarchy
|
||||||
. ( HasCallStack, Applicative f )
|
. ( HasCallStack, Applicative f )
|
||||||
=> LayerMetadata
|
=> LayerMetadata
|
||||||
-> StrokeHierarchy
|
-> StrokeHierarchy
|
||||||
-> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
|
-> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
|
||||||
-> f StrokeHierarchy
|
-> f StrokeHierarchy
|
||||||
forStrokeHierarchy
|
forStrokeHierarchy
|
||||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
|
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
|
||||||
foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
|
foldr' ( g Root ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
|
||||||
where
|
where
|
||||||
|
|
||||||
insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
|
insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
|
||||||
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
|
insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
|
||||||
PreserveStroke -> old
|
PreserveStroke -> old
|
||||||
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
|
UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
|
||||||
DeleteStroke ->
|
DeleteStroke ->
|
||||||
let newStrokes = Map.delete u oldStrokes
|
let newStrokes = Map.delete u oldStrokes
|
||||||
in case mbPar of
|
in case mbPar of
|
||||||
Nothing ->
|
Root ->
|
||||||
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
|
Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
|
||||||
Just par ->
|
Parent par ->
|
||||||
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
|
Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
|
||||||
|
|
||||||
|
|
||||||
g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
|
g :: Parent Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
|
||||||
g par ( vis, lock ) u acc =
|
g par ( vis, lock ) u acc =
|
||||||
let vis' = vis && not ( u `Set.member` invisibleLayers )
|
let vis' = vis && not ( u `Set.member` invisibleLayers )
|
||||||
lock' = lock || u `Set.member` lockedLayers
|
lock' = lock || u `Set.member` lockedLayers
|
||||||
in
|
in
|
||||||
case Map.lookup u ( groups hierarchy0 ) of
|
case Map.lookup u ( groups hierarchy0 ) of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
let
|
case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of
|
||||||
meta =
|
( Just strokeName, Just oldStroke ) ->
|
||||||
StrokeMetadata
|
let
|
||||||
{ strokeName = layerNames ! u
|
meta =
|
||||||
, strokeVisible = vis'
|
StrokeMetadata
|
||||||
, strokeLocked = lock'
|
{ strokeName
|
||||||
}
|
, strokeVisible = vis'
|
||||||
in
|
, strokeLocked = lock'
|
||||||
insertMaybe par u <$> acc <*> f u ( content hierarchy0 ! u ) meta
|
}
|
||||||
|
in
|
||||||
|
insertMaybe par u <$> acc <*> f ( WithinParent par u ) oldStroke meta
|
||||||
|
_ ->
|
||||||
|
trace
|
||||||
|
( unlines
|
||||||
|
[ "internal error in 'forStrokeHierarchy'"
|
||||||
|
, "failed to look up stroke with unique " ++ show u
|
||||||
|
, ""
|
||||||
|
, "call stack: " ++ prettyCallStack callStack
|
||||||
|
]
|
||||||
|
) acc
|
||||||
|
|
||||||
Just ds ->
|
Just ds ->
|
||||||
foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
|
foldr' ( g ( Parent u ) ( vis', lock' ) ) acc ds
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -338,29 +351,48 @@ data Layer
|
||||||
}
|
}
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
|
strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers
|
||||||
strokeHierarchyLayers
|
strokeHierarchyLayers
|
||||||
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
|
( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
|
||||||
( Hierarchy topLevel hierarchy content ) = map go topLevel
|
( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel
|
||||||
where
|
where
|
||||||
go :: Unique -> Layer
|
go :: Unique -> Maybe Layer
|
||||||
go layerUnique =
|
go layerUnique =
|
||||||
let
|
let
|
||||||
layerName = layerNames ! layerUnique
|
|
||||||
layerVisible = not $ layerUnique `Set.member` invisibleLayers
|
layerVisible = not $ layerUnique `Set.member` invisibleLayers
|
||||||
layerLocked = layerUnique `Set.member` lockedLayers
|
layerLocked = layerUnique `Set.member` lockedLayers
|
||||||
in
|
in
|
||||||
case Map.lookup layerUnique hierarchy of
|
case Map.lookup layerUnique hierarchy of
|
||||||
Nothing ->
|
Nothing
|
||||||
StrokeLayer
|
| Just layerName <- Map.lookup layerUnique layerNames
|
||||||
{ layerName, layerVisible, layerLocked
|
, Just layerStroke <- Map.lookup layerUnique content
|
||||||
, layerStroke = content ! layerUnique
|
->
|
||||||
}
|
Just $
|
||||||
Just cs ->
|
StrokeLayer
|
||||||
GroupLayer
|
{ layerName, layerVisible, layerLocked, layerStroke }
|
||||||
{ layerName, layerVisible, layerLocked
|
| otherwise
|
||||||
, groupChildren = map go cs
|
-> trace
|
||||||
}
|
( unlines [ "internal error in 'strokeHierarchyLayers"
|
||||||
|
, "could not retrieve data for layer with unique: " ++ show layerUnique
|
||||||
|
, ""
|
||||||
|
, "call stack: " ++ prettyCallStack callStack
|
||||||
|
]
|
||||||
|
) Nothing
|
||||||
|
Just cs
|
||||||
|
| Just layerName <- Map.lookup layerUnique layerNames
|
||||||
|
-> Just $
|
||||||
|
GroupLayer
|
||||||
|
{ layerName, layerVisible, layerLocked
|
||||||
|
, groupChildren = mapMaybe go cs
|
||||||
|
}
|
||||||
|
| otherwise
|
||||||
|
-> trace
|
||||||
|
( unlines [ "internal error in 'strokeHierarchyLayers"
|
||||||
|
, "could not retrieve data for group with unique: " ++ show layerUnique
|
||||||
|
, ""
|
||||||
|
, "call stack: " ++ prettyCallStack callStack
|
||||||
|
]
|
||||||
|
) Nothing
|
||||||
|
|
||||||
{-# INLINEABLE layersStrokeHierarchy #-}
|
{-# INLINEABLE layersStrokeHierarchy #-}
|
||||||
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )
|
layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy )
|
||||||
|
|
|
@ -1,25 +1,8 @@
|
||||||
module MetaBrush.Util
|
module MetaBrush.Util
|
||||||
( Exists(..)
|
( Exists(..) )
|
||||||
, (!)
|
|
||||||
)
|
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
|
||||||
import GHC.Stack
|
|
||||||
( HasCallStack )
|
|
||||||
|
|
||||||
-- containers
|
|
||||||
import Data.Map.Strict
|
|
||||||
( Map )
|
|
||||||
import qualified Data.Map.Strict as Map
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Exists c where
|
data Exists c where
|
||||||
Exists :: c a => a -> Exists c
|
Exists :: c a => a -> Exists c
|
||||||
|
|
||||||
infixl 9 !
|
|
||||||
(!) :: ( Show k, Ord k, HasCallStack ) => Map k a -> k -> a
|
|
||||||
m ! k = case Map.lookup k m of
|
|
||||||
Nothing -> error $ "MetaBrush internal error: key not in map: " ++ show k
|
|
||||||
Just a -> a
|
|
Loading…
Reference in a new issue