anchor position is not static

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

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 )
+            , Just ( doc', _ ) <- dragUpdate p0 p1 dragAction alternateMode doc
-                afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
+            -> getVisibleStrokes doc'
-            -> case afterDrag of
-                Just ( docUpdate, _ ) -> getVisibleStrokes docUpdate
-                Nothing               -> 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
+                previewSpline :: Spline Open () ( PointData () )
-                previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) ->
+                previewSpline = catMaybesSpline ()
-                  let
+                  ( PointData p0 () )
-                    previewSpline :: Spline Open CurveData ( PointData ( Record pointFields ) )
+                  ( do
-                    previewSpline = catMaybesSpline ( CurveData 987654321 ( invalidateCache undefined ) )
+                      cp <- cp0
-                      ( PointData p0 pointData )
+                      guard ( cp /= p0 )
-                      ( do
+                      pure ( PointData cp () )
-                          cp <- cp0
+                  )
-                          guard ( cp /= p0 )
+                  ( do
-                          pure ( PointData cp pointData )
+                      cp <- mbControlPoint
-                      )
+                      guard ( cp /= finalPoint )
-                      ( do
+                      pure ( PointData cp () )
-                          cp <- mbControlPoint
+                  )
-                          guard ( cp /= finalPoint )
+                  ( PointData finalPoint () )
-                          pure ( PointData cp pointData )
+                doc' = addToAnchor anchor previewSpline doc
-                      )
+            -> getVisibleStrokes doc'
-                      ( PointData finalPoint pointData )
-                  in
-                    Stroke
-                      { strokeSpline = previewSpline
-                      , strokeBrush  = mbBrush
-                      }
-              -> ( Nothing, previewStroke ) : getVisibleStrokes doc
           _ -> getVisibleStrokes doc
 
       strokesRenderData <-

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 {} ->
+    DeletePoints { deletedStrokes } ->
-      error "TODO"
+      unless ( null deletedStrokes ) $
+        putStrLn "TODO: delete strokes"
 
 -- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
 -- moving one layer or group around.

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 )

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

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 = uniq1, anchorIsAtEnd = end1 } )
-  ( DrawAnchor { anchorStroke = uniq2, anchorIndex = end2 } )
+  ( 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 }) ->
+    Left anchor ->
-      let newSel = StrokePoints $ Map.singleton anchorStroke ( Set.singleton anchorIndex )
+      let newMeta :: DocumentMetadata
-          newMeta :: DocumentMetadata
+          newMeta = documentMetadata { selectedPoints = mempty }
-          newMeta = documentMetadata { selectedPoints = newSel }
       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 )