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,27 +790,26 @@ 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
+          , any ( \ case { Control _ -> True; _ -> False } ) modifiers
-            -> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
+          -> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
-                  pure Don'tModifyDoc
+                pure Don'tModifyDoc
-            | BrushMode <- mode
+          -- In brush mode: modify brush parameters through brush widget.
-            -- Pen tool in brush mode: modify brush parameters through brush widget.
+          | BrushMode <- mode
-            -> do mbHoldAction <- STM.readTVar mouseHoldTVar
+          -> do mbHoldAction <- STM.readTVar mouseHoldTVar
-                  case mbHoldAction of
+                case mbHoldAction of
-                    Just ( BrushWidgetAction { brushWidgetAction } ) ->
+                  Just ( BrushWidgetAction { brushWidgetAction } ) ->
-                      case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction) doc of
+                    case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
-                        Nothing ->
+                      Nothing ->
-                          pure Don'tModifyDoc
+                        pure Don'tModifyDoc
-                        Just ( widgetAction, newDocument ) -> do
+                      Just ( widgetAction, newDocument ) -> do
-                          STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
+                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
-                          let changeText :: Text
+                        pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
-                              changeText = "Update brush parameters"
+                  _ -> pure Don'tModifyDoc
-                          pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+          | otherwise
-                    _ -> pure Don'tModifyDoc
+          -> pure Don'tModifyDoc
-          _ -> pure Don'tModifyDoc
       mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
       for_ mbDoc \doc ->
         updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
@@ -863,38 +865,35 @@ instance HandleAction MouseClick where
               SingleClick -> do
                 modifiers <- STM.readTVar modifiersTVar
                 tool <- STM.readTVar toolTVar
-
+                case mode of
-                case tool of
+                  PathMode ->
-                  -- Selection mode mouse hold:
+                    case tool of
-                  --
+                      Selection ->
-                  --   - If holding shift or alt, mouse hold initiates a rectangular selection.
+                        -- Selection mode mouse hold:
-                  --   - If not holding shift or alt:
+                        --
-                  --      - if mouse click selected an object, initiate a drag move,
+                        --   - If holding shift or alt, mouse hold initiates a rectangular selection.
-                  --      - otherwise, initiate a rectangular selection.
+                        --   - If not holding shift or alt:
-                  Selection ->
+                        --      - if mouse click selected an object, initiate a drag move,
-                    case selectionMode modifiers of
+                        --      - otherwise, initiate a rectangular selection.
-                      -- Drag move: not holding shift or alt, click has selected something.
+                        case selectionMode modifiers of
-                      New
+                          -- Drag move: not holding shift or alt, click has selected something.
-                        | PathMode <- mode
+                          New
-                        , Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
+                            | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-                        -> do
+                            -> do
-                          STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
+                              STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
-                          case dragMove of
+                              case dragMove of
-                            ClickedOnSelected ->
+                                ClickedOnSelected ->
+                                  pure Don'tModifyDoc
+                                ClickedOnUnselected ->
+                                  pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+                                ClickedOnCurve {} ->
+                                  pure Don'tModifyDoc
+                          -- Rectangular selection.
+                          _ -> do
+                              STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                               pure Don'tModifyDoc
-                            ClickedOnUnselected ->
+                      Pen -> do
-                              pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+                        -- Pen tool in path mode: start or continue a drawing operation.
-                            ClickedOnCurve {} ->
-                              pure Don'tModifyDoc
-                      -- Rectangular selection.
-                      _ -> do
-                          STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-                          pure Don'tModifyDoc
-
-                  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
+                  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
+                      Just ( actionState@( BrushWidgetActionState { brushWidgetAction = act } ), newDocument ) -> do
+                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
+                        let changeText :: Text
+                            changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
+                        pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                      _ ->
+                        pure Don'tModifyDoc
 
-                      -- Pen tool in brush mode: modify brush parameters through brush widget.
+                  _ -> pure Don'tModifyDoc
-                      BrushMode -> do
-                        mbAction <- STM.readTVar mouseHoldTVar
-                        let mbPrevWidgetAction = case mbAction of
-                              Just ( BrushWidgetAction { brushWidgetAction } )
-                                -> Just brushWidgetAction
-                              _ -> Nothing
-                        case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
-                          Nothing ->
-                            pure Don'tModifyDoc
-                          Just ( widgetAction, newDocument ) -> do
-                            STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
-                            let changeText :: Text
-                                changeText = "Update brush parameters"
-                            pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-
-                      MetaMode -> 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,91 +920,106 @@ 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
+        ( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
 
     updateSplinePoint
       :: forall pointParams brushFields
       .  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
+      let
-      case mbPreviousBrushWidgetAction of
+        currentBrushParams :: Record brushFields
-        -- Already started a brush widget update: don't do anything else.
+        currentBrushParams = toBrushParams ( brushParams pt )
-        Just {}
+        brushWidgetElts :: Brush.WidgetElements
-          -> pure pt
+        brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
-        -- Otherwise, check whether we are updating the brush parameters at this stroke point.
+        newBrushWidgetAction :: Maybe BrushWidgetActionState
-        Nothing -> do
+        ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
-          let
+          -- Continue the current brush widget action.
-            currentBrushParams :: Record brushFields
+          Just prevAction@( BrushWidgetActionState
-            currentBrushParams = toBrushParams ( brushParams pt )
+                            { brushWidgetPointBeingMoved = oldPt
-            brushWidgetElts :: Brush.WidgetElements
+                            , brushWidgetPointIndex = j'
-            brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
+                            , brushWidgetAction = act }) ->
-            newBrushWidgetAction :: Maybe BrushWidgetActionState
+            if j /= j'
-            ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
+              -- If we have already started a widget action, only continue an action
-              -- Continue the current brush widget action.
+              -- at the point with the correct index in the stroke.
-              Just prevAction@( BrushWidgetActionState { brushWidgetPointBeingMoved = oldPt, brushWidgetAction = act }) ->
+            then ( Just prevAction, currentBrushParams )
-                let newPt = pointCoords pt --> c
+            else
-                    newParams =
+              let newPt = pointCoords pt --> c
-                      Brush.widgetUpdate ( brushWidget brush ) act
+                  newParams =
-                        ( oldPt, newPt )
+                    Brush.widgetUpdate ( brushWidget brush ) act
-                        currentBrushParams
+                      ( oldPt, newPt )
-                in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
+                      currentBrushParams
-              Nothing ->
+              in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
-                -- See if we can start a new brush widget action.
+          Nothing ->
-                case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
+            -- See if we can start a new brush widget action.
-                  Just cp ->
+            case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
-                    let newAction =
+              Just cp ->
-                          BrushWidgetActionState
+                let newAction =
-                            { brushWidgetPointBeingMoved = cp
+                      BrushWidgetActionState
-                            , brushWidgetStrokeUnique = uniq
+                        { brushWidgetPointBeingMoved = cp
-                            , brushWidgetPointIndex = i
+                        , brushWidgetStrokeUnique = uniq
-                            , brushWidgetAction = case brushWidget brush of
+                        , brushWidgetCurveIndex = i
-                                Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
+                        , brushWidgetPointIndex = j
-                                Brush.RotatableRectangleWidget ->
+                        , brushWidgetAction = case brushWidget brush of
-                                  if pressingCtrl
+                            Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
-                                  then Brush.RotateAction
+                            Brush.RotatableRectangleWidget ->
-                                  else Brush.ScaleAction Brush.ScaleXY
+                              if pressingCtrl
-                            }
+                              then Brush.RotateAction
-                    in ( Just newAction, currentBrushParams )
+                              else Brush.ScaleAction Brush.ScaleXY
-                  Nothing -> ( Nothing, currentBrushParams )
+                        }
-                    -- TODO: handle clicking on an edge.
+                in ( Just newAction, currentBrushParams )
-                    -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
+              Nothing -> ( Nothing, currentBrushParams )
-                    --   Just ln -> error "todo"
+                -- TODO: handle clicking on an edge.
-                    --   Nothing -> Nothing
+                -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
+                --   Just ln -> error "todo"
+                --   Nothing -> Nothing
 
-          Tardis.sendFuture newBrushWidgetAction
+      unless ( isNothing newBrushWidgetAction ) $
-          pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
+        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 )