From a41c6235ae315a66a884ebe3570a72c6f0bc8d18 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 28 Sep 2024 03:12:23 +0200 Subject: [PATCH] anchor position is not static --- src/app/MetaBrush/Application/Action.hs | 10 +-- src/app/MetaBrush/Render/Document.hs | 50 +++++++-------- src/app/MetaBrush/UI/StrokeTreeView.hs | 5 +- src/metabrushes/MetaBrush/Action.hs | 6 -- src/metabrushes/MetaBrush/Document/Diff.hs | 2 +- src/metabrushes/MetaBrush/Draw.hs | 73 +++++++--------------- 6 files changed, 52 insertions(+), 94 deletions(-) diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 4e7e220..a84b44c 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -1167,7 +1167,7 @@ instance HandleAction MouseRelease where ) -> do let p1 :: ℝ 2 - p1 = anchorPos anchor + p1 = anchorPos anchor doc pathPoint :: ℝ 2 mbControlPoint :: Maybe ( ℝ 2 ) partialControlPoint :: Maybe ( ℝ 2 ) @@ -1192,10 +1192,10 @@ instance HandleAction MouseRelease where ) ( do cp <- mbControlPoint - guard ( cp /= anchorPos otherAnchor ) + guard ( cp /= anchorPos otherAnchor doc ) pure ( PointData cp () ) ) - ( PointData ( anchorPos otherAnchor ) () ) + ( PointData ( anchorPos otherAnchor doc ) () ) newDocument :: Document newDocument = addToAnchor anchor newSegment doc diff = HistoryDiff $ ContentDiff @@ -1209,7 +1209,7 @@ instance HandleAction MouseRelease where pure Don'tModifyDoc -- Finish current partial path. else do - STM.writeTVar partialPathTVar ( Just $ PartialPath ( anchor { anchorPos = pathPoint } ) partialControlPoint False ) + STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False ) let newSegment :: Spline Open () ( PointData () ) newSegment = catMaybesSpline () @@ -1230,7 +1230,7 @@ instance HandleAction MouseRelease where diff = HistoryDiff $ ContentDiff $ ContinueStroke { continuedStroke = anchorStroke anchor - , newSegment = bimapSpline ( \ _ crv -> bimapCurve ( \ _ -> () ) ( \ _ _ -> () ) crv ) ( \ _ -> () ) newSegment + , newSegment } pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) BrushMode -> do diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 3651829..ed3ae18 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -110,6 +110,8 @@ import MetaBrush.Unique import MetaBrush.GTK.Util ( withRGBA ) +import Debug.Trace + -------------------------------------------------------------------------------- data Renders a @@ -174,14 +176,11 @@ getDocumentRender , let alternateMode :: Bool alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers - afterDrag :: Maybe ( Document, StrokePoints ) - afterDrag = dragUpdate p0 p1 dragAction alternateMode doc - -> case afterDrag of - Just ( docUpdate, _ ) -> getVisibleStrokes docUpdate - Nothing -> getVisibleStrokes doc + , Just ( doc', _ ) <- dragUpdate p0 p1 dragAction alternateMode doc + -> getVisibleStrokes doc' | Just ( PartialPath anchor cp0 firstPoint ) <- mbPartialPath , let - p0 = anchorPos anchor + p0 = anchorPos anchor doc mbFinalPoint :: Maybe ( ℝ 2 ) mbControlPoint :: Maybe ( ℝ 2 ) ( mbFinalPoint, mbControlPoint ) @@ -193,29 +192,22 @@ getDocumentRender = ( mbMousePos, Nothing ) , Just finalPoint <- mbFinalPoint , let - previewStroke :: Stroke - previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) -> - let - previewSpline :: Spline Open CurveData ( PointData ( Record pointFields ) ) - previewSpline = catMaybesSpline ( CurveData 987654321 ( invalidateCache undefined ) ) - ( PointData p0 pointData ) - ( do - cp <- cp0 - guard ( cp /= p0 ) - pure ( PointData cp pointData ) - ) - ( do - cp <- mbControlPoint - guard ( cp /= finalPoint ) - pure ( PointData cp pointData ) - ) - ( PointData finalPoint pointData ) - in - Stroke - { strokeSpline = previewSpline - , strokeBrush = mbBrush - } - -> ( Nothing, previewStroke ) : getVisibleStrokes doc + previewSpline :: Spline Open () ( PointData () ) + previewSpline = catMaybesSpline () + ( PointData p0 () ) + ( do + cp <- cp0 + guard ( cp /= p0 ) + pure ( PointData cp () ) + ) + ( do + cp <- mbControlPoint + guard ( cp /= finalPoint ) + pure ( PointData cp () ) + ) + ( PointData finalPoint () ) + doc' = addToAnchor anchor previewSpline doc + -> getVisibleStrokes doc' _ -> getVisibleStrokes doc strokesRenderData <- diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs b/src/app/MetaBrush/UI/StrokeTreeView.hs index 739360d..baccb13 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs @@ -1145,8 +1145,9 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do item <- GI.new LayerItem [] GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique ) GIO.listStoreInsert srcStore srcIx item - DeletePoints {} -> - error "TODO" + DeletePoints { deletedStrokes } -> + unless ( null deletedStrokes ) $ + putStrLn "TODO: delete strokes" -- | Update the 'StrokeHierarchy' after a drag-and-drop operation, -- moving one layer or group around. diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index e8a1183..54057cd 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -886,12 +886,6 @@ data BrushWidgetActionState , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) ) } deriving stock ( Eq, Show ) -instance Semigroup BrushWidgetActionState where - a <> b - | a == b - = a - | otherwise - = error "internal error: trying to combine incompatible brush widget action states" -- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point. applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( Document, BrushWidgetActionState ) diff --git a/src/metabrushes/MetaBrush/Document/Diff.hs b/src/metabrushes/MetaBrush/Document/Diff.hs index 34704ed..49434ee 100644 --- a/src/metabrushes/MetaBrush/Document/Diff.hs +++ b/src/metabrushes/MetaBrush/Document/Diff.hs @@ -117,7 +117,7 @@ data ContentDiff { closedStroke :: !Unique } | ContinueStroke { continuedStroke :: !Unique - , newSegment :: !( Spline Open () () ) + , newSegment :: !( Spline Open () ( PointData () ) ) } | UpdateBrushParameters { updateBrushStroke :: !Unique diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index 665f6c5..f8f947d 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -4,7 +4,7 @@ module MetaBrush.Draw ( DrawAnchor(..), anchorsAreComplementary , getOrCreateDrawAnchor, addToAnchor - , withAnchorBrushData + , anchorPos ) where @@ -60,7 +60,7 @@ import Math.Linear import MetaBrush.Assert ( assert ) import MetaBrush.Brush - ( NamedBrush(..), PointFields ) + ( NamedBrush(..) ) import MetaBrush.Document import MetaBrush.Hover ( inPointClickRange ) @@ -70,6 +70,8 @@ import MetaBrush.Stroke import MetaBrush.Unique ( Unique, UniqueSupply, freshUnique ) +import Debug.Trace + -------------------------------------------------------------------------------- -- | A draw anchor, to continue drawing from one end of an existing stroke. @@ -78,8 +80,6 @@ data DrawAnchor { anchorIsNew :: !Bool , anchorStroke :: !Unique , anchorIsAtEnd :: !Bool - , anchorPos :: !( ℝ 2 ) - , anchorIndex :: !PointIndex } deriving stock ( Show, Eq, Generic ) deriving anyclass NFData @@ -87,8 +87,8 @@ data DrawAnchor -- | Computes whether two anchors are the two ends of the same stroke. anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool anchorsAreComplementary - ( DrawAnchor { anchorStroke = uniq1, anchorIndex = end1 } ) - ( DrawAnchor { anchorStroke = uniq2, anchorIndex = end2 } ) + ( DrawAnchor { anchorStroke = uniq1, anchorIsAtEnd = end1 } ) + ( DrawAnchor { anchorStroke = uniq2, anchorIsAtEnd = end2 } ) = uniq1 == uniq2 && end1 /= end2 -- | Compute a draw anchor at the given position, e.g. to continue @@ -111,10 +111,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte findAnchor of -- Anchor found: use it. - Left anchor@( DrawAnchor { anchorStroke, anchorIndex }) -> - let newSel = StrokePoints $ Map.singleton anchorStroke ( Set.singleton anchorIndex ) - newMeta :: DocumentMetadata - newMeta = documentMetadata { selectedPoints = newSel } + Left anchor -> + let newMeta :: DocumentMetadata + newMeta = documentMetadata { selectedPoints = mempty } in pure ( doc { documentMetadata = newMeta } , anchor ) -- No anchor found: start a new stroke (on a new stroke layer). @@ -156,8 +155,6 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte { anchorIsNew = True , anchorStroke = newStrokeUnique , anchorIsAtEnd = True - , anchorPos = c - , anchorIndex = FirstPoint } pure ( newDoc', anchor ) where @@ -190,8 +187,6 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte { anchorIsNew = False , anchorStroke = uniq , anchorIsAtEnd = False - , anchorPos = p0 - , anchorIndex = FirstPoint } -> Just anchor | OpenCurves ( _ :|> lastCurve ) <- splineCurves @@ -204,14 +199,23 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte { anchorIsNew = False , anchorStroke = uniq , anchorIsAtEnd = True - , anchorPos = pn - , anchorIndex = PointIndex - ( curveIndex $ curveData lastCurve ) - PathPoint } -> Just anchor _ -> Nothing +anchorPos :: DrawAnchor -> Document -> ℝ 2 +anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } ) + ( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) = + case Map.lookup anchorStroke strokes of + Nothing -> error "draw anchor: stroke not present in hierarchy" + Just ( Stroke { strokeSpline } ) -> + let res = + coords $ + if anchorIsAtEnd + then splineEnd ( adjustSplineType @Open strokeSpline ) + else splineStart ( adjustSplineType @Open strokeSpline ) + in trace ("anchorPos: " ++ show res) res + addToAnchor :: DrawAnchor -> Spline Open () ( PointData () ) -> Document -> Document addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) = let @@ -261,36 +265,3 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = UpdateStrokeTo $ overStrokeSpline updateSpline stroke | otherwise = PreserveStroke - -withAnchorBrushData - :: forall r - . DrawAnchor - -> Document - -> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) - . ( pointParams ~ Record pointFields - , PointFields pointFields - ) - => Maybe ( NamedBrush brushFields ) - -> pointParams - -> r - ) - -> r -withAnchorBrushData anchor ( Document { documentMetadata = Metadata { layerMetadata }, documentContent = Content { strokeHierarchy } } ) f = - splineAnchor $ Except.runExcept $ forStrokeHierarchy layerMetadata strokeHierarchy relevantStroke - where - - relevantStroke :: Unique -> Stroke -> StrokeMetadata -> Except Stroke UpdateStroke - relevantStroke strokeUnique stroke _ - | strokeUnique == anchorStroke anchor - = Except.throwE stroke - | otherwise - = return PreserveStroke - - splineAnchor :: Either Stroke other -> r - splineAnchor ( Left ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) ) - | SOpen <- ssplineType @clo - = if anchorIsAtEnd anchor - then f strokeBrush ( brushParams ( splineEnd strokeSpline ) ) - else f strokeBrush ( brushParams ( splineStart strokeSpline ) ) - splineAnchor _ - = f @_ @'[] @'[] Nothing ( MkR ℝ0 )