fixes to brush widget UI

src/app/MetaBrush/Action.hs

@@ -8,7 +8,7 @@ import Control.Monad
 import Control.Monad.ST
   ( RealWorld )
 import Data.Foldable
-  ( for_, sequenceA_ )
+  ( for_ )
 import Data.Int
   ( Int32 )
 import Data.List
@@ -106,6 +106,8 @@ import Math.Linear
 -- MetaBrush
 import MetaBrush.Asset.WindowIcons
   ( drawClose )
+import qualified MetaBrush.Brush.Widget as Brush
+  ( describeWidgetAction )
 import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..), modifierKey
@@ -128,6 +130,7 @@ import MetaBrush.Document.Selection
   , UpdateInfo(..)
   , deleteSelected
   , dragUpdate, pressingControl
+  , BrushWidgetActionState(..)
   , applyBrushWidgetAction
   )
 import MetaBrush.Document.Serialise
@@ -135,7 +138,7 @@ import MetaBrush.Document.Serialise
 import MetaBrush.Document.SubdivideStroke
   ( subdivide )
 import MetaBrush.Document.Update
-  ( activeDocument, withActiveDocument
+  ( activeDocument
   , DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
   , modifyingCurrentDocument
   , updateUIAction, updateHistoryState
@@ -787,14 +790,14 @@ instance HandleAction MouseMove where
         mbPartialPath <- STM.readTVar partialPathTVar
         mode <- STM.readTVar modeTVar
         STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
-        case tool of
+        if
-          Pen
+          | Pen <- tool
-            | Just pp <- mbPartialPath
+          , Just pp <- mbPartialPath
           , any ( \ case { Control _ -> True; _ -> False } ) modifiers
           -> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
                 pure Don'tModifyDoc
+          -- In brush mode: modify brush parameters through brush widget.
           | BrushMode <- mode
-            -- Pen tool in brush mode: modify brush parameters through brush widget.
           -> do mbHoldAction <- STM.readTVar mouseHoldTVar
                 case mbHoldAction of
                   Just ( BrushWidgetAction { brushWidgetAction } ) ->
@@ -803,11 +806,10 @@ instance HandleAction MouseMove where
                         pure Don'tModifyDoc
                       Just ( widgetAction, newDocument ) -> do
                         STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
-                          let changeText :: Text
+                        pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
-                              changeText = "Update brush parameters"
-                          pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-                    _ -> pure Don'tModifyDoc
                   _ -> pure Don'tModifyDoc
+          | otherwise
+          -> pure Don'tModifyDoc
       mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
       for_ mbDoc \doc ->
         updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
@@ -863,20 +865,20 @@ instance HandleAction MouseClick where
               SingleClick -> do
                 modifiers <- STM.readTVar modifiersTVar
                 tool <- STM.readTVar toolTVar
-
+                case mode of
+                  PathMode ->
                     case tool of
+                      Selection ->
                         -- Selection mode mouse hold:
                         --
                         --   - If holding shift or alt, mouse hold initiates a rectangular selection.
                         --   - If not holding shift or alt:
                         --      - if mouse click selected an object, initiate a drag move,
                         --      - otherwise, initiate a rectangular selection.
-                  Selection ->
                         case selectionMode modifiers of
                           -- Drag move: not holding shift or alt, click has selected something.
                           New
-                        | PathMode <- mode
+                            | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-                        , Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
                             -> do
                               STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
                               case dragMove of
@@ -890,11 +892,8 @@ instance HandleAction MouseClick where
                           _ -> do
                               STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                               pure Don'tModifyDoc
-
+                      Pen -> do
-                  Pen ->
-                    case mode of
                         -- Pen tool in path mode: start or continue a drawing operation.
-                      PathMode -> do
                         mbPartialPath <- STM.readTVar partialPathTVar
                         STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
                         case mbPartialPath of
@@ -922,24 +921,23 @@ instance HandleAction MouseClick where
                           Just pp -> do
                             STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
                             pure Don'tModifyDoc
-
-                      -- Pen tool in brush mode: modify brush parameters through brush widget.
                   BrushMode -> do
+                    -- Brush mode: modify brush parameters through brush widget.
                     mbAction <- STM.readTVar mouseHoldTVar
                     let mbPrevWidgetAction = case mbAction of
                           Just ( BrushWidgetAction { brushWidgetAction } )
                             -> Just brushWidgetAction
                           _ -> Nothing
                     case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
-                          Nothing ->
+                      Just ( actionState@( BrushWidgetActionState { brushWidgetAction = act } ), newDocument ) -> do
-                            pure Don'tModifyDoc
+                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
-                          Just ( widgetAction, newDocument ) -> do
-                            STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
                         let changeText :: Text
-                                changeText = "Update brush parameters"
+                            changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
                         pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                      _ ->
+                        pure Don'tModifyDoc
 
-                      MetaMode -> pure Don'tModifyDoc
+                  _ -> pure Don'tModifyDoc
 
               DoubleClick -> do
                 tool   <- STM.readTVar toolTVar
@@ -1178,6 +1176,20 @@ instance HandleAction MouseRelease where
                   BrushMode -> do
                     STM.writeTVar mouseHoldTVar Nothing
                     pure Don'tModifyDoc
+                    {-
+                    mbHoldAction <- STM.readTVar mouseHoldTVar
+                    case mbHoldAction of
+                      Just ( BrushWidgetAction { brushWidgetAction } ) ->
+                        case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
+                          Just ( BrushWidgetActionState { brushWidgetAction = act }, newDocument ) -> do
+                            STM.writeTVar mouseHoldTVar Nothing
+                            let changeText :: Text
+                                changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
+                            pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                          _ ->
+                            pure Don'tModifyDoc
+                      _ -> pure Don'tModifyDoc
+                    -}
 
                   MetaMode ->
                     pure Don'tModifyDoc

src/app/MetaBrush/Document/Selection.hs

@@ -15,7 +15,7 @@ module MetaBrush.Document.Selection
 
 -- base
 import Control.Monad
-  ( guard )
+  ( guard, unless )
 import Control.Monad.ST
   ( RealWorld )
 import Data.Functor
@@ -23,7 +23,7 @@ import Data.Functor
 import Data.Functor.Identity
   ( runIdentity )
 import Data.Maybe
-  ( catMaybes, listToMaybe )
+  ( catMaybes, isNothing, listToMaybe )
 import Data.Monoid
   ( Sum(..) )
 import Data.Semigroup
@@ -70,7 +70,7 @@ import Control.Monad.Trans.Class
   ( lift )
 import Control.Monad.Trans.Maybe
   ( MaybeT(..) )
-import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.State.Strict as State
   ( StateT(..), State
   , evalState, evalStateT, runState
   , get, put, modify'
@@ -845,6 +845,7 @@ data BrushWidgetActionState
   = BrushWidgetActionState
   { brushWidgetAction :: !Brush.WidgetAction
   , brushWidgetStrokeUnique :: !Unique
+  , brushWidgetCurveIndex :: !Int
   , brushWidgetPointIndex :: !Int
   , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
   }
@@ -860,24 +861,21 @@ instance Semigroup BrushWidgetActionState where
 applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document )
 applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
   let
-    res :: Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Document
+    res :: State ( Maybe BrushWidgetActionState ) Document
-    res = do
+    res = ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
-      newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
+  in case ( `runState` Nothing ) res of
-      Tardis.getPast >>= Tardis.sendPast
+    ( newDoc, Just brushWidgetAction )
-      pure newDoc
-  in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) $ res of
-    ( newDoc, ( _, Just brushWidgetAction ) )
       -> Just ( brushWidgetAction, newDoc )
     _ -> Nothing
 
   where
-    updateStrokeHierarchy :: StrokeHierarchy -> ( Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) ) StrokeHierarchy
+    updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe BrushWidgetActionState ) StrokeHierarchy
     updateStrokeHierarchy ( StrokeGroup { .. } ) = do
       newContents <- traverse updateStrokeHierarchy groupContents
       pure ( StrokeGroup { groupContents = newContents, .. } )
     updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
 
-    updateStroke :: Stroke -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Stroke
+    updateStroke :: Stroke -> State ( Maybe BrushWidgetActionState ) Stroke
     updateStroke stroke@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) =
       case strokeBrush of
         -- Don't touch strokes without brushes.
@@ -906,12 +904,11 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
           -> ( Record brushFields -> pointParams -> pointParams )
           -> Unique
           -> StrokeSpline clo pointParams
-          -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
+          -> State ( Maybe BrushWidgetActionState ) ( StrokeSpline clo pointParams )
-                ( StrokeSpline clo pointParams )
         updateSpline brush toBrushParams updatePointParams uniq oldSpline =
           ibitraverseSpline
             ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
-            ( updateSplinePoint brush toBrushParams updatePointParams uniq 0 )
+            ( updateSplinePoint brush toBrushParams updatePointParams uniq 0 0 )
             oldSpline
 
     updateSplineCurve
@@ -923,35 +920,47 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
       -> ( Record brushFields -> pointParams -> pointParams )
       -> Unique -> Int
       -> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
-      -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
+      -> State ( Maybe BrushWidgetActionState )
             ( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) )
     updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve
       -- If we have already started a widget action, only continue an action
       -- at the point with the correct index in the stroke.
-      | case mbPrevAction of { Just act -> brushWidgetPointIndex act /= i ; Nothing -> False }
+      | case mbPrevAction of
-      = pure curve
+          Just act ->
+            case ssplineType @clo' of
+              SClosed -> brushWidgetCurveIndex act /= i && brushWidgetCurveIndex act /= 0
+              SOpen   -> brushWidgetCurveIndex act /= i
+          Nothing -> False
+      = case mbPrevAction of
+          Just act
+            | abs ( i - brushWidgetCurveIndex act ) <= 1
+            -> pure $ curve { curveData = invalidateCache $ curveData curve }
+          _ -> pure curve
       | otherwise
+      , let i' :: Int
+            j' :: Int -> Int
+            ( i', j' ) = case ssplineType @clo' of { SClosed -> ( 0, const 0 ) ; SOpen -> ( i, id ) }
       = case curve of
-      line@( LineTo sp1 _ ) -> do
+      line@( LineTo sp1 dat ) -> do
-        sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp1
+        sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i' ( j' 1 ) ) sp1
-        pure ( line { curveEnd = sp1' } )
+        pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
-      bez2@( Bezier2To sp1 sp2 _ ) -> do
+      bez2@( Bezier2To sp1 sp2 dat ) -> do
-        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
+        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
-        sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp2
+        sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 2 ) ) sp2
-        pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
+        pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
-      bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
+      bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
-        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
+        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
-        sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp2
+        sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 2 sp2
-        sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp3
+        sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 3 ) ) sp3
-        pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
+        pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
 
     inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
     inSelectionRange p cp =
       squaredNorm ( c --> ( cp • p ) :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
 
     lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool
-    lineInSelectionRange p seg
+    lineInSelectionRange p seg =
-      = case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
+      case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
         ( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
 
     updateSplinePoint
@@ -959,18 +968,11 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
       .  NamedBrush brushFields
       -> ( pointParams -> Record brushFields )
       -> ( Record brushFields -> pointParams -> pointParams )
-      -> Unique -> Int
+      -> Unique -> Int -> Int
       -> PointData pointParams
-      -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
+      -> State ( Maybe BrushWidgetActionState )
           ( PointData pointParams )
-    updateSplinePoint brush toBrushParams updatePointParams uniq i pt = do
+    updateSplinePoint brush toBrushParams updatePointParams uniq i j pt = do
-      mbPreviousBrushWidgetAction <- Tardis.getPast
-      case mbPreviousBrushWidgetAction of
-        -- Already started a brush widget update: don't do anything else.
-        Just {}
-          -> pure pt
-        -- Otherwise, check whether we are updating the brush parameters at this stroke point.
-        Nothing -> do
       let
         currentBrushParams :: Record brushFields
         currentBrushParams = toBrushParams ( brushParams pt )
@@ -979,7 +981,15 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
         newBrushWidgetAction :: Maybe BrushWidgetActionState
         ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
           -- Continue the current brush widget action.
-              Just prevAction@( BrushWidgetActionState { brushWidgetPointBeingMoved = oldPt, brushWidgetAction = act }) ->
+          Just prevAction@( BrushWidgetActionState
+                            { brushWidgetPointBeingMoved = oldPt
+                            , brushWidgetPointIndex = j'
+                            , brushWidgetAction = act }) ->
+            if j /= j'
+              -- If we have already started a widget action, only continue an action
+              -- at the point with the correct index in the stroke.
+            then ( Just prevAction, currentBrushParams )
+            else
               let newPt = pointCoords pt --> c
                   newParams =
                     Brush.widgetUpdate ( brushWidget brush ) act
@@ -994,7 +1004,8 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
                       BrushWidgetActionState
                         { brushWidgetPointBeingMoved = cp
                         , brushWidgetStrokeUnique = uniq
-                            , brushWidgetPointIndex = i
+                        , brushWidgetCurveIndex = i
+                        , brushWidgetPointIndex = j
                         , brushWidgetAction = case brushWidget brush of
                             Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
                             Brush.RotatableRectangleWidget ->
@@ -1009,5 +1020,6 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
                 --   Just ln -> error "todo"
                 --   Nothing -> Nothing
 
-          Tardis.sendFuture newBrushWidgetAction
+      unless ( isNothing newBrushWidgetAction ) $
+        State.put newBrushWidgetAction
       pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )

src/metabrushes/MetaBrush/Brush/Widget.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module MetaBrush.Brush.Widget
   ( Widget(..)
   , WidgetElements(..)
@@ -5,6 +7,7 @@ module MetaBrush.Brush.Widget
   , widgetUpdate
   , WhatScale(..)
   , WidgetAction(..)
+  , describeWidgetAction
   )
   where
 
@@ -26,6 +29,10 @@ import Math.Module
   , norm
   )
 
+-- text
+import Data.Text
+  ( Text )
+
 -- metabrushes
 import MetaBrush.Records
   ( Record(..) )
@@ -94,6 +101,10 @@ data WidgetAction
     --{ windingNumber :: Int }
   deriving stock ( Eq, Ord, Show )
 
+describeWidgetAction :: WidgetAction -> Text
+describeWidgetAction ( ScaleAction {} ) = "scaling"
+describeWidgetAction RotateAction       = "rotation"
+
 -- | Given an UI action (moving a widget control element),
 -- how should we update the brush parameters?
 widgetUpdate :: Widget flds
@@ -121,9 +132,9 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
           -> MkR oldFlds
           | otherwise
           ->
-          let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt )
+          let θ1 = atan2 ( oldPt × newPt ) ( oldPt ^.^ newPt )
-              θ' = nearestAngle θ θ1
+              θ' = θ + nearestAngle 0 θ1
-          in MkR $ ℝ3 w h θ'
+          in MkR ( ℝ3 w h θ' )
 
 nearestAngle :: Double -> Double -> Double
 nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )