WIP: add brush widget UI

MetaBrush.cabal

@@ -171,6 +171,7 @@ library metabrushes
         MetaBrush.Assert
       , MetaBrush.Asset.Brushes
       , MetaBrush.Brush
+      , MetaBrush.Brush.Widget
       , MetaBrush.Document
       , MetaBrush.Document.Draw
       , MetaBrush.Document.History

assets/colours.css

@@ -32,6 +32,9 @@
 @define-color glass              rgba( 156, 231, 255, 0.5);
 @define-color selected           rgba( 161, 201, 236, 0.5);
 @define-color selectedOutline     rgb(  74, 150, 218);
+@define-color brushWidget        rgba(   0,   0,   0, 0.9);
+@define-color brushWidgetHover    rgb( 231, 172,  83);
+
 @define-color shortcutKey         rgb( 112, 109, 96 );
 
 @define-color windowButtonHover   rgb(  34, 131, 186);

assets/theme.css

@@ -113,7 +113,12 @@
 .selectedOutline {
   color: @selectedOutline;
 }
-
+.brushWidget {
+  color: @brushWidget;
+}
+.brushWidgetHover {
+  color: @brushWidgetHover;
+}
 
 /* Proper CSS styling */
 

src/app/MetaBrush/Action.hs

@@ -127,7 +127,8 @@ import MetaBrush.Document.Selection
   , DragMoveSelect(..), dragMoveSelect
   , UpdateInfo(..)
   , deleteSelected
-  , dragUpdate
+  , dragUpdate, pressingControl
+  , applyBrushWidgetAction
   )
 import MetaBrush.Document.Serialise
   ( saveDocument, loadDocument )
@@ -765,13 +766,13 @@ data MouseMove = MouseMove !( ℝ 2 )
 
 instance HandleAction MouseMove where
   handleAction
-    ( UIElements { viewport = Viewport {..}, .. } )
+    uiElts@( UIElements { viewport = Viewport {..}, infoBar } )
     vars@( Variables {..} )
     ( MouseMove ( ℝ2 x y ) )
     = do
       viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
       viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
-      uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
+      modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do
         modifiers   <- STM.readTVar modifiersTVar
         let
           toViewport :: ℝ 2 -> ℝ 2
@@ -784,18 +785,34 @@ instance HandleAction MouseMove where
         -- moves the partial control point (if one exists).
         tool <- STM.readTVar toolTVar
         mbPartialPath <- STM.readTVar partialPathTVar
+        mode <- STM.readTVar modeTVar
+        STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
         case tool of
           Pen
             | Just pp <- mbPartialPath
             , any ( \ case { Control _ -> True; _ -> False } ) modifiers
-            -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
-          _ -> pure ()
-        STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
-        pure do
+            -> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
+                  pure Don'tModifyDoc
+            | BrushMode <- mode
+            -- Pen tool in brush mode: modify brush parameters through brush widget.
+            -> do mbHoldAction <- STM.readTVar mouseHoldTVar
+                  case mbHoldAction of
+                    Just ( BrushWidgetAction { brushWidgetAction } ) ->
+                      case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction) 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 {..} )
+                    _ -> pure Don'tModifyDoc
+          _ -> pure Don'tModifyDoc
+      mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
+      for_ mbDoc \doc ->
         updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
       for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
         GTK.widgetQueueDraw drawingArea
-      sequenceA_ uiUpdateAction
 
 -----------------
 -- Mouse click --
@@ -874,8 +891,10 @@ instance HandleAction MouseClick where
                           STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
                           pure Don'tModifyDoc
 
-                  -- Pen tool: start or continue a drawing operation.
-                  Pen | PathMode <- mode -> 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
@@ -904,7 +923,23 @@ instance HandleAction MouseClick where
                             STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
                             pure Don'tModifyDoc
 
-                  _ -> pure Don'tModifyDoc
+                      -- Pen tool in brush mode: modify brush parameters through brush widget.
+                      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
@@ -1057,9 +1092,8 @@ instance HandleAction MouseRelease where
                       -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
                     _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
 
-                Pen 
-                  | PathMode <- mode
-                  -> do
+                Pen -> case mode of
+                  PathMode -> do
                     mbPartialPath <- STM.readTVar partialPathTVar
                     case mbPartialPath of
                       -- Normal pen mode mouse click should have created an anchor.
@@ -1141,8 +1175,12 @@ instance HandleAction MouseRelease where
                               changeText :: Text
                               changeText = "Continue stroke"
                             pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                  BrushMode -> do
+                    STM.writeTVar mouseHoldTVar Nothing
+                    pure Don'tModifyDoc
 
-                _ -> pure Don'tModifyDoc
+                  MetaMode ->
+                    pure Don'tModifyDoc
 
       -- Other mouse buttons: ignored (for the moment at least).
       _ -> pure ()

src/app/MetaBrush/Application.hs

@@ -206,8 +206,8 @@ runApplication application = do
   maxHistorySizeTVar   <- STM.newTVarIO @Int                                     1000
   fitParametersTVar    <- STM.newTVarIO @FitParameters $
                             FitParameters
-                              { maxSubdiv  = 0 --5 --2 --3 -- 6
-                              , nbSegments = 1 --5
+                              { maxSubdiv  = 2 --5 --2 --3 -- 6
+                              , nbSegments = 3
                               , dist_tol   = 5e-3
                               , t_tol      = 1e-4
                               , maxIters   = 20
@@ -217,7 +217,7 @@ runApplication application = do
                             NewtonRaphson
                               { maxIters = 20, precision = 8 }
   cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
-                              Nothing --Just defaultRootIsolationOptions
+                              Just defaultRootIsolationOptions
 
   -- Put all these stateful variables in a record for conciseness.
   let

src/app/MetaBrush/Asset/Colours.hs

@@ -35,8 +35,13 @@ data ColourRecord a
   , pointHover, pointSelected
   , viewport, viewportScrollbar, tabScrollbar
   , guide, rulerBg, rulerTick, magnifier, glass
-  , selected, selectedOutline :: !a
+  , selected, selectedOutline
+  , brushWidget, brushWidgetHover :: !a
   }
+  -- NB: when adding a new colour to this record, don't forget to update:
+  --
+  --  - colours.css, to define a value for the colour,
+  --  - theme.css, which is where GTK parses the colours in 'getColours'.
   deriving stock ( Show, Functor, Foldable, Traversable )
 
 newtype ColourName
@@ -76,6 +81,8 @@ colourNames = Colours
   , glass               = ColourName "glass"
   , selected            = ColourName "selected"
   , selectedOutline     = ColourName "selectedOutline"
+  , brushWidget         = ColourName "brushWidget"
+  , brushWidgetHover    = ColourName "brushWidgetHover"
   }
 
 type Colours = ColourRecord GDK.RGBA

src/app/MetaBrush/Context.hs

@@ -54,7 +54,7 @@ import MetaBrush.Document.Draw
 import MetaBrush.Document.History
   ( DocumentHistory(..) )
 import MetaBrush.Document.Selection
-  ( DragMoveSelect )
+  ( DragMoveSelect, BrushWidgetActionState )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( FileBar, FileBarTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
@@ -135,16 +135,25 @@ data GuideAction
 --  - start a rectangular selection,
 --  - move objects by dragging,
 --  - draw a control point,
---  - create/modify a guide.
+--  - create/modify a guide,
+--  - modify brush parameters through a brush widget.
 data HoldAction
-  = SelectionHold { holdStartPos :: !( ℝ 2 ) }
-  | DragMoveHold  { holdStartPos :: !( ℝ 2 )
+  = SelectionHold
+      { holdStartPos :: !( ℝ 2 ) }
+  | DragMoveHold
+      { holdStartPos :: !( ℝ 2 )
       , dragAction   :: !DragMoveSelect
       }
-  | DrawHold      { holdStartPos :: !( ℝ 2 ) }
-  | GuideAction   { holdStartPos :: !( ℝ 2 )
+  | DrawHold
+      { holdStartPos :: !( ℝ 2 ) }
+  | GuideAction
+      { holdStartPos :: !( ℝ 2 )
       , guideAction  :: !GuideAction
       }
+  | BrushWidgetAction
+      { holdStartPos :: !( ℝ 2 )
+      , brushWidgetAction :: !BrushWidgetActionState
+      }
   deriving stock Show
 
 -- | Keep track of a path that is in the middle of being drawn.

src/app/MetaBrush/Document/Selection.hs

@@ -2,12 +2,14 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module MetaBrush.Document.Selection
-  ( SelectionMode(..), selectionMode
+  ( SelectionMode(..), selectionMode, pressingControl
   , selectAt, selectRectangle
   , DragMoveSelect(.., PointDrag), dragMoveSelect
   , UpdateInfo(..)
   , translateSelection, deleteSelected
   , dragUpdate
+  , BrushWidgetActionState(..)
+  , applyBrushWidgetAction
   )
   where
 
@@ -21,7 +23,7 @@ import Data.Functor
 import Data.Functor.Identity
   ( runIdentity )
 import Data.Maybe
-  ( catMaybes )
+  ( catMaybes, listToMaybe )
 import Data.Monoid
   ( Sum(..) )
 import Data.Semigroup
@@ -97,6 +99,15 @@ import Math.Module
   ( Module, lerp, squaredNorm, closestPointOnSegment )
 import Math.Linear
   ( Segment(..), ℝ(..), T(..) )
+
+-- metabrush
+import MetaBrush.Brush
+  ( NamedBrush(..), WithParams(defaultParams) )
+import qualified MetaBrush.Brush.Widget as Brush
+  ( Widget(..), WidgetAction(..), WidgetElements(..)
+  , WhatScale(..)
+  , widgetElements, widgetUpdate
+  )
 import {-# SOURCE #-} MetaBrush.Context
   ( Modifier(..) )
 import MetaBrush.Document
@@ -108,6 +119,10 @@ import MetaBrush.Document
   )
 import {-# SOURCE #-} MetaBrush.Document.Update
   ( DocChange(..) )
+import MetaBrush.Records
+  ( Record
+  , Intersection(..), intersect
+  )
 import MetaBrush.Unique
   ( Unique )
 import MetaBrush.Util
@@ -137,6 +152,11 @@ selectionMode = foldMap \case
   Shift _ -> Add
   _       -> New
 
+pressingControl :: Foldable f => f Modifier -> Bool
+pressingControl = any \case
+  Control {} -> True
+  _ -> False
+
 -- | Updates the selected objects on a single click selection event.
 selectAt :: SelectionMode -> ℝ 2 -> Document -> Document
 selectAt selMode c doc@( Document { zoomFactor } ) =
@@ -816,3 +836,178 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
                             dragSegmentParameter
                             p
                       in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )
+
+
+--------------------------------------------------------------------------------
+-- Brush widget
+
+data BrushWidgetActionState
+  = BrushWidgetActionState
+  { brushWidgetAction :: !Brush.WidgetAction
+  , brushWidgetStrokeUnique :: !Unique
+  , brushWidgetPointIndex :: !Int
+  , 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 ( BrushWidgetActionState, Document )
+applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
+  let
+    res :: Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Document
+    res = do
+      newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
+      Tardis.getPast >>= Tardis.sendPast
+      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 ( 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@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) =
+      case strokeBrush of
+        -- Don't touch strokes without brushes.
+        Nothing -> pure stroke
+        Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields )
+          | -- Don't touch invisible strokes
+            not strokeVisible
+             -- If we have already started a widget action, only continue an action
+             -- for the stroke with the correct unique.
+          || case mbPrevAction of { Just act -> brushWidgetStrokeUnique act /= strokeUnique ; Nothing -> False }
+          -> pure stroke
+          | otherwise
+          -> case intersect @pointFields @brushFields of
+               Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do
+                let embedUsedParams = updateBrushParams ( defaultParams $ brushFunction brush )
+                    toBrushParams = embedUsedParams . ptParamsToUsedParams
+                    updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' )
+                spline' <- updateSpline brush toBrushParams updatePointParams strokeUnique spline0
+                pure $ stroke { strokeSpline = spline' }
+      where
+        updateSpline
+          :: forall clo pointParams brushFields
+          .  ( KnownSplineType clo )
+          => NamedBrush brushFields
+          -> ( pointParams -> Record brushFields )
+          -> ( Record brushFields -> pointParams -> pointParams )
+          -> Unique
+          -> StrokeSpline clo pointParams
+          -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
+                ( StrokeSpline clo pointParams )
+        updateSpline brush toBrushParams updatePointParams uniq oldSpline =
+          ibitraverseSpline
+            ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
+            ( updateSplinePoint brush toBrushParams updatePointParams uniq 0 )
+            oldSpline
+
+    updateSplineCurve
+      :: forall clo' pointParams brushFields
+      .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
+      => PointData pointParams
+      -> NamedBrush brushFields
+      -> ( pointParams -> Record brushFields )
+      -> ( Record brushFields -> pointParams -> pointParams )
+      -> Unique -> Int
+      -> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
+      -> Tardis ( Maybe BrushWidgetActionState ) ( 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 }
+      = pure curve
+      | otherwise
+      = case curve of
+      line@( LineTo sp1 _ ) -> do
+        sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp1
+        pure ( line { curveEnd = sp1' } )
+      bez2@( Bezier2To sp1 sp2 _ ) -> do
+        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
+        sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp2
+        pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
+      bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
+        sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
+        sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp2
+        sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp3
+        pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
+
+    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
+      = case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
+          ( _, 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
+      -> PointData pointParams
+      -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
+          ( PointData pointParams )
+    updateSplinePoint brush toBrushParams updatePointParams uniq i 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 )
+            brushWidgetElts :: Brush.WidgetElements
+            brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
+            newBrushWidgetAction :: Maybe BrushWidgetActionState
+            ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
+              -- Continue the current brush widget action.
+              Just prevAction@( BrushWidgetActionState { brushWidgetPointBeingMoved = oldPt, brushWidgetAction = act }) ->
+                let newPt = pointCoords pt --> c
+                    newParams =
+                      Brush.widgetUpdate ( brushWidget brush ) act
+                        ( oldPt, newPt )
+                        currentBrushParams
+                in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
+              Nothing ->
+                -- See if we can start a new brush widget action.
+                case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
+                  Just cp ->
+                    let newAction =
+                          BrushWidgetActionState
+                            { brushWidgetPointBeingMoved = cp
+                            , brushWidgetStrokeUnique = uniq
+                            , brushWidgetPointIndex = i
+                            , brushWidgetAction = case brushWidget brush of
+                                Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
+                                Brush.RotatableRectangleWidget ->
+                                  if pressingCtrl
+                                  then Brush.RotateAction
+                                  else Brush.ScaleAction Brush.ScaleXY
+                            }
+                    in ( Just newAction, currentBrushParams )
+                  Nothing -> ( Nothing, currentBrushParams )
+                    -- TODO: handle clicking on an edge.
+                    -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
+                    --   Just ln -> error "todo"
+                    --   Nothing -> Nothing
+
+          Tardis.sendFuture newBrushWidgetAction
+          pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )

src/app/MetaBrush/Render/Document.hs

@@ -77,7 +77,7 @@ import Math.Bezier.Stroke
   , RootSolvingAlgorithm
   )
 import Math.Linear
-  ( ℝ(..), T(..)
+  ( ℝ(..), T(..), Segment(..)
   , rotate
   )
 import Math.Module
@@ -88,6 +88,8 @@ import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Brush
   ( NamedBrush(..), WithParams(..) )
+import qualified MetaBrush.Brush.Widget as Brush
+  ( Widget(..), WidgetElements(..), widgetElements )
 import MetaBrush.Context
   ( Modifier(..)
   , HoldAction(..), PartialPath(..)
@@ -125,7 +127,8 @@ import MetaBrush.GTK.Util
 
 data Renders a
   = Renders
-  { renderStrokes, renderPath, renderDebug, renderBrushes
+  { renderStrokes, renderPath, renderDebug
+  , renderBrushes, renderBrushWidgets
   , renderCLines, renderCPts, renderPPts :: a
   }
   deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
@@ -261,7 +264,7 @@ data StrokeRenderData where
     =>  { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
     -> StrokeRenderData
   StrokeWithOutlineRenderData
-    :: forall pointParams clo
+    :: forall pointParams clo brushFields
     .  ( KnownSplineType clo, Show pointParams, NFData pointParams )
     =>  { strokeDataSpline    :: !( StrokeSpline clo pointParams )
         , strokeOutlineData   :: !( Either
@@ -271,6 +274,7 @@ data StrokeRenderData where
                                   , [ Cusp ]
                                   )
         , strokeBrushFunction :: pointParams -> SplinePts Closed
+        , strokeWidgetData :: ( Brush.Widget brushFields, pointParams -> Record brushFields )
         }
     -> StrokeRenderData
 
@@ -285,7 +289,8 @@ instance NFData StrokeRenderData where
 -- - If the stroke has an associated brush, this consists of:
 --    - the path that the brush follows,
 --    - the computed outline (using fitting algorithm),
---    - the brush shape function.
+--    - the brush shape function,
+--    - the brush widget (UI for modifying brush parameters).
 -- - Otherwise, this consists of the underlying spline path only.
 strokeRenderData
   :: RootSolvingAlgorithm
@@ -301,7 +306,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
     }
   ) | strokeVisible
     = Just $ case strokeBrush of
-        Just ( NamedBrush { brushFunction = fn } )
+        Just ( NamedBrush { brushFunction = fn, brushWidget = widget } )
           | WithParams
              { defaultParams = brush_defaults
              , withParams    = brush@( Brush { brushBaseShape, mbRotation = mbRot } )
@@ -311,10 +316,10 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
              -- the collection of parameters expected by the brush.
              case intersect @pointFields @brushFields of
                Intersection
-                 { inject
-                 , project = toUsedParams :: Record pointFields -> Record usedFields }
+                 { inject2
+                 , project1 = toUsedParams :: Record pointFields -> Record usedFields }
                  -> do
-                    let embedUsedParams = inject brush_defaults
+                    let embedUsedParams = inject2 brush_defaults
 
                   -- Compute the outline using the brush function.
                     ( outline, fitPts, cusps ) <-
@@ -339,6 +344,8 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
                                        cosθ = cos θ
                                        sinθ = sin θ
                                    in fmap ( unT . rotate cosθ sinθ . T ) shape
+                        , strokeWidgetData =
+                            ( widget, \ params -> embedUsedParams $ toUsedParams params )
                         }
         _ -> pure $
                 StrokeRenderData
@@ -353,10 +360,19 @@ renderStroke
 renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
   StrokeRenderData { strokeDataSpline } ->
     renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
-  StrokeWithOutlineRenderData strokeDataSpline ( strokeOutlineData, fitPts, cusps ) strokeBrushFunction ->
+  StrokeWithOutlineRenderData
+    { strokeDataSpline
+    , strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
+    , strokeBrushFunction
+    , strokeWidgetData = ( widget, widgetParams )
+    } ->
     renderStrokeSpline cols mode rdrMode mbHoverContext zoom
       ( when ( mode == BrushMode )
-      . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction
+      . ( \ pt ->
+          renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom )
+            strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
+            pt
+        )
       )
       strokeDataSpline
     *> Compose blank
@@ -445,10 +461,11 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
 
 renderBrushShape
   :: Colours -> Maybe HoverContext -> Double
-  -> ( brushParams -> SplinePts Closed )
-  -> PointData brushParams
+  -> ( pointParams -> SplinePts Closed )
+  -> Brush.WidgetElements
+  -> PointData pointParams
   -> Compose Renders Cairo.Render ()
-renderBrushShape cols mbHoverContext zoom brushFn pt =
+renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
   let
     x, y :: Double
     ℝ2 x y = coords pt
@@ -462,6 +479,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt =
       Cairo.translate x y
     *> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
         ( fmap ( \ p -> PointData p Normal () ) brushPts )
+    *> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
     *> toAll Cairo.restore
 
 drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
@@ -742,6 +760,49 @@ drawCross ( Colours {..} ) zoom = do
   Cairo.restore
 -}
 
+renderBrushWidgetElements :: Colours -> Double -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
+renderBrushWidgetElements ( Colours { .. } ) zoom mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
+  Compose blank
+    { renderBrushWidgets = do
+      for_ lns $ \ seg@( Segment ( T p0@( ℝ2 x1 y1 ) ) ( T p1@( ℝ2 x2 y2 ) ) ) -> do
+        let lineFocus
+               -- Don't do rectangle hover highlighting; doesn't make sense here.
+               | Just ( MouseHover {} ) <- mbHover
+               -- Only focus the line if we aren't focusing a point,
+               -- as line focus corresponds to horizontal/vertical scaling
+               -- as opposed to 2D scaling.
+               , Normal <- hovered mbHover zoom p0
+               , Normal <- hovered mbHover zoom p1
+               = hovered mbHover zoom ( fmap unT seg )
+               | otherwise
+               = Normal
+        Cairo.save
+        Cairo.moveTo x1 y1
+        Cairo.lineTo x2 y2
+        Cairo.setLineWidth ( 2 / zoom )
+        case lineFocus of
+          Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
+          _     -> withRGBA brushWidget      Cairo.setSourceRGBA
+        Cairo.stroke
+        Cairo.restore
+      for_ pts $ \ ( T p@( ℝ2 x y ) ) -> do
+        let ptFocus
+              -- Don't do rectangle hover highlighting; doesn't make sense here.
+              | Just ( MouseHover {} ) <- mbHover
+              = hovered mbHover zoom p
+              | otherwise
+              = Normal
+        Cairo.save
+        Cairo.translate x y
+        Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
+        Cairo.setLineWidth ( 2 / zoom )
+        case ptFocus of
+          Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
+          _     -> withRGBA brushWidget      Cairo.setSourceRGBA
+        Cairo.fill
+        Cairo.restore
+    }
+
 hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double )
 hsl2rgb h s l = case hc2rgb h c of
   ( r, g, b ) -> ( r + m, g + m, b + m )

src/metabrushes/MetaBrush/Asset/Brushes.hs

@@ -39,6 +39,8 @@ import Math.Ring
 -- MetaBrush
 import MetaBrush.Brush
   ( NamedBrush(..), SomeBrush(..), WithParams(..) )
+import qualified MetaBrush.Brush.Widget as Brush
+  ( Widget(..) )
 import MetaBrush.Records
   ( Record(MkR) )
 
@@ -60,7 +62,12 @@ brushes = HashMap.fromList
 type CircleBrushFields = '[ "r" ]
 -- | A circular brush with the given radius.
 circle :: NamedBrush CircleBrushFields
-circle = NamedBrush "circle" ( WithParams deflts $ coerce circleBrush )
+circle =
+  NamedBrush
+    { brushName     = "circle"
+    , brushFunction = WithParams deflts $ coerce circleBrush
+    , brushWidget   = Brush.SquareWidget
+    }
   where
     deflts :: Record CircleBrushFields
     deflts = MkR ( ℝ1 1 )
@@ -70,7 +77,12 @@ type EllipseBrushFields = '[ "a", "b", "phi" ]
 -- | An elliptical brush with the given semi-major and semi-minor axes and
 -- angle of rotation.
 ellipse :: NamedBrush EllipseBrushFields
-ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
+ellipse =
+  NamedBrush
+    { brushName     = "ellipse"
+    , brushFunction = WithParams deflts $ coerce ellipseBrush
+    , brushWidget   = Brush.RotatableRectangleWidget
+    }
   where
     deflts :: Record EllipseBrushFields
     deflts = MkR ( ℝ3 1 1 0 )
@@ -79,7 +91,12 @@ ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
 type TearDropBrushFields = '[ "w", "h", "phi" ]
 -- | A tear-drop shape with the given width, height and angle of rotation.
 tearDrop :: NamedBrush TearDropBrushFields
-tearDrop = NamedBrush "tear-drop" ( WithParams deflts $ coerce tearDropBrush )
+tearDrop =
+  NamedBrush
+    { brushName     = "tear-drop"
+    , brushFunction = WithParams deflts $ coerce tearDropBrush
+    , brushWidget   = Brush.RotatableRectangleWidget
+    }
   where
     deflts :: Record TearDropBrushFields
     deflts = MkR ( ℝ3 1 2.25 0 )

src/metabrushes/MetaBrush/Brush.hs

@@ -42,8 +42,6 @@ import qualified Data.Text as Text
 -- brush-strokes
 import Calligraphy.Brushes
   ( Brush(..) )
-import Math.Bezier.Spline
-  ( SplineType(Closed), Spline )
 import Math.Differentiable
   ( DiffInterp )
 import Math.Interval
@@ -51,6 +49,8 @@ import Math.Interval
 import Math.Linear
 
 -- MetaBrush
+import qualified MetaBrush.Brush.Widget as Brush
+  ( Widget )
 import MetaBrush.Records
   ( KnownSymbols, Length, Record )
 import MetaBrush.Serialisable
@@ -77,19 +77,22 @@ type NamedBrush :: [ Symbol ] -> Type
 data NamedBrush brushFields where
   NamedBrush
     :: forall brushFields
-    .  ( KnownSymbols brushFields, Typeable brushFields
+    .  ( KnownSymbols brushFields
        , Representable Double ( ℝ ( Length brushFields ) )
        , DiffInterp 2 () ( ℝ ( Length brushFields ) )
        , DiffInterp 3 𝕀  ( ℝ ( Length brushFields ) )
        )
     => { brushName     :: !Text
-       , brushFunction :: BrushFunction brushFields
+       , brushFunction :: !( BrushFunction brushFields )
+       , brushWidget   :: !( Brush.Widget brushFields )
        }
     -> NamedBrush brushFields
 
 data SomeBrush where
   SomeBrush
-    :: { someBrush :: !( NamedBrush brushFields ) }
+    :: forall brushFields
+    .  KnownSymbols brushFields
+    => { someBrush :: !( NamedBrush brushFields ) }
     -> SomeBrush
 
 instance Show ( NamedBrush brushFields ) where
@@ -102,9 +105,11 @@ instance NFData ( NamedBrush brushFields ) where
   rnf ( NamedBrush { brushName } )
     = rnf brushName
 instance Eq ( NamedBrush brushFields ) where
-  NamedBrush name1 _ == NamedBrush name2 _ = name1 == name2
+  NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 }
+    = name1 == name2
 instance Ord ( NamedBrush brushFields ) where
-  compare ( NamedBrush name1 _ ) ( NamedBrush name2 _ ) = compare name1 name2
+  compare ( NamedBrush { brushName = name1 } ) ( NamedBrush { brushName = name2 } )
+    = compare name1 name2
 instance Hashable ( NamedBrush brushFields ) where
   hashWithSalt salt ( NamedBrush { brushName } ) =
     hashWithSalt salt brushName

src/metabrushes/MetaBrush/Brush/Widget.hs

@@ -0,0 +1,129 @@
+module MetaBrush.Brush.Widget
+  ( Widget(..)
+  , WidgetElements(..)
+  , widgetElements
+  , widgetUpdate
+  , WhatScale(..)
+  , WidgetAction(..)
+  )
+  where
+
+-- base
+import Data.Fixed
+  ( mod' )
+import Data.Kind
+  ( Type )
+import GHC.TypeLits
+  ( Symbol )
+
+-- brush-strokes
+import Math.Linear
+  ( ℝ(..), T(..), Segment(..)
+  , rotate
+  )
+import Math.Module
+  ( (^.^), (×)
+  , norm
+  )
+
+-- metabrushes
+import MetaBrush.Records
+  ( Record(..) )
+
+--------------------------------------------------------------------------------
+
+-- | A description of a widget to control brush parameters interactively.
+--
+-- For example, a rotatable rectangle widget to control the size of an
+-- elliptical brush.
+type Widget :: [ Symbol ] -> Type
+data Widget flds where
+  SquareWidget
+    :: Widget '[ r ]
+  RotatableRectangleWidget
+    :: Widget '[ w, h, phi ]
+deriving stock instance Eq   ( Widget flds )
+deriving stock instance Ord  ( Widget flds )
+deriving stock instance Show ( Widget flds )
+
+-- | Components of a widget that can be displayed visually.
+data WidgetElements
+  = WidgetElements
+  { widgetPoints :: ![ T ( ℝ 2 ) ]
+  , widgetLines :: ![ Segment ( T ( ℝ 2 ) ) ]
+  }
+
+-- | All UI elements associated to a 'Widget'.
+widgetElements :: Widget flds -> Record flds -> WidgetElements
+widgetElements widget ( MkR flds ) =
+  case widget of
+    SquareWidget
+      | ℝ1 r <- flds
+      -> rectElements r r 0
+    RotatableRectangleWidget
+      | ℝ3 w h θ <- flds
+      -> rectElements w h θ
+  where
+    rectElements w h θ =
+      WidgetElements
+      { widgetPoints = [ p1, p2, p3, p4 ]
+      , widgetLines = [ Segment p1 p2
+                      , Segment p2 p3
+                      , Segment p3 p4
+                      , Segment p4 p1
+                      ]
+      }
+      where
+        p1 = rot $ T $ ℝ2 -w -h
+        p2 = rot $ T $ ℝ2  w -h
+        p3 = rot $ T $ ℝ2  w  h
+        p4 = rot $ T $ ℝ2 -w  h
+        rot = rotate ( cos θ ) ( sin θ )
+
+data WhatScale
+  = ScaleXY
+  | ScaleX
+  | ScaleY
+  deriving stock ( Eq, Ord, Show )
+
+-- | Keep track of state in a brush widget action, e.g.
+-- scaling or rotating a brush.
+data WidgetAction
+  = ScaleAction WhatScale
+  | RotateAction
+    --{ windingNumber :: Int }
+  deriving stock ( Eq, Ord, Show )
+
+-- | Given an UI action (moving a widget control element),
+-- how should we update the brush parameters?
+widgetUpdate :: Widget flds
+             -> WidgetAction
+             -> ( T ( ℝ 2 ), T ( ℝ 2 ) )
+               -- ^ ( oldPt, newPt )
+             -> Record flds
+             -> Record flds
+widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
+  case widget of
+    SquareWidget
+      | T ( ℝ2 x y ) <- newPt
+      -> MkR $ ℝ1 ( max ( abs x ) ( abs y ) )
+    RotatableRectangleWidget
+      | ℝ3 w h θ <- oldFlds
+      -> case mode of
+        ScaleAction whatScale ->
+          let T ( ℝ2 w' h' ) = rotate ( cos -θ ) ( sin -θ ) newPt
+          in case whatScale of
+                ScaleXY -> MkR $ ℝ3 ( abs w' ) ( abs h' ) θ
+                ScaleX  -> MkR $ ℝ3 ( abs w' )       h    θ
+                ScaleY  -> MkR $ ℝ3       w    ( abs h' ) θ
+        RotateAction {}
+          | norm newPt < 1e-5
+          -> MkR oldFlds
+          | otherwise
+          ->
+          let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt )
+              θ' = nearestAngle θ θ1
+          in MkR $ ℝ3 w h θ'
+
+nearestAngle :: Double -> Double -> Double
+nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )

src/metabrushes/MetaBrush/Document.hs

@@ -85,9 +85,10 @@ import Math.Module
     ( origin, (^+^), (^-^), (*^) )
   , Inner((^.^))
   , squaredNorm, quadrance
+  , closestPointOnSegment
   )
 import Math.Linear
-  ( ℝ(..), T(..) )
+  ( ℝ(..), T(..), Segment(..) )
 import MetaBrush.Brush
   ( NamedBrush, PointFields )
 import MetaBrush.Records
@@ -298,6 +299,17 @@ instance Hoverable ( ℝ 2 ) where
     | otherwise
     = Normal
 
+instance Hoverable ( Segment ( ℝ 2 ) ) where
+  hovered Nothing _ _ = Normal
+  hovered ( Just ( MouseHover p ) ) zoom seg
+    = hovered ( Just ( MouseHover p ) ) zoom p'
+    where
+      ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
+  hovered hov@( Just ( RectangleHover {} ) ) zoom ( Segment p0 p1 )
+    -- Only consider a segment to be "hovered" if it lies entirely within the
+    -- hover rectangle, not just if the hover rectangle intersects it.
+    = hovered hov zoom p0 <> hovered hov zoom p1
+
 class HasSelection pt where
   _selection :: Lens' pt FocusState
 instance HasSelection ( PointData brushParams ) where

src/metabrushes/MetaBrush/Records.hs

@@ -162,7 +162,7 @@ type family Length xs where
   Length ( _ : xs ) = 1 + Length xs
 
 type KnownSymbols :: [ Symbol ] -> Constraint
-class KnownSymbols ks where
+class Typeable ks => KnownSymbols ks where
   knownSymbols :: [ Text ]
 instance KnownSymbols '[] where
   knownSymbols = []
@@ -176,8 +176,7 @@ instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where
 
 {-# INLINE intersect #-}
 intersect :: forall r1 r2 l1 l2
-          . ( Typeable r1, Typeable r2
-            , KnownSymbols r1, KnownSymbols r2
+          . ( KnownSymbols r1, KnownSymbols r2
             , l1 ~ Length r1, l2 ~ Length r2
             , Representable Double ( ℝ l1 )
             , Representable Double ( ℝ l2 )
@@ -189,16 +188,22 @@ intersect
   -- Shortcut when the two rows are equal.
   | Just Refl <- eqT @r1 @r2
   , Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
-  = Intersection { project = id, inject = \ _ -> id }
+  = Intersection { project1 = id, project2 = id, inject1 = \ _ -> id, inject2 = \ _ -> id }
   | otherwise
   = doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
       let
-        project :: Record r1 -> Record r1r2
-        project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
+        project1 :: Record r1 -> Record r1r2
+        project1 = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
 
-        inject :: Record r2 -> Record r1r2 -> Record r2
-        inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2
-      in Intersection { project, inject }
+        project2 :: Record r2 -> Record r1r2
+        project2 = \ ( MkR r2 ) -> MkR $ projection ( (!) r2_idxs ) r2
+
+        inject1 :: Record r1 -> Record r1r2 -> Record r1
+        inject1 = \ ( MkR r1 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r1_idxs ) r1r2 r1
+
+        inject2 :: Record r2 -> Record r1r2 -> Record r2
+        inject2 = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2
+      in Intersection { project1, project2, inject1, inject2 }
 
 data Intersection r1 r2 where
   Intersection
@@ -209,10 +214,16 @@ data Intersection r1 r2 where
        , Differentiable 2 () ( ℝ l12 )
        , Differentiable 3 𝕀  ( ℝ l12 )
        )
-    => { project :: Record r1 -> Record r1r2
+    => { project1 :: Record r1 -> Record r1r2
           -- ^ project out fields present in both rows
           -- (linear non-decreasing mapping)
-       , inject  :: Record r2 -> Record r1r2 -> Record r2
+       , project2 :: Record r2 -> Record r1r2
+          -- ^ project out fields present in both rows
+          -- (linear non-decreasing mapping)
+       , inject1  :: Record r1 -> Record r1r2 -> Record r1
+          -- ^ overrides the components of the first record with the second
+          -- (linear non-decreasing mapping in its second argument)
+       , inject2  :: Record r2 -> Record r1r2 -> Record r2
           -- ^ overrides the components of the first record with the second
           -- (linear non-decreasing mapping in its second argument)
        } -> Intersection r1 r2