improvements to brush params when changing brush

app/Main.hs

@@ -56,7 +56,7 @@ main = withCP65001 do
   when (isNothing mbGdkScale) $
     setEnv "GDK_SCALE" "2"
 
-  setEnv "GSK_RENDERER" "cairo"
+  setEnv "GSK_RENDERER" "vulkan"
 
   ---------------------------------------------------------
   -- Run GTK application

brush-strokes/src/lib/Calligraphy/Brushes.hs

@@ -213,8 +213,8 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams
 tearDropBrushFn _ mkI1 mkI2 =
   D \ params ->
     let w, h :: D k nbParams ( I i Double )
-        w = runD ( var @_ @k ( Fin 1 ) ) params
+        w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
-        h = runD ( var @_ @k ( Fin 2 ) ) params
+        h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
         mkPt :: Double -> Double -> D k nbParams ( I i 2 )
         mkPt x y
           -- 1. translate the teardrop so that the centre of mass is at the origin

brush-strokes/src/lib/Math/Bezier/Stroke.hs

@@ -25,6 +25,8 @@ module Math.Bezier.Stroke
   where
 
 -- base
+import Prelude
+  hiding ( unzip )
 import Control.Arrow
   ( first, (***) )
 import Control.Monad
@@ -40,7 +42,7 @@ import Data.Fixed
 import Data.Foldable
   ( for_ )
 import Data.Functor
-  ( (<&>) )
+  ( (<&>), unzip )
 import Data.Functor.Identity
   ( Identity(..) )
 import Data.List
@@ -48,7 +50,7 @@ import Data.List
 import Data.List.NonEmpty
   ( NonEmpty )
 import qualified Data.List.NonEmpty as NE
-  ( cons, singleton, unzip )
+  ( cons, singleton )
 import Data.Maybe
   ( fromMaybe, isJust, listToMaybe, mapMaybe )
 import Data.Proxy
@@ -721,7 +723,7 @@ joinBetweenOffsets
     = let
         pcs, lastAndRest :: Maybe ( SplinePts Open )
         ( pcs, lastAndRest )
-          =  NE.unzip
+          =  unzip
           $ ( discardCurveData *** discardCurveData )
           .  splitSplineAt ( i2 - i1 )
          <$> dropCurves i1 openSpline

brush-strokes/src/lib/Math/Root/Isolation/Utils.hs

@@ -9,7 +9,7 @@ module Math.Root.Isolation.Utils
 import Prelude hiding ( unzip )
 import Data.Foldable
   ( toList )
-import Data.List.NonEmpty
+import Data.Functor
   ( unzip )
 
 -- MetaBrush

src/app/MetaBrush/Application.hs

@@ -214,6 +214,7 @@ runApplication application = do
   modifiersTVar          <- STM.newTVarIO Set.empty
   toolTVar               <- STM.newTVarIO Selection
   modeTVar               <- STM.newTVarIO PathMode
+  selectedBrushTVar      <- STM.newTVarIO Nothing
   debugTVar              <- STM.newTVarIO False
   partialPathTVar        <- STM.newTVarIO Nothing
   fileBarTabsTVar        <- STM.newTVarIO Map.empty
@@ -479,7 +480,7 @@ runApplication application = do
   ---------------------------------------------------------
   -- Brushes view
 
-  brushesListView <- newBrushView window DragBrush
+  brushesListView <- newBrushView window variables DragBrush
   GTK.scrolledWindowSetChild
     ( brushesScrolledWindow panelsBar )
     ( Just brushesListView )

src/app/MetaBrush/Application/Action.hs

@@ -939,13 +939,14 @@ instance HandleAction MouseClick where
                       Pen -> do
                         -- Pen tool in path mode: start or continue a drawing operation.
                         mbPartialPath <- STM.readTVar partialPathTVar
+                        mbSelBrush    <- STM.readTVar selectedBrushTVar
                         STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
                         case mbPartialPath of
                           -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
                           Nothing -> do
                             ( newDocument, drawAnchor ) <-
-                              getOrCreateDrawAnchor uniqueSupply pos doc
+                              getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc
-                            let firstPos = anchorPos drawAnchor doc
+                            let firstPos = anchorPos drawAnchor newDocument
                             STM.writeTVar partialPathTVar
                               ( Just $ PartialPath
                                 { partialPathAnchor   = drawAnchor
@@ -1159,6 +1160,7 @@ instance HandleAction MouseRelease where
                 Pen -> case mode of
                   PathMode -> do
                     mbPartialPath <- STM.readTVar partialPathTVar
+                    mbSelBrush    <- STM.readTVar selectedBrushTVar
                     case mbPartialPath of
                       -- Normal pen mode mouse click should have created an anchor.
                       -- If no anchor exists, then just ignore the mouse release event.
@@ -1186,7 +1188,7 @@ instance HandleAction MouseRelease where
                             = ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
                             | otherwise
                             = ( pos, Nothing, Nothing )
-                        ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
+                        ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply mbSelBrush pathPoint doc
                         if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor
                         -- Close path.
                         then do

src/app/MetaBrush/Application/Context.hs

@@ -58,6 +58,8 @@ import MetaBrush.Action
   ( BrushWidgetActionState )
 import MetaBrush.Asset.Colours
   ( Colours )
+import MetaBrush.Brush
+  ( SomeBrush )
 import MetaBrush.Document.Diff
   ( DragMoveSelect )
 import MetaBrush.Draw
@@ -74,6 +76,7 @@ import MetaBrush.Unique
   ( UniqueSupply, Unique )
 
 
+
 --------------------------------------------------------------------------------
 
 data UIElements
@@ -113,6 +116,8 @@ data Variables
     -- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
   , listModelUpToDateTMVar :: !( STM.TMVar () )
 
+  , selectedBrushTVar      :: !( STM.TVar ( Maybe SomeBrush ) )
+
   , mousePosTVar           :: !( STM.TVar ( Maybe ( ℝ 2 ) )                       )
   , mouseHoldTVar          :: !( STM.TVar ( Maybe HoldAction )                    )
   , modifiersTVar          :: !( STM.TVar ( Set Modifier )                        )

src/app/MetaBrush/Render/Document.hs

@@ -175,6 +175,7 @@ getDocumentRender
             | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
             , Just p1 <- mbMousePos
             , p0 /= p1
+            -- Non-trivial drag in progress.
             , let
                 alternateMode :: Bool
                 alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
@@ -197,6 +198,7 @@ getDocumentRender
                   | otherwise
                   = ( mbMousePos, Nothing )
             , Just finalPoint <- mbFinalPoint
+            -- Path drawing operation in progress.
             , let
                 previewSpline :: Spline Open () ( PointData () )
                 previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()

src/app/MetaBrush/UI/BrushList.hs

@@ -33,27 +33,46 @@ import qualified GI.Gtk as GTK
 import qualified Data.GI.Base as GI
 import qualified Data.GI.Base.GValue as GI
 
+-- stm
+import qualified Control.Concurrent.STM as STM
+
 -- text
 import Data.Text
   ( Text )
 import qualified Data.Text as Text
-  ( toLower )
+  ( null, toLower )
 
 -- unordered-containers
 import qualified Data.HashMap.Strict as HashMap
 
 -- MetaBrush
+import MetaBrush.Application.Context
+  ( Variables(selectedBrushTVar) )
+import MetaBrush.Brush
+  ( SomeBrush )
 import qualified MetaBrush.Asset.Brushes as Brushes
   ( brushes )
 
+
+--------------------------------------------------------------------------------
+-- Brush lookup --
+------------------
+
+brushFromName :: Text -> Maybe SomeBrush
+brushFromName str
+  | Text.null str || Text.toLower str == "no brush"
+  = Nothing
+  | otherwise
+  = HashMap.lookup str Brushes.brushes
+
 --------------------------------------------------------------------------------
 -- GTK StringList --
 --------------------
 
 -- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold
 -- the given brush names.
-newBrushListModel :: [ Text ] -> IO GTK.SingleSelection
+newBrushListModel :: Variables -> [ Text ] -> IO GTK.SingleSelection
-newBrushListModel brushNames = do
+newBrushListModel vars brushNames = do
 
   stringList <- GTK.stringListNew ( Just brushNames )
 
@@ -61,6 +80,17 @@ newBrushListModel brushNames = do
                     GI.withNewObject slPtr $ \ slCopy ->
                     GTK.singleSelectionNew ( Just slCopy )
 
+  void $ GI.after selectionModel ( GI.PropertyNotify #selected ) $ \ _ -> do
+    selObj <- GTK.singleSelectionGetSelectedItem selectionModel
+    selBrush <-
+      case selObj of
+        Nothing -> return Nothing
+        Just obj -> do
+          strObj <- GTK.unsafeCastTo GTK.StringObject obj
+          str <- GTK.stringObjectGetString strObj
+          return $ brushFromName str
+    STM.atomically $ STM.writeTVar ( selectedBrushTVar vars ) selBrush
+
   return selectionModel
 
 ------------------
@@ -70,12 +100,13 @@ newBrushListModel brushNames = do
 -- | Create a new 'GTK.ListView' that displays brush names.
 newBrushView :: Typeable dnd_data
              => GTK.ApplicationWindow
+             -> Variables
              -> ( Maybe Text -> dnd_data )
                  -- ^ drag and drop data for the brush
              -> IO GTK.ListView
-newBrushView rootWindow mkDND_data = mdo
+newBrushView rootWindow vars mkDND_data = mdo
 
-  brushListModel <- newBrushListModel ( "No brush" : HashMap.keys Brushes.brushes )
+  brushListModel <- newBrushListModel vars ( "No brush" : HashMap.keys Brushes.brushes )
 
   brushesListFactory <- GTK.signalListItemFactoryNew
 

src/metabrushes/MetaBrush/Action.hs

@@ -52,7 +52,7 @@ import qualified Data.Set as Set
 
 -- generic-lens
 import Data.Generics.Product.Fields
-  ( field' )
+  ( field, field' )
 
 -- groups
 import Data.Group
@@ -924,7 +924,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
     zoom = documentZoom $ documentMetadata
 
     updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
-    updateStroke u stroke@( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline _clo ( Record pointFields ) } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
+    updateStroke u
+      ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
+      ( StrokeMetadata { strokeVisible, strokeLocked } )
       | strokeVisible
       , not strokeLocked
         -- If we have already started a widget action, only continue an action
@@ -932,35 +934,42 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       , case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
         -- Don't touch strokes without brushes.
       , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
-      = case intersect @pointFields @brushFields of
+      , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
-          Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do
+          <- intersect @pointFields @brushFields
-            let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush )
+      , Union @pointFields' unionWith
+          <- union @pointFields @brushFields
+      = do  let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
+                embedUsedParams = updateBrushParams defaultBrushParams
                 toBrushParams = embedUsedParams . ptParamsToUsedParams
-                updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' )
+                noUpdatePointParams :: Record pointFields -> Record pointFields'
+                noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
+                updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
+                updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
             spline' <-
               bitraverseSpline
-                ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u )
+                ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
                 ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
                 oldSpline
             ( mbAct, _ ) <- State.get
             case mbAct of
               Nothing -> return PreserveStroke
-              Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
+              Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
       | otherwise
       = return PreserveStroke
 
     updateSplineCurve
-      :: forall clo' pointParams brushFields
+      :: forall clo' pointParams brushFields pointParams'
       .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
       => PointData pointParams
       -> NamedBrush brushFields
       -> ( pointParams -> Record brushFields )
-      -> ( Record brushFields -> pointParams -> pointParams )
+      -> ( pointParams -> pointParams' )
+      -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique
       -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
       -> State ( Maybe BrushWidgetActionState, Bool )
-            ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) )
+            ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
-    updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do
+    updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
       ( mbAct, prevCurveAct ) <- State.get
       -- We can only perform a brush widget update if:
       --   - we aren't already updating another point,
@@ -979,24 +988,24 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       if canAct
       then do
         case curve of
-          line@( LineTo sp1 dat ) -> do
+          LineTo sp1 dat -> do
             sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
-            pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
+            pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } )
-          bez2@( Bezier2To sp1 sp2 dat ) -> do
+          Bezier2To sp1 sp2 dat -> do
             sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
             sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
-            pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
+            pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
-          bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
+          Bezier3To sp1 sp2 sp3 dat -> do
             sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
             sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
             sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
-            pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
+            pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
       else do
         State.put ( mbAct, False )
         let curve' = if prevCurveAct
                      then curve { curveData = invalidateCache $ curveData curve }
                      else curve
-        return curve'
+        return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve'
       where
         crvIx = curveIndex ( curveData curve )
 
@@ -1011,14 +1020,14 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
           inPointClickRange zoom c q
 
     updateSplinePoint
-      :: forall pointParams brushFields
+      :: forall pointParams brushFields pointParams'
       .  NamedBrush brushFields
       -> ( pointParams -> Record brushFields )
-      -> ( Record brushFields -> pointParams -> pointParams )
+      -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique -> PointIndex
       -> PointData pointParams
       -> State ( Maybe BrushWidgetActionState, Bool )
-          ( PointData pointParams )
+          ( PointData pointParams' )
     updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
       let
         currentBrushParams :: Record brushFields
@@ -1069,4 +1078,4 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       case newBrushWidgetAction of
         Just a -> State.put ( Just a, True )
         _      -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
-      pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
+      pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )

src/metabrushes/MetaBrush/Asset/Brushes.hs

@@ -23,6 +23,8 @@ import GHC.Exts
 -- text
 import Data.Text
   ( Text )
+import qualified Data.Text as Text
+  ( toLower )
 
 -- unordered-containers
 import Data.HashMap.Strict
@@ -45,7 +47,7 @@ import qualified MetaBrush.Brush.Widget as Brush
 --------------------------------------------------------------------------------
 
 lookupBrush :: Text -> Maybe SomeBrush
-lookupBrush nm = HashMap.lookup nm brushes
+lookupBrush nm = HashMap.lookup ( Text.toLower nm ) brushes
 
 -- | All brushes supported by this application.
 brushes :: HashMap Text SomeBrush
@@ -57,7 +59,7 @@ brushes = HashMap.fromList
 
 --------------------------------------------------------------------------------
 
-type CircleBrushFields = '[ "r" ]
+type CircleBrushFields = '[ "a" ]
 -- | A circular brush with the given radius.
 circle :: NamedBrush CircleBrushFields
 circle =
@@ -67,7 +69,7 @@ circle =
     , brushWidget   = Brush.SquareWidget
     }
   where
-    deflts = ℝ1 1
+    deflts = ℝ1 10
 {-# INLINE circle #-}
 
 type EllipseBrushFields = '[ "a", "b", "phi" ]
@@ -81,11 +83,11 @@ ellipse =
     , brushWidget   = Brush.RotatableRectangleWidget
     }
   where
-    deflts = ℝ3 1 1 0
+    deflts = ℝ3 10 7 0
 {-# INLINE ellipse #-}
 
-type TearDropBrushFields = '[ "w", "h", "phi" ]
+type TearDropBrushFields = '[ "a", "b", "phi" ]
--- | A tear-drop shape with the given width, height and angle of rotation.
+-- | A tear-drop shape with the given half-width, half-height and angle of rotation.
 tearDrop :: NamedBrush TearDropBrushFields
 tearDrop =
   NamedBrush
@@ -94,5 +96,5 @@ tearDrop =
     , brushWidget   = Brush.RotatableRectangleWidget
     }
   where
-    deflts = ℝ3 1 2.25 0
+    deflts = ℝ3 10 7 0
 {-# INLINE tearDrop #-}

src/metabrushes/MetaBrush/Brush.hs

@@ -84,6 +84,7 @@ data NamedBrush brushFields where
        , DiffInterp 2 ℝ ( Length brushFields )
        , DiffInterp 3 𝕀 ( Length brushFields )
        , Show ( ℝ ( Length brushFields ) )
+       , NFData ( ℝ ( Length brushFields ) )
        )
     => { brushName     :: !Text
        , brushFunction :: !( BrushFunction brushFields )

src/metabrushes/MetaBrush/Draw.hs

@@ -17,6 +17,8 @@ import Data.Foldable
   ( for_ )
 import GHC.Generics
   ( Generic )
+import GHC.Stack
+  ( HasCallStack )
 import GHC.TypeLits
   ( Symbol )
 
@@ -58,7 +60,7 @@ import Math.Linear
 
 -- MetaBrush
 import MetaBrush.Brush
-  ( NamedBrush(..) )
+  ( SomeBrush(..), NamedBrush (..), WithParams (defaultParams) )
 import MetaBrush.Document
 import MetaBrush.Hover
   ( inPointClickRange )
@@ -91,10 +93,11 @@ anchorsAreComplementary
 -- drawing a stroke or to start a new one.
 getOrCreateDrawAnchor
   :: UniqueSupply
+  -> Maybe SomeBrush
   -> ℝ 2
   -> Document
   -> STM ( Document, DrawAnchor )
-getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldContent, documentMetadata } ) =
+getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent = oldContent, documentMetadata } ) =
 
   -- Deselect all points, and try to find a valid anchor for drawing
   -- (a path start/end point at mouse click point).
@@ -116,17 +119,35 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
     Right {} -> do
       newStrokeUnique <- runReaderT freshUnique uniqueSupply
       let
-        newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
-        newSpline =
-          Spline { splineStart  = PointData c ( MkR ℝ0 )
-                 , splineCurves = OpenCurves Empty
-                 }
         newStroke :: Stroke
         newStroke =
-          Stroke
+          case mbBrush of
-            { strokeSpline  = newSpline
+            Nothing ->
-            , strokeBrush   = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
+              let
-            }
+                newSpline :: StrokeSpline Open ( Record @Symbol '[] )
+                newSpline =
+                  Spline
+                    { splineStart  = PointData c ( MkR ℝ0 )
+                    , splineCurves = OpenCurves Empty
+                    }
+              in
+                Stroke
+                  { strokeSpline  = newSpline
+                  , strokeBrush   = Nothing
+                  }
+            Just ( SomeBrush ( b@( NamedBrush { brushFunction = fn } ) :: NamedBrush brushFields ) ) ->
+              let
+                newSpline :: StrokeSpline Open ( Record brushFields )
+                newSpline =
+                  Spline
+                    { splineStart  = PointData c ( MkR $ defaultParams fn )
+                    , splineCurves = OpenCurves Empty
+                    }
+              in
+                Stroke
+                  { strokeSpline  = newSpline
+                  , strokeBrush   = Just b
+                  }
         newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
         newMeta :: DocumentMetadata
         newMeta =
@@ -199,7 +220,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
                 -> Just anchor
               _ -> Nothing
 
-anchorPos :: DrawAnchor -> Document -> ℝ 2
+anchorPos :: HasCallStack => DrawAnchor -> Document -> ℝ 2
 anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } )
   ( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) =
     case Map.lookup anchorStroke strokes of

src/metabrushes/MetaBrush/Records.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE ParallelListComp     #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -11,7 +12,9 @@ import Data.Functor
 import Data.Kind
   ( Type, Constraint )
 import Data.List
-  ( findIndex, intersperse )
+  ( findIndex, intersperse, sortBy )
+import Data.Ord
+  ( comparing )
 import Data.Typeable
   ( Typeable, eqT )
 import Data.Type.Equality
@@ -33,6 +36,9 @@ import Unsafe.Coerce
 import Data.Act
   ( Act(..), Torsor(..) )
 
+-- containers
+import qualified Data.Map.Strict as Map
+
 -- deepseq
 import Control.DeepSeq
   ( NFData(..) )
@@ -291,3 +297,144 @@ type family Elem k ks where
   Elem _ '[]         = False
   Elem k ( k ': _  ) = True
   Elem k ( _ ': ks ) = Elem k ks
+
+--------------------------------------------------------------------------------
+-- Union of two records.
+
+data Union r1 r2 where
+  Union
+    :: forall r1r2_rocky r1 r2 l12_rocky
+    .  ( l12_rocky ~ Length r1r2_rocky
+       , KnownSymbols r1r2_rocky
+       , Representable Double ( ℝ l12_rocky )
+       , Show ( ℝ l12_rocky )
+       , NFData ( ℝ l12_rocky )
+       , DiffInterp 2 ℝ l12_rocky
+       , DiffInterp 3 𝕀 l12_rocky
+       )
+    => { unionWith :: ( Double -> Double -> Double )
+                   -> Record r1 -> Record r2 -> Record r1r2_rocky
+         -- ^ union of two records
+       } -> Union r1 r2
+
+{-# INLINE union #-}
+union :: forall r1 r2 l1 l2
+          . ( KnownSymbols r1, KnownSymbols r2
+            , l1 ~ Length r1, l2 ~ Length r2
+            , Representable Double ( ℝ l1 )
+            , Representable Double ( ℝ l2 )
+            , Show ( ℝ l1 )
+            , Show ( ℝ l2 )
+            , NFData ( ℝ l2 )
+            , DiffInterp 2 ℝ l2
+            , DiffInterp 3 𝕀 l2
+            )
+          => Union r1 r2
+union
+  -- Shortcut when the two rows are equal.
+  | Just Refl <- eqT @r1 @r2
+  = Union { unionWith = \ f ( MkR l ) ( MkR r ) -> MkR @Symbol @r1 ( tabulate $ \ i -> f ( index l i ) ( index r i ) ) }
+  | otherwise
+  = doUnion @r1 @r2 \ ( _ :: Proxy# r1r2 ) idxs ->
+      let
+        unionWith :: ( Double -> Double -> Double )
+                  -> Record r1 -> Record r2 -> Record r1r2
+        unionWith f = \ ( MkR r1 ) ( MkR r2 ) -> MkR $ tabulate $ \ i ->
+          case idxs ! i of
+            InBoth i1 i2 -> f ( index r1 i1 ) ( index r2 i2 )
+            InL    i1    -> index r1 i1
+            InR    i2    -> index r2 i2
+      in Union { unionWith }
+
+
+data LR l r
+  = InL !l
+  | InR !r
+  | InBoth !l !r
+  deriving stock ( Eq, Show )
+
+bimapLR :: ( l1 -> l2 ) -> ( r1 -> r2 ) -> LR l1 r1 -> LR l2 r2
+bimapLR f g = \case
+  InL    l   -> InL    ( f l )
+  InR      r -> InR            ( g r )
+  InBoth l r -> InBoth ( f l ) ( g r )
+
+instance ( Ord l, Ord r ) => Ord ( LR l r ) where
+  compare a b = compare ( getL a, getR a ) ( getL b, getR b )
+    where
+      getL :: LR l r -> Maybe l
+      getL ( InL l ) = Just l
+      getL ( InBoth l _ ) = Just l
+      getL ( InR {} ) = Nothing
+      getR :: LR l r -> Maybe r
+      getR ( InL {} ) = Nothing
+      getR ( InBoth _ r ) = Just r
+      getR ( InR r ) = Just r
+
+{-# INLINE doUnion #-}
+doUnion
+  :: forall r1 r2 l1 l2 kont
+  .  ( KnownSymbols r1, KnownSymbols r2
+     , l1 ~ Length r1, l2 ~ Length r2
+     )
+  => ( forall r1r2 l12.
+        ( KnownSymbols r1r2, l12 ~ Length r1r2
+        , DiffInterp 2 ℝ l12
+        , DiffInterp 3 𝕀  l12
+        , Representable Double ( ℝ l12 )
+        , Show ( ℝ l12 )
+        , NFData ( ℝ l12 )
+        )
+      => Proxy# r1r2 -> Vec l12 ( LR ( Fin l1 ) ( Fin l2 ) ) -> kont )
+  -> kont
+doUnion k =
+  case knownSymbols @r1 `unionLists` knownSymbols @r2 of
+
+    [ ]
+      | ( _ :: Proxy# r1r2 ) <- proxy# @'[ ]
+      , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
+      -> k @r1r2 proxy#
+           ( Vec [] )
+
+    [ ( f1, i1 ) ]
+      | SomeSymbol @f1 _     <- someSymbolVal ( Text.unpack f1 )
+      , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ]
+      -> k @r1r2 proxy#
+           ( Vec $ map ( bimapLR Fin Fin ) [ i1 ] )
+
+    [ ( f1, i1 ), ( f2, i2 ) ]
+      | SomeSymbol @f1 _     <- someSymbolVal ( Text.unpack f1 )
+      , SomeSymbol @f2 _     <- someSymbolVal ( Text.unpack f2 )
+      , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ]
+      -> k @r1r2 proxy#
+           ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2 ] )
+
+    [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ) ]
+      | SomeSymbol @f1 _     <- someSymbolVal ( Text.unpack f1 )
+      , SomeSymbol @f2 _     <- someSymbolVal ( Text.unpack f2 )
+      , SomeSymbol @f3 _     <- someSymbolVal ( Text.unpack f3 )
+      , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ]
+      -> k @r1r2 proxy#
+           ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3 ] )
+
+    [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ), ( f4, i4 ) ]
+      | SomeSymbol @f1 _     <- someSymbolVal ( Text.unpack f1 )
+      , SomeSymbol @f2 _     <- someSymbolVal ( Text.unpack f2 )
+      , SomeSymbol @f3 _     <- someSymbolVal ( Text.unpack f3 )
+      , SomeSymbol @f4 _     <- someSymbolVal ( Text.unpack f4 )
+      , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3, f4 ]
+      -> k @r1r2 proxy#
+           ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3, i4 ] )
+
+    other -> error $ "Union not defined in dimension " ++ show ( length other )
+
+unionLists :: forall k. Ord k => [ k ] -> [ k ] -> [ ( k, LR Word Word ) ]
+unionLists l r = sortBy ( comparing snd )
+               $ Map.toList
+               $ Map.unionWith f
+                  ( Map.fromList [ ( k, InL i ) | k <- l | i <- [ 0 .. ] ] )
+                  ( Map.fromList [ ( k, InR i ) | k <- r | i <- [ 0 .. ] ] )
+  where
+    f :: LR Word Word -> LR Word Word -> LR Word Word
+    f ( InL i ) ( InR j ) = InBoth i j
+    f _ _ = error "unionList: internal error"

src/metabrushes/MetaBrush/Stroke.hs

@@ -14,8 +14,6 @@ import Data.Foldable
   ( foldr' )
 import Data.Functor.Identity
   ( Identity(..) )
-import Data.Typeable
-  ( Typeable )
 import GHC.Generics
   ( Generic, Generic1 )
 import GHC.Stack
@@ -97,7 +95,7 @@ data PointData params
   { pointCoords :: !( ℝ 2 )
   , brushParams :: !params
   }
-  deriving stock ( Show, Generic )
+  deriving stock ( Show, Generic, Functor, Foldable, Traversable )
   deriving anyclass NFData
 
 -- | Data attached to each curve in a spline.
@@ -141,14 +139,11 @@ type StrokeSpline clo brushParams =
 
 data Stroke where
   Stroke
-    :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
+    :: forall clo ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
-    .  ( KnownSplineType clo
+    .  ( KnownSplineType clo , PointFields pointFields )
-       , pointParams ~ Record pointFields
-       , PointFields pointFields, Typeable pointFields
-       )
     =>
       { strokeBrush  :: !( Maybe ( NamedBrush brushFields ) )
-      , strokeSpline :: !( StrokeSpline clo pointParams )
+      , strokeSpline :: !( StrokeSpline clo ( Record pointFields ) )
       }
     -> Stroke
 deriving stock instance Show Stroke