Implement programmable brush framework

MetaBrush.cabal

@@ -27,7 +27,7 @@ common common
 
     build-depends:
         base
-          >= 4.13 && < 4.16
+          >= 4.13 && < 4.17
       , acts
           ^>= 0.3.1.0
       , containers
@@ -77,6 +77,7 @@ library
         Math.Bezier.Cubic
       , Math.Bezier.Cubic.Fit
       , Math.Bezier.Quadratic
+      , Math.Bezier.Spline
       , Math.Bezier.Stroke
       , Math.Epsilon
       , Math.Linear.Solve
@@ -85,12 +86,14 @@ library
       , Math.Vector2D
 
     build-depends:
-        groups-generic
+        bifunctors
+          ^>= 5.5.4
+      , groups-generic
           ^>= 0.1.0.0
       , hmatrix
           ^>= 0.20.0.0
-      , monad-par
+      , parallel
-          ^>= 0.3.5
+          ^>= 3.2.2.0
       , prim-instances
           ^>= 0.2
       , vector
@@ -128,6 +131,14 @@ executable MetaBrush
       , MetaBrush.Document.SubdivideStroke
       , MetaBrush.Document.Update
       , MetaBrush.Event
+      , MetaBrush.MetaParameter.AST
+      , MetaBrush.MetaParameter.Driver
+      , MetaBrush.MetaParameter.Eval
+      , MetaBrush.MetaParameter.Interpolation
+      , MetaBrush.MetaParameter.Parse
+      , MetaBrush.MetaParameter.PrimOp
+      , MetaBrush.MetaParameter.Rename
+      , MetaBrush.MetaParameter.TypeCheck
       , MetaBrush.Render.Document
       , MetaBrush.Render.Rulers
       , MetaBrush.Time
@@ -153,11 +164,17 @@ executable MetaBrush
       , atomic-file-ops
           ^>= 0.3.0.0
       , bytestring
-          ^>= 0.10.10.1
+          ^>= 0.10.10.0
       , directory
           >= 1.3.4.0 && < 1.4
+      , dlist
+          ^>= 1.0
+      , Earley
+          ^>= 0.13.0.1
       , filepath
           ^>= 1.4.2.1
+      , ghc-typelits-knownnat
+          ^>= 0.7.3
       , gi-gdk
           >= 3.0.22 && < 3.1
       , gi-gio
@@ -173,16 +190,22 @@ executable MetaBrush
       , gi-cairo-connector
           ^>= 0.0.1
       , haskell-gi-base
-          ^>= 0.24
+          ^>= 0.24.3
       , lens
           ^>= 4.19.2
+      , mtl
+          ^>= 2.2.2
       , scientific
           ^>= 0.3.6.2
       , stm
           ^>= 2.5.0.0
+      , superrecord
+          ^>= 0.5.1.0
       , tardis
           ^>= 0.4.1.0
       , text
-          ^>= 1.2.3.1 && < 1.2.5
+          >= 1.2.3.1 && < 1.2.5
+      , tree-view
+          ^>= 0.5
       , waargonaut
           ^>= 0.8.0.1

app/Main.hs

@@ -2,11 +2,13 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE NegativeLiterals    #-}
+{-# LANGUAGE OverloadedLabels    #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE RecursiveDo         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module Main
   ( main )
@@ -30,9 +32,7 @@ import GHC.Conc
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( empty )
+  ( adjust, empty )
-import Data.Sequence
-  ( Seq(..) )
 import qualified Data.Sequence as Seq
   ( fromList )
 import Data.Set
@@ -48,6 +48,10 @@ import qualified System.Directory as Directory
 import Data.Generics.Product.Fields
   ( field' )
 
+-- gi-cairo-render
+import qualified GI.Cairo.Render as Cairo
+  ( Render )
+
 -- gi-cairo-connector
 import qualified GI.Cairo.Render.Connector as Cairo
   ( renderWithContext )
@@ -60,13 +64,19 @@ import qualified GI.Gtk as GTK
 
 -- lens
 import Control.Lens
-  ( (.~) )
+  ( (.~), set )
 
 -- stm
 import qualified Control.Concurrent.STM as STM
   ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
-  ( newTVarIO, readTVar )
+  ( modifyTVar', newTVarIO, readTVar )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( (:=)(..), (&), rnil )
 
 -- text
 import qualified Data.Text as Text
@@ -75,14 +85,16 @@ import qualified Data.Text as Text
 -- MetaBrush
 import Math.Bezier.Cubic.Fit
   ( FitParameters(..) )
+import Math.Bezier.Spline
+  ( Spline(..), Curves(..), Curve(..), NextPoint(..) )
 import Math.Bezier.Stroke
-  ( StrokePoint(..) )
+  ( CachedStroke(..) )
 import Math.Vector2D
   ( Point2D(..) )
 import MetaBrush.Action
   ( ActionOrigin(..) )
-import MetaBrush.Asset.Brushes
+import qualified MetaBrush.Asset.Brushes as Asset.Brushes
-  ( ellipse, rect )
+  ( circle )
 import MetaBrush.Asset.Colours
   ( getColours )
 import MetaBrush.Asset.Logo
@@ -95,7 +107,7 @@ import MetaBrush.Context
 import MetaBrush.Document
   ( Document(..), emptyDocument
   , Stroke(..), FocusState(..)
-  , PointData(..), BrushPointData(..)
+  , PointData(..)
   )
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory )
@@ -131,56 +143,6 @@ import qualified Paths_MetaBrush as Cabal
 
 --------------------------------------------------------------------------------
 
-testDocuments :: Map Unique DocumentHistory
-testDocuments = fmap newHistory $ uniqueMapFromList
-  [ emptyDocument "Closed" ( unsafeUnique 0 )
-  & ( field' @"documentContent" . field' @"strokes" ) .~
-    [ Stroke
-      { strokeName    = "Ellipse"
-      , strokeVisible = True
-      , strokeUnique  = unsafeUnique 10
-      , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
-      }
-    ]
-  , emptyDocument "Line" ( unsafeUnique 1 )
-  & ( field' @"documentContent" . field' @"strokes" ) .~
-    [ Stroke
-      { strokeName    = "Line"
-      , strokeVisible = True
-      , strokeUnique  = unsafeUnique 11
-      , strokePoints  = linePts
-      }
-    ]
-  , emptyDocument "Short line" ( unsafeUnique 2 )
-  & ( field' @"documentContent" . field' @"strokes" ) .~
-    [ Stroke
-      { strokeName    = "ShortLine"
-      , strokeVisible = True
-      , strokeUnique  = unsafeUnique 12
-      , strokePoints  = linePts2
-      }
-    ]
-  ]
-  where
-    linePts :: Seq ( StrokePoint PointData )
-    linePts = Seq.fromList
-      [    PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse 30 8 $ BrushPointData Normal ) )
-      , ControlPoint ( Point2D 0  -30 ) ( PointData Normal ( ellipse 25 6 $ BrushPointData Normal ) )
-      , ControlPoint ( Point2D 0   30 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) )
-      ,    PathPoint ( Point2D 0  100 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) )
-      , ControlPoint ( Point2D 0  150 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) )
-      , ControlPoint ( Point2D 0  200 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) )
-      ,    PathPoint ( Point2D 0  250 ) ( PointData Normal ( ellipse 10 1 $ BrushPointData Normal ) )
-      ]
-    linePts2 :: Seq ( StrokePoint PointData )
-    linePts2 = Seq.fromList
-      [    PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse  20 8 $ BrushPointData Normal ) )
-      --, ControlPoint ( Point2D 0    0 ) ( PointData Normal ( ellipse 140 8 $ BrushPointData Normal ) )
-      ,    PathPoint ( Point2D 0  100 ) ( PointData Normal ( ellipse  20 8 $ BrushPointData Normal ) )
-      ]
-
---------------------------------------------------------------------------------
-
 main :: IO ()
 main = do
 
@@ -200,13 +162,42 @@ main = do
   -- Initialise state
 
   uniqueSupply <- newUniqueSupply
+
+  circleBrush <- Asset.Brushes.circle uniqueSupply
+
+  let
+    testDocuments :: Map Unique DocumentHistory
+    testDocuments = fmap newHistory $ uniqueMapFromList
+      [ emptyDocument "Test" ( unsafeUnique 0 )
+      & ( field' @"documentContent" . field' @"strokes" ) .~
+        [ Stroke
+          { strokeName    = "Stroke 1"
+          , strokeVisible = True
+          , strokeUnique  = unsafeUnique 10
+          , strokeBrush   = circleBrush
+          , strokeSpline  =
+            Spline
+              { splineStart  = mkPoint ( Point2D 10 -20 ) 2
+              , splineCurves = OpenCurves $ Seq.fromList
+                [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D  10  10 ) 5 ), curveData = CachedStroke Nothing }
+                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10  10 ) 5 ), curveData = CachedStroke Nothing }
+                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
+                ]
+              }
+          }
+        ]
+      ]
+        where
+          mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
+          mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
+
   activeDocumentTVar <- STM.newTVarIO @( Maybe Unique )                            Nothing
   openDocumentsTVar  <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
   mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) )                Nothing
   mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldAction )                        Nothing
   modifiersTVar      <- STM.newTVarIO @( Set Modifier )                            Set.empty
   toolTVar           <- STM.newTVarIO @Tool                                        Selection
-  modeTVar           <- STM.newTVarIO @Mode                                        Path
+  modeTVar           <- STM.newTVarIO @Mode                                        PathMode
   debugTVar          <- STM.newTVarIO @Bool                                        False
   partialPathTVar    <- STM.newTVarIO @( Maybe PartialPath )                       Nothing
   fileBarTabsTVar    <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
@@ -332,7 +323,7 @@ main = do
     -- Get the relevant document information
     viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
     viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-    mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
+    mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> do
       modifiers      <- STM.readTVar modifiersTVar
       mbMousePos     <- STM.readTVar mousePosTVar
       mbHoldAction   <- STM.readTVar mouseHoldTVar
@@ -341,18 +332,33 @@ main = do
       debug          <- STM.readTVar debugTVar
       showGuides     <- STM.readTVar showGuidesTVar
       fitParameters  <- STM.readTVar fitParametersTVar
-      pure do
+
+      let
+        mbUpdatedDoc :: Maybe Document
+        renderDoc, renderAction :: Cairo.Render ()
+        ( mbUpdatedDoc, renderDoc ) =
           renderDocument
             colours fitParameters mode debug ( viewportWidth, viewportHeight )
             modifiers mbMousePos mbHoldAction mbPartialPath
             doc
+        renderAction = do
+          renderDoc
           renderRuler
             colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
             mbMousePos mbHoldAction showGuides
             doc
-    case mbRender of
+      pure
-      Just render -> Cairo.renderWithContext render                  ctx
+        ( mbUpdatedDoc, renderAction )
-      Nothing     -> Cairo.renderWithContext ( blankRender colours ) ctx
+
+    case mbDocAndRender of
+      Just ( mbNewDoc, render ) -> do
+        Cairo.renderWithContext render ctx
+        for_ mbNewDoc \ newDoc -> STM.atomically do
+          mbCurrDocUnique <- STM.readTVar activeDocumentTVar
+          for_ mbCurrDocUnique \ currDocUnique -> do
+            STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
+      Nothing ->
+        Cairo.renderWithContext ( blankRender colours ) ctx
 
     pure True
 
@@ -365,7 +371,7 @@ main = do
       viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
       width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
       height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
-      mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
+      mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
         mbMousePos     <- STM.readTVar mousePosTVar
         mbHoldAction   <- STM.readTVar mouseHoldTVar
         showGuides     <- STM.readTVar showGuidesTVar

cabal.project

@@ -6,6 +6,7 @@ constraints:
 allow-newer:
     waargonaut:*
 
+
 -- fixes gi-cairo-render to work with haskell-gi >= 0.24
 source-repository-package
   type: git
@@ -30,8 +31,18 @@ source-repository-package
   location: https://github.com/sheaf/waargonaut
   tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699
 
--- haskell-gi: add fix for GValue
+-- instances for CPS Writer / CPS RWST
 source-repository-package
   type: git
-  location: https://github.com/haskell-gi/haskell-gi
+  location: https://github.com/haskell/mtl
-  tag: 6fe7fc271095b5b6115b142f72995ebc11840afb
+  tag: a9023c764a08beedbb1b8ca20bc39103f26529c5
+
+-- patch to superrecord with API improvements
+source-repository-package
+  type: git
+  location: https://github.com/sheaf/superrecord
+  tag: 4cecac06afaa3fb60e67cdb273e36eed3f04335d
+
+constraints:
+  -- fix for Haskell GI GValue bug
+  haskell-gi >= 0.24.5

src/app/MetaBrush/Action.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
@@ -23,7 +22,7 @@ import Data.Foldable
 import Data.Int
   ( Int32 )
 import Data.Maybe
-  ( catMaybes, listToMaybe )
+  ( listToMaybe )
 import Data.Traversable
   ( for )
 import Data.Word
@@ -40,10 +39,6 @@ import Data.Act
 -- containers
 import qualified Data.Map as Map
   ( insert, lookup )
-import Data.Sequence
-  ( Seq(..) )
-import qualified Data.Sequence as Seq
-  ( fromList )
 import qualified Data.Set as Set
   ( delete, insert )
 
@@ -84,8 +79,12 @@ import qualified Data.Text as Text
   ( intercalate, pack )
 
 -- MetaBrush
+import Math.Bezier.Spline
+  ( Spline(..), SplineType(Open)
+  , catMaybesSpline
+  )
 import Math.Bezier.Stroke
-  ( StrokePoint(..) )
+  ( CachedStroke(..) )
 import Math.Module
   ( Module((*^)) )
 import Math.Vector2D
@@ -96,11 +95,11 @@ import MetaBrush.Context
   , HoldAction(..), GuideAction(..), PartialPath(..)
   )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..), PointData(..), FocusState(..) )
+  ( Document(..), DocumentContent(..), PointData(..), FocusState(..)
+  , Guide(..), selectedGuide, addGuide
+  )
 import MetaBrush.Document.Draw
   ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
-import MetaBrush.Document
-  ( Guide(..), selectedGuide, addGuide )
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory
   , back, fwd
@@ -132,7 +131,7 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
 import MetaBrush.UI.Menu
   ( MenuItem(..), Menu(..), ViewMenu(..) )
 import MetaBrush.UI.ToolBar
-  ( Tool(..) )
+  ( Tool(..), Mode(..) )
 import MetaBrush.UI.Viewport
   ( Viewport(..), Ruler(..) )
 import MetaBrush.Unique
@@ -243,7 +242,6 @@ instance HandleAction OpenFolder where
                 newDocHist = newHistory doc
               newFileTab False uiElts vars ( Just newDocHist ) tabLoc
               updateHistoryState uiElts ( Just newDocHist )
-    pure ()
 
 ---------------
 -- Save file --
@@ -253,12 +251,12 @@ data Save = Save
   deriving stock Show
 
 instance HandleAction Save where
-  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
+  handleAction uiElts vars _ =
     save uiElts vars True
 
 save :: UIElements -> Variables -> Bool -> IO ()
 save uiElts vars keepOpen = do
-  mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars )
+  mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
   for_ mbDoc \case
     doc@( Document { mbFilePath, documentContent } )
       | Nothing <- mbFilePath
@@ -285,7 +283,7 @@ instance HandleAction SaveAs where
 saveAs :: UIElements -> Variables -> Bool -> IO ()
 saveAs uiElts vars keepOpen = do
   mbSavePath <- askForSavePath uiElts
-  for_ mbSavePath \ savePath -> do
+  for_ mbSavePath \ savePath ->
     modifyingCurrentDocument uiElts vars \ doc -> do
       let
         modif :: DocumentUpdate
@@ -332,7 +330,7 @@ pattern CancelClose  = 3
 
 instance HandleAction Close where
   handleAction
-    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    uiElts@( UIElements {..} )
     vars@( Variables {..} )
     close = do
       mbDoc <- case close of
@@ -391,7 +389,7 @@ data SwitchTo = SwitchTo Unique
 
 instance HandleAction SwitchTo where
   handleAction
-    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    uiElts
     vars@( Variables {..} )
     ( SwitchTo newUnique ) = do
       uiUpdateAction <- STM.atomically do
@@ -424,17 +422,17 @@ data Undo = Undo
   deriving stock Show
 
 instance HandleAction Undo where
-  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars
+  handleAction uiElts vars _ = updateHistory back uiElts vars
 
 
 data Redo = Redo
   deriving stock Show
 
 instance HandleAction Redo where
-  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars
+  handleAction uiElts vars _ = updateHistory fwd uiElts vars
 
 updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
-updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do
+updateHistory f uiElts vars@( Variables {..} ) = do
   uiUpdateAction <- STM.atomically do
     mbUnique <- STM.readTVar activeDocumentTVar
     case mbUnique of
@@ -514,13 +512,14 @@ instance HandleAction Delete where
         tool <- STM.readTVarIO toolTVar
         mode <- STM.readTVarIO modeTVar
         case tool of
-          -- Delete selected points on pressing 'Delete'.
+          -- Delete selected points on pressing 'Delete' in path mode.
           Selection
+            | PathMode <- mode
             -> modifyingCurrentDocument uiElts vars \ doc -> do
                 let
                   newDocument :: Document
                   updateInfo :: UpdateInfo
-                  ( newDocument, updateInfo ) = deleteSelected mode doc
+                  ( newDocument, updateInfo ) = deleteSelected doc
                 case updateInfo of
                   UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
                     | null strokesAffected
@@ -677,6 +676,10 @@ instance HandleAction MouseClick where
             pos :: Point2D Double
             pos = toViewport mouseClickCoords
           STM.writeTVar mousePosTVar ( Just pos )
+          mode <- STM.readTVar modeTVar
+          case mode of
+            BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
+            _ ->
               case actionOrigin of
 
                 ViewportOrigin -> case ty of
@@ -684,7 +687,7 @@ instance HandleAction MouseClick where
                   SingleClick -> do
                     modifiers <- STM.readTVar modifiersTVar
                     tool <- STM.readTVar toolTVar
-                mode <- STM.readTVar modeTVar
+
                     case tool of
                       -- Selection mode mouse hold:
                       --
@@ -696,7 +699,7 @@ instance HandleAction MouseClick where
                         case selectionMode modifiers of
                           -- Drag move: not holding shift or alt, click has selected something.
                           New
-                        | Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc
+                            | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
                             -> do
                               STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
                               case dragMove of
@@ -743,14 +746,14 @@ instance HandleAction MouseClick where
 
                   DoubleClick -> do
                     tool   <- STM.readTVar toolTVar
-                mode <- STM.readTVar modeTVar
                     modifs <- STM.readTVar modifiersTVar
                     case tool of
                       Selection
-                    | null modifs
+                        | PathMode <- mode
+                        , null modifs
                         -> do
                           STM.writeTVar mouseHoldTVar Nothing
-                      case subdivide mode pos doc of
+                          case subdivide pos doc of
                             Nothing              ->
                               pure Don'tModifyDoc
                             Just ( newDocument, loc ) -> do
@@ -869,6 +872,9 @@ instance HandleAction MouseRelease where
             _ -> do
               tool <- STM.readTVar toolTVar
               mode <- STM.readTVar modeTVar
+              case mode of
+                BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
+                _ ->
                   case tool of
 
                     Selection -> do
@@ -882,13 +888,13 @@ instance HandleAction MouseRelease where
                           -> let
                                 alternateMode :: Bool
                                 alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
-                          in case dragUpdate mode pos0 pos dragAction alternateMode doc of
+                              in case dragUpdate pos0 pos dragAction alternateMode doc of
                                 Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
                                 Nothing  -> pure Don'tModifyDoc
                           | SelectionHold pos0 <- hold
                           , pos0 /= pos
-                      -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
+                          -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
-                    _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc )
+                        _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
 
                     Pen -> do
                       mbPartialPath <- STM.readTVar partialPathTVar
@@ -924,21 +930,20 @@ instance HandleAction MouseRelease where
                           then do
                             STM.writeTVar partialPathTVar Nothing
                             let
-                          newSegment :: Seq ( StrokePoint PointData )
+                              newSegment :: Spline Open CachedStroke ( PointData () )
-                          newSegment
+                              newSegment = catMaybesSpline ( CachedStroke Nothing )
-                            = Seq.fromList
+                                ( PointData p1 Normal () )
-                            $ catMaybes
+                                ( do
-                            [ Just ( PathPoint p1 ( PointData Normal Empty ) )
-                            , do
                                     cp <- mbCp2
                                     guard ( cp /= p1 )
-                                pure $ ControlPoint cp ( PointData Normal Empty )
+                                    pure ( PointData cp Normal () )
-                            , do
+                                )
+                                ( do
                                     cp <- mbControlPoint
                                     guard ( cp /= otherAnchorPt )
-                                pure $ ControlPoint cp ( PointData Normal Empty )
+                                    pure ( PointData cp Normal () )
-                            , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
+                                )
-                            ]
+                                ( PointData otherAnchorPt Normal () )
                               newDocument :: Document
                               newDocument = addToAnchor anchor newSegment doc
                               changeText :: Text
@@ -954,21 +959,20 @@ instance HandleAction MouseRelease where
                             else do
                               STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
                               let
-                            newSegment :: Seq ( StrokePoint PointData )
+                                newSegment :: Spline Open CachedStroke ( PointData () )
-                            newSegment
+                                newSegment = catMaybesSpline ( CachedStroke Nothing )
-                              = Seq.fromList
+                                  ( PointData p1 Normal () )
-                              $ catMaybes
+                                  ( do
-                              [ Just ( PathPoint p1 ( PointData Normal Empty ) )
-                              , do
                                       cp <- mbCp2
                                       guard ( cp /= p1 )
-                                  pure $ ControlPoint cp ( PointData Normal Empty )
+                                      pure ( PointData cp Normal () )
-                              , do
+                                  )
+                                  ( do
                                       cp <- mbControlPoint
                                       guard ( cp /= pathPoint )
-                                  pure $ ControlPoint cp ( PointData Normal Empty )
+                                      pure ( PointData cp Normal () )
-                              , Just ( PathPoint pathPoint ( PointData Normal Empty ) )
+                                  )
-                              ]
+                                  ( PointData pathPoint Normal () )
                                 newDocument :: Document
                                 newDocument = addToAnchor anchor newSegment doc
                                 changeText :: Text
@@ -987,7 +991,7 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
 
 instance HandleAction Scroll where
   handleAction
-    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    uiElts@( UIElements { viewport = Viewport {..} } )
     vars@( Variables {..} )
     ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
 
@@ -1051,12 +1055,12 @@ data KeyboardPress = KeyboardPress Word32
 
 instance HandleAction KeyboardPress where
   handleAction
-    uiElts@( UIElements { viewport = Viewport {..}, .. } )
+    uiElts@( UIElements { viewport = Viewport {..} } )
     vars@( Variables {..} )
     ( KeyboardPress keyCode ) = do
 
-      for_ ( modifierKey keyCode ) \ modifier ->
+      for_ ( modifierKey keyCode )
-        STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier )
+        ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
 
       case keyCode of
 
@@ -1096,5 +1100,5 @@ data KeyboardRelease = KeyboardRelease Word32
 
 instance HandleAction KeyboardRelease where
   handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
-    for_ ( modifierKey keyCode ) \ modifier -> do
+    for_ ( modifierKey keyCode )
-      STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )
+      ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.delete )

src/app/MetaBrush/Asset/Brushes.hs

@@ -1,70 +1,108 @@
-{-# LANGUAGE NegativeLiterals    #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
 
-module MetaBrush.Asset.Brushes
+module MetaBrush.Asset.Brushes where
-  ( ellipse, blob, rect )
-  where
 
--- containers
+-- base
-import Data.Sequence
+import Data.Kind
-  ( Seq(..) )
+  ( Type )
-import qualified Data.Sequence as Seq
+import Data.Type.Equality
-  ( fromList )
+  ( (:~:)(Refl) )
+
+-- superrecord
+import qualified SuperRecord
+  ( (:=) )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( unpack )
 
 -- MetaBrush
-import Math.Bezier.Stroke
+import MetaBrush.Document
-  ( StrokePoint(..) )
+  ( Brush(..) )
-import Math.Vector2D
+import MetaBrush.MetaParameter.AST
-  ( Point2D(..) )
+  ( BrushFunction, STypesI(sTypesI), eqTys )
+import MetaBrush.MetaParameter.Driver
+  ( SomeBrushFunction(..), interpretBrush )
+import MetaBrush.Unique
+  ( UniqueSupply )
 
 --------------------------------------------------------------------------------
 
-ellipse :: forall d. Double -> Double -> d -> Seq ( StrokePoint d )
+circle
-ellipse w h d = Seq.fromList
+  :: forall circleBrushFields
-  [ pp ( Point2D   0    1  )
+  .  ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] )
-  , cp ( Point2D   a    1  )
+  => UniqueSupply -> IO ( Brush circleBrushFields )
-  , cp ( Point2D   1    a  )
+circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
-  , pp ( Point2D   1    0  )
-  , cp ( Point2D   1  (-a) )
-  , cp ( Point2D   a  (-1) )
-  , pp ( Point2D   0  (-1) )
-  , cp ( Point2D (-a) (-1) )
-  , cp ( Point2D (-1) (-a) )
-  , pp ( Point2D (-1)   0  )
-  , cp ( Point2D (-1)   a  )
-  , cp ( Point2D (-a)   1  )
-  , pp ( Point2D   0    1  )
-  ]
   where
-    a :: Double
+    name, code :: Text
-    a = 0.551915024494
+    name = "Circle"
-    pp, cp :: Point2D Double -> StrokePoint d
+    code =
-    pp ( Point2D x y ) =    PathPoint ( Point2D ( w * x ) ( h * y ) ) d
+     "with\n\
-    cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d
+     \  r = 1\n\
+     \satisfying\n\
+     \  r > 0\n\
+     \define\n\
+     \  let c = kappa in\n\
+     \  [ (r,0) -- ( r  , r*c) -- ( r*c, r  ) -> ( 0, r)\n\
+     \          -- (-r*c, r  ) -- (-r  , r*c) -> (-r, 0)\n\
+     \          -- (-r  ,-r*c) -- (-r*c,-r  ) -> ( 0,-r)\n\
+     \          -- ( r*c,-r  ) -- ( r  ,-r*c) ->   .   ]"
 
-blob :: forall d. Double -> Double -> d -> Seq ( StrokePoint d )
+rounded
-blob w h d = Seq.fromList
+  :: forall roundedBrushFields
-  [ pp ( Point2D  1  0 )
+  .  ( roundedBrushFields ~ '[ ] ) -- TODO
-  , cp ( Point2D  1 -1 )
+  => UniqueSupply -> IO ( Brush roundedBrushFields )
-  , cp ( Point2D -1 -1 )
+rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
-  , pp ( Point2D -1  0 )
-  , cp ( Point2D -1  1 )
-  , cp ( Point2D  1  1 )
-  , pp ( Point2D  1  0 )
-  ]
   where
-    pp, cp :: Point2D Double -> StrokePoint d
+    name, code :: Text
-    pp ( Point2D x y ) =    PathPoint ( Point2D ( w * x ) ( h * y ) ) d
+    name = "Rounded quadrilateral"
-    cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d
+    code =
+     "with\n\
+     \  tr = (1,-2)\n\
+     \  rt = (2,-1)\n\
+     \  br = (1,2)\n\
+     \  rb = (2,1)\n\
+     \  bl = (-1,2)\n\
+     \  lb = (-2,1)\n\
+     \  tl = (-1,-2)\n\
+     \  lt = (-2,-1)\n\
+     \define\n\
+     \  let c = kappa in\n\
+     \  [ tr -- lerp c tr ( project rt onto [ tl -> tr ] ) -- lerp c rt ( project tr onto [ rb -> rt ] ) -> rt\n\
+     \                                                                                                   -> rb\n\
+     \       -- lerp c rb ( project br onto [ rt -> rb ] ) -- lerp c br ( project rb onto [ bl -> br ] ) -> br\n\
+     \                                                                                                   -> bl\n\
+     \       -- lerp c bl ( project lb onto [ br -> bl ] ) -- lerp c lb ( project bl onto [ lt -> lb ] ) -> lb\n\
+     \                                                                                                   -> lt\n\
+     \       -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\
+     \                                                                                                   -> .]"
 
-rect :: forall d. Double -> Double -> d -> Seq ( StrokePoint d )
+--------------------------------------------------------------------------------
-rect w h d = Seq.fromList
+
-  [ pp ( Point2D  1  1 )
+mkBrush
-  , pp ( Point2D  1 -1 )
+  :: forall ( givenBrushFields :: [ Type ] )
-  , pp ( Point2D -1 -1 )
+  .  STypesI givenBrushFields
-  , pp ( Point2D -1  1 )
+  => UniqueSupply -> Text -> Text
-  , pp ( Point2D  1  1 )
+  -> IO ( Brush  givenBrushFields )
-  ]
+mkBrush uniqSupply brushName brushCode = do
-  where
+  ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
-    pp :: Point2D Double -> StrokePoint d
+  case mbBrush of
-    pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d
+    Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
+    Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) ->
+      case eqTys @givenBrushFields @inferredBrushFields of
+        Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
+        Nothing   ->
+          error
+            ( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\
+              \Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\
+              \  Actual: " <> show ( sTypesI @inferredBrushFields )
+            )

src/app/MetaBrush/Document.hs

@@ -1,82 +1,118 @@
 {-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DeriveTraversable     #-}
+{-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module MetaBrush.Document
   ( AABB(..), mkAABB
   , Document(..), DocumentContent(..)
   , emptyDocument
-  , Stroke(..)
+  , Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline
-  , PointData(..), BrushPointData(..)
+  , PointData(..), BrushPointData(..), DiffPointData(..)
+  , Brush(..), emptyBrush
   , FocusState(..), Hoverable(..), HoverContext(..)
-  , _selection, _brush
   , Guide(..)
+  , _selection, _coords, coords
   , addGuide, selectedGuide
   )
   where
 
 -- base
+import Data.Coerce
+  ( coerce )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.Kind
+  ( Type )
 import Data.Semigroup
   ( Arg(..), Min(..), ArgMin )
 import GHC.Generics
-  ( Generic )
+  ( Generic, Generic1 )
 
 -- acts
 import Data.Act
-  ( Act
+  ( Act(..), Torsor(..) )
-    ( (•) )
-  , Torsor
-    ( (-->) )
-  )
 
 -- containers
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( insert )
+  ( empty, insert )
-import qualified Data.Map.Strict as Map
-  ( empty )
-import Data.Sequence
-  ( Seq )
 
 -- deepseq
 import Control.DeepSeq
-  ( NFData )
+  ( NFData(..), NFData1, deepseq )
 
 -- generic-lens
 import Data.Generics.Product.Fields
   ( field' )
-import Data.Generics.Product.Typed
+
-  ( HasType(typed) )
+-- groups
+import Data.Group
+  ( Group(..) )
 
 -- lens
 import Control.Lens
-  ( Lens' )
+  ( Lens'
+  , set, view, over
+  )
 
 -- stm
 import Control.Concurrent.STM
   ( STM )
 
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( Intersect, rnil )
+
 -- text
 import Data.Text
   ( Text )
+import qualified Data.Text as Text
+  ( unpack )
+
+-- transformers
+import Control.Monad.Trans.Reader
+  ( ReaderT, runReaderT )
 
 -- MetaBrush
+import Math.Bezier.Spline
+  ( Spline(..), KnownSplineType, Curves(..) )
 import Math.Bezier.Stroke
-  ( StrokePoint(..) )
+  ( CachedStroke )
 import Math.Module
-  ( Inner((^.^)), squaredNorm, quadrance )
+  ( Module
+    ( origin, (^+^), (^-^), (*^) )
+  , Inner((^.^))
+  , squaredNorm, quadrance
+  )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
+import {-# SOURCE #-} MetaBrush.Document.Serialise
+  ( Serialisable(..) )
+import MetaBrush.MetaParameter.AST
+  ( STypesI, Adapted, AdaptableFunction(..), BrushFunction )
+import MetaBrush.MetaParameter.Interpolation
+  ( Interpolatable(..) ) -- + orphan instances
 import MetaBrush.UI.Viewport
   ( Ruler(..) )
 import MetaBrush.Unique
@@ -113,7 +149,7 @@ data Document
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
--- | Main content of document (data which we keept track of throughout history).
+-- | Main content of document (data which we kept track of throughout history).
 data DocumentContent
   = Content
   { unsavedChanges :: !Bool
@@ -124,20 +160,90 @@ data DocumentContent
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
-data Stroke
+type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams )
-  = Stroke
+
+data Stroke where
+  Stroke
+    :: ( KnownSplineType clo
+       , pointParams ~ Super.Rec pointFields, STypesI pointFields
+       , brushParams ~ Super.Rec brushFields, STypesI brushFields
+       , usedParams  ~ Super.Rec usedFields , STypesI usedFields
+       , usedFields  ~ ( brushFields `SuperRecord.Intersect` pointFields )
+       , Show brushParams, NFData brushParams
+       , Show pointParams, NFData pointParams
+       , Interpolatable pointParams
+       , Interpolatable usedParams
+       , Serialisable pointParams
+       , Adapted brushFields pointFields usedFields
+       )
+    =>
       { strokeName    :: Text
       , strokeVisible :: !Bool
       , strokeUnique  :: Unique
-  , strokePoints  :: !( Seq ( StrokePoint PointData ) )
+      , strokeBrush   :: Brush brushFields
+      , strokeSpline  :: !( StrokeSpline clo pointParams )
       }
-  deriving stock    ( Show, Generic )
+    -> Stroke
-  deriving anyclass NFData
+deriving stock instance Show Stroke
+instance NFData Stroke where
+  rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } )
+    = deepseq strokeSpline
+    . deepseq strokeUnique
+    . deepseq strokeVisible
+    $ rnf strokeName
 
-data PointData
+_strokeSpline
+  :: forall f
+  .  Functor f
+  => (  forall clo pointParams pointFields
+     .  ( KnownSplineType clo
+        , Show pointParams, NFData pointParams
+        , pointParams ~ Super.Rec pointFields, STypesI pointFields
+        , Interpolatable pointParams
+        , Serialisable pointParams
+        )
+     => StrokeSpline clo pointParams
+     -> f ( StrokeSpline clo pointParams )
+     )
+  -> Stroke -> f Stroke
+_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
+  = ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
+
+overStrokeSpline
+  :: (  forall clo pointParams pointFields
+     .  ( KnownSplineType clo
+        , Show pointParams, NFData pointParams
+        , pointParams ~ Super.Rec pointFields, STypesI pointFields
+        , Interpolatable pointParams
+        , Serialisable pointParams
+        )
+     => StrokeSpline clo pointParams
+     -> StrokeSpline clo pointParams
+     )
+  -> Stroke -> Stroke
+overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
+
+
+data Brush ( brushFields :: [ Type ] )
+  = BrushData
+  { brushName     :: !Text
+  , brushCode     :: !Text
+  , brushFunction :: !( BrushFunction brushFields )
+  }
+
+instance Show ( Brush brushFields ) where
+  show ( BrushData { brushName } ) = Text.unpack brushName
+
+-- Brush parameters using open records.
+emptyBrush :: Brush '[]
+emptyBrush = BrushData "Empty brush" ""
+  ( AdaptableFunction ( const SuperRecord.rnil, const $ Spline ( Point2D 0 0 ) NoCurves ) )
+
+data PointData params
   = PointData
-  { pointState :: FocusState
+  { pointCoords :: !( Point2D Double )
-  , brushShape :: Seq ( StrokePoint BrushPointData )
+  , pointState  :: FocusState
+  , brushParams :: !params
   }
   deriving stock ( Show, Generic )
   deriving anyclass NFData
@@ -164,12 +270,6 @@ instance Semigroup FocusState where
 instance Monoid FocusState where
   mempty = Normal
 
-_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState
-_selection = field' @"pointData" . typed @FocusState
-
-_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
-_brush = field' @"pointData" . field' @"brushShape"
-
 emptyDocument :: Text -> Unique -> Document
 emptyDocument docName unique =
   Document
@@ -218,6 +318,74 @@ instance Hoverable ( Point2D Double ) where
     | otherwise
     = Normal
 
+class HasSelection pt where
+  _selection :: Lens' pt FocusState
+instance HasSelection ( PointData brushParams ) where
+  _selection = field' @"pointState"
+instance HasSelection BrushPointData where
+  _selection = field' @"brushPointState"
+
+_coords :: Lens' ( PointData brushParams ) ( Point2D Double )
+_coords = field' @"pointCoords"
+
+coords :: PointData brushParams -> Point2D Double
+coords = view _coords
+
+data FocusDifference
+  = DifferentFocus
+  | SameFocus
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+
+instance Semigroup FocusDifference where
+  SameFocus <> SameFocus = SameFocus
+  _ <> _ = DifferentFocus
+
+instance Monoid FocusDifference where
+  mempty = SameFocus
+
+instance Group FocusDifference where
+  invert = id
+
+data DiffPointData diffBrushParams
+  = DiffPointData
+  { diffVector :: !( Vector2D Double )
+  , diffParams :: !diffBrushParams
+  , diffState  :: !FocusDifference
+  }
+  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass ( NFData, NFData1 )
+
+instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
+  DiffPointData v1 p1 s1 <> DiffPointData v2 p2 s2 =
+    DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) ( s1 <> s2 )
+instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
+  mempty = DiffPointData mempty origin mempty
+instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
+  invert ( DiffPointData v1 p1 s1 ) =
+    DiffPointData ( invert v1 ) ( (-1) *^ p1 ) ( invert s1 )
+
+instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
+      => Act    ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
+  (•) ( DiffPointData { diffVector = dp, diffParams = db, diffState = focusDiff } )
+    = over _coords ( dp • )
+    . over ( field' @"brushParams" ) ( db • )
+    . ( case focusDiff of { SameFocus -> id; DifferentFocus -> set ( field' @"pointState" ) Normal } )
+instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
+      => Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
+  ( PointData { pointCoords = p1, brushParams = b1, pointState = s1 } ) <-- ( PointData { pointCoords = p2, brushParams = b2, pointState = s2 } ) =
+    DiffPointData
+      { diffVector = p1 <-- p2
+      , diffParams = b1 <-- b2
+      , diffState  = if s1 == s2 then SameFocus else DifferentFocus
+      }
+instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
+  origin = mempty
+  (^+^) = (<>)
+  x ^-^ y = x <> invert y
+  d *^ DiffPointData v1 p1 s1 = DiffPointData ( d *^ v1 ) ( d *^ p1 ) s1
+
+
 --------------------------------------------------------------------------------
 -- Guides.
 
@@ -250,14 +418,14 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
 
 -- | Add new guide after a mouse drag from a ruler area.
 addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
-addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) insertNewGuides
+addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
   where
-    insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
+    insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
     insertNewGuides gs = case ruler of
       RulerCorner
         -> do
-          uniq1 <- freshUnique uniqueSupply
+          uniq1 <- freshUnique
-          uniq2 <- freshUnique uniqueSupply
+          uniq2 <- freshUnique
           let
             guide1, guide2 :: Guide
             guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
@@ -265,14 +433,14 @@ addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" )
           pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
       TopRuler
         -> do
-          uniq1 <- freshUnique uniqueSupply
+          uniq1 <- freshUnique
           let
             guide1 :: Guide
             guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
           pure ( Map.insert uniq1 guide1 gs )
       LeftRuler
         -> do
-          uniq2 <- freshUnique uniqueSupply
+          uniq2 <- freshUnique
           let
             guide2 :: Guide
             guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }

src/app/MetaBrush/Document/Draw.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
 
 module MetaBrush.Document.Draw
@@ -22,12 +24,10 @@ import Data.Act
 -- containers
 import Data.Sequence
   ( Seq(..) )
-import qualified Data.Sequence as Seq
-  ( singleton, reverse, take, drop, length )
 
 -- generic-lens
 import Data.Generics.Product.Fields
-  ( field' )
+  ( field, field' )
 
 -- lens
 import Control.Lens
@@ -37,6 +37,12 @@ import Control.Lens
 import Control.Concurrent.STM 
   ( STM )
 
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( rnil )
+
 -- text
 import Data.Text
   ( Text )
@@ -44,17 +50,27 @@ import Data.Text
 -- transformers
 import Control.Monad.Trans.State.Strict
   ( State, runState, get, put )
+import Control.Monad.Trans.Reader
+  ( runReaderT )
 
 -- MetaBrush
-import Math.Bezier.Stroke
+import Math.Bezier.Spline
-  ( StrokePoint(..) )
+  ( Spline(..), Curves(..)
+  , SplineType(..), SSplineType(..)
+  , SplineTypeI(ssplineType)
+  , reverseSpline, splineEnd
+  , openCurveEnd
+  )
 import Math.Module
   ( squaredNorm )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Document
-  ( Document(..), Stroke(..), FocusState(..), PointData(..)
+  ( Document(..), Stroke(..), StrokeSpline
-  , _selection
+  , FocusState(..), PointData(..)
+  , emptyBrush
+  , _selection, _strokeSpline
+  , coords, overStrokeSpline
   )
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique, uniqueText )
@@ -82,31 +98,51 @@ getOrCreateDrawAnchor
   -> Document
   -> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
 getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
-  case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of
+  case
+      ( `runState` Nothing )
+    $ ( field' @"documentContent" . field' @"strokes" . traverse )
+    updateStroke doc
+  of
     -- Anchor found: use it.
-    ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
+    ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) ->
       pure ( newDoc, anchor, anchorPt, Just anchorName )
     -- No anchor found: start a new stroke (on a new stroke layer).
     ( newDoc, Nothing ) -> do
-      uniq <- freshUnique uniqueSupply
+      uniq <- runReaderT freshUnique uniqueSupply
       let
-        newDoc' :: Document
+        newSpline :: StrokeSpline Open ( Super.Rec '[] )
-        newDoc'
+        newSpline =
-          = over ( field' @"documentContent" . field' @"strokes" )
+          Spline { splineStart  = PointData c Normal ( SuperRecord.rnil )
-              ( Stroke
+                 , splineCurves = OpenCurves Empty
+                 }
+        newStroke :: Stroke
+        newStroke =
+          Stroke
             { strokeName    = "Stroke " <> uniqueText uniq
             , strokeVisible = True
             , strokeUnique  = uniq
-                , strokePoints  = Seq.singleton $ PathPoint c ( PointData Normal Empty )
+            , strokeSpline  = newSpline
+            , strokeBrush   = emptyBrush
             }
-              : )
+        newDoc' :: Document
+        newDoc'
+          = over ( field' @"documentContent" . field' @"strokes" )
+              ( newStroke : )
               newDoc
       pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
   where
     -- Deselect all points, and try to find a valid anchor for drawing
     -- (a path start/end point at mouse click point).
     updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke
-    updateStroke stroke@( Stroke { strokeName, strokeVisible, strokePoints, strokeUnique } ) = do
+    updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
+
+      where
+        updateStrokeSpline
+          :: forall clo brushParams
+          .  SplineTypeI clo
+          => StrokeSpline clo brushParams
+          -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams )
+        updateStrokeSpline spline = do
 
           mbAnchor <- get
           case mbAnchor of
@@ -115,41 +151,61 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
             -- then select it as an anchor for the drawing operation.
             Nothing
               | strokeVisible
-          , Just anchor <- endpointAnchor strokeUnique strokePoints
+              , Just anchor <- endpointAnchor strokeUnique spline
               -> put ( Just ( anchor, strokeName ) )
-                  $> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
+                      $> set ( mapped . _selection ) Normal spline
             -- Otherwise, just deselect.
-        _ -> pure $  set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
+            _ -> pure $  set ( mapped . _selection ) Normal spline
 
+          where
             -- See if we can anchor a drawing operation on a given (visible) stroke.
-    endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )
+            endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, Point2D Double )
-    endpointAnchor _    ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) )
+            endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
-      | p0 == pn
+              SOpen
-      = Nothing 
+                | let
-    endpointAnchor uniq (PathPoint { coords = p0 } :<| _ )
+                    p0 :: Point2D Double
-      | inPointClickRange p0
+                    p0 = coords splineStart
-      = Just ( AnchorAtStart uniq, p0 )
+                , inPointClickRange p0
-    endpointAnchor uniq ( _ :|> PathPoint { coords = pn } )
+                -> Just ( AnchorAtStart uniq, p0 )
-      | inPointClickRange pn
+                | OpenCurves ( _ :|> lastCurve ) <- splineCurves
-      = Just ( AnchorAtEnd   uniq, pn )
+                , let
-    endpointAnchor _ _ = Nothing
+                    pn :: Point2D Double
+                    pn = coords ( openCurveEnd lastCurve )
+                , inPointClickRange pn
+                -> Just ( AnchorAtEnd uniq, pn )
+              _ -> Nothing
             inPointClickRange :: Point2D Double -> Bool
             inPointClickRange p =
               squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
 
-addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document
+addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
-addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
+addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
   where
     addToStroke :: Stroke -> Stroke
-    addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )
+    addToStroke stroke@( Stroke { strokeUnique } )
       | strokeUnique == anchorStrokeUnique anchor
+      = 
+        let
+          updateSpline
+            :: forall clo brushData
+            .  SplineTypeI clo
+            => StrokeSpline clo brushData -> StrokeSpline clo brushData
+          updateSpline prevSpline
+            | SOpen <- ssplineType @clo
             = case anchor of
-        AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts }
+              AnchorAtStart _ ->
-        AnchorAtEnd   _ -> stroke { strokePoints = dropEnd 1 pts <> newPts }
+                let
+                  setBrushData :: PointData () -> PointData brushData
+                  setBrushData =  set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
+                in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
+              AnchorAtEnd   _ -> 
+                let
+                  setBrushData :: PointData () -> PointData brushData
+                  setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
+                in prevSpline <> fmap setBrushData newSpline
+            | otherwise
+            = error "addToAnchor: trying to add to a closed spline"
+        in
+          overStrokeSpline updateSpline stroke
       | otherwise
       = stroke
-    dropEnd :: Int -> Seq a -> Seq a
-    dropEnd i as = Seq.take ( n - i ) as
-      where
-        n :: Int
-        n = Seq.length as

src/app/MetaBrush/Document/History.hs

@@ -1,13 +1,10 @@
 
 {-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveTraversable    #-}
-{-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE DerivingVia          #-}
 {-# LANGUAGE MonoLocalBinds       #-}
 {-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE PolyKinds            #-}
-{-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 

src/app/MetaBrush/Document/Selection.hs

@@ -4,12 +4,12 @@
 {-# LANGUAGE DerivingVia         #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE MagicHash           #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE PatternSynonyms     #-}
-{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE ViewPatterns        #-}
@@ -25,8 +25,6 @@ module MetaBrush.Document.Selection
   where
 
 -- base
-import Control.Category
-  ( (>>>) )
 import Control.Monad
   ( guard )
 import Data.Functor
@@ -63,12 +61,6 @@ import Generic.Data
 -- generic-lens
 import Data.Generics.Product.Fields
   ( field' )
-import Data.Generics.Product.Typed
-  ( HasType )
-
--- groups
-import Data.Group
-  ( invert )
 
 -- lens
 import Control.Lens
@@ -78,9 +70,7 @@ import Control.Lens
 import Control.Monad.Trans.Tardis
   ( Tardis )
 import qualified Control.Monad.Trans.Tardis as Tardis
-  ( TardisT(..)
+  ( runTardisT, getPast, getFuture, sendPast, sendFuture )
-  , getPast, getFuture, sendPast, sendFuture
-  )
 
 -- text
 import Data.Text
@@ -91,34 +81,49 @@ import qualified Data.Text as Text
 -- transformers
 import Control.Monad.Trans.Class
   ( lift )
+import Control.Monad.Trans.Maybe
+  ( MaybeT(..) )
 import Control.Monad.Trans.State.Strict
-  ( StateT(..), State, runState, evalState
+  ( StateT, State
-  , get, put, modify
+  , runState, evalState, evalStateT
+  , get, put, modify'
   )
 import Control.Monad.Trans.Writer.CPS
   ( WriterT, runWriterT, tell )
 
 -- MetaBrush
 import qualified Math.Bezier.Cubic as Cubic
-  ( Bezier(..), closestPoint, fromQuadratic, drag )
+  ( Bezier(..), bezier, closestPoint, fromQuadratic, drag )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..), closestPoint, interpolate )
+import Math.Bezier.Spline
+  ( Spline(..), SplineType(..), SSplineType(..), NextPoint(..)
+  , Curve(..), Curves(..), PointType(..)
+  , splitSplineAt
+  , SplineTypeI(ssplineType)
+  , KnownSplineType
+    ( lastPoint, adjustSplineType, biwitherSpline, ibitraverseSpline, bitraverseSpline )
+  , fromNextPoint
+  )
 import Math.Bezier.Stroke
-  ( StrokePoint(..) )
+  ( CachedStroke(..), discardCache )
 import Math.Module
-  ( squaredNorm, closestPointToSegment )
+  ( lerp, squaredNorm, closestPointOnSegment )
 import Math.Vector2D
-  ( Point2D(..), Vector2D(..) )
+  ( Point2D(..), Vector2D(..), Segment(..) )
 import {-# SOURCE #-} MetaBrush.Context
   ( Modifier(..) )
 import MetaBrush.Document
   ( Document(..), Stroke(..)
+  , PointData(..), DiffPointData
   , FocusState(..), _selection
+  , StrokeSpline, _strokeSpline, overStrokeSpline
+  , _coords, coords
   )
 import {-# SOURCE #-} MetaBrush.Document.Update
   ( DocChange(..) )
-import {-# SOURCE #-} MetaBrush.UI.ToolBar
+import MetaBrush.MetaParameter.Interpolation
-  ( Mode(..) )
+  ( Interpolatable(Diff) )
 import MetaBrush.Unique
   ( Unique )
 
@@ -147,30 +152,25 @@ selectionMode = foldMap \case
   _       -> New
 
 -- | Updates the selected objects on a single click selection event.
-selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document
+selectAt :: SelectionMode -> Point2D Double -> Document -> Document
-selectAt mode selMode c doc@( Document { zoomFactor } ) =
+selectAt selMode c doc@( Document { zoomFactor } ) =
   ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
     where
       updateStroke :: Stroke -> State Bool Stroke
-      updateStroke stroke@( Stroke { strokeVisible } )
+      updateStroke stroke@( Stroke { strokeVisible } ) = _strokeSpline updateSpline stroke
-        | Brush <- mode
+        where
-        = ( field' @"strokePoints" . traverse )
+          updateSpline
-            ( \ spt ->
+            :: forall clo brushParams
-              ( field' @"pointData" . field' @"brushShape" )
+            .  ( KnownSplineType clo )
-                ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
+            => StrokeSpline clo brushParams -> State Bool ( StrokeSpline clo brushParams )
-                >>> fmap matchEndpoints
+          updateSpline oldSpline =
-                )
+            bitraverseSpline
-              spt
+              ( const pure )
-            )
+              ( updateSplinePoint strokeVisible )
-            stroke
+              oldSpline
-        | otherwise
+
-        = ( field' @"strokePoints" )
+          updateSplinePoint :: Bool -> PointData brushParams -> State Bool ( PointData brushParams )
-            ( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) )
+          updateSplinePoint isVisible pt = do
-            >>> fmap matchEndpoints
-            )
-            stroke
-      updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> State Bool ( StrokePoint pt )
-      updatePoint isVisible offset pt = do
             anotherPointHasAlreadyBeenSelected <- get
             if selected && not anotherPointHasAlreadyBeenSelected
             then put True $> case selMode of
@@ -183,13 +183,7 @@ selectAt mode selMode c doc@( Document { zoomFactor } ) =
               selected :: Bool
               selected
                 | not isVisible = False
-            | otherwise     = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
+                | otherwise     = squaredNorm ( c --> coords pt :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-      -- Ensure consistency of selection at endpoints for closed loops.
-      matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
-      matchEndpoints ( p0 :<| ( ps :|> pn ) )
-        | coords p0 == coords pn
-        = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
-      matchEndpoints ps = ps
 
 -- | Type of a drag move selection:
 --
@@ -203,7 +197,6 @@ data DragMoveSelect
     { dragStrokeUnique     :: !Unique
     , dragSegmentIndex     :: !Int
     , dragSegmentParameter :: !Double
-    , dragBrushCenter      :: !( Maybe ( Point2D Double ) )
     }
   deriving stock Show
 
@@ -220,8 +213,8 @@ instance Semigroup DragMoveSelect where
 
 -- | Checks whether a mouse click can initiate a drag move event,
 -- and if so returns an updated document with the selection modified from the start of the drag move.
-dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
+dragMoveSelect :: Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
-dragMoveSelect mode c doc@( Document { zoomFactor } ) =
+dragMoveSelect c doc@( Document { zoomFactor } ) =
   let
     res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document
     res = do
@@ -235,53 +228,31 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
 
   where
     updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
+    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke
-      | Brush <- mode
-      = ( field' @"strokePoints" . traverse )
-          ( \ spt ->
-            ( field' @"pointData" . field' @"brushShape" )
-              ( updateStrokePoints strokeVisible strokeUnique ( coords spt )
-              >>> fmap matchEndpoints
-              )
-            spt
-          )
-          stroke
-      | otherwise
-      = ( field' @"strokePoints" )
-          ( updateStrokePoints strokeVisible strokeUnique ( Point2D 0 0 )
-          >>> fmap matchEndpoints
-          )
-          stroke
-
-    -- Ensure consistency of selection at endpoints for closed loops.
-    matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
-    matchEndpoints ( p0 :<| ( ps :|> pn ) )
-      | coords p0 == coords pn
-      = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
-    matchEndpoints ps = ps
-
-    updateStrokePoints
-      :: forall pt
-      .  ( Show pt, HasType FocusState pt )
-      => Bool
-      -> Unique
-      -> Point2D Double
-      -> Seq ( StrokePoint pt )
-      -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
-    updateStrokePoints _         _    _      Empty            = pure Empty
-    updateStrokePoints isVisible uniq offset ( spt :<| spts ) = go 0 spt spts
       where
-        inSelectionRange :: Point2D Double -> Bool
+        updateSpline
-        inSelectionRange p
+          :: forall clo brushParams
-          | not isVisible = False
+          .  KnownSplineType clo
-          | otherwise     = squaredNorm ( c --> ( MkVector2D offset • p ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
+          => StrokeSpline clo brushParams
-        go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt )
+          -> WriterT ( Maybe DragMoveSelect )
-           -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
+              ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
-        go _ sp0 Empty = ( :<| Empty ) <$> updatePoint sp0
+                ( StrokeSpline clo brushParams )
-        -- Line.
+        updateSpline oldSpline =
-        go i sp0 ( sp1 :<| sps )
+          ibitraverseSpline
-          | PathPoint {} <- sp1
+            ( updateSplineCurve ( splineStart oldSpline ) strokeVisible strokeUnique )
-          = do
+            ( updateSplinePoint strokeVisible )
+            oldSpline
+
+    updateSplineCurve
+      :: forall clo' brushParams
+      .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
+      => PointData brushParams -> Bool -> Unique
+      -> Int -> PointData brushParams -> Curve clo' CachedStroke ( PointData brushParams )
+      -> WriterT ( Maybe DragMoveSelect )
+          ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
+            ( Curve clo' CachedStroke ( PointData brushParams ) )
+    updateSplineCurve start isVisible uniq i sp0 curve = case curve of
+      line@( LineTo sp1 _ ) -> do
         let
           mbCurveDrag :: Maybe DragMoveSelect
           mbCurveDrag = do
@@ -289,82 +260,77 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
               t :: Double
               p :: Point2D Double
               ( t, p )
-                    = closestPointToSegment @( Vector2D Double ) ( invert ( MkVector2D offset ) • c ) ( coords sp0 ) ( coords sp1 )
+                = closestPointOnSegment @( Vector2D Double ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
-                guard ( inSelectionRange p )
+            guard ( inSelectionRange isVisible p )
             pure $
               ClickedOnCurve
                 { dragStrokeUnique     = uniq
                 , dragSegmentIndex     = i
                 , dragSegmentParameter = t
-                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
                 }
         tell mbCurveDrag
-            sp0' <- updatePoint sp0
+        sp1' <- traverse ( updateSplinePoint isVisible ) sp1
-            ( sp0' :<| ) <$> go ( i + 1 ) sp1 sps
+        pure ( line { curveEnd = sp1' } )
-        -- Quadratic Bézier curve.
+      bez2@( Bezier2To sp1 sp2 _ ) -> do
-        go i sp0 ( sp1 :<| sp2 :<| sps )
-          | ControlPoint {} <- sp1
-          , PathPoint    {} <- sp2
-          = do
         let
           mbCurveDrag :: Maybe DragMoveSelect
           mbCurveDrag = do
             let
               bez :: Quadratic.Bezier ( Point2D Double )
-                  bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 )
+              bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
               sq_d :: Double
               t :: Double
               Min ( Arg sq_d (t, _) )
-                    = Quadratic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
+                = Quadratic.closestPoint @( Vector2D Double ) bez c
             guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
             pure $
               ClickedOnCurve
                 { dragStrokeUnique     = uniq
                 , dragSegmentIndex     = i
                 , dragSegmentParameter = t
-                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
                 }
         tell mbCurveDrag
-            sp0' <- updatePoint sp0
+        sp1' <- updateSplinePoint isVisible sp1
-            sp1' <- updatePoint sp1
+        sp2' <- traverse ( updateSplinePoint isVisible ) sp2
-            ( ( sp0' :<| ) . ( sp1' :<| ) ) <$> go ( i + 2 ) sp2 sps
+        pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
-        -- Cubic Bézier curve.
+      bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
-        go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
-          | ControlPoint {} <- sp1
-          , ControlPoint {} <- sp2
-          , PathPoint    {} <- sp3
-          = do
         let
           mbCurveDrag :: Maybe DragMoveSelect
           mbCurveDrag = do
             let
               bez :: Cubic.Bezier ( Point2D Double )
-                  bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
+              bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
               sq_d :: Double
               t :: Double
               Min ( Arg sq_d (t, _) )
-                    = Cubic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
+                = Cubic.closestPoint @( Vector2D Double ) bez c
             guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
             pure $
               ClickedOnCurve
                 { dragStrokeUnique     = uniq
                 , dragSegmentIndex     = i
                 , dragSegmentParameter = t
-                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
                 }
         tell mbCurveDrag
-            sp0' <- updatePoint sp0
+        sp1' <- updateSplinePoint isVisible sp1
-            sp1' <- updatePoint sp1
+        sp2' <- updateSplinePoint isVisible sp2
-            sp2' <- updatePoint sp2
+        sp3' <- traverse ( updateSplinePoint isVisible ) sp3
-            ( ( sp0' :<| ) . ( sp1' :<| ) . ( sp2' :<| ) ) <$> go ( i + 3 ) sp3 sps
+        pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
-        go _ sp0 sps = error ( "dragMoveSelect: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
+
-        updatePoint
+    inSelectionRange :: Bool -> Point2D Double -> Bool
-          :: StrokePoint pt
+    inSelectionRange isVisible p
-          -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( StrokePoint pt )
+      | not isVisible = False
-        updatePoint pt
+      | otherwise     = squaredNorm ( c --> p :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-          | inSelectionRange ( coords pt )
+
+    updateSplinePoint
+      :: Bool -> PointData brushParams
+      -> WriterT ( Maybe DragMoveSelect )
+          ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
+          ( PointData brushParams )
+    updateSplinePoint strokeVisible pt
+      | inSelectionRange strokeVisible ( coords pt )
       = do
-              mbPreviousSelect <- lift $ Tardis.getPast
+          mbPreviousSelect <- lift Tardis.getPast
           case mbPreviousSelect of
             -- Already clicked on a point: don't select further points.
             Just dragSelect
@@ -379,13 +345,13 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
                 mbDrag = case view _selection pt of
                   Selected -> Just ClickedOnSelected
                   _        -> Just ClickedOnUnselected
-                  lift $ Tardis.sendFuture mbDrag
+              lift ( Tardis.sendFuture mbDrag )
               tell mbDrag
               -- Select this point (whether it was previously selected or not).
               pure ( set _selection Selected pt )
       | otherwise
       = do
-            mbDragClick <- lift $ Tardis.getFuture
+        mbDragClick <- lift Tardis.getFuture
         let
           -- needs to be lazy
           newPointState :: FocusState
@@ -401,8 +367,8 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
         pure ( set _selection newPointState pt )
 
 -- | Updates the selected objects on a rectangular selection event.
-selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
+selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
-selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
+selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
   = over ( field' @"documentContent" . field' @"strokes" . mapped )
       updateStroke
     where
@@ -410,21 +376,12 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
       ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
       ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
       updateStroke :: Stroke -> Stroke
-      updateStroke stroke@( Stroke { strokeVisible } )
+      updateStroke stroke@( Stroke { strokeVisible } ) =
-        | Brush <- mode
+          overStrokeSpline
-        = over ( field' @"strokePoints" . mapped )
+            ( fmap ( updateSplinePoint strokeVisible ) )
-            ( \ spt ->
-              over ( field' @"pointData" . field' @"brushShape" . mapped )
-                ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
-              spt
-            )
             stroke
-        | otherwise
+      updateSplinePoint :: Bool -> PointData brushParams -> PointData brushParams
-        = over ( field' @"strokePoints" . mapped )
+      updateSplinePoint isVisible pt
-            ( updatePoint strokeVisible ( Vector2D 0 0 ) )
-            stroke
-      updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> StrokePoint pt
-      updatePoint isVisible offset pt
         | selected  = case selMode of
           Subtract -> set _selection Normal   pt
           _        -> set _selection Selected pt
@@ -433,7 +390,7 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
           _        -> pt
         where
           x, y :: Double
-          Point2D x y = offset • coords pt
+          Point2D x y = coords pt
           selected :: Bool
           selected
             | not isVisible = False
@@ -449,123 +406,237 @@ data UpdateInfo
   deriving ( Semigroup, Monoid )
     via Generically UpdateInfo
 
--- Update the info to record a modification.
---
--- Needs to be lazy in the given Boolean, to avoid time paradoxes.
-recordPointUpdate :: Monad m => Bool -> Unique -> StrokePoint d -> StateT UpdateInfo m ()
-recordPointUpdate doUpdate uniq ( PathPoint {} ) = modify $
-  if doUpdate
-  then
-    ( over ( field' @"pathPointsAffected" ) (<>1)
-    . over ( field' @"strokesAffected" ) ( Set.insert uniq )
-    )
-  else id
-recordPointUpdate doUpdate uniq ( ControlPoint {} ) = modify $
-  if doUpdate
-  then
-  ( over ( field' @"controlPointsAffected" ) (<>1)
-  . over ( field' @"strokesAffected" ) ( Set.insert uniq )
-  )
-  else id
-
 -- | Translate all selected points by the given vector.
 --
--- Returns the updated doucment, together with info about how many points were translated.
+-- Returns the updated document, together with info about how many points were translated.
-translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, UpdateInfo )
+translateSelection :: Vector2D Double -> Document -> ( Document, UpdateInfo )
-translateSelection mode t doc =
+translateSelection t doc =
-  ( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
+  ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-
   where
-    updateStroke :: Stroke -> State UpdateInfo Stroke
+    updateStroke :: Stroke -> StateT Bool ( State UpdateInfo ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
+    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke
+      where
+        updateSpline
+          :: forall clo brushParams
+          .  KnownSplineType clo
+          => StrokeSpline clo brushParams
+          -> StateT Bool ( State UpdateInfo ) ( StrokeSpline clo brushParams )
+        updateSpline oldSpline
           | not strokeVisible
-      = pure stroke
+          = pure oldSpline
-      | Brush <- mode
-      = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse )
-          ( updateStrokePoint strokeUnique )
-          stroke
           | otherwise
-      = ( field' @"strokePoints" . traverse )
+          = bitraverseSpline 
-          ( updateStrokePoint strokeUnique )
+              ( const $ updateSplineCurve ( splineStart oldSpline ) )
-          stroke
+              ( updatePoint PathPoint )
+              oldSpline
+          where
+            updateSplineCurve
+              :: forall clo'
+              .  SplineTypeI clo'
+              => PointData brushParams
+              -> Curve clo' CachedStroke ( PointData brushParams )
+              -> StateT Bool ( State UpdateInfo ) ( Curve clo' CachedStroke ( PointData brushParams ) )
+            updateSplineCurve start crv = do
+              prevMod <- get
+              case crv of
+                LineTo p1 dat -> do
+                  p1' <- traverse ( updatePoint PathPoint ) p1
+                  pure $ LineTo p1' dat'
+                  where
+                    dat' :: CachedStroke
+                    dat'
+                      | prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected )
+                      = discardCache dat
+                      | otherwise
+                      = dat
+                Bezier2To p1 p2 dat -> do
+                  p1' <- updatePoint ControlPoint p1
+                  p2' <- traverse ( updatePoint PathPoint ) p2
+                  pure $ Bezier2To p1' p2' dat'
+                  where
+                    dat' :: CachedStroke
+                    dat'
+                      | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ]
+                      = discardCache dat
+                      | otherwise
+                      = dat
+                Bezier3To p1 p2 p3 dat -> do
+                  p1' <- updatePoint ControlPoint p1
+                  p2' <- updatePoint ControlPoint p2
+                  p3' <- traverse ( updatePoint PathPoint ) p3
+                  pure $ Bezier3To p1' p2' p3' dat'
+                  where
+                    dat' :: CachedStroke
+                    dat'
+                      | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ]
+                      = discardCache dat
+                      | otherwise
+                      = dat
 
-    updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt )
+            updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams )
-    updateStrokePoint uniq pt
+            updatePoint PathPoint pt
               | Selected <- view _selection pt
-      =  recordPointUpdate True uniq pt
+              = do
-      $> pt { coords = t • coords pt }
+                lift . modify' $
+                      ( over ( field' @"pathPointsAffected" ) (<>1)
+                      . over ( field' @"strokesAffected" )    ( Set.insert strokeUnique )
+                      )
+                put True  $> over _coords ( t • ) pt
+              | otherwise
+              = put False $> pt
+            updatePoint ControlPoint pt
+              | Selected <- view _selection pt
+              = do
+                lift . modify' $
+                      ( over ( field' @"controlPointsAffected" ) (<>1)
+                      . over ( field' @"strokesAffected" )       ( Set.insert strokeUnique )
+                      )
+                pure $ over _coords ( t • ) pt
               | otherwise
               = pure pt
 
 -- | Delete the selected points.
 --
 -- Returns the updated document, together with info about how many points were deleted.
-deleteSelected :: Mode -> Document -> ( Document, UpdateInfo )
+deleteSelected :: Document -> ( Document, UpdateInfo )
-deleteSelected mode doc = deletionResult
+deleteSelected doc = deletionResult
   where
 
     deletionResult :: ( Document, UpdateInfo )
     deletionResult
-      = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) . ( `runStateT` mempty )
+      = ( `runState` mempty )
-      $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
+      $ ( field' @"documentContent" . field' @"strokes" )
+          ( fmap catMaybes . traverse updateStroke )
+          doc
 
-    updateStroke :: Stroke -> StateT UpdateInfo ( Tardis Bool Bool ) Stroke
+    updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke )
-    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
+    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke
-      | not strokeVisible
-      = pure stroke
-      | Brush <- mode
-      = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
-          ( updateStrokePoints strokeUnique )
-          stroke
-      | otherwise
-      = ( field' @"strokePoints" )
-          ( updateStrokePoints strokeUnique )
-          stroke
-
-    updateStrokePoints
-      :: forall pt
-      .  HasType FocusState pt
-      => Unique -> Seq ( StrokePoint pt )
-      -> StateT UpdateInfo ( Tardis Bool Bool ) ( Seq ( StrokePoint pt ) )
-    updateStrokePoints _    Empty = pure Empty
-    updateStrokePoints uniq ( p :<| ps ) = case p of
-      PathPoint {}
-        | Selected <- selectionState
-        -> do
-          lift ( Tardis.sendPast   True )
-          lift ( Tardis.sendFuture True )
-          recordPointUpdate True uniq p
-          updateStrokePoints uniq ps
-        | otherwise
-        -> do
-          lift ( Tardis.sendPast   False )
-          lift ( Tardis.sendFuture False )
-          ( p :<| ) <$> updateStrokePoints uniq ps
-      _ -> do
-        prevPathPointDeleted <- lift Tardis.getPast
-        nextPathPointDeleted <- lift Tardis.getFuture
-        rest <- updateStrokePoints uniq ps
-        let
-          -- Control point must be deleted:
-          --  - if it is selected,
-          --  - if the previous path point was deleted,
-          --  - if the next path point is going to be deleted.
-          --
-          -- Need to be lazy in "nextPathPointDeleted" to avoid looping.
-          needsDeletion :: Bool
-          needsDeletion
-            =  selectionState == Selected
-            || prevPathPointDeleted
-            || nextPathPointDeleted
-        recordPointUpdate needsDeletion uniq p
-        pure $ if needsDeletion then rest else ( p :<| rest )
       where
-        selectionState :: FocusState
+        updateSpline
-        selectionState = view _selection p
+          :: forall clo brushParams
+          .  KnownSplineType clo
+          => StrokeSpline clo brushParams 
+          -> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams )
+        updateSpline oldSpline
+          | not strokeVisible
+          = pure oldSpline
+          | otherwise
+          = MaybeT
+          $ biwitherSpline
+              ( updateSplineCurve strokeUnique )
+              ( updateSplinePoint strokeUnique )
+              oldSpline
+            where
+
+              noDat :: CachedStroke
+              noDat = CachedStroke Nothing
+
+              updateSplinePoint
+                :: Unique
+                -> PointData brushParams
+                -> State UpdateInfo
+                      ( Maybe ( PointData brushParams ) )
+              updateSplinePoint uniq pt
+                | Selected <- view _selection pt
+                = do
+                    modify'
+                      ( over ( field' @"pathPointsAffected" ) ( <> 1 )
+                      . over ( field' @"strokesAffected"    ) ( Set.insert uniq )
+                      )
+                    pure Nothing
+                | otherwise
+                = do
+                  pure ( Just pt )
+
+              updateSplineCurve
+                :: forall clo'. SplineTypeI clo'
+                => Unique
+                -> Maybe ( PointData brushParams )
+                -> Curve clo' CachedStroke ( PointData brushParams )
+                -> State UpdateInfo
+                      ( Maybe ( Curve clo' CachedStroke ( PointData brushParams ) ) )
+              updateSplineCurve uniq mbPrevPt crv =
+                case crv of
+                  LineTo p1 _ ->
+                    case ssplineType @clo' of
+                      SOpen
+                        | NextPoint pt <- p1
+                        , Selected <- view _selection pt
+                        -> do
+                            modify'
+                              ( over ( field' @"pathPointsAffected" ) ( <> 1 )
+                              . over ( field' @"strokesAffected"    ) ( Set.insert uniq )
+                              )
+                            pure Nothing
+                      _ ->
+                        case mbPrevPt of
+                          Nothing -> pure ( Just $ LineTo p1 noDat ) -- no need to update "strokesAffected"
+                          Just _  -> pure ( Just crv )
+                  Bezier2To cp1 p2 _ ->
+                    case ssplineType @clo' of
+                      SOpen
+                        | NextPoint pt <- p2
+                        , Selected <- view _selection pt
+                        -> do
+                          modify'
+                            ( over ( field' @"pathPointsAffected"    ) ( <> 1 )
+                            . over ( field' @"controlPointsAffected" ) ( <> 1 )
+                            . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                            )
+                          pure Nothing
+                      _ ->
+                        case mbPrevPt of
+                          Just _ | Normal <- view _selection cp1
+                            -> pure ( Just crv )
+                          _ -> do
+                            modify'
+                              ( over ( field' @"controlPointsAffected" ) ( <> 1 )
+                              . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                              )
+                            pure ( Just $ LineTo p2 noDat )
+                  Bezier3To cp1 cp2 p3 _ ->
+                    case ssplineType @clo' of
+                      SOpen
+                        | NextPoint pt <- p3
+                        , Selected <- view _selection pt
+                        -> do
+                          modify'
+                            ( over ( field' @"pathPointsAffected"    ) ( <> 1 )
+                            . over ( field' @"controlPointsAffected" ) ( <> 2 )
+                            . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                            )
+                          pure Nothing
+                      _ ->
+                        case mbPrevPt of
+                          Just _
+                            | Normal <- view _selection cp1
+                            , Normal <- view _selection cp2
+                            -> pure ( Just crv )
+                            | Normal <- view _selection cp1
+                            -> do
+                              modify'
+                                ( over ( field' @"controlPointsAffected" ) ( <> 1 )
+                                . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                                )
+                              pure ( Just $ Bezier2To cp1 p3 noDat )
+                            | Normal <- view _selection cp2
+                            -> do
+                              modify'
+                                ( over ( field' @"controlPointsAffected" ) ( <> 1 )
+                                . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                                )
+                              pure ( Just $ Bezier2To cp2 p3 noDat )
+                          _ -> do
+                            modify'
+                              ( over ( field' @"controlPointsAffected" ) ( <> 2 )
+                              . over ( field' @"strokesAffected"       ) ( Set.insert uniq )
+                              )
+                            pure ( Just $ LineTo p3 noDat )
+
 
 -- | Perform a drag move action on a document.
-dragUpdate :: Mode -> Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
+dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
-dragUpdate mode p0 p PointDrag _ doc = case updateInfo of
+dragUpdate p0 p PointDrag _ doc = case updateInfo of
   UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
     | null strokesAffected
     -> Nothing
@@ -589,8 +660,8 @@ dragUpdate mode p0 p PointDrag _ doc = case updateInfo of
   where
     newDocument :: Document
     updateInfo :: UpdateInfo
-    ( newDocument, updateInfo ) = translateSelection mode ( p0 --> p ) doc
+    ( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
-dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc
+dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc
   | Just name <- mbStrokeName
   , let
       changeText :: Text
@@ -602,124 +673,93 @@ dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc
     newDocument :: Document
     mbStrokeName :: Maybe Text
     ( newDocument, mbStrokeName )
-      = ( `runState` Nothing )
+      = ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-      $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
     updateStroke :: Stroke -> State ( Maybe Text ) Stroke
     updateStroke stroke@( Stroke { strokeUnique, strokeName } )
       | strokeUnique /= dragStrokeUnique
       = pure stroke
-      | Brush <- mode
-      = ( field' @"strokePoints" . traverse )
-          ( \ spt ->
-            if dragBrushCenter /= Just ( coords spt )
-            then -- only update the correct brush path
-              pure spt
-            else
-              ( field' @"pointData" . field' @"brushShape" )
-                ( updateStrokePoints strokeName ( MkVector2D $ coords spt ) )
-              spt
-          )
-          stroke
       | otherwise
-      = ( field' @"strokePoints" )
+      = _strokeSpline updateSpline stroke
-          ( updateStrokePoints strokeName ( Vector2D 0 0 ) )
-          stroke
-    updateStrokePoints
-      :: forall pt. Show pt
-      => Text -> Vector2D Double
-      -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
-    updateStrokePoints _    _      Empty            = pure Empty
-    updateStrokePoints name offset ( spt :<| spts ) = go 0 spt spts
       where
-        p_eff :: Point2D Double
+        updateSpline
-        p_eff = invert offset • p
+          :: forall clo pointParams
-        go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
+          .  ( KnownSplineType clo, Interpolatable pointParams )
-        go _ sp0 Empty = pure ( sp0 :<| Empty )
+          => StrokeSpline clo pointParams
-        -- Line.
+          -> State ( Maybe Text ) ( StrokeSpline clo pointParams )
-        go i sp0 ( sp1 :<| sps )
+        updateSpline
-          | PathPoint {} <- sp1
+          = fmap ( adjustSplineType @clo )
-          = case compare i dragSegmentIndex of
+          . updateSplineCurves strokeName
-              GT -> pure ( sp0 :<| sp1 :<| sps )
+          . adjustSplineType @Open
-              LT -> ( sp0 :<| ) <$> go ( i + 1 ) sp1 sps
+
-              EQ -> do
+          where
+
+            updateSplineCurves
+              :: Text
+              -> StrokeSpline Open pointParams
+              -> State ( Maybe Text ) ( StrokeSpline Open pointParams)
+            updateSplineCurves name spline = case splitSplineAt dragSegmentIndex spline of
+              ( _  , Spline { splineCurves = OpenCurves Empty } ) -> pure spline
+              ( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do
                 put ( Just name )
+                pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ updateCurve ( lastPoint bef ) curve :<| next } )
+            
+              where
+                updateCurve
+                  :: PointData pointParams
+                  -> Curve Open CachedStroke ( PointData pointParams )
+                  -> Curve Open CachedStroke ( PointData pointParams )
+                updateCurve sp0 curve = case curve of
+                  LineTo ( NextPoint sp1 ) dat -> do
+                    let
+                      bez2 :: Quadratic.Bezier ( PointData pointParams )
+                      bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( Diff pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1
                     if alternateMode
-                then
+                    then quadraticDragCurve dat bez2
+                    else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2 )
+                  Bezier2To sp1 ( NextPoint sp2 ) dat -> do
                     let
-                    p1 :: Point2D Double
+                      bez2 :: Quadratic.Bezier ( PointData pointParams )
-                    Quadratic.Bezier { p1 } =
+                      bez2 = Quadratic.Bezier sp0 sp1 sp2
-                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp1 ) dragSegmentParameter p_eff
-                    cp :: StrokePoint pt
-                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
-                  in pure ( sp0 :<| cp :<| sp1 :<| sps )
-                else
-                  let
-                    bez :: Cubic.Bezier ( Point2D Double )
-                    bez = Cubic.Bezier ( coords sp0 ) ( coords sp0 ) ( coords sp1 ) ( coords sp1 )
-                    p1, p2 :: Point2D Double
-                    Cubic.Bezier { p1, p2 } =
-                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
-                    cp1, cp2 :: StrokePoint pt
-                    cp1 = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
-                    cp2 = ControlPoint { coords = p2, pointData = pointData sp1 } -- TODO: interpolate
-                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp1 :<| sps )
-        -- Quadratic Bézier curve.
-        go i sp0 ( sp1 :<| sp2 :<| sps )
-          | ControlPoint {} <- sp1
-          , PathPoint    {} <- sp2
-          = case compare i dragSegmentIndex of
-              GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sps )
-              LT -> ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go ( i + 2 ) sp2 sps
-              EQ -> do
-                put ( Just name )
-                if not alternateMode -- switch alternate mode for quadratic Bézier case...
-                then
-                  let
-                    p1 :: Point2D Double
-                    Quadratic.Bezier { p1 } =
-                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p_eff
-                    cp :: StrokePoint pt
-                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
-                  in pure ( sp0 :<| cp :<| sp2 :<| sps )
-                else
-                  let
-                    bez :: Cubic.Bezier ( Point2D Double )
-                    bez = Cubic.fromQuadratic @( Vector2D Double ) ( Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) )
-                    p1, p2 :: Point2D Double
-                    Cubic.Bezier { p1, p2 } =
-                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
-                    cp1, cp2 :: StrokePoint pt
-                    cp1 = sp1 { coords = p1 } -- TODO: interpolate
-                    cp2 = sp1 { coords = p2 } -- TODO: interpolate
-                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp2 :<| sps )
-        -- Cubic Bézier curve.
-        go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
-          | ControlPoint {} <- sp1
-          , ControlPoint {} <- sp2
-          , PathPoint    {} <- sp3
-          = case compare i dragSegmentIndex of
-              GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| sps )
-              LT -> ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go ( i + 3 ) sp3 sps
-              EQ -> do
-                put ( Just name )
                     if alternateMode
-                then
+                    then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2
+                    else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 )
+                  Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do
                     let
-                    p1 :: Point2D Double
+                      bez3 :: Cubic.Bezier ( PointData pointParams )
-                    Quadratic.Bezier { p1 } =
+                      bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
-                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp3 ) dragSegmentParameter p_eff
+                    if alternateMode
-                    cp :: StrokePoint pt
+                    then quadraticDragCurve dat
-                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
+                          ( Quadratic.Bezier
-                  in pure ( sp0 :<| cp :<| sp3 :<| sps )
+                            sp0
-                else
+                            ( Cubic.bezier @( DiffPointData ( Diff pointParams ) ) bez3 dragSegmentParameter )
+                            sp3
+                          )
+                    else cubicDragCurve dat bez3
+                  where
+                    quadraticDragCurve
+                      :: CachedStroke
+                      -> Quadratic.Bezier ( PointData pointParams )
+                      -> Curve Open CachedStroke ( PointData pointParams )
+                    quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
                       let
-                    bez :: Cubic.Bezier ( Point2D Double )
+                        cp :: Point2D Double
-                    bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
+                        Quadratic.Bezier { Quadratic.p1 = cp } =
-                    p1, p2 :: Point2D Double
+                          Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
-                    Cubic.Bezier { p1, p2 } =
+                        dat' :: CachedStroke
-                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
+                        dat' = discardCache dat
-                    cp1, cp2 :: StrokePoint pt
+                      in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) dat'
-                    cp1 = sp1 { coords = p1 } -- TODO: interpolate
+                    cubicDragCurve
-                    cp2 = sp2 { coords = p2 } -- TODO: interpolate
+                      :: CachedStroke
-                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp3 :<| sps )
+                      -> Cubic.Bezier ( PointData pointParams )
-        go _ sp0 sps = error ( "dragUpdate: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
+                      -> Curve Open CachedStroke ( PointData pointParams )
+                    cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
+                      let
+                        cp1, cp2 :: Point2D Double
+                        Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } =
+                          Cubic.drag @( Vector2D Double )
+                            ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
+                            dragSegmentParameter
+                            p
+                        dat' :: CachedStroke
+                        dat' = discardCache dat
+                      in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) dat'

src/app/MetaBrush/Document/Serialise.hs

@@ -1,12 +1,26 @@
+{-# LANGUAGE AllowAmbiguousTypes  #-}
 {-# LANGUAGE BlockArguments       #-}
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE MagicHash            #-}
 {-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
 
 module MetaBrush.Document.Serialise
-  ( documentToJSON, documentFromJSON
+  ( Serialisable(..)
+  , documentToJSON, documentFromJSON
   , saveDocument, loadDocument
   )
   where
@@ -24,6 +38,24 @@ import Data.Functor.Contravariant
   ( contramap )
 import Data.Functor.Identity
   ( Identity(..) )
+import Data.Kind
+  ( Type )
+import Data.List
+  ( sortBy )
+import Data.Ord
+  ( comparing )
+import Data.Proxy
+  ( Proxy(Proxy) )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+import Data.Typeable
+  ( Typeable, eqT )
+import GHC.Exts
+  ( Proxy#, proxy# )
+import GHC.TypeLits
+  ( symbolVal', KnownSymbol, SomeSymbol(..), someSymbolVal, sameSymbol )
+import GHC.TypeNats
+  ( KnownNat )
 import Unsafe.Coerce
   ( unsafeCoerce ) -- Tony Morris special
 
@@ -51,6 +83,10 @@ import Data.Sequence
 import qualified Data.Sequence as Seq
   ( fromList )
 
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
 -- directory
 import System.Directory
   ( canonicalizePath, createDirectoryIfMissing, doesFileExist )
@@ -63,10 +99,18 @@ import System.FilePath
 import Data.Generics.Product.Typed
   ( HasType(typed) )
 
+-- groups
+import Data.Group
+  ( Group )
+
 -- lens
 import Control.Lens
   ( view )
 
+-- mtl
+import Control.Monad.Except
+  ( MonadError(throwError) )
+
 -- scientific
 import qualified Data.Scientific as Scientific
   ( fromFloatDigits, toRealFloat )
@@ -75,13 +119,29 @@ import qualified Data.Scientific as Scientific
 import qualified Control.Concurrent.STM as STM
   ( atomically )
 
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( Has, RecTy, (:=), FldProxy(..)
+  , RecSize, RecApply(..), RecVecIdxPos, UnsafeRecBuild(..)
+  , TraversalCHelper, RemoveAccessTo, Intersect
+  , reflectRec
+  )
+import SuperRecord
+  ( ConstC, Tuple22C )
+
 -- text
 import Data.Text
   ( Text )
+import qualified Data.Text as Text
+  ( pack, unpack, unwords )
 
 -- transformers
 import Control.Monad.IO.Class
   ( MonadIO(liftIO) )
+import Control.Monad.Trans.Reader
+  ( runReaderT )
 import Control.Monad.Trans.Class
   ( MonadTrans(lift) )
 
@@ -91,14 +151,14 @@ import qualified Waargonaut.Attoparsec as JSON.Decoder
 import qualified Waargonaut.Decode as JSON
   ( Decoder )
 import qualified Waargonaut.Decode.Error as JSON
-  ( DecodeError )
+  ( DecodeError(ParseFailed) )
 import qualified Waargonaut.Decode as JSON.Decoder
-  ( atKey, bool, list, oneOf, scientific, text )
+  ( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text )
 import qualified Waargonaut.Encode as JSON
-  ( Encoder, Encoder' )
+  ( Encoder )
 import qualified Waargonaut.Encode as JSON.Encoder
-  ( runEncoder
+  ( runEncoder, runPureEncoder
-  , atKey', bool, list, mapLikeObj, scientific, text
+  , atKey', bool, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
   )
 import qualified Waargonaut.Encode.Builder as JSON.Builder
   ( waargonautBuilder, bsBuilder )
@@ -112,20 +172,40 @@ import qualified Waargonaut.Prettier as JSON
   ( prettyJson )
 import qualified Waargonaut.Prettier as TonyMorris
   ( Natural )
+import Waargonaut.Types.Json
+  ( Json )
 
 -- MetaBrush
-import Math.Bezier.Stroke
+import qualified Math.Bezier.Cubic as Cubic
-  ( StrokePoint(..) )
+  ( Bezier )
-import Math.Vector2D
+import qualified Math.Bezier.Quadratic as Quadratic
-  ( Point2D(..), Vector2D(..) )
+  ( Bezier )
-import MetaBrush.Document
+import Math.Bezier.Spline
-  ( Document(..), DocumentContent(..)
+  ( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..)
-  , Guide(..)
+  , Curves(..), Curve(..), NextPoint(..)
-  , Stroke(..)
-  , PointData(..)
-  , BrushPointData(..)
-  , FocusState(..)
   )
+import Math.Bezier.Stroke
+  ( CachedStroke(..) )
+import Math.Module
+  ( Module )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..), Segment )
+import MetaBrush.Document
+  ( Document(..), DocumentContent(..), Guide(..)
+  , Stroke(..), StrokeSpline
+  , PointData(..), Brush(..) , FocusState(..)
+  )
+import MetaBrush.MetaParameter.AST
+  ( SType(..), STypeI(..), STypes(..), STypesI(..)
+  , SomeSType(..), someSTypes
+  , Adapted, AdaptableFunction(..), BrushFunction
+  , MapFields, UniqueField, UseFieldsInBrush
+  , eqTy, eqTys
+  )
+import MetaBrush.MetaParameter.Driver
+  ( SomeBrushFunction(..), interpretBrush )
+import MetaBrush.MetaParameter.Interpolation
+  ( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
 import MetaBrush.Unique
   ( Unique, UniqueSupply, freshUnique )
 
@@ -176,31 +256,53 @@ loadDocument uniqueSupply fp = do
 
 --------------------------------------------------------------------------------
 
-encodeDouble :: Applicative f => JSON.Encoder f Double
+class Serialisable a where
-encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
+  encoder :: Monad f => JSON.Encoder f a
+  decoder :: Monad m => JSON.Decoder m a
 
-decodeDouble :: Monad m => JSON.Decoder m Double
+instance Serialisable Double where
-decodeDouble = fmap      Scientific.toRealFloat     JSON.Decoder.scientific
+  encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
+  decoder = fmap      Scientific.toRealFloat     JSON.Decoder.scientific
 
+instance Serialisable a => Serialisable ( Point2D a ) where
+  encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
+      JSON.Encoder.atKey' "x" encoder x
+    . JSON.Encoder.atKey' "y" encoder y
+  decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
 
+instance Serialisable a => Serialisable ( Vector2D a ) where
+  encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
+      JSON.Encoder.atKey' "x" encoder x
+    . JSON.Encoder.atKey' "y" encoder y
+  decoder =  Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
 
-encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a )
+instance ( SuperRecord.RecApply       flds flds ( ConstC Serialisable )
-encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
+         , SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
-  JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y
+         , KnownNat ( SuperRecord.RecSize flds )
+         )
+      => Serialisable ( Super.Rec flds ) where
+  encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds )
+  encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
+    where
+      keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json )
+      keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v )
 
-decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a )
+  decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
-decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
+  decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
-
+    where
-
+      decodeAndWrite
-
+        :: forall k v
-encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
+        .  ( KnownSymbol k, Serialisable v )
-encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
+        => SuperRecord.FldProxy k -> Proxy# v
-    JSON.Encoder.atKey' "x" enc x
+        -> JSON.Decoder m v
-  . JSON.Encoder.atKey' "y" enc y
+      decodeAndWrite _ _ = do
-
+        let
-decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
+          k :: Text
-decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
+          k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
+        val <- JSON.Decoder.atKey k ( decoder @v @m )
+        pure val
 
+--------------------------------------------------------------------------------
 
 {-
 encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
@@ -238,30 +340,115 @@ decodeAABB = do
 -}
 
 
-encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
+encodeCurve
-encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case
+  :: forall clo crvData ptData f
-  PathPoint { coords, pointData } ->
+  .  ( SplineTypeI clo, Applicative f )
-      JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
+  => JSON.Encoder Identity ptData
-    . JSON.Encoder.atKey' "data"   enc                            pointData
+  -> JSON.Encoder f ( Curve clo crvData ptData )
-    . JSON.Encoder.atKey' "type"   JSON.Encoder.text              "path"
+encodeCurve  encodePtData = case ssplineType @clo of
-  ControlPoint { coords, pointData } ->
+  SOpen   -> JSON.Encoder.mapLikeObj \case
-      JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
+    LineTo          ( NextPoint p1 ) _ ->
-    . JSON.Encoder.atKey' "data"   enc                            pointData
+        JSON.Encoder.atKey' "p1"     encodePtData p1
-    . JSON.Encoder.atKey' "type"   JSON.Encoder.text              "control"
+    Bezier2To    p1 ( NextPoint p2 ) _ ->
+        JSON.Encoder.atKey' "p1"     encodePtData p1
+      . JSON.Encoder.atKey' "p2"     encodePtData p2
+    Bezier3To p1 p2 ( NextPoint p3 ) _ ->
+        JSON.Encoder.atKey' "p1"     encodePtData p1
+      . JSON.Encoder.atKey' "p2"     encodePtData p2
+      . JSON.Encoder.atKey' "p3"     encodePtData p3
+  SClosed -> JSON.Encoder.mapLikeObj \case
+    LineTo          BackToStart _ -> id
+    Bezier2To    p1 BackToStart _ ->
+        JSON.Encoder.atKey' "p1"     encodePtData p1
+    Bezier3To p1 p2 BackToStart _ ->
+        JSON.Encoder.atKey' "p1"     encodePtData p1
+      . JSON.Encoder.atKey' "p2"     encodePtData p2
 
-decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool
+decodeCurve
-decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type"
+  :: forall clo ptData m
-  [ ( "path", True ), ( "control", False ) ]
+  .  ( SplineTypeI clo, Monad m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Curve clo CachedStroke ptData )
+decodeCurve decodePtData = case ssplineType @clo of
+  SOpen   -> do
+    p1    <- JSON.Decoder.atKey         "p1" decodePtData
+    mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
+    case mb_p2 of
+      Nothing ->
+        pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) )
+      Just p2 -> do
+        mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
+        case mb_p3 of
+          Nothing -> pure ( Bezier2To    p1 ( NextPoint p2 ) ( CachedStroke Nothing ) )
+          Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) )
+  SClosed -> do
+    mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
+    case mb_p1 of
+      Nothing ->
+        pure ( LineTo BackToStart ( CachedStroke Nothing ) )
+      Just p1 -> do
+        mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
+        case mb_p2 of
+          Nothing -> pure ( Bezier2To    p1 BackToStart ( CachedStroke Nothing ) )
+          Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) )
 
-decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d )
-decodeStrokePoint dec = do
-  coords      <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble )
-  pointData   <- JSON.Decoder.atKey "data"   dec
-  isPathPoint <- JSON.Decoder.atKey "type"   decodeStrokePointTypeIsPath
-  if isPathPoint
-  then pure (    PathPoint { coords, pointData } )
-  else pure ( ControlPoint { coords, pointData } )
 
+
+encodeCurves
+  :: forall clo crvData ptData f
+  .  ( SplineTypeI clo, Applicative f )
+  => JSON.Encoder Identity ptData
+  -> JSON.Encoder f ( Curves clo crvData ptData )
+encodeCurves encodePtData = case ssplineType @clo of
+  SOpen   -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
+  SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
+    where
+      encodeL :: JSON.Encoder f ()
+      encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
+      encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
+      encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
+          JSON.Encoder.atKey' "prevOpenCurves"  ( encodeSequence $ encodeCurve @Open   encodePtData ) openCurves
+        . JSON.Encoder.atKey' "lastClosedCurve"                  ( encodeCurve @Closed encodePtData ) closedCurve
+
+decodeCurves
+  :: forall clo ptData m
+  .  ( SplineTypeI clo, Monad m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Curves clo CachedStroke ptData )
+decodeCurves decodePtData = case ssplineType @clo of
+  SOpen   -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
+  SClosed -> do
+    mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
+    case mbNoCurves of
+      Just _ -> pure NoCurves
+      Nothing -> do
+        prevCurves <- JSON.Decoder.atKey "prevOpenCurves"  ( decodeSequence $ decodeCurve @Open   decodePtData )
+        lastCurve  <- JSON.Decoder.atKey "lastClosedCurve"                  ( decodeCurve @Closed decodePtData )
+        pure ( ClosedCurves prevCurves lastCurve )
+
+
+
+encodeSpline
+  :: forall clo crvData ptData f
+  .  ( SplineTypeI clo, Applicative f )
+  => JSON.Encoder Identity ptData
+  -> JSON.Encoder f ( Spline clo crvData ptData )
+encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
+    JSON.Encoder.atKey' "splineStart"  encodePtData                       splineStart
+  . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
+
+decodeSpline
+  :: forall clo ptData m
+  .  ( SplineTypeI clo, Monad m )
+  => JSON.Decoder m ptData
+  -> JSON.Decoder m ( Spline clo CachedStroke ptData )
+decodeSpline decodePtData = do
+  splineStart  <- JSON.Decoder.atKey "splineStart"  decodePtData
+  splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
+  pure ( Spline { splineStart, splineCurves } )
+
+
+{-
 encodeFocusState :: Applicative f => JSON.Encoder f FocusState
 encodeFocusState = contramap focusText JSON.Encoder.text
   where
@@ -287,7 +474,7 @@ decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
 decodeBrushPointData = do
   brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
   pure ( BrushPointData { brushPointState } )
-
+-}
 
 
 encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
@@ -306,50 +493,269 @@ decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.
 
 
 
-encodePointData :: Applicative f => JSON.Encoder f PointData
+encodePointData
-encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
+  :: forall f flds brushParams
-    JSON.Encoder.atKey' "focus" encodeFocusState pointState
+  . ( Applicative f
-  . JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape
+    , brushParams ~ Super.Rec flds
+    , Serialisable ( Super.Rec flds )
+    )
+  => JSON.Encoder f ( PointData brushParams )
+encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
+    JSON.Encoder.atKey' "coords"      ( encoder @( Point2D Double ) ) pointCoords
+  . JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams
 
-decodePointData :: Monad m => JSON.Decoder m PointData
+decodePointData
+  :: forall m flds brushParams
+  . ( Monad m
+    , brushParams ~ Super.Rec flds
+    , Serialisable ( Super.Rec flds )
+    )
+  => JSON.Decoder m ( PointData brushParams )
 decodePointData = do
-  pointState <- JSON.Decoder.atKey "focus" decodeFocusState
+  pointCoords <- JSON.Decoder.atKey "coords"      ( decoder @( Point2D Double ) )
-  brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) )
+  let
-  pure ( PointData { pointState, brushShape } )
+    pointState :: FocusState
+    pointState = Normal
+  brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) )
+  pure ( PointData { pointCoords, pointState, brushParams } )
 
 
 
-encodeStroke :: Applicative f => JSON.Encoder f Stroke
+encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
-encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) ->
+encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
+  case sTypeI @ty of
+    sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
+       . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
+       . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) )
+    STyBool
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool"
+    STyDouble
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
+    sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point"
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+    sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+    sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2"
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+    sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
+       . JSON.Encoder.atKey' "coords" encodeSomeSType  ( SomeSType ( proxy# :: Proxy# a ) )
+    sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline"
+       . JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } )
+    sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord
+      -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun"
+       . JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs )
+       . JSON.Encoder.atKey' "res"    encodeSomeSType  ( SomeSType ( proxy# :: Proxy# res ) )
+{-
+decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
+decodeSomeSType = do
+  tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
+  case tag of
+    "fun"    -> do
+      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType
+      ( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) )
+    "bool"   -> pure ( SomeSType ( proxy# :: Proxy# Bool ) )
+    "double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) )
+    "point"  -> do
+      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) )
+    "line"   -> do
+      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) )
+    "bez2"   -> do
+      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) )
+    "bez3"   -> do
+      ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) )
+    "spline" -> do
+      closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
+      case closed of
+        True  -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) )
+        False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open   ) ) )
+    "adaptableFun" -> do
+      ( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
+      ( SomeSType       ( _ :: Proxy# a   ) ) <- JSON.Decoder.atKey "res"    decodeSomeSType
+      pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) )
+-}
+decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
+decodeSomeFieldSType = do
+  tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
+  case tag of
+    "double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) )
+    "point"  -> do
+      ( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
+      case eqT @a @Double of
+        Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+        Nothing   -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" )
+    _ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
+
+
+encodeFieldTypes :: Monad f => JSON.Encoder f ( [ ( Text, SomeSType ) ] )
+encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
+
+decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields
+decodeFieldTypes = do
+  fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType
+  let
+    sortedFields :: [ ( Text, SomeFieldSType ) ]
+    sortedFields = sortBy ( comparing fst ) fields
+    duplicates :: [ Text ]
+    duplicates = duplicatesAcc [] [] sortedFields
+    duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, SomeFieldSType ) ] -> [ Text ]
+    duplicatesAcc _    dups [] = dups
+    duplicatesAcc seen dups ( ( k, _ ) : kvs )
+      | k `elem` seen
+      = duplicatesAcc seen ( k : dups ) kvs
+      | otherwise
+      = duplicatesAcc ( k : seen ) dups kvs
+  case duplicates of
+    []    -> pure ( mkBrushFields sortedFields )
+    [dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" )
+    dups  -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
+  
+  where
+
+    mkBrushFields :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
+    mkBrushFields = fromSomeBrushFieldsList . mkBrushFieldsList
+
+    mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList
+    mkBrushFieldsList [] = SomeBrushFieldsList NilFields
+    mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs )
+      | SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs
+      , SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k )
+      -- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs
+      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs )
+      -- compute indexing into record list (with SuperRecord, the index is the number of fields remaining)
+      , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs )
+      = SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list )
+
+    fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields
+    fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of
+      SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) ->
+        SomeBrushFields ( proxy# :: Proxy# kvs )
+      where
+        go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] )
+           .  ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) )
+           => BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts
+        go NilFields =
+          SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] )
+        go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' )
+          | ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs'
+          -- Assert some facts that result from the field names being distinct:
+          --   - current field name does not re-occur later on
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' )
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' )
+          --   - looking up the type associated with the current field name returns the current type
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a )
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) )
+          --   - MapDiff preserves length
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' )
+          --   - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right)
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' )
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' )
+          = SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) )
+
+
+
+encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushParams )
+encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) ->
+    JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
+  . JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
+
+decodeBrush
+  :: forall m flds. ( MonadIO m, STypesI flds )
+  => UniqueSupply
+  -> JSON.Decoder m ( Brush flds )
+decodeBrush uniqSupply = do
+  brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
+  brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
+  ( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode )
+  case mbBrush of
+    Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
+    Right ( SomeBrushFunction ( brushFunction :: BrushFunction brushParams ) ) ->
+      case eqTys @flds @brushParams of
+        Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
+        Nothing   ->
+          throwError
+            ( JSON.ParseFailed $
+                "Brush has unexpected input record type:\n\
+                \Expected: " <> Text.pack ( show ( sTypesI @flds ) ) <> "\n\
+                \  Actual: " <> Text.pack ( show ( sTypesI @brushParams ) )
+            )
+  
+
+
+encodeStroke :: Monad f => JSON.Encoder f Stroke
+encodeStroke = JSON.Encoder.mapLikeObj 
+  \ ( Stroke
+      { strokeName
+      , strokeVisible
+      , strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
+      , strokeBrush  = strokeBrush  :: Brush brushFields
+      }
+    ) ->
+    let
+      closed :: Bool
+      closed = case ssplineType @clo of
+        SClosed -> True
+        SOpen   -> False
+    in
       JSON.Encoder.atKey' "name"        JSON.Encoder.text                strokeName
     . JSON.Encoder.atKey' "visible"     JSON.Encoder.bool                strokeVisible
-  . JSON.Encoder.atKey' "points"  ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints
+    . JSON.Encoder.atKey' "closed"      JSON.Encoder.bool                closed
+    . JSON.Encoder.atKey' "brushFields" encodeFieldTypes                 ( someSTypes @brushFields )
+    . JSON.Encoder.atKey' "pointFields" encodeFieldTypes                 ( someSTypes @pointFields )
+    . JSON.Encoder.atKey' "usedFields"  encodeFieldTypes                 ( someSTypes @( brushFields `SuperRecord.Intersect` pointFields ) )
+    . JSON.Encoder.atKey' "brush"       encodeBrush                      strokeBrush
+    . JSON.Encoder.atKey' "spline"      ( encodeSpline encodePointData ) strokeSpline
 
-decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
+
+
+decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
 decodeStroke uniqueSupply = do
   strokeName    <- JSON.Decoder.atKey "name"    JSON.Decoder.text
   strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
-  strokeUnique  <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
+  strokeUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
-  strokePoints  <- JSON.Decoder.atKey "points"  ( decodeSequence ( decodeStrokePoint decodePointData ) )
+  strokeClosed  <- JSON.Decoder.atKey "closed"  JSON.Decoder.bool
-  pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } )
+  SomeBrushFields ( _ :: Proxy# brushFields ) <- JSON.Decoder.atKey "brushFields" decodeFieldTypes
-
+  SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
-
+  SomeBrushFields ( _ :: Proxy# usedFields  ) <- JSON.Decoder.atKey "usedFields"  decodeFieldTypes
+  strokeBrush   <- JSON.Decoder.atKey "brush"   ( decodeBrush @m @brushFields uniqueSupply )
+  case proveAdapted @brushFields @pointFields @usedFields of
+    Nothing -> throwError ( JSON.ParseFailed "Stroke: 'usedFields' is not equal to 'brushFields `Intersect` pointFields'" )
+    Just Dict ->
+      case strokeClosed of
+        True -> do
+          strokeSpline  <- JSON.Decoder.atKey "spline"  ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
+          pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
+        False -> do
+          strokeSpline  <- JSON.Decoder.atKey "spline"  ( decodeSpline @Open   @( PointData ( Super.Rec pointFields ) ) decodePointData )
+          pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
 
 encodeGuide :: Applicative f => JSON.Encoder f Guide
-encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) ->
+encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
-    JSON.Encoder.atKey' "point"  ( encodePoint2D  encodeDouble ) guidePoint
+    JSON.Encoder.atKey' "point"  ( encoder @( Point2D  Double ) ) guidePoint
-  . JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
+  . JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal
-  . JSON.Encoder.atKey' "focus"  encodeFocusState guideFocus
 
 decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
 decodeGuide uniqueSupply = do
-  guidePoint  <- JSON.Decoder.atKey "point"  ( decodePoint2D  decodeDouble )
+  guidePoint  <- JSON.Decoder.atKey "point"  ( decoder @( Point2D  Double ) )
-  guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble )
+  guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) )
-  guideFocus  <- JSON.Decoder.atKey "focus" decodeFocusState
+  let
-  guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
+    guideFocus :: FocusState
+    guideFocus = Normal
+  guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
 
 
+
 encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
 encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
     JSON.Encoder.atKey' "guides"  ( encodeUniqueMap encodeGuide )    guides
@@ -371,15 +777,187 @@ decodeDocumentContent uniqueSupply = do
 encodeDocument :: Applicative f => JSON.Encoder f Document
 encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
     JSON.Encoder.atKey' "name"    JSON.Encoder.text               displayName
-  . JSON.Encoder.atKey' "center"  ( encodePoint2D encodeDouble ) viewportCenter
+  . JSON.Encoder.atKey' "center"  ( encoder @( Point2D Double ) ) viewportCenter
-  . JSON.Encoder.atKey' "zoom"    encodeDouble                   zoomFactor
+  . JSON.Encoder.atKey' "zoom"    ( encoder @Double )             zoomFactor
   . JSON.Encoder.atKey' "content" encodeDocumentContent           documentContent
 
 decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
 decodeDocument uniqueSupply mbFilePath = do
   displayName     <- JSON.Decoder.atKey "name" JSON.Decoder.text
-  viewportCenter  <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
+  viewportCenter  <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
-  zoomFactor      <- JSON.Decoder.atKey "zoom"   decodeDouble
+  zoomFactor      <- JSON.Decoder.atKey "zoom"   ( decoder @Double )
-  documentUnique  <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
+  documentUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
   pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )
+
+--------------------------------------------------------------------------------
+-- Various auxiliary types.
+
+-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
+data SomeFieldSType where
+  SomeFieldSType
+    :: ( STypeI a, Show a, NFData a, Serialisable a, Interpolatable a, Typeable a )
+    => Proxy# a -> SomeFieldSType
+
+-- | Existential type for allowed fields of a brush record.
+data SomeBrushFields where
+  SomeBrushFields
+    :: forall kvs rec
+    . ( STypesI kvs
+      , rec ~ Super.Rec kvs
+      , Show rec, NFData rec
+      , Interpolatable rec
+      , Serialisable rec
+      )
+    => Proxy# kvs -> SomeBrushFields
+
+instance Show SomeBrushFields where
+  show ( SomeBrushFields ( _ :: Proxy# kvs ) ) = show ( sTypesI @kvs )
+
+-- | Auxiliary datatype used to create a proof that record fields have the required instances.
+data BrushFieldsList kvs where
+  NilFields  :: BrushFieldsList '[]
+  ConsFields
+    ::
+      ( KnownSymbol k
+      , Show a, NFData a, Serialisable a
+      , Interpolatable a
+      , STypesI kvs
+      , KnownNat ( SuperRecord.RecSize kvs )
+      , SuperRecord.Has ( k SuperRecord.:= a ': kvs ) k a
+      )
+    => Proxy# k -> Proxy# a -> BrushFieldsList kvs -> BrushFieldsList ( k SuperRecord.:= a ': kvs )
+
+-- | Existential type used in the process of proving that record fields have the required instances.
+data SomeBrushFieldsList where
+  SomeBrushFieldsList
+    :: ( STypesI kvs
+       , KnownNat ( SuperRecord.RecSize kvs )
+       , KnownNat ( SuperRecord.RecSize ( MapDiff kvs ) )
+       )
+    => BrushFieldsList kvs -> SomeBrushFieldsList
+
+-- | Type used to backtrack instance resolution in the SuperRecord library,
+-- to witness the required typeclass instances by induction on the record fields.
+data SomeClassyBrushFieldsList rts lts where
+  SomeClassyBrushFieldsList
+    :: forall rts lts drts dlts
+    . ( drts ~ MapDiff rts
+      , dlts ~ MapDiff lts
+      , KnownNat ( SuperRecord.RecSize rts )
+      , KnownNat ( SuperRecord.RecSize drts )
+      , SuperRecord.UnsafeRecBuild rts lts ( ConstC Serialisable )
+      , SuperRecord.UnsafeRecBuild drts dlts ( ConstC ( Module Double ) )
+      , SuperRecord.UnsafeRecBuild drts dlts ( ConstC Monoid )
+      , SuperRecord.RecApply rts lts ( ConstC Show )
+      , SuperRecord.RecApply rts lts ( ConstC NFData )
+      , SuperRecord.RecApply rts lts ( ConstC Serialisable )
+      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts ) )
+      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Semigroup )         ( SuperRecord.Has drts ) )
+      , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Group )             ( SuperRecord.Has drts ) )
+      , SuperRecord.RecApply drts dlts ( HasDiff' rts )
+      , SuperRecord.TraversalCHelper dlts rts drts ( HasTorsor rts )
+      )
+    => Proxy# rts -> Proxy# lts -> SomeClassyBrushFieldsList rts lts
+
+proveAdapted
+  :: forall brushFields givenFields usedFields
+  .  ( STypesI brushFields, STypesI givenFields, STypesI usedFields )
+  => Maybe ( Dict ( Adapted brushFields givenFields usedFields ) )
+proveAdapted
+  | Just Dict <- proveUnsafeRecBuild @usedFields
+  , Just Dict <- proveRecApply       @brushFields ( size @usedFields )
+  , Refl      <- ( unsafeCoerce Refl :: usedFields :~: ( brushFields `SuperRecord.Intersect` givenFields ) )
+  = Just Dict
+  | otherwise
+  = Nothing
+  where
+    -- Provide evidence that each field of "used" appears in "given".
+    proveUnsafeRecBuild
+      :: forall lts_used 
+      .  ( STypesI lts_used )
+      => Maybe ( Dict ( SuperRecord.UnsafeRecBuild usedFields lts_used ( SuperRecord.Has givenFields ) ) )
+    proveUnsafeRecBuild = case sTypesI @lts_used of
+      STyNil -> Just Dict
+      sTyCons@STyCons
+        | ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_used ) ) <- sTyCons
+        , SomeIndex ( _ :: Proxy# i ) <- lookupIndex @k @v @givenFields
+        , Just Dict <- proveUnsafeRecBuild @tail_lts_used
+        -> Just Dict
+        | otherwise
+        -> Nothing
+
+    -- Provide evidence whether each field of "brush" appears in "used" or not.
+    -- Additionally checks that "used" is a subset of "brush".
+    proveRecApply
+      :: forall lts_brush
+      .  ( STypesI lts_brush )
+      => Int 
+      -> Maybe ( Dict ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField lts_brush ) ( UseFieldsInBrush usedFields ) ) )
+    proveRecApply nbUnseen = case sTypesI @lts_brush of
+      STyNil -> if nbUnseen < 1 then Just Dict else Nothing
+      sTyCons@STyCons
+        | ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_brush ) ) <- sTyCons
+        , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize brushFields )
+        , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize tail_lts_brush )
+        , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapFields UniqueField brushFields ) :~: Just ( UniqueField v ) )
+        , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapFields UniqueField tail_lts_brush ) :~: MapFields UniqueField tail_lts_brush )
+        -> case lookupIndex @k @v @usedFields of
+              SomeIndex ( _ :: Proxy# i ) ->
+                case proveRecApply @tail_lts_brush ( nbUnseen - 1 ) of
+                  Just Dict -> Just Dict
+                  Nothing   -> Nothing
+              NoIndex ->
+                case proveRecApply @tail_lts_brush nbUnseen of
+                  Just Dict -> Just Dict
+                  Nothing   -> Nothing
+
+data LookupResult k v kvs where
+  NoIndex
+    :: forall k v kvs
+    .  ( SuperRecord.RecTy k kvs ~ Nothing )
+    => LookupResult k v kvs
+  SomeIndex
+    :: forall k v kvs i
+    .  ( SuperRecord.RecTy k kvs ~ Just v
+       , SuperRecord.RecVecIdxPos k kvs ~ i
+       , KnownNat i
+       )
+    => Proxy# i -> LookupResult k v kvs
+
+lookupIndex
+  :: forall k v kvs
+  .  ( STypesI kvs, KnownSymbol k, STypeI v )
+  => LookupResult k v kvs
+lookupIndex = case sTypesI @kvs of
+  STyNil -> NoIndex
+  sTyCons@STyCons
+    | ( _ :: STypes ( ( l SuperRecord.:= w ) ': tail_kvs ) ) <- sTyCons
+    -> case sameSymbol ( Proxy :: Proxy k ) ( Proxy :: Proxy l ) of
+        Just Refl
+          | Just Refl <- eqTy @v @w
+          , ( index_proxy :: Proxy# i ) <- ( proxy# :: Proxy# ( SuperRecord.RecSize tail_kvs ) )
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: i )
+          , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
+          -> SomeIndex index_proxy
+        _ -> case lookupIndex @k @v @tail_kvs of
+                NoIndex
+                  | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Nothing )
+                  -> NoIndex
+                SomeIndex ( px_j :: Proxy# j )
+                  | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
+                  , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: j )
+                  -> SomeIndex px_j
+
+size :: forall kvs. STypesI kvs => Int
+size = case sTypesI @kvs of
+  STyNil -> 0
+  sTyCons@STyCons
+    | ( _ :: STypes ( head_kvs ': tail_kvs ) ) <- sTyCons
+    -> 1 + size @tail_kvs
+
+data Dict c where
+  Dict :: c => Dict c
+
+type family FromJust ( x :: Maybe a ) where
+  FromJust ( Just a ) = a

src/app/MetaBrush/Document/Serialise.hs-boot

@@ -0,0 +1,15 @@
+module MetaBrush.Document.Serialise
+  ( Serialisable(..) )
+  where
+
+-- waargonaut
+import qualified Waargonaut.Decode as JSON
+  ( Decoder )
+import qualified Waargonaut.Encode as JSON
+  ( Encoder )
+
+--------------------------------------------------------------------------------
+
+class Serialisable a where
+  encoder :: Monad f => JSON.Encoder f a
+  decoder :: Monad m => JSON.Decoder m a

src/app/MetaBrush/Document/SubdivideStroke.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
@@ -11,6 +13,8 @@ module MetaBrush.Document.SubdivideStroke
   where
 
 -- base
+import Data.Functor
+  ( ($>) )
 import Data.Semigroup
   ( Min(..), Arg(..) )
 
@@ -21,6 +25,8 @@ import Data.Act
 -- containers
 import Data.Sequence
   ( Seq(..) )
+import qualified Data.Sequence as Seq
+  ( singleton )
 
 -- generic-lens
 import Data.Generics.Product.Fields
@@ -43,22 +49,29 @@ import qualified Math.Bezier.Cubic as Cubic
   ( Bezier(..), closestPoint, subdivide )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..), closestPoint, subdivide )
+import Math.Bezier.Spline
+  ( Spline(..), SplineType(..), Curve(..), Curves(..), NextPoint(..)
+  , KnownSplineType(bifoldSpline, adjustSplineType)
+  )
 import Math.Bezier.Stroke
-  ( StrokePoint(..) )
+  ( CachedStroke, discardCache )
 import Math.Module
-  ( quadrance, closestPointToSegment )
+  ( lerp, quadrance, closestPointOnSegment )
 import Math.Vector2D
-  ( Point2D(..), Vector2D(..) )
+  ( Point2D(..), Vector2D(..), Segment(..) )
 import MetaBrush.Document
-  ( Document(..), Stroke(..) )
+  ( Document(..), Stroke(..), StrokeSpline
-import MetaBrush.UI.ToolBar
+  , PointData(..), DiffPointData(..)
-  ( Mode(..) )
+  , coords, _strokeSpline
+  )
+import MetaBrush.MetaParameter.Interpolation
+  ( Interpolatable(Diff) )
 
 --------------------------------------------------------------------------------
 
 -- | Subdivide a path at the given center, provided a path indeed lies there.
-subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text )
+subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
-subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
+subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
   where
     updatedDoc :: Document
     mbSubdivLoc :: Maybe Text
@@ -69,95 +82,87 @@ subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdiv
           doc
 
     updateStroke :: Stroke -> State ( Maybe Text ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible, strokeName } )
+    updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
-      | Brush <- mode
-      = ( field' @"strokePoints" . traverse )
-          ( \ spt ->
-            ( field' @"pointData" . field' @"brushShape" )
-              ( subdivideStroke strokeVisible ( "brush shape of stroke " <> strokeName ) ( MkVector2D $ coords spt ) )
-            spt
-          )
-          stroke
-      | otherwise
-      = ( field' @"strokePoints" )
-          ( subdivideStroke strokeVisible ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
-          stroke
 
-    subdivideStroke
-      :: forall pt
-      .  Show pt
-      => Bool
-      -> Text
-      -> Vector2D Double
-      -> Seq ( StrokePoint pt )
-      -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
-    subdivideStroke False _   _      pts   = pure pts
-    subdivideStroke True  _   _      Empty = pure Empty
-    subdivideStroke True  txt offset ( spt :<| spts ) = go spt spts
       where
-        go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
+        updateSpline
-        go sp0 Empty = pure ( sp0 :<| Empty )
+          :: forall clo brushParams
-        -- Line.
+          .  ( KnownSplineType clo, Interpolatable brushParams )
-        go sp0 ( sp1 :<| sps )
+          => StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
-          | PathPoint {} <- sp1
+        updateSpline spline@( Spline { splineStart } )
-          , let
+          | not strokeVisible
+          = pure spline
+          | otherwise
+          = fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
+          $ bifoldSpline
+              ( updateCurve ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
+              ( const $ pure Empty )
+              ( adjustSplineType @Open spline )
+
+            where
+              updateCurve
+                :: Text
+                -> Vector2D Double
+                -> PointData brushParams
+                -> Curve Open CachedStroke ( PointData brushParams )
+                -> State ( Maybe Text )
+                    ( Seq ( Curve Open CachedStroke ( PointData brushParams ) ) )
+              updateCurve txt offset sp0 curve = case curve of
+                line@( LineTo ( NextPoint sp1 ) dat ) ->
+                  let
                       p0, p1, s :: Point2D Double
                       t :: Double
                       p0 = coords sp0
                       p1 = coords sp1
-              ( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
+                      ( t, s ) = closestPointOnSegment @( Vector2D Double ) ( invert offset • c ) ( Segment p0 p1 )
                       sqDist :: Double
                       sqDist = quadrance @( Vector2D Double ) c ( offset • s )
-          = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-            then do
+                    then
-              put ( Just txt )
+                      let
-              -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                        subdiv :: PointData brushParams
-              pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
+                        subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
-            else ( sp0 :<| ) <$> go sp1 sps
+                        dat' :: CachedStroke
-        -- Quadratic Bézier curve.
+                        dat' = discardCache dat
-        go sp0 ( sp1 :<| sp2 :<| sps )
+                      in put ( Just txt ) $> ( LineTo ( NextPoint subdiv ) dat' :<| LineTo ( NextPoint sp1 ) dat' :<| Empty )
-          | ControlPoint {} <- sp1
+                    else pure $ Seq.singleton line
-          , PathPoint    {} <- sp2
+                bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
-          , let
+                  let
-              p0, p1, p2, s :: Point2D Double
+                    p0, p1, p2 :: Point2D Double
                     p0 = coords sp0
                     p1 = coords sp1
                     p2 = coords sp2
-              bez :: Quadratic.Bezier ( Point2D Double )
-              bez = Quadratic.Bezier {..}
                     sqDist :: Double
-              Min ( Arg sqDist ( t, s ) )
+                    Min ( Arg sqDist ( t, _ ) )
-                = Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
+                      = Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c )
-          = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-            then case Quadratic.subdivide @( Vector2D Double ) bez t of
+                    then case Quadratic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
-              ( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do
+                      ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> 
-                put ( Just txt )
+                        let
-                -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                          dat' :: CachedStroke
-                pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
+                          dat' = discardCache dat
-            else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
+                          bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
-        -- Cubic Bézier curve.
+                          bez_start = Bezier2To q1 ( NextPoint subdiv ) dat'
-        go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
+                          bez_end   = Bezier2To r1 ( NextPoint sp2    ) dat'
-          | ControlPoint {} <- sp1
+                        in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
-          , ControlPoint {} <- sp2
+                    else pure $ Seq.singleton bez2
-          , PathPoint    {} <- sp3
+                bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
-          , let
+                  let
-              p0, p1, p2, p3, s :: Point2D Double
+                      p0, p1, p2, p3 :: Point2D Double
                       p0 = coords sp0
                       p1 = coords sp1
                       p2 = coords sp2
                       p3 = coords sp3
-              bez :: Cubic.Bezier ( Point2D Double )
+                      Min ( Arg sqDist ( t, _ ) )
-              bez = Cubic.Bezier {..}
+                        = Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c )
-              Min ( Arg sqDist ( t, s ) )
+                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-                = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
+                    then case Cubic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
-          = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+                      ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) ->
-            then case Cubic.subdivide @( Vector2D Double ) bez t of
+                        let
-              ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
+                          dat' :: CachedStroke
-                put ( Just txt )
+                          dat' = discardCache dat
-                -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                          bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
-                pure
+                          bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) dat'
-                  ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
+                          bez_end   = Bezier3To r1 r2 ( NextPoint sp2    ) dat'
-                  :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
+                        in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
-                  )
+                    else pure $ Seq.singleton bez3
-            else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
-        go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )

src/app/MetaBrush/Document/Update.hs

@@ -145,7 +145,7 @@ instance DocumentModification DocModification where
 --
 -- Does nothing if no document is currently active.
 modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
-modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
+modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do
   mbAction <- STM.atomically . runMaybeT $ do
     unique      <- MaybeT ( STM.readTVar activeDocumentTVar )
     oldDoc      <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )

src/app/MetaBrush/MetaParameter/AST.hs

@@ -0,0 +1,625 @@
+{-# LANGUAGE AllowAmbiguousTypes        #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE EmptyCase                  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilyDependencies     #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+
+module MetaBrush.MetaParameter.AST
+  ( Span(..), Located(.., Location)
+  , Term(..), Pat(..), Decl(..)
+  , toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl
+  , termSpan
+  , TypedTerm(..), TypedPat(..)
+  , SType(..), STypeI(..), SomeSType(..)
+  , STypes(..), STypesI(..), someSTypes
+  , eqSTy, eqTy, eqSTys, eqTys
+  , Pass(..), Name, UniqueName(..), Loc
+  , Ext_With(..), X_With(..)
+  , MapFields, IsUniqueTerm, IsUniqueTerm2, UseFieldsInBrush
+  , UniqueField(..), GetUniqueField, UniqueTerm, GetUniqueTerm
+  , Adapted, AdaptableFunction(..), BrushFunction
+  , X_Ext(..)
+  , Expr, EPat, RnExpr, RnPat
+  )
+  where
+
+-- base
+import Data.Functor.Compose
+  ( Compose(..) )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.Kind
+  ( Type, Constraint )
+import Data.Proxy
+  ( Proxy(..) )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+import GHC.Exts
+  ( Proxy#, proxy# )
+import GHC.Generics
+  ( Generic )
+import GHC.TypeLits
+  ( Symbol, KnownSymbol, symbolVal', sameSymbol )
+import GHC.TypeNats
+  ( KnownNat )
+
+-- containers
+import Data.Tree
+ ( Tree(Node) )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( (:=), RecApply, UnsafeRecBuild, Has, TraversalC
+  , Intersect, Lookup, RecTy, RecSize, reflectRec
+  )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( pack )
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D(..), Segment(..) )
+import qualified Math.Bezier.Cubic     as Cubic
+  ( Bezier(..) )
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..) )
+import Math.Bezier.Spline
+  ( Spline(..), SplinePts, SplineType(..)
+  , SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline)
+  , Curve(..), NextPoint(..)
+  )
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+---------------------
+-- Source locations.
+
+data Span = Span
+  { startRow :: !Int
+  , startCol :: !Int
+  , endRow   :: !Int
+  , endCol   :: !Int
+  } deriving stock ( Eq, Ord )
+instance Show Span where
+  show ( Span sr sc er ec ) =
+    "l" <> show sr <> "c" <> show sc <> " -- " <> "l" <> show er <> "c" <> show ec
+instance Semigroup Span where
+  Span 0 0 0 0 <> s = s
+  s <> Span 0 0 0 0 = s
+  Span sr1 sc1 er1 ec1 <> Span sr2 sc2 er2 ec2
+    = case ( compare ( sr1, sc1 ) ( sr2, sc2 ), compare ( er1, ec1 ) ( er2, ec2 ) ) of
+        ( LT, LT ) -> Span sr1 sc1 er2 ec2
+        ( LT, _  ) -> Span sr1 sc1 er1 ec1
+        ( _ , LT ) -> Span sr2 sc2 er2 ec2
+        _          -> Span sr2 sc2 er1 ec1
+instance Monoid Span where
+  mempty = Span 0 0 0 0
+
+data Located a =
+  Located
+    { location :: !Span
+    , located  :: !a
+    }
+  deriving stock Show
+
+{-# COMPLETE Location #-}
+pattern Location :: Span -> Located ()
+pattern Location loc = Located loc ()
+
+----------
+-- Types.
+
+data SType ( ty :: Type ) where
+  SFunTy    :: ( STypeI a, STypeI b ) => SType ( a -> b )
+  STyBool   :: SType Bool
+  STyDouble :: SType Double
+  STyPoint  :: STypeI a => SType ( Point2D a )
+  STyLine   :: STypeI a => SType ( Segment a )
+  STyBez2   :: STypeI a => SType ( Quadratic.Bezier a )
+  STyBez3   :: STypeI a => SType ( Cubic.Bezier a )
+  STySpline :: KnownSplineType clo => SType ( SplinePts clo )
+  STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( AdaptableFunction kvs a )
+  -- reminder: update eqSTy when adding new constructors
+
+deriving stock instance Show ( SType ty )
+
+class STypeI ty where
+  sTypeI :: SType ty
+instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where
+  sTypeI = SFunTy
+instance STypeI Bool where
+  sTypeI = STyBool
+instance STypeI Double where
+  sTypeI = STyDouble
+instance STypeI a => STypeI ( Point2D a ) where
+  sTypeI = STyPoint
+instance STypeI a => STypeI ( Segment a ) where
+  sTypeI = STyLine
+instance STypeI a => STypeI ( Quadratic.Bezier a ) where
+  sTypeI = STyBez2
+instance STypeI a => STypeI ( Cubic.Bezier a ) where
+  sTypeI = STyBez3
+instance KnownSplineType clo => STypeI ( SplinePts clo ) where
+  sTypeI = STySpline
+instance ( STypesI kvs, STypeI a ) => STypeI ( AdaptableFunction kvs a ) where
+  sTypeI = STyWithFn
+
+data STypes ( kvs :: [ Type ] ) where
+  STyNil  :: STypes '[]
+  STyCons :: ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
+deriving stock instance Show ( STypes kvs )
+
+class KnownNat ( SuperRecord.RecSize kvs ) => STypesI kvs where
+  sTypesI :: STypes kvs
+
+instance STypesI '[] where
+  sTypesI = STyNil
+-- Warning: this instance is somewhat overly general as it doesn't check that the names are ordered.
+instance ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
+  sTypesI = STyCons
+
+data SomeSType where
+  SomeSType :: STypeI a => Proxy# a -> SomeSType
+
+instance Show SomeSType where
+  show ( SomeSType ( _ :: Proxy# a ) ) = show ( sTypeI @a )
+
+eqSTy :: SType a -> SType b -> Maybe ( a :~: b )
+eqSTy sTy_a@SFunTy sTy_b@SFunTy
+  | ( _ :: SType ( a1 -> b1 ) ) <- sTy_a
+  , ( _ :: SType ( a2 -> b2 ) ) <- sTy_b
+  , Just Refl <- eqTy @a1 @a2
+  , Just Refl <- eqTy @b1 @b2
+  = Just Refl
+eqSTy STyBool   STyBool   = Just Refl
+eqSTy STyDouble STyDouble = Just Refl
+eqSTy sTy_a@STyPoint sTy_b@STyPoint
+  | ( _ :: SType ( Point2D l ) ) <- sTy_a
+  , ( _ :: SType ( Point2D r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyLine sTy_b@STyLine
+  | ( _ :: SType ( Segment l ) ) <- sTy_a
+  , ( _ :: SType ( Segment r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyBez2 sTy_b@STyBez2
+  | ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a
+  , ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STyBez3 sTy_b@STyBez3
+  | ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a
+  , ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b
+  , Just Refl <- eqTy @l @r
+  = Just Refl
+eqSTy sTy_a@STySpline sTy_b@STySpline
+  | ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a
+  , ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b
+  = case ( ssplineType @clo1, ssplineType @clo2 ) of
+      ( SOpen  , SOpen   ) -> Just Refl
+      ( SClosed, SClosed ) -> Just Refl
+      _                    -> Nothing
+eqSTy sTy_a@STyWithFn sTy_b@STyWithFn
+  | ( _ :: SType ( AdaptableFunction kvs a ) ) <- sTy_a
+  , ( _ :: SType ( AdaptableFunction lvs b ) ) <- sTy_b
+  , Just Refl <- eqTys @kvs @lvs
+  , Just Refl <- eqTy  @a   @b
+  = Just Refl
+eqSTy _ _ = Nothing
+
+eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b )
+eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b )
+
+eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
+eqSTys STyNil STyNil = Just Refl
+eqSTys sTyCons1@STyCons sTyCons2@STyCons
+  | ( _ :: STypes ( ( l1 SuperRecord.:= v1 ) ': as' ) ) <- sTyCons1
+  , ( _ :: STypes ( ( l2 SuperRecord.:= v2 ) ': bs' ) ) <- sTyCons2
+  , Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
+  , Just Refl <- eqTy @v1 @v2
+  , Just Refl <- eqTys @as' @bs'
+  = Just Refl
+eqSTys _ _ = Nothing
+
+eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs )
+eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs )
+
+someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ]
+someSTypes = go ( sTypesI @kvs )
+  where
+    go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ]
+    go STyNil = []
+    go sTyCons@STyCons
+      | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs' ) ) <- sTyCons
+      = ( Text.pack $ symbolVal' ( proxy# :: Proxy# l ), SomeSType ( proxy# :: Proxy# v ) )
+      : go ( sTypesI @lvs' )
+
+------------------------------------------------
+-- AST. --
+----------
+
+data Pass = P | Rn | Tc
+  deriving stock Show
+
+type family K ( p :: Pass ) :: Type where
+  K P  = ()
+  K Rn = ()
+  K Tc = Type
+
+type family Ks ( p :: Pass ) :: Type where
+  Ks P  = ()
+  Ks Rn = ()
+  Ks Tc = [Type]
+
+type family T ( p :: Pass ) ( t :: Type ) :: K p where
+  T P  _ = '()
+  T Rn _ = '()
+  T Tc a = a
+
+type family Ts ( p :: Pass ) ( as :: [ Type ] ) :: Ks p where
+  Ts P  _           = '()
+  Ts Rn _           = '()
+  Ts Tc '[]         = '[]
+  Ts Tc ( a ': as ) = T Tc a ': Ts Tc as
+
+type family R ( p :: Pass ) ( kvs :: [ Type ] ) :: Ks p where
+  R P  _   = '()
+  R Rn _   = '()
+  R Tc kvs = kvs
+
+type family C ( p :: Pass ) ( ct :: Constraint ) :: Constraint where
+  C P  _  = ()
+  C Rn _  = ()
+  C Tc ct = ct
+
+-- C p ct: constraint for which evidence is generated at Tc stage
+-- ct: constraint for which evidence is provided from the start
+
+infixl 9 :$
+data Term ( p :: Pass ) ( kind :: K p ) where
+  (:$)  :: C p ( STypeI a )
+        => Term p ( T p ( a -> b ) )
+        -> Term p ( T p a )
+        -> Term p ( T p b )
+  Var   :: { varName :: !( Loc p ( Name p ) ) }
+        -> Term p ( T p a )
+  Let   :: { let_loc   :: ![ Loc p () ]
+           , let_decls :: ![ Decl p ]
+           , let_body  :: !( Term p ( T p a ) )
+           }
+        -> Term p ( T p a )
+  With  :: forall ( p :: Pass ) ( kvs :: [ Type ] ) ( a :: Type )
+        .  C p ( STypeI a )
+        => ![ Loc p () ]
+        -> !( X_With p ( R p kvs ) )
+        -> ![ Term p ( T p Bool ) ]
+        -> !( Term p ( T p a ) ) 
+        -> Term p ( T p ( AdaptableFunction kvs a ) )
+  Lit   :: ( Show a, STypeI a )
+        => !( Loc p ( Maybe Text ) )
+        -> !a
+        -> Term p ( T p a )
+  Op    :: STypeI a
+        => ![ Loc p () ] -> !Text -> a -> Term p ( T p a )
+  Point :: ( C p ( STypeI a ), pt ~ Term p ( T p ( Point2D a ) ) )
+        => ![ Loc p () ]
+        -> !( Term p ( T p a ) ) -> !( Term p ( T p a ) )
+        -> Term p ( T p ( Point2D a ) )
+  Line  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
+        => ![ Loc p () ]
+        -> !pt -> !pt
+        -> Term p ( T p ( Segment a ) )
+  Bez2  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
+        => ![ Loc p () ]
+        -> !pt -> !pt -> !pt
+        -> Term p ( T p ( Quadratic.Bezier a ) )
+  Bez3  :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
+        => ![ Loc p () ]
+        -> !pt -> !pt -> !pt -> !pt
+        -> Term p ( T p ( Cubic.Bezier a ) )
+  PolyBez
+     :: ( KnownSplineType clo, C p ( STypeI a ) )
+     => ![ Loc p () ]
+     -> Spline clo [ Loc p () ] ( Term p ( T p a ) )
+     -> Term p ( T p ( Spline clo () a ) )
+  CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a )
+
+data Decl ( p :: Pass ) where
+  Decl  :: C p ( STypeI a )
+        => !( Loc p () )
+        -> !( Pat p ( T p a ) ) -> !( Term p ( T p a ) )
+        -> Decl p
+
+data Pat ( p :: Pass ) ( kind :: K p ) where
+  PName :: { patName :: !( Loc p ( Name p ) ) }
+        -> Pat p ( T p a )
+  PPoint :: ![ Loc p () ]
+         -> !( Pat p ( T p a ) )
+         -> !( Pat p ( T p a ) )
+         -> Pat p ( T p ( Point2D a ) )
+  PWild :: { wildName :: !( Loc p Text ) }
+        -> Pat p ( T p a )
+  AsPat :: { atSymbol  :: !( Loc p () )
+           , asPatName :: !( Loc p ( Name p ) )
+           , asPat     :: !( Pat p ( T p a ) )
+           }
+        -> Pat p ( T p a )
+
+type Expr = Term  P '()
+type EPat = Pat   P '()
+
+type RnExpr = Term  Rn '()
+type RnPat  = Pat   Rn '()
+
+data TypedTerm where
+  TypedTerm :: STypeI a => Term Tc a -> TypedTerm
+
+data TypedPat where
+  TypedPat :: STypeI a => Pat Tc a -> TypedPat
+
+---------------------
+-- Extension fields
+
+data UniqueName
+  = UniqueName
+  { occName    :: !Text
+  , nameUnique :: !Unique
+  }
+  deriving stock ( Show, Generic )
+
+type family   Name ( p :: Pass ) :: Type
+type instance Name   P   = Text
+type instance Name   Rn  = UniqueName
+type instance Name   Tc  = UniqueName
+
+type family   Loc  ( p :: Pass ) ( a :: Type ) :: Type
+type instance Loc p a = Located a
+
+class Ext_With ( p :: Pass ) ( kvs :: Ks p ) where
+  data family X_With p kvs :: Type
+  toTreeWith :: forall ( lvs :: Ks p ). Ext_With p lvs => X_With p kvs -> [ Tree String ]
+
+instance Ext_With P kvs where
+  newtype X_With P _ = P_With [ Decl P ]
+  toTreeWith ( P_With decls ) = map toTreeDecl decls
+
+instance Ext_With Rn kvs where
+  newtype X_With Rn _ = Rn_With [ Decl Rn ]
+  toTreeWith ( Rn_With decls ) = map toTreeDecl decls
+
+
+instance Ext_With Tc kvs where
+  data X_With Tc kvs where
+    Tc_With
+      :: ( ts ~ MapFields UniqueTerm  kvs
+         , fs ~ MapFields UniqueField kvs
+         , SuperRecord.RecApply ts ts IsUniqueTerm
+         , SuperRecord.TraversalC IsUniqueTerm2 ts fs
+         )
+      => Super.Rec ts -> X_With Tc kvs
+  toTreeWith ( Tc_With decls ) =
+    SuperRecord.reflectRec @IsUniqueTerm
+      ( \ _ ( Compose ( UniqueField { uniqueField = a } ) ) -> toTreeTerm @Tc a )
+      decls
+
+data UniqueField a =
+  UniqueField { uniqueFieldName :: !UniqueName, uniqueField :: !a }
+
+type UniqueTerm = Compose UniqueField ( Term Tc )
+
+type family MapFields ( f :: Type -> Type ) ( kvs :: [ Type ] ) = ( r :: [ Type ] ) | r -> kvs where
+  MapFields _ '[] = '[]
+  MapFields f ( ( k SuperRecord.:= v ) ': kvs ) = ( k SuperRecord.:= f v ) ': MapFields f kvs
+
+
+type family GetUniqueField ( uniqueField :: Type ) :: Type where
+  GetUniqueField ( UniqueField a ) = a
+type family GetUniqueTerm ( uniqueTerm :: Type ) :: Type where
+  GetUniqueTerm ( Compose UniqueField ( Term Tc ) a ) = a
+
+class    ( STypeI ( GetUniqueTerm t )
+         , t ~ UniqueTerm ( GetUniqueTerm t )
+         )
+      => IsUniqueTerm ( k :: Symbol ) t
+  where
+instance ( STypeI ( GetUniqueTerm t )
+         , t ~ UniqueTerm ( GetUniqueTerm t )
+         )
+      => IsUniqueTerm ( k :: Symbol ) t
+  where
+
+class    ( IsUniqueTerm k t
+         , a ~ UniqueField ( GetUniqueField a )
+         , GetUniqueTerm t ~ GetUniqueField a
+         )
+      => IsUniqueTerm2 k t a
+  where
+instance ( IsUniqueTerm k t
+         , a ~ UniqueField ( GetUniqueField a )
+         , GetUniqueTerm t ~ GetUniqueField a
+         )
+      => IsUniqueTerm2 k t a
+  where
+
+class    ( STypeI ( GetUniqueField t )
+         , t ~ UniqueField ( GetUniqueField t )
+         , SuperRecord.Lookup kvs k ( GetUniqueField t )
+              ( SuperRecord.RecTy k kvs )
+         )
+      => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
+instance ( STypeI ( GetUniqueField t )
+         , t ~ UniqueField ( GetUniqueField t )
+         , SuperRecord.Lookup kvs k ( GetUniqueField t )
+              ( SuperRecord.RecTy k kvs )
+         )
+      => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
+
+class    ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
+         , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
+         , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
+              ( UseFieldsInBrush usedFields )
+         )
+      => Adapted brushFields givenFields usedFields | givenFields brushFields -> usedFields
+instance ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
+         , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
+         , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
+              ( UseFieldsInBrush usedFields )
+         )
+      => Adapted brushFields givenFields usedFields 
+
+type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Closed )
+newtype AdaptableFunction brushFields a
+  = AdaptableFunction
+      ( forall givenFields usedFields
+      .  Adapted brushFields givenFields usedFields
+      => ( Super.Rec givenFields -> Super.Rec usedFields
+         , Super.Rec usedFields  -> a
+         )
+      )
+
+
+class Ext ( p :: Pass ) ( a :: K p ) where
+  data family X_Ext ( p :: Pass ) a :: Type
+  toTreeArgsExt :: [ Tree String ] -> X_Ext p a -> Tree String
+
+instance Ext P a where
+  data instance X_Ext P  a
+  toTreeArgsExt _ x = case x of {}
+
+instance Ext Rn a where
+  data instance X_Ext Rn a
+  toTreeArgsExt _ x = case x of {}
+
+instance Ext Tc a where
+  newtype instance X_Ext Tc a = Val a
+    deriving stock   ( Generic, Show )
+    deriving newtype NFData
+  toTreeArgsExt as ( Val _ ) = Node "Value..." as
+
+
+------------------------------------------------
+-- Printing AST. --
+-------------------
+
+termSpan :: Term p a -> Span
+termSpan ( f :$ a ) = termSpan f <> termSpan a
+termSpan ( Var ( Located l _ ) )   = l
+termSpan ( Let locs _ body )       = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
+termSpan ( With locs _ _ body )    = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
+termSpan ( Lit ( Located l _ ) _ ) = l
+termSpan ( Op locs _ _ )           = foldMap ( \ ( Located l _ ) -> l ) locs
+termSpan ( Point locs x y )        = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan x <> termSpan y
+termSpan ( Line locs _ _ )         = foldMap ( \ ( Located l _ ) -> l ) locs
+termSpan ( Bez2 locs _ _ _ )       = foldMap ( \ ( Located l _ ) -> l ) locs
+termSpan ( Bez3 locs _ _ _ _ )     = foldMap ( \ ( Located l _ ) -> l ) locs
+termSpan ( PolyBez locs _ )        = foldMap ( \ ( Located l _ ) -> l ) locs
+termSpan ( CExt _ ) = mempty
+
+
+toTreeTerm
+  :: forall ( p :: Pass ) ( a :: K p )
+  .  ( Show ( Name p ), forall x. Ext p x, forall kvs. Ext_With p kvs )
+  => Term p a
+  -> Tree String
+toTreeTerm = toTreeArgsTerm @p @a []
+
+toTreeArgsTerm
+  :: forall ( p :: Pass ) ( a :: K p )
+  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  => [ Tree String ]
+  -> Term p a
+  -> Tree String
+toTreeArgsTerm as ( f :$ a )       = toTreeArgsTerm ( toTreeTerm a : as ) f
+toTreeArgsTerm as ( Op    _ nm _ ) = Node ( "Op " <> show nm ) as
+toTreeArgsTerm as ( Var  nm      ) = Node ( "Var " <> show nm ) as
+toTreeArgsTerm as ( Lit  loc a   ) =
+  case loc of
+    Located l Nothing     -> Node ( "Lit " <> show ( Located l a  ) ) as
+    Located l ( Just nm ) -> Node ( "Lit " <> show ( Located l nm ) ) as
+toTreeArgsTerm as ( Point   _ p1 p2       ) = Node "(,)"  ( toTreeTerm p1 : toTreeTerm p2 : as )
+toTreeArgsTerm as ( Line    _ p0 p1       ) = Node "Line" ( toTreeTerm p0 : toTreeTerm p1 : as )
+toTreeArgsTerm as ( Bez2    _ p0 p1 p2    ) = Node "Bez2" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : as )
+toTreeArgsTerm as ( Bez3    _ p0 p1 p2 p3 ) = Node "Bez3" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : toTreeTerm p3 : as )
+toTreeArgsTerm as ( PolyBez _ spline      ) = Node "Spline"
+  ( ( runIdentity
+    $ ( bifoldSpline @_ @Identity @[ Tree String ] @_ )
+        ( const ( toTreeCurve @p ) )
+        ( Identity . (:[]) . toTreeTerm )
+      spline
+    )
+  <> as
+  )
+toTreeArgsTerm as ( Let _ ds a ) =
+  Node "Let"
+    ( Node "Decls" ( map ( toTreeDecl @p ) ds )
+    : Node "In"    [ toTreeTerm a ]
+    : as
+    )
+toTreeArgsTerm as ( With _ args conds body ) =
+  Node "With" 
+    ( Node "Params" ( toTreeWith @p args )
+    : Node "Conds"  ( map toTreeTerm conds )
+    : Node "Define" [ toTreeTerm body ]
+    : as
+    )
+toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext
+
+toTreeDecl
+  :: forall ( p :: Pass )
+  .  ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  => Decl p
+  -> Tree String
+toTreeDecl ( Decl _ lhs rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ]
+
+toTreePat :: Show ( Name p ) => Pat p a -> Tree String
+toTreePat ( PName   nm       ) = Node ( show nm ) [ ]
+toTreePat ( PPoint  _  pl pr ) = Node "(_,_)"     [ toTreePat pl, toTreePat pr ]
+toTreePat ( PWild   nm       ) = Node ( show nm ) [ ]
+toTreePat ( AsPat _ nm pat   ) = Node "(@)"       [ Node ( show nm ) [], toTreePat pat ]
+
+toTreeCurve
+  :: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p )
+  .  ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
+  => Curve clo crvData ( Term p a )
+  -> Identity [ Tree String ]
+toTreeCurve curve = Identity . (:[]) $ case ssplineType @clo of
+  SOpen -> case curve of
+    ( LineTo          ( NextPoint p1 ) _ ) -> Node "LineTo"    [ toTreeTerm p1 ]
+    ( Bezier2To p1    ( NextPoint p2 ) _ ) -> Node "Bezier2To" [ toTreeTerm p1, toTreeTerm p2 ]
+    ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, toTreeTerm p3 ]
+  SClosed -> case curve of
+    ( LineTo          BackToStart _ ) -> Node "LineTo"    [ Node "cycle" [] ]
+    ( Bezier2To p1    BackToStart _ ) -> Node "Bezier2To" [ toTreeTerm p1, Node "cycle" [] ]
+    ( Bezier3To p1 p2 BackToStart _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, Node "cycle" [] ]

src/app/MetaBrush/MetaParameter/Driver.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE MagicHash           #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module MetaBrush.MetaParameter.Driver where
+
+-- base
+import GHC.Exts
+  ( Proxy#, proxy# )
+
+-- dlist
+import qualified Data.DList as DList
+  ( toList )
+
+-- Earley
+import qualified Text.Earley as Earley
+  ( Report(..), fullParses, parser )
+
+-- text
+import Data.Text
+  ( Text )
+
+-- transformers
+import Control.Monad.Trans.Except
+  ( runExceptT )
+import Control.Monad.Trans.Reader
+  ( runReaderT )
+import Control.Monad.Trans.RWS.CPS
+  ( runRWST )
+import Control.Monad.Trans.State.Strict
+  ( evalState )
+
+-- MetaBrush
+import Math.Bezier.Spline
+  ( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) )
+import MetaBrush.MetaParameter.AST
+  ( Located
+  , Term, TypedTerm(..)
+  , SType(..), STypeI(sTypeI)
+  , SomeSType(..), STypesI
+  , Pass(Tc)
+  , AdaptableFunction(..), BrushFunction
+  )
+import MetaBrush.MetaParameter.Eval
+  ( EvalState(..), eval )
+import MetaBrush.MetaParameter.Parse
+  ( grammar, Token, tokenize )
+import MetaBrush.MetaParameter.Rename
+  ( rename, RnM, RnMessage, RnError, emptyRnState )
+import MetaBrush.MetaParameter.TypeCheck
+  ( typeCheck, TcM, TcMessage, TcError, emptyTcState )
+import MetaBrush.Unique
+  ( UniqueSupply, MonadUnique(freshUnique) )
+
+--------------------------------------------------------------------------------
+
+data DriverError
+  = ParseError     !( Earley.Report Text [ Located Token ] )
+  | RenameError    !RnError
+  | TypeCheckError !TcError
+  | NonBrushType   !SomeSType
+  deriving stock Show
+
+data DriverMessage
+  = RenameMessage    !RnMessage
+  | TypeCheckMessage !TcMessage
+
+data SomeBrushFunction where
+  SomeBrushFunction
+    :: forall brushParams
+    .  ( STypesI brushParams )
+    => BrushFunction brushParams
+    -> SomeBrushFunction
+
+interpretBrush
+  :: UniqueSupply
+  -> Text
+  -> IO
+      ( Either DriverError SomeBrushFunction
+      , [ DriverMessage ]
+      )
+interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser grammar ) $ tokenize sourceText of
+  ( [], parserReport )  -> pure ( Left ( ParseError parserReport ), [] )
+  ( parsedExpr : _, _ ) -> do
+    ( renamedExpr, _, rnMessages ) <- runRWST              ( rename    @RnM  parsedExpr ) uniqSupply emptyRnState
+    ( tcResult   , _, tcMessages ) <- runRWST ( runExceptT $ typeCheck @TcM renamedExpr ) uniqSupply emptyTcState
+    let
+      messages :: [ DriverMessage ]
+      messages = DList.toList ( fmap RenameMessage rnMessages <> fmap TypeCheckMessage tcMessages )
+    case tcResult of
+      Left err -> pure ( Left ( TypeCheckError err ), messages )
+      -- Type checking succeeded: check that the type of the given program
+      -- is indeed a function that takes in a record of parameters and returns
+      -- a closed brush shape.
+      Right ( TypedTerm ( term :: Term Tc v ) )
+        | sTyWithFn@STyWithFn <- sTypeI @v
+        , ( _ :: SType ( AdaptableFunction kvs b ) ) <- sTyWithFn
+        , sTySpline@STySpline <- sTypeI @b
+        , ( _ :: SType ( SplinePts clo ) ) <- sTySpline
+        , SClosed <- ssplineType @clo
+        -> do
+          uniq <- ( `runReaderT` uniqSupply ) freshUnique
+          let
+            initEvalState :: EvalState
+            initEvalState =
+              EvalState { evalHeap = mempty, nextUnique = uniq }
+            val :: BrushFunction kvs
+            val = ( `evalState` initEvalState ) $ eval term
+          pure ( Right ( SomeBrushFunction @kvs val ), messages )
+        | otherwise
+        -> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages )

src/app/MetaBrush/MetaParameter/Eval.hs

@@ -0,0 +1,234 @@
+{-# LANGUAGE ApplicativeDo         #-}
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecursiveDo           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+module MetaBrush.MetaParameter.Eval
+  ( EvalState(..), eval )
+  where
+
+-- base
+import Data.Foldable
+  ( for_ )
+import Data.Functor.Compose
+  ( Compose(..) )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+import GHC.Generics
+  ( Generic )
+
+-- containers
+import Data.Map
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( insert, lookup, union, fromList )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- lens
+import Control.Lens
+  ( assign, modifying, use )
+
+-- mtl
+import Control.Monad.State
+  ( get )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( RecApply(..), Lookup(..), Has, UnsafeRecBuild, traverseC, project )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( pack )
+
+-- transformers
+import Control.Monad.Trans.State.Strict
+  ( State, evalState )
+
+-- MetaBrush
+import qualified Math.Bezier.Cubic     as Cubic
+  ( Bezier(..) )
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..) )
+import Math.Bezier.Spline
+  ( KnownSplineType(bitraverseSpline), bitraverseCurve )
+import Math.Vector2D
+  ( Point2D(..), Segment(..) )
+import MetaBrush.MetaParameter.AST
+  ( Term(..), Pat(..), Decl(..)
+  , TypedTerm(..), STypeI(..), SType(..)
+  , Pass(Tc), X_Ext(..), X_With(..)
+  , Span(..), Located(..)
+  , MapFields, AdaptableFunction(..)
+  , UniqueField(..), UniqueTerm, IsUniqueTerm2, UseFieldsInBrush
+  , eqTy
+  )
+import MetaBrush.MetaParameter.Rename
+  ( UniqueName(..) )
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+data EvalState
+  = EvalState
+  { evalHeap   :: !( Map Unique TypedTerm )
+  , nextUnique :: !Unique
+  }
+  deriving stock Generic
+
+eval :: forall a. STypeI a => Term Tc a -> State EvalState a
+eval ( f :$ a )           = eval f <*> eval a
+eval ( Lit _ x )          = pure x
+eval ( Op _ _ f )         = pure f
+eval ( Point _ x y )      = Point2D <$> eval x <*> eval y
+eval ( Line _ p q )       = Segment <$> eval p <*> eval q
+eval ( Bez2 _ p q r )     = Quadratic.Bezier <$> eval p <*> eval q <*> eval r
+eval ( Bez3 _ p q r s )   = Cubic.Bezier <$> eval p <*> eval q <*> eval r <*> eval s
+eval ( PolyBez _ spline ) =
+  bitraverseSpline
+    ( const $ bitraverseCurve ( const $ pure () ) ( const eval ) )
+    eval
+    spline
+eval ( Let _ decls a ) = declare decls *> eval a
+eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do
+  defaultParamsRecord <-
+    SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields )
+      ( \ _ ( Compose ( UniqueField uniq term ) ) -> UniqueField uniq <$> eval term )
+      withDeclsRecord
+  EvalState { evalHeap, nextUnique } <- get
+  let
+    toBrushParameters
+      :: forall givenFields usedFields
+      .  ( SuperRecord.UnsafeRecBuild usedFields usedFields
+             ( SuperRecord.Has givenFields )
+         )
+      => Super.Rec givenFields -> Super.Rec usedFields
+    toBrushParameters = SuperRecord.project
+    brushFunction
+      :: forall usedFields
+      .  ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
+            ( UseFieldsInBrush usedFields )
+          )
+      => Super.Rec usedFields -> r
+    brushFunction usedParamsRecord =
+      let
+        updatedHeap :: Map Unique TypedTerm
+        updatedHeap = bindRecordValues @brushFields @usedFields defaultParamsRecord usedParamsRecord evalHeap
+      in
+        ( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) ) $ eval body
+  pure ( AdaptableFunction ( toBrushParameters, brushFunction ) )
+eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do
+  vars <- use ( field' @"evalHeap" )
+  case Map.lookup varUniq vars of
+    Nothing -> error ( "eval: out of scope variable " <> show var )
+    Just ( TypedTerm ( r :: Term Tc b ) )
+      | Just Refl <- eqTy @a @b
+      -> do 
+        res <- eval r
+        modifying ( field' @"evalHeap" )
+          ( Map.insert varUniq ( TypedTerm $ CExt @Tc @a ( Val res ) ) )
+        pure res
+      | otherwise
+      -> error
+          ( "eval: unexpected type of variable read from environment.\n\
+            \Expected: " <> show ( sTypeI @a ) <> "\n\
+            \  Actual: " <> show ( sTypeI @b )
+          )
+eval ( CExt ( Val v ) ) = pure v
+
+declare :: [ Decl Tc ] -> State EvalState ()
+declare [] = pure ()
+declare ( Decl _ pat t : next ) = go pat t *> declare next
+  where
+    go :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName )
+    go ( PName ( Located _ patUniqName@( UniqueName _ patUniq ) ) ) r = do
+      modifying ( field' @"evalHeap" )
+        ( Map.insert patUniq $ TypedTerm r )
+      pure ( Just patUniqName )
+    go ( PPoint _ lpat rpat ) r = do
+      case sTypeI @a of
+        sTyPoint@STyPoint
+          | ( _ :: SType ( Point2D x ) ) <- sTyPoint
+          -> do
+          nextUnique <- use ( field' @"nextUnique" )
+          let
+            uniq1, uniq2, uniq3, nextUnique' :: Unique
+            uniq1       = nextUnique
+            uniq2       = succ uniq1
+            uniq3       = succ uniq2
+            nextUnique' = succ uniq3
+          assign ( field' @"nextUnique" ) nextUnique'
+          let
+            pairText :: Text
+            pairText = "$pair%" <> Text.pack ( show uniq1 ) 
+            pairName, fstName, sndName :: UniqueName
+            pairName = UniqueName pairText               uniq1
+            fstName  = UniqueName ( pairText <> "$fst" ) uniq2
+            sndName  = UniqueName ( pairText <> "$snd" ) uniq3
+            var_l, var_r :: Term Tc x
+            var_l = Var ( Located noSpan fstName )
+            var_r = Var ( Located noSpan sndName )
+          modifying ( field' @"evalHeap" )
+            ( Map.union
+            $ Map.fromList
+                [ ( uniq1, TypedTerm $ Point [] var_l var_r )
+                , ( uniq2, TypedTerm $ ( Op @( a -> x ) [] "fst" ( \ ~( Point2D x _ ) -> x ) ) :$ r )
+                , ( uniq3, TypedTerm $ ( Op @( a -> x ) [] "snd" ( \ ~( Point2D _ y ) -> y ) ) :$ r )
+                ]
+            )
+          go lpat var_l
+          go rpat var_r
+          pure ( Just pairName )
+    go ( AsPat _ ( Located _ asUniqName@( UniqueName _ asUniq ) ) patt ) r = do
+      mbNm <- go patt r
+      for_ mbNm \ nm ->
+        modifying ( field' @"evalHeap" )
+          ( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) )
+      pure ( Just asUniqName )
+    go ( PWild _ ) _ = pure Nothing
+
+bindRecordValues
+  :: forall brushFields usedFields defaultFields
+  .  ( defaultFields ~ MapFields UniqueField brushFields
+     , SuperRecord.RecApply defaultFields defaultFields ( UseFieldsInBrush usedFields )
+     )
+  => Super.Rec defaultFields
+  -> Super.Rec usedFields
+  -> Map Unique TypedTerm
+  -> Map Unique TypedTerm
+bindRecordValues defaultValues usedValues heap = do
+  SuperRecord.recApply @defaultFields @defaultFields @( UseFieldsInBrush usedFields )
+    ( \ k ( UniqueField ( UniqueName _ uniq ) ( defaultVal :: a ) ) prevState ->
+      let
+        val :: a
+        val = SuperRecord.lookupWithDefault k defaultVal usedValues
+        updatedHeap :: Map Unique TypedTerm
+        updatedHeap = Map.insert uniq ( TypedTerm $ CExt @Tc @a ( Val val ) ) prevState
+      in updatedHeap
+    )
+    defaultValues
+    heap
+
+noSpan :: Span
+noSpan = Span 0 0 0 0

src/app/MetaBrush/MetaParameter/Interpolation.hs

@@ -0,0 +1,141 @@
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module MetaBrush.MetaParameter.Interpolation
+  ( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
+  where
+
+-- base
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.Kind
+  ( Type )
+import Data.Monoid
+  ( Sum )
+import GHC.TypeLits
+  ( Symbol )
+
+-- acts
+import Data.Act
+  ( Act(..), Torsor(..) )
+
+-- groups
+import Data.Group
+  ( Group(..) )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( (:=), Has, RecTy, RecApply(..), UnsafeRecBuild(..), TraversalC, traverseC
+  , get, set, modify
+  )
+import SuperRecord
+  ( ConstC, Tuple22C )
+
+-- MetaBrush
+import Math.Module
+  ( Module(..) )
+import Math.Vector2D
+  ( Point2D, Vector2D )
+
+--------------------------------------------------------------------------------
+
+class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where
+  type Diff a = ( d :: Type ) | d -> a
+
+instance ( a ~ Double ) => Interpolatable ( Point2D a ) where
+  type Diff ( Point2D a ) = Vector2D a
+
+instance Interpolatable Double where
+  type Diff Double = Sum Double
+
+instance ( dvs ~ MapDiff kvs
+         , SuperRecord.UnsafeRecBuild dvs dvs ( ConstC Monoid )
+         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has dvs ) )
+         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup )         ( SuperRecord.Has dvs ) )
+         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Group )             ( SuperRecord.Has dvs ) )
+         , SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
+         , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
+         , Module Double ( Super.Rec ( MapDiff kvs ) )
+         )
+      => Interpolatable ( Super.Rec kvs )
+      where
+  type Diff ( Super.Rec kvs ) = Super.Rec ( MapDiff kvs )
+
+type family MapDiff ( kvs :: [ Type ] ) = ( lvs :: [ Type ] ) | lvs -> kvs where
+  MapDiff '[] = '[]
+  MapDiff ( k SuperRecord.:= v ': kvs ) = ( k SuperRecord.:= Diff v ': MapDiff kvs )
+
+
+
+
+instance  ( Monoid ( Super.Rec kvs ) 
+          , SuperRecord.RecApply kvs kvs
+              ( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
+          )
+       => Group ( Super.Rec kvs )
+    where
+  invert r = SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
+    ( \ lbl v res -> SuperRecord.set lbl ( invert v ) res ) r r
+instance  ( SuperRecord.RecApply kvs kvs
+             ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
+          , SuperRecord.UnsafeRecBuild kvs kvs ( ConstC ( Module Double ) )
+          )
+       => Module Double ( Super.Rec kvs )
+    where
+  origin = runIdentity $ SuperRecord.unsafeRecBuild @kvs @kvs @( ConstC ( Module Double ) ) ( \ _ _ -> Identity origin )
+  r1 ^+^ r2 =
+    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
+      ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^+^ ) res ) r1 r2
+  r1 ^-^ r2 =
+    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
+      ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^-^ ) res ) r1 r2
+  k *^ r =
+    SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
+      ( \ lbl v1 res -> SuperRecord.set lbl ( k *^ v1 ) res ) r r
+
+class    ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
+      => HasDiff ( kvs :: [ Type ] ) ( t :: Type ) ( k :: Symbol ) ( d :: Type )
+instance ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
+      => HasDiff kvs t k d
+
+type family FromJust ( a :: Maybe k ) :: k where
+  FromJust ( Just a ) = a
+
+class    HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
+instance HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
+
+instance ( dvs ~ MapDiff kvs
+         , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
+         , SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
+         )
+      => Act ( Super.Rec dvs ) ( Super.Rec kvs )
+      where
+  ds • as = SuperRecord.recApply @dvs @dvs @( HasDiff' kvs )
+              ( \ lbl d1 res -> SuperRecord.modify lbl ( d1 • ) res ) ds as
+
+
+class    ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor ( kvs :: [Type] ) ( k :: Symbol ) t d where
+instance ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor kvs k t d where
+
+instance ( dvs ~ MapDiff kvs
+         , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
+         , Act ( Super.Rec dvs ) ( Super.Rec kvs )
+         , Group ( Super.Rec dvs )
+         )
+      => Torsor ( Super.Rec dvs ) ( Super.Rec kvs ) where
+  as <-- bs =
+    runIdentity $ SuperRecord.traverseC @( HasTorsor kvs ) @Identity @kvs @dvs 
+      ( \ lbl a -> Identity ( a <-- SuperRecord.get lbl bs ) )
+      as

src/app/MetaBrush/MetaParameter/Parse.hs

@@ -0,0 +1,828 @@
+{-# LANGUAGE ApplicativeDo         #-}
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RecursiveDo           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+module MetaBrush.MetaParameter.Parse where
+
+-- base
+import Control.Applicative
+  ( Alternative
+    ( (<|>), some, many )
+  , optional
+  )
+import Control.Category
+  ( (>>>) )
+import Control.Monad
+  ( void )
+import qualified Data.Char as Char
+  ( isAlpha, isAlphaNum, isDigit, isSpace, isSymbol, isPunctuation, toLower )
+import Data.Foldable
+  ( for_ )
+
+-- containers
+import Data.Set 
+  ( Set )
+import qualified Data.Set as Set
+  ( member, fromList )
+import qualified Data.Sequence as Seq
+  ( fromList )
+
+-- Earley
+import qualified Text.Earley as Earley
+import Text.Earley
+  ( (<?>) )
+import qualified Text.Earley.Mixfix as Earley
+
+-- text
+import Data.Text.Internal
+  ( Text(..) )
+import qualified Data.Text as Text
+  ( all, break, cons, foldl'
+  , length, map, null
+  , singleton, span
+  , uncons, unpack
+  )
+import qualified Data.Text.Read as Text.Read
+  ( double )
+
+-- tree-view
+import Data.Tree.View
+  ( drawTree )
+
+-- MetaBrush
+import Math.Bezier.Spline
+  ( SplineType(..), SSplineType(..), SplineTypeI(ssplineType)
+  , Spline(..), Curves(..), Curve(..), NextPoint(..)
+  )
+import MetaBrush.MetaParameter.AST
+  ( Span(..), Located(..)
+  , Expr, EPat
+  , Term(..), Pat(..), Decl(..)
+  , X_With(..)
+  , toTreeTerm
+  )
+import MetaBrush.MetaParameter.PrimOp
+  ( Orientation(..), kappa
+  , rotate_around_by, rotate_by
+  , scale_around_by, scale_by
+  , shear_from_by, shear_by
+  , translate_by
+  )
+  
+--------------------------------------------------------------------------------
+-- Parsing using the language grammar.
+
+parse :: Text -> ( [ ( Expr, Int ) ], Earley.Report Text [ Located Token ] )
+parse = Earley.allParses ( Earley.parser grammar ) . tokenize
+
+showParses :: Text -> IO ()
+showParses x = do
+  let
+    ( parses, report ) = parse x
+  putStrLn "Report:\n"
+  print report
+  putStrLn "\n\n"
+  putStrLn "Parses:\n"
+  for_ parses \ ( expr, _ ) -> do
+    let
+      tree = toTreeTerm expr
+    drawTree tree
+
+examples :: [ Located Token ] -> Int -> IO ()
+examples inputToks n =
+  for_ ( Earley.exactly n ( Earley.generator grammar inputToks ) ) \ ( expr, toks ) -> do
+    for_ toks ( located >>> showToken >>> ( <> " " ) >>> putStr )
+    putStrLn ""
+    drawTree ( toTreeTerm expr )
+    putStrLn "\n\n"
+
+someToks :: [ Located Token ]
+someToks = map ( Located mempty )
+  [ TokAlphabetic "x"
+  , TokAlphabetic "let"
+  , TokAlphabetic "in"
+  , TokSpecial '['
+  , TokSpecial ']'
+  , TokSpecial '('
+  , TokSpecial ')'
+  , TokSymbolic "="
+  , TokSymbolic "--"
+  , TokSymbolic "->"
+  , TokSymbolic "."
+  ]
+
+test1 :: Text
+test1 =
+  "  let\n\
+  \    q = rotate p around c CW by theta + 3 * theta2\n\
+  \    r = scale ( translate q by t ) by (7,11)\n\
+  \  in rotate q around p CW by phi"
+
+test2 :: Text
+test2 =
+  "  let\n\
+  \    p = (3,3)\n\
+  \    q = (1,1)\n\
+  \  in\n\
+  \    rotate p\n\
+  \      around q\n\
+  \      CCW by\n\
+  \        let\n\
+  \          q = pi / 2 \n\
+  \        in q"
+
+test3 :: Text
+test3 =
+  "  let\n\
+  \    p = (1,1)\n\
+  \  in\n\
+  \    [ p -- c1 -- c2 -> q\n\
+  \        -- c3 -- c4 -> r\n\
+  \        -> s  -> .\n\
+  \      ]"
+
+
+
+--------------------------------------------------------------------------------
+-- Language grammar.
+
+grammar :: forall r. Earley.Grammar r ( Earley.Prod r Text ( Located Token ) Expr )
+grammar = mdo
+
+  pair  <- Earley.rule $
+    do
+      lp <- special '('
+      l <- expr
+      anyWhitespace
+      comma <- special ','
+      r <- expr
+      anyWhitespace
+      rp <- special ')'
+      pure $
+        Point
+          [ Location ( location lp )
+          , Location ( location comma )
+          , Location ( location rp ) ]
+          l r
+    <?> "pair"
+  atom  <- Earley.rule
+    ( identifier 
+    <|> pair 
+    <|> ( special '(' *> expr <* anyWhitespace <* special ')' )
+    <|> spline
+    )
+  app   <- Earley.rule ( atom <|> (:$) <$> app <*> ( anyWhitespace *> atom ) )
+
+  pairPattern <- Earley.rule
+    ( do
+      openLoc <- special '('
+      anyWhitespace
+      l <- anyPattern
+      anyWhitespace
+      commaLoc <- special ','
+      anyWhitespace
+      r <- anyPattern
+      anyWhitespace
+      closeLoc <- special ')'
+      pure $ PPoint
+        [ Location ( location openLoc )
+        , Location ( location commaLoc )
+        , Location ( location closeLoc )
+        ]
+        l r
+    <?> "pair"
+    )
+
+  basicPattern <- Earley.rule
+    ( wildcard 
+    <|> ( PName <$> alphabeticName 
+        <?> "pattern name"
+        )
+    <|> pairPattern
+    )
+
+  asPattern <- Earley.rule
+    ( do
+      n <- alphabeticName <?> "pattern name"
+      asLoc <- symbol "@"
+      pat <- anyPattern
+      pure $
+        AsPat ( Location ( location asLoc ) ) n pat
+    <?> "as pattern"
+    )
+
+  anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) <?> "pattern" )
+
+  declaration <-
+    Earley.rule
+      ( do
+        p <- anyPattern
+        anyWhitespace
+        eqLoc <- symbol "="
+        e <- expr
+        pure ( Location ( location eqLoc ), p, e )
+      <?> "declaration"
+      )
+
+  moreDeclarations <- Earley.rule
+    ( do
+        separator
+        decl <- declaration
+        more <- moreDeclarations
+        pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
+    <|> pure []
+    )
+
+  declarations <-
+    Earley.rule
+      ( do
+          decl <- declaration
+          more <- moreDeclarations
+          pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
+      <|> pure []
+      )
+
+  let_statement <-
+    Earley.rule
+      ( do
+          loc_let <- tokAlpha "let"
+          anyWhitespace
+          decls <- declarations <?> "declarations"
+          anyWhitespace
+          loc_in <- tokAlpha "in"
+          e <- expr
+          pure $
+            Let
+              [ Location ( location loc_let )
+              , Location ( location loc_in  ) ]
+              decls
+              e
+      <?> "let statement" 
+      )
+
+  moreProperties <- Earley.rule
+    ( do
+        separator
+        prop <- expr
+        more <- moreProperties
+        pure ( prop : more )
+    <|> pure []
+    )
+
+  properties <-
+    Earley.rule
+      ( do
+          prop <- expr
+          more <- moreProperties
+          pure ( prop : more )
+      <|> pure []
+      )
+
+  with_statement <-
+    Earley.rule
+      ( do
+          loc_with <- tokAlpha "with"
+          anyWhitespace
+          decls <- declarations <?> "parameter default definitions"
+          mbProps <- optional do
+            anyWhitespace
+            loc_sats <- tokAlpha "satisfying"
+            props    <- properties <?> "parameter range properties"
+            pure ( loc_sats, props )
+          anyWhitespace
+          loc_def <- tokAlpha "define"
+          e <- expr
+          pure $
+            let
+              ( locs, props ) = case mbProps of
+                Nothing ->
+                  ( [ Location ( location loc_with )
+                    , Location ( location loc_def  ) ]
+                  , []
+                  )
+                Just ( loc_sats, sat_props ) ->
+                  ( [ Location ( location loc_with )
+                    , Location ( location loc_sats )
+                    , Location ( location loc_def  ) ]
+                  , sat_props
+                  )
+            in
+              With locs ( P_With decls ) props e
+      <?> "with statement"
+      )
+
+  spline <-
+    Earley.rule 
+    ( do
+        start <- special '['
+        p0 <- expr <?> "first point of spline"
+        openCurves <- many     $ curveTo @Open   expr <?> "open curve to"
+        mbClosed   <- optional $ curveTo @Closed expr <?> "closed curve"
+        anyWhitespace
+        end <- special ']'
+        pure $
+          ( \ opens -> \ case 
+            Nothing     ->
+              PolyBez
+                [ Location ( location start ), Location ( location end ) ]
+                ( Spline p0 ( OpenCurves   opens ) )
+            Just closed ->
+              PolyBez
+                [ Location ( location start ), Location ( location end ) ]
+                ( Spline p0 ( ClosedCurves opens closed ) )
+          ) ( Seq.fromList openCurves ) mbClosed
+    <?> "spline" ) 
+
+  simpleExpr <- Earley.rule do
+    anyWhitespace
+    res <- app <|> let_statement
+    pure res
+  expr <- Earley.mixfixExpressionSeparate mixfixTable simpleExpr
+
+  pure ( with_statement <|> expr )
+
+-- | Reserved alphabetic identifiers.
+reserved :: Set Text
+reserved
+  = Set.fromList
+  [ "let", "in"
+  , "with", "set", "satisfying"
+  , "around", "by", "rotate", "scale", "shear", "translate", "transform"
+  , "cw", "ccw"
+  , "pi", "tau", "kappa"
+  ]
+{-
+[ "=", "_", "@", "--", "->" ]
+-}
+
+dots :: Earley.Prod r Text ( Located Token ) ( Located Token )
+dots = Earley.satisfy ( located >>> \case { TokSymbolic s | Text.all ( == '.' ) s -> True; _ -> False } )
+
+locatedToken :: Token -> Earley.Prod r Text ( Located Token ) ( Located Token )
+locatedToken t = Earley.satisfy ( located >>> ( == t ) )
+
+tokAlpha, ws_tokAlpha :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
+tokAlpha t = Earley.satisfy
+  ( located >>> \case { TokAlphabetic a | Text.map Char.toLower a == t -> True; _ -> False } )
+  <?> t
+ws_tokAlpha t = anyWhitespace *> tokAlpha t
+
+tokSymbol, ws_tokSymbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
+tokSymbol t = locatedToken ( TokSymbolic t ) <?> t
+ws_tokSymbol t = anyWhitespace *> tokSymbol t
+
+tokOrientation :: Earley.Prod r Text ( Located Token ) ( Located Token )
+tokOrientation = anyWhitespace *> ( tokAlpha "ccw" <|> tokAlpha "cw" )
+
+orientation :: Token -> Orientation
+orientation ( TokAlphabetic ori )
+  | Text.map Char.toLower ori == "ccw"
+  = CCW
+  | Text.map Char.toLower ori == "cw"
+  = CW
+orientation tok = error ( "orientation: unexpected token " <> show tok )
+
+curveTo
+  :: forall clo r
+  .  SplineTypeI clo
+  => Earley.Prod r Text ( Located Token ) Expr
+  -> Earley.Prod r Text ( Located Token ) ( Curve clo [ Located () ] Expr )
+curveTo expr = do
+  anyWhitespace
+  cps <- optional do
+    locTo1 <- symbol "--"
+    cp1 <- expr
+    anyWhitespace
+    mb_cp2 <- optional do
+      locTo2 <- symbol "--"
+      cp2 <- expr
+      anyWhitespace
+      pure ( locTo2, cp2 )
+    pure ( ( locTo1, cp1), mb_cp2 )
+  locTo3 <- symbol "->"
+  mkCurve <- case ssplineType @clo of
+    SClosed ->
+      let
+        mkCurve
+          :: Located Token
+          -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
+          -> Span
+          -> Curve Closed [ Located () ] Expr
+        mkCurve ( Located dotsLoc _ ) mbCps loc3 = case mbCps of
+          Nothing ->
+            LineTo BackToStart [ Location loc3, Location dotsLoc ]
+          Just ( ( Located loc1 _, cp1 ), Nothing  ) ->
+            Bezier2To cp1 BackToStart [ Location loc1, Location loc3, Location dotsLoc ]
+          Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
+            Bezier3To cp1 cp2 BackToStart [ Location loc1, Location loc2, Location loc3, Location dotsLoc ]
+      in do
+        anyWhitespace
+        locatedDots <- dots
+        pure ( mkCurve locatedDots )
+    SOpen ->
+      let
+        mkCurve
+          :: Expr
+          -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
+          -> Span
+          -> Curve Open [ Located () ] Expr
+        mkCurve p mbCps loc3 = case mbCps of
+          Nothing ->
+            LineTo ( NextPoint p ) [ Location loc3 ]
+          Just ( ( Located loc1 _, cp1 ), Nothing  ) ->
+            Bezier2To cp1 ( NextPoint p ) [ Location loc1, Location loc3 ]
+          Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
+            Bezier3To cp1 cp2 ( NextPoint p ) [ Location loc1, Location loc2, Location loc3 ]
+      in do
+        p <- expr
+        pure ( mkCurve p )
+  pure ( mkCurve cps ( location locTo3 ) )
+
+mixfixTable
+  ::  [ [ 
+        ( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) )
+        , Earley.Associativity
+        , Earley.Holey ( Located Token ) -> [ Expr ] -> Expr 
+        )
+      ] ]
+mixfixTable
+  = [ [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just $ ws_tokAlpha "around", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located lr _ ), _, Just ( Located la _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _ ), _ ] [ p, c, theta ] ->
+          let
+            ori :: Orientation
+            ori = orientation ori_tok
+            opName :: Text
+            opName = case ori of { CW -> "rotate_around_cwby_"; CCW -> "rotate_around_ccwby_" }
+          in
+            Op [ Location lr, Location la, Location lo, Location lb ]
+              opName ( rotate_around_by ori )
+                :$ p :$ c :$ theta
+      )
+    , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "around", Nothing, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located ls _ ), _, Just ( Located la _ ), _, Just ( Located lb _ ), _ ] [ p, c, r ] ->
+        Op [ Location ls, Location la, Location lb ]
+          "scale_around_by_" scale_around_by
+            :$ p :$ c :$ r
+      )
+    , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "from", Nothing, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located ls _ ), _, Just ( Located lf _ ), _, Just ( Located lb _ ), _ ] [ p, c, v ] ->
+        Op [ Location ls, Location lf, Location lb ]
+          "shear_from_by_" shear_from_by
+            :$ p :$ c :$ v
+      )
+    ]
+  , [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located lr _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _), _ ] [ p, theta ] ->
+          let
+            ori :: Orientation
+            ori = orientation ori_tok
+            opName :: Text
+            opName = case ori of { CW -> "rotate_around_cw_"; CCW -> "rotate_around_ccw_" }
+          in
+            Op [ Location lr, Location lo, Location lb ]
+              opName ( rotate_by ori )
+                :$ p :$ theta
+      )
+    , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \  [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, r ] ->
+        Op [ Location ls, Location lb ]
+          "scale_by_" scale_by
+            :$ p :$ r
+      )
+    , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "along", Nothing, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, v ] ->
+        Op [ Location ls, Location lb ]
+          "shear_along_by_" shear_by
+            :$ p :$ v
+      )
+    , ( [ Just $ ws_tokAlpha "translate", Nothing, Just $ ws_tokAlpha "by", Nothing ]
+      , Earley.NonAssoc
+      , \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ p, t ] ->
+        Op [ Location lt, Location lb ]
+          "translate_by_" translate_by
+            :$ p :$ t
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "||", Nothing ]
+      , Earley.RightAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(||)" (||)
+            :$ a :$ b
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "&&", Nothing ]
+      , Earley.RightAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(&&)" (&&)
+            :$ a :$ b
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "<", Nothing ]
+      , Earley.NonAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(<)" ( (<) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol "<=", Nothing ]
+      , Earley.NonAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(<=)" ( (<=) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol ">", Nothing ]
+      , Earley.NonAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(>)" ( (>) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol ">=", Nothing ]
+      , Earley.NonAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(>=)" ( (>=) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol "==", Nothing ]
+      , Earley.NonAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(==)" ( (==) @Double )
+            :$ a :$ b
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "+", Nothing ]
+      , Earley.LeftAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(+)" ( (+) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol "-", Nothing ]
+      , Earley.LeftAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(-)" ( (-) @Double )
+            :$ a :$ b
+      )
+    , ( [ Just $ ws_tokSymbol "-", Nothing ]
+      , Earley.RightAssoc
+      , \ [ Just ( Located l _ ), _ ] [ a ] ->
+        Op [ Location l ]
+          "negate" ( negate @Double )
+            :$ a
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "*", Nothing ]
+      , Earley.LeftAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(*)" ( (*) @Double )
+            :$ a :$ b
+      )
+    , ( [ Nothing, Just $ ws_tokSymbol "/", Nothing ]
+      , Earley.LeftAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(/)" ( (/) @Double )
+            :$ a :$ b
+      )
+    ]
+  , [ ( [ Nothing, Just $ ws_tokSymbol "^", Nothing ]
+      , Earley.RightAssoc
+      , \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
+        Op [ Location l ]
+          "(^)" ( (**) @Double )
+            :$ a :$ b
+      )
+    ]
+  ]
+
+numericLiteral :: Located Token -> Maybe Expr
+numericLiteral ( Located l ( TokNumeric x ) ) = Just $ Lit @Double ( Located l Nothing ) x
+numericLiteral _                              = Nothing
+
+number :: Earley.Prod r Text ( Located Token ) Expr
+number = Earley.terminal numericLiteral
+  <?> "number"
+
+identifier :: Earley.Prod r Text ( Located Token ) Expr
+identifier =
+        number
+    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "pi"    ) )    pi      ) <$> tokAlpha "pi"
+    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "tau"   ) ) ( 2 * pi ) ) <$> tokAlpha "tau"
+    <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "kappa" ) )    kappa   ) <$> tokAlpha "kappa"
+    <|> ( ( \ n -> Var n ) <$> alphabeticName
+         <?> "identifier"
+        )
+
+
+
+whitespace, anyWhitespace :: Earley.Prod r Text ( Located Token ) ()
+whitespace    = Earley.terminal $ located >>> \case { TokWhitespace _ -> Just (); _ -> Nothing }
+anyWhitespace = void $ many whitespace
+
+significantWhitespace :: Earley.Prod r Text ( Located Token ) ()
+significantWhitespace = Earley.terminal ( located >>> \case { TokWhitespace True -> Just (); _ -> Nothing } )
+  <?> "newline"
+
+separator :: Earley.Prod r Text ( Located Token ) ()
+separator =
+    ( void ( some significantWhitespace )
+      <|> ( void ( anyWhitespace *> special ';' <* anyWhitespace ) )
+    )
+  <?> "separator"
+
+alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text )
+alphabeticName =
+  Earley.terminal \case 
+   Located l ( TokAlphabetic x )
+     | not ( x `Set.member` reserved )
+     -> Just ( Located l x )
+   _ -> Nothing
+
+special :: Char -> Earley.Prod r Text ( Located Token ) ( Located Token )
+special c = locatedToken ( TokSpecial c ) <?> Text.singleton c
+
+symbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
+symbol s = locatedToken ( TokSymbolic s ) <?> s
+
+wildcard :: Earley.Prod r Text ( Located Token ) EPat
+wildcard = Earley.terminal
+  \case
+    Located l ( TokWildcard x ) -> Just ( PWild ( Located l x ) )
+    _ -> Nothing
+  <?> "wildcard pattern"
+
+--------------------------------------------------------------------------------
+-- Tokenizer.
+
+isSpecial :: Char -> Bool
+isSpecial c = Set.member c ( Set.fromList "(){}[],;`\"" )
+
+data Token
+  = TokWhitespace Bool
+  | TokSpecial    Char
+  | TokAlphabetic Text
+  | TokNumeric    Double
+  | TokWildcard   Text
+  | TokSymbolic   Text
+  | OtherTok      Text
+  deriving stock ( Show, Eq, Ord )
+
+showToken :: Token -> String
+showToken ( TokWhitespace False ) = " "
+showToken ( TokWhitespace True  ) = "\n"
+showToken ( TokSpecial    s ) = [s]
+showToken ( TokAlphabetic a ) = Text.unpack a
+showToken ( TokNumeric    x ) = show x
+showToken ( TokWildcard   w ) = Text.unpack w
+showToken ( TokSymbolic   s ) = Text.unpack s
+showToken ( OtherTok      t ) = Text.unpack t
+
+tokenize :: Text -> [ Located Token ]
+tokenize = go 1 1
+  where
+    go :: Int -> Int -> Text -> [ Located Token ]
+    go sr sc t = case Text.uncons t of
+      Nothing -> []
+      Just ( x, xs )
+        -- White space.
+        | Char.isSpace x
+        , let
+            ( ys, rest ) = Text.span Char.isSpace xs
+            ( er1, er2, ec ) =
+              Text.foldl'
+                ( \ (r1,r2,c) -> \ case
+                      '\n' -> (r1+1,r2,1)
+                      '\r' -> (r1,r2+1,1)
+                      '\t' -> (r1,r2,c+2)
+                      '\f' -> (r1,r2,c)
+                      '\v' -> (r1,r2,c)
+                      _    -> (r1,r2,c+1)
+                )
+                (sr,sr,sc)
+                ( x `Text.cons` ys )
+            er = max er1 er2
+        -> if er > sr
+          then  Located ( Span sr sc er ec ) ( TokWhitespace True  ) : go er ec rest
+          else  Located ( Span sr sc er ec ) ( TokWhitespace False ) : go er ec rest
+        -- Special characters.
+        | isSpecial x
+        -> Located ( Span sr sc sr ( sc + 1 ) ) ( TokSpecial x )
+        : go sr ( sc + 1 ) xs
+        -- Alphabetic identifier.
+        | Char.isAlpha x
+        , let
+            ( ys, rest ) = Text.span ( \case { '\'' -> True; '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
+            tok = x `Text.cons` ys
+            l = Text.length tok
+        -> Located ( Span sr sc sr ( sc + l ) ) ( TokAlphabetic tok )
+        : go sr ( sc + l ) rest
+        -- Numeric identifier.
+        | Just ( locTok@Located { location = Span { endRow, endCol } }, rest ) <- tokenizeNumeric sr sc t
+        -> locTok
+        : go endRow endCol rest
+        -- Wildcard.
+        | '_' <- x
+        , let
+            ( ys, rest ) = Text.span ( \case { '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
+            tok :: Text
+            tok = x `Text.cons` ys
+            l = Text.length tok
+        -> Located ( Span sr sc sr ( sc + l ) ) ( TokWildcard tok )
+        : go sr ( sc + l ) rest
+        -- Symbolic identifier.
+        | Char.isSymbol x || Char.isPunctuation x
+        , let
+            ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c || Char.isAlphaNum c ) xs
+            tok = x `Text.cons` ys
+            l = Text.length tok
+        -> Located ( Span sr sc sr ( sc + l ) ) ( TokSymbolic tok )
+        : go sr ( sc + l ) rest
+        -- Fallback.
+        | let
+            ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c ) xs
+            tok = x `Text.cons` ys
+            l = Text.length tok
+        -> Located ( Span sr sc sr ( sc + l ) ) ( OtherTok tok )
+        : go sr ( sc + l ) rest
+
+-- Tokenize a numeric literal (without any leading sign).
+tokenizeNumeric :: Int -> Int -> Text -> Maybe ( Located Token, Text )
+tokenizeNumeric sr sc t = case Text.span Char.isDigit t of
+  -- Integer part of the mantissa.
+  ( integ, rest )
+    | not ( Text.null integ )
+    -> case Text.uncons rest of
+        Just ( c, rest' )
+        -- Fraction.
+          | c == '.'
+          ->
+            -- Fractional part of the mantissa. 
+            let ( frac, rest'' ) = Text.span Char.isDigit rest'
+            in case Text.uncons rest'' of
+                  Just ( c', rest''' )
+                  -- Fraction followed by exponent.
+                    | c' == 'e' || c' == 'E'
+                    , Just ( expo, rest'''' ) <- spanExponent rest'''
+                    , Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac <> "e" <> expo )
+                    , Text.null leftover
+                    , let
+                        l = Text.length integ + 1 + Text.length frac + 1 + Text.length expo
+                    -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'''' )
+                  -- Simple fraction (no exponent).
+                  _ | Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac )
+                    , Text.null leftover
+                    , let
+                        l = Text.length integ + 1 + Text.length frac
+                    -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
+                  _ -> Nothing
+        -- Positive integer followed by exponent.
+          | c == 'e' || c == 'E'
+          , Just ( expo, rest'' ) <- spanExponent rest'
+          , Right ( r, leftover ) <- Text.Read.double ( integ <> "e" <> expo )
+          , Text.null leftover
+          , let
+              l = Text.length integ + 1 + Text.length expo
+          -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
+        -- Simple positive integer (no fractional part or exponent).
+        _ | Right ( r, leftover ) <- Text.Read.double integ
+          , Text.null leftover
+          , let
+              l = Text.length integ
+          -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest )
+        _ -> Nothing
+  _ -> Nothing
+
+spanExponent :: Text -> Maybe ( Text, Text )
+spanExponent t = case Text.uncons t of
+  Just ( x, xs )
+    | x == '+' || x == '-' || Char.isDigit x
+    , let
+        ( ds, rest ) = Text.span Char.isDigit xs
+    -> Just ( Text.cons x ds, rest )
+  _ -> Nothing

src/app/MetaBrush/MetaParameter/PrimOp.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module MetaBrush.MetaParameter.PrimOp where
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D(..) )
+
+--------------------------------------------------------------------------------
+-- Operations supported by the DSL.
+
+data Orientation = CCW | CW
+  deriving stock Show
+
+kappa :: Double
+kappa = 0.5519150244935105707435627227925
+-- root of (Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]
+
+rotate_around_by :: Orientation -> Point2D Double -> Point2D Double -> Double -> Point2D Double
+rotate_around_by ori ( Point2D px py ) ( Point2D cx cy ) theta =
+  translate_by ( rotate_by ori ( Point2D ( px - cx ) ( py - cy ) ) theta ) ( Point2D cx cy )
+rotate_by :: Orientation -> Point2D Double  -> Double -> Point2D Double
+rotate_by CCW ( Point2D px py ) theta = Point2D ( c * px - s * py ) ( c * py + s * px )
+  where
+    c, s :: Double
+    c = cos theta
+    s = sin theta
+rotate_by CW  p theta = rotate_by CCW p ( -theta ) 
+
+scale_around_by :: Point2D Double -> Point2D Double -> Point2D Double  -> Point2D Double
+scale_around_by ( Point2D px py ) ( Point2D cx cy ) ( Point2D rx ry ) = Point2D ( rx * ( px - cx ) + cx ) ( ry * ( py - cy ) + cy )
+scale_by :: Point2D Double -> Point2D Double -> Point2D Double
+scale_by ( Point2D px py ) ( Point2D rx ry ) = Point2D ( rx * px ) ( ry * py )
+
+shear_from_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
+shear_from_by ( Point2D px py ) ( Point2D cx cy ) v =
+  translate_by ( shear_by ( Point2D ( px - cx ) ( py - cy ) ) v ) ( Point2D cx cy )
+shear_by :: Point2D Double -> Point2D Double -> Point2D Double
+shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined
+
+translate_by :: Point2D Double -> Point2D Double -> Point2D Double
+translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty )

src/app/MetaBrush/MetaParameter/Rename.hs

@@ -0,0 +1,240 @@
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DerivingStrategies  #-}
+{-# LANGUAGE EmptyCase           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+module MetaBrush.MetaParameter.Rename
+  ( rename, MonadRn, RnM
+  , RnMessage, RnError
+  , RnState, emptyRnState
+  , Env(..), UniqueName(..)
+  )
+  where
+
+-- base
+import Data.Foldable
+  ( for_ )
+import GHC.Generics
+  ( Generic )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( lookup )
+
+-- dlist
+import Data.DList
+  ( DList )
+import qualified Data.DList as DList
+  ( singleton )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- lens
+import Control.Lens
+  ( assign, at, modifying, use )
+
+-- mtl
+import Control.Monad.State
+  ( MonadState(..) )
+import Control.Monad.Writer
+  ( MonadWriter(..) )
+
+-- text
+import Data.Text
+  ( Text )
+
+-- transformers
+import Control.Monad.Trans.RWS.CPS
+  ( RWST )
+
+-- MetaBrush
+import Math.Bezier.Spline
+  ( KnownSplineType(bitraverseSpline), bitraverseCurve )
+import MetaBrush.MetaParameter.AST
+  ( Located(..)
+  , Pass(P,Rn), Name, UniqueName(..), X_With(..)
+  , Term(..), Decl(..), Pat(..)
+  )
+import MetaBrush.MetaParameter.Parse
+  ( ) -- AST type family instances for parsing pass
+import MetaBrush.Unique
+  ( UniqueSupply, MonadUnique(freshUnique)
+  , Unique
+  )
+
+--------------------------------------------------------------------------------
+-- Renaming pass.
+
+rename :: MonadRn m => Term P '() -> m ( Term Rn '() )
+rename ( f :$ a ) = (:$) <$> locally ( rename f ) <*> locally ( rename a )
+rename ( Var locv@( Located l v ) ) = do
+  mbRes <- use ( field' @"localEnv" . field' @"rnLocalVars" . at v )
+  case mbRes of
+    Nothing -> do
+      rnError ( OutOfScope locv )
+      uniq' <- freshUnique
+      pure $ Var ( Located l ( UniqueName v uniq' ) )
+    Just uniq ->
+      pure $ Var ( Located l ( UniqueName v uniq ) )
+rename ( Lit l a ) = pure ( Lit l a )
+rename ( Op locs nm op ) = pure ( Op locs nm op )
+rename ( Point locs a b ) = Point locs <$> locally ( rename a ) <*> locally ( rename b )
+rename ( Line locs p1 p2 ) = Line locs <$> locally ( rename p1 ) <*> locally ( rename p2 )
+rename ( Bez2 locs p1 p2 p3 ) = Bez2 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 )
+rename ( Bez3 locs p1 p2 p3 p4 ) = Bez3 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) <*> locally ( rename p4 )
+rename ( PolyBez locs spline ) = PolyBez locs <$>
+  bitraverseSpline
+    ( const $ bitraverseCurve pure ( const $ locally . rename ) )
+    ( locally . rename )
+    spline
+rename ( Let locs decls body ) = do
+  decls' <- renameDecls decls
+  body'  <- rename body
+  pure ( Let locs decls' body' )
+rename ( With locs ( P_With decls ) conds body ) = do
+  decls' <- renameDecls decls
+  conds' <- traverse ( locally . rename ) conds
+  body'  <- rename body
+  pure ( With locs ( Rn_With decls' ) conds' body' )
+
+renameDecls :: forall m. MonadRn m => [ Decl P ] -> m [ Decl Rn ]
+renameDecls decls = do
+  outerLocalVars <- use ( field' @"localEnv" . field' @"rnLocalVars" )
+  assign ( field' @"localEnv" . field' @"rnLocalVars" ) mempty
+  decls' <- go outerLocalVars decls
+  pure decls'
+
+  where
+
+    go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ]
+    go outerLocalVars ( Decl loc lhs rhs : next ) = do
+      -- Collect all the declarations from the left-hand sides.
+      lhs'  <- renameLhs outerLocalVars lhs
+      next' <- go outerLocalVars next
+      -- Now rename each right-hand side with the full LHS info.
+      rhs'  <- locally ( rename rhs )
+      pure $ Decl loc lhs' rhs' : next'
+    go outerLocalVars [] = do
+      -- Finished handling all the left-hand sides:
+      --   add all the declared names to the existing (outer) names,
+      --   shadowing the outer names if necessary.
+      modifying ( field' @"localEnv" . field' @"rnLocalVars" ) ( <> outerLocalVars )
+      pure []
+
+    renameLhs :: Map Text Unique -> Pat P '() -> m ( Pat Rn '() )
+    renameLhs outerLocalVars ( PName locPat@( Located l nm ) ) = do
+      mbUniq <- use ( field' @"localEnv" . field' @"rnLocalVars" . at nm )
+      case mbUniq of
+        Just uniq -> do
+          rnError ( DuplicateDecl uniq locPat )
+          uniq' <- freshUnique
+          pure $ PName ( Located l ( UniqueName nm uniq' ) )
+        Nothing -> do
+          let
+            mbPrevUniq :: Maybe Unique 
+            mbPrevUniq = Map.lookup nm outerLocalVars
+          uniq <- freshUnique
+          for_ mbPrevUniq \ prevUniq -> do
+            rnWarning ( NameShadowing prevUniq ( Located l ( UniqueName nm uniq ) ) )
+          assign ( field' @"localEnv"  . field' @"rnLocalVars"  . at nm   ) ( Just uniq   )
+          assign ( field' @"globalEnv" . field' @"rnGlobalVars" . at uniq ) ( Just locPat )
+          pure $ PName ( Located l ( UniqueName nm uniq ) )
+    renameLhs outerLocalVars ( PPoint l p1 p2 ) = PPoint l <$> renameLhs outerLocalVars p1 <*> renameLhs outerLocalVars p2
+    renameLhs _ ( PWild wild ) = pure ( PWild wild )
+    renameLhs outerLocalVars ( AsPat atLoc locName pat ) = do
+      name' <- renameLhs outerLocalVars ( PName locName )
+      case name' of
+        PName locName' -> do
+          pat' <- renameLhs outerLocalVars pat
+          pure $ AsPat atLoc locName' pat'
+        _ -> error "renameLHS: internal error"
+
+
+--------------------------------------------------------------------------------
+-- Renamer-specific data and instances.
+
+data RnLocalEnv
+  = RnLocalEnv
+    { rnLocalVars :: !( Map Text Unique ) }
+  deriving stock ( Show, Generic )
+
+data RnGlobalEnv
+  = RnGlobalEnv
+    { rnGlobalVars :: !( Map Unique ( Located Text ) ) }
+  deriving stock ( Show, Generic )
+
+data Env global local
+  = Env
+  { globalEnv :: !global
+  , localEnv  :: !local
+  }
+  deriving stock    ( Show, Generic )
+
+type RnState = Env RnGlobalEnv RnLocalEnv
+
+emptyRnState :: RnState
+emptyRnState = Env ( RnGlobalEnv mempty ) ( RnLocalEnv mempty )
+
+locally :: MonadState ( Env global local ) m => m a -> m a
+locally action = do
+  Env { localEnv } <- get
+  res <- action
+  assign ( field' @"localEnv" ) localEnv
+  pure res
+
+data RnMessage
+  = RnWarningMessage
+    { rnWarningMessage :: !RnWarning
+    , rnMessageState   :: !RnState
+    }
+  | RnErrorMessage
+    { rnErrorMessage :: !RnError
+    , rnMessageState :: !RnState
+    }
+  deriving stock ( Show, Generic )
+
+data RnError
+  = OutOfScope    !( Located Text )
+  | DuplicateDecl 
+    { prevDecl :: !Unique
+    , dupDecl  :: !( Located Text )
+    }
+  deriving stock ( Show, Generic )
+
+data RnWarning
+  = NameShadowing 
+  { shadowedUnique :: !Unique
+  , shadowingName  :: !( Located UniqueName )
+  }
+  deriving stock ( Show, Generic )
+
+rnError
+  :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
+  => RnError -> m ()
+rnError err = do
+  st <- get
+  tell ( DList.singleton $ RnErrorMessage err st )
+
+rnWarning
+  :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
+  => RnWarning -> m ()
+rnWarning warn = do
+  st <- get
+  tell ( DList.singleton $ RnWarningMessage warn st )
+
+type RnM = RWST UniqueSupply ( DList RnMessage ) RnState IO
+type MonadRn m = ( MonadUnique m, MonadState RnState m, MonadWriter ( DList RnMessage ) m )
+
+type instance Name Rn = UniqueName

src/app/MetaBrush/MetaParameter/TypeCheck.hs

@@ -0,0 +1,446 @@
+{-# LANGUAGE BlockArguments         #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE DerivingStrategies     #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE MagicHash              #-}
+{-# LANGUAGE NamedFieldPuns         #-}
+{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE PartialTypeSignatures  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE UndecidableInstances   #-}
+
+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
+
+module MetaBrush.MetaParameter.TypeCheck
+  ( typeCheck, MonadTc, TcM
+  , TcMessage, TcError
+  , TcState, emptyTcState
+  )
+  where
+
+import Data.Kind
+  ( Type )
+
+-- base
+import Data.Either
+  ( partitionEithers )
+import Data.Functor.Compose
+  ( Compose(..) )
+import Data.List
+  ( sortBy )
+import Data.Ord
+  ( comparing )
+import Data.Proxy
+  ( Proxy )
+import Data.Type.Equality
+  ( (:~:)(Refl) )
+import GHC.Exts
+  ( Proxy#, proxy# )
+import GHC.Generics
+  ( Generic )
+import GHC.TypeLits
+  ( someSymbolVal, SomeSymbol(..) )
+import GHC.TypeNats
+  ( KnownNat )
+import Unsafe.Coerce
+  ( unsafeCoerce )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import Data.Sequence
+  ( Seq(..) )
+
+-- dlist
+import Data.DList
+  ( DList )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- lens
+import Control.Lens
+  ( assign, at, use )
+
+-- mtl
+import Control.Monad.Except
+  ( MonadError(..) )
+import Control.Monad.State
+  ( MonadState(..) )
+import Control.Monad.Writer
+  ( MonadWriter(..) )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( (:=)(..), FldProxy(..), RecSize, RecApply
+  , RecTy, RemoveAccessTo, RecVecIdxPos
+  , TraversalCHelper
+  , unsafeRNil, unsafeRCons
+  )
+
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( unpack )
+
+-- transformers
+import Control.Monad.Trans.RWS.CPS
+  ( RWST )
+import Control.Monad.Trans.Except
+  ( ExceptT )
+
+-- MetaBrush
+import Math.Bezier.Spline
+  ( Spline(..), Curve(..), Curves(..)
+  , SSplineType(..), SplineTypeI(ssplineType)
+  , bitraverseCurve, KnownSplineType(bitraverseSpline)
+  , NextPoint(..)
+  )
+import Math.Vector2D
+  ( Point2D(..) )
+import MetaBrush.MetaParameter.AST
+  ( Span(..), Located(..)
+  , Pass(Rn,Tc)
+  , Pat(..), Decl(..)
+  , X_With(..), MapFields
+  , UniqueTerm, UniqueField(..), IsUniqueTerm, IsUniqueTerm2
+  , SType(..), STypeI(sTypeI), SomeSType(..)
+  , STypes(..), STypesI(..)
+  , Term(..), TypedTerm(..), eqTy
+  , termSpan
+  )
+import MetaBrush.MetaParameter.Rename
+  ( Env(..), UniqueName(..) )
+import MetaBrush.Unique
+  ( UniqueSupply, MonadUnique, Unique )
+
+--------------------------------------------------------------------------------
+
+typeCheckAt
+  :: forall ( a :: Type ) m
+  .  ( STypeI a, MonadTc m )
+  => Text
+  -> Term Rn '() -> m ( Term Tc a )
+typeCheckAt mismatchMessage term = do
+  TypedTerm ( x :: Term Tc x ) <- typeCheck term
+  case eqTy @a @x of
+    Just Refl -> pure x
+    Nothing   ->
+      tcError $
+        UnexpectedType
+          mismatchMessage
+          ( "Expected: ",                             SomeSType ( proxy# :: Proxy# a ) )
+          ( "  Actual: ", Located ( termSpan term ) $ SomeSType ( proxy# :: Proxy# x ) )
+
+typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm
+typeCheck ( uf :$ ua ) = do
+  TypedTerm ( f :: Term Tc f ) <- typeCheck uf
+  case sTypeI @f of
+    sFunTy@SFunTy | ( _ :: SType ( b -> c ) ) <- sFunTy
+      -> do
+        TypedTerm ( a :: Term Tc a ) <- typeCheck ua
+        case eqTy @a @b of
+          Just Refl -> pure ( TypedTerm @c ( f :$ a ) )
+          Nothing   -> tcError $
+            UnexpectedType
+              "Unexpected function argument type"
+              ( "Expected: ", SomeSType ( proxy# :: Proxy# b ) )
+              ( "  Actual: ", Located ( termSpan ua ) $ SomeSType ( proxy# :: Proxy# a ) )
+    _ -> tcError $
+      OverSaturatedFunctionApplication
+        ( Located ( termSpan uf ) ( SomeSType ( proxy# :: Proxy# f ) ) )
+        ( termSpan ua )
+typeCheck ( Var locVar@( Located _ ( UniqueName _ uniq ) ) ) = do
+  mbType <- use ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
+  case mbType of
+    Just ( SomeSType ( _ :: Proxy# a ) ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
+    Nothing -> tcError ( OutOfScope locVar )
+typeCheck ( Let loc decls body ) = do
+  decls' <- typeCheckDecls decls
+  TypedTerm body' <- typeCheck body
+  pure ( TypedTerm $ Let loc decls' body' )
+typeCheck ( With locs ( Rn_With decls ) conds body ) = do
+  decls' <- typeCheckDecls decls
+  conds' <- traverse ( typeCheckAt @Bool "Expected Boolean condition, but expression has the wrong type." ) conds
+  TypedTerm body' <- typeCheck body
+  withDeclsRecord decls' \ ( decls'Record :: Super.Rec ( MapFields UniqueTerm kvs ) ) -> do
+    case unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueTerm kvs ) :~: SuperRecord.RecSize kvs of
+      Refl ->
+        case treeArgsDict @kvs @kvs of
+          RecTreeArgsDict ->
+            TypedTerm $ With locs ( Tc_With decls'Record ) conds' body'
+typeCheck ( Lit loc a ) = pure ( TypedTerm $ Lit loc a )
+typeCheck ( Op locs nm op ) = pure ( TypedTerm $ Op locs nm op )
+typeCheck ( Point locs a b ) = do
+  TypedTerm ( a' :: Term Tc a ) <- typeCheck a
+  TypedTerm ( b' :: Term Tc b ) <- typeCheck b
+  case eqTy @a @b of
+    Just Refl -> pure ( TypedTerm $ Point locs a' b' )
+    Nothing   ->
+      tcError $
+        MismatchedTypes
+          "Components of a point with different types."
+          ( "1st component: ", Located ( termSpan a ) ( SomeSType ( proxy# :: Proxy# a ) ) )
+          ( "2nd component: ", Located ( termSpan b ) ( SomeSType ( proxy# :: Proxy# b ) ) )
+typeCheck ( Line {} ) = error "typeCheck: error, unexpected 'line'"
+typeCheck ( Bez2 {} ) = error "typeCheck: error, unexpected 'bez2'"
+typeCheck ( Bez3 {} ) = error "typeCheck: error, unexpected 'bez3'"
+typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline clo [ Located () ] ( Term Rn '() ) ) ) = do
+  TypedTerm ( start' :: Term Tc pt ) <- typeCheck splineStart
+  case sTypeI @pt of
+    sTy@STyPoint
+      | ( _ :: SType ( Point2D a ) ) <- sTy
+      -> case sTypeI @a of
+        STyDouble -> let
+            tcPoint :: Term Rn '() -> m ( Term Tc pt )
+            tcPoint = typeCheckAt @pt "Unexpected Bézier spline coordinate type"
+          in case ssplineType @clo of
+            SClosed -> do
+              spline' <-
+                bitraverseSpline
+                  ( const $ bitraverseCurve pure ( const tcPoint ) ) tcPoint spline
+              pure ( TypedTerm $ PolyBez locs spline' )
+            SOpen   -> case splineCurves of
+              OpenCurves Empty ->
+                pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves Empty ) ) )
+              OpenCurves ( crv :<| Empty ) -> case crv of
+                LineTo          ( NextPoint p1 ) _ -> do
+                  p1' <- tcPoint p1
+                  pure ( TypedTerm $ Line locs start' p1' )
+                Bezier2To    p1 ( NextPoint p2 ) _ -> do
+                  p1' <- tcPoint p1
+                  p2' <- tcPoint p2
+                  pure ( TypedTerm $ Bez2 locs start' p1' p2' )
+                Bezier3To p1 p2 ( NextPoint p3 ) _ -> do
+                  p1' <- tcPoint p1
+                  p2' <- tcPoint p2
+                  p3' <- tcPoint p3
+                  pure ( TypedTerm $ Bez3 locs start' p1' p2' p3' )
+              OpenCurves crvs -> do
+                crvs' <- traverse ( traverse tcPoint ) crvs
+                pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves crvs' ) ) )
+        _ ->
+          tcError $
+            UnexpectedType
+              "Unexpected Bézier spline coordinate type"
+              ( "Expected: ", SomeSType ( proxy# :: Proxy# Double ) )
+              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# a ) )
+    _ -> tcError $
+            UnexpectedType
+              "Unexpected Bézier spline point type"
+              ( "Expected: ", SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+              ( "  Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# pt ) )
+
+typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ]
+typeCheckDecls = go []
+  where
+    go :: [ Decl Tc ] -> [ Decl Rn ] -> m [ Decl Tc ]
+    go dones [] = pure dones
+    go dones todos = do
+
+      ( not_oks, oks ) <-
+        partitionEithers
+         <$> traverse
+              ( \ decl -> ( `catchError` ( catchOutOfScope decl ) ) ( fmap Right $ typeCheckDecl decl ) )
+              todos
+      case oks of
+        [] -> traverse ( throwError . snd ) not_oks
+        _  -> go ( dones ++ oks ) ( fmap fst not_oks )
+
+    catchOutOfScope :: Decl Rn -> TcError -> m ( Either ( Decl Rn, TcError ) ( Decl Tc ) )
+    catchOutOfScope decl err@( OutOfScope {} ) = pure ( Left ( decl, err ) )
+    catchOutOfScope _    err                   = throwError err
+
+typeCheckDecl :: MonadTc m => Decl Rn -> m ( Decl Tc )
+typeCheckDecl ( Decl loc lhs rhs ) = do
+  TypedTerm ( rhs' :: Term Tc a ) <- typeCheck rhs
+  lhs' <- typeCheckPatAt @a lhs
+  pure ( Decl loc lhs' rhs' )
+
+typeCheckPatAt :: forall ( a :: Type ) m. ( STypeI a, MonadTc m ) => Pat Rn '() -> m ( Pat Tc a )
+typeCheckPatAt ( PName nm@( Located _ ( UniqueName _ uniq ) ) ) = do
+  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
+  pure ( PName nm )
+typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
+  sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair
+    -> do
+      pat1' <- typeCheckPatAt @c pat1
+      pat2' <- typeCheckPatAt @c pat2
+      pure ( PPoint locs pat1' pat2' )
+  _ -> tcError $
+         UnexpectedPatType
+         "RHS of let binding does not have the expected type"
+         ( "Expected type: ", Located ( foldMap location locs ) $ SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
+         ( "  Actual type: ", SomeSType ( proxy# :: Proxy# a ) )
+typeCheckPatAt ( PWild nm ) = pure ( PWild nm )
+typeCheckPatAt ( AsPat symbLoc nm@( Located _ ( UniqueName _ uniq ) ) pat ) = do
+  pat' <- typeCheckPatAt @a pat
+  assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
+  pure ( AsPat symbLoc nm pat' )
+
+withDeclsRecord
+  :: forall r m
+  .  ( MonadTc m )
+  => [ Decl Tc ]
+  -> ( forall kvs. STypesI kvs => Super.Rec ( MapFields UniqueTerm kvs ) -> r )
+  -> m r
+withDeclsRecord decls f = do
+  TypedTermsRecord record <- go ( TypedTermsRecord $ SuperRecord.unsafeRNil lg ) <$> ( revSortDecls decls )
+  pure ( f record )
+  where
+    lg :: Int
+    lg = length decls
+    -- This list cannot have duplicate names,
+    -- as these would have been caught by the renamer.
+    -- Sort in reverse order as we must add elements in decreasing label order.
+    revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ]
+    revSortDecls = fmap ( sortBy ( flip $ comparing fst ) ) . traverse getDeclName
+    getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) )
+    getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of
+      PName   ( Located _ uniq@( UniqueName nm _ ) )   -> pure ( nm, ( uniq, TypedTerm term ) )
+      AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) )
+      _                                                -> tcError $ NoPatternName loc
+    go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord
+    go record [] = record
+    go  ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) )
+        ( ( nm, ( uniq, TypedTerm ( t :: Term Tc a ) ) ) : ps )
+      = case someSymbolVal ( Text.unpack nm ) of
+          SomeSymbol ( _ :: Proxy nm ) ->
+            go
+              ( TypedTermsRecord @( ( nm SuperRecord.:= a ) ': kvs )
+              $ SuperRecord.unsafeRCons @nm @( UniqueTerm a ) @( MapFields UniqueTerm kvs )
+                ( SuperRecord.FldProxy @nm SuperRecord.:= Compose ( UniqueField uniq t ) )
+                record
+              )
+              ps
+
+data TypedTermsRecord where
+  TypedTermsRecord
+    :: ( STypesI kvs, ts ~ MapFields UniqueTerm kvs, KnownNat ( SuperRecord.RecSize ts ) )
+    => Super.Rec ts -> TypedTermsRecord
+
+data RecTreeArgsDict rts lts where
+  RecTreeArgsDict
+    :: forall rts lts trts tlts frts flts
+    .  ( trts ~ MapFields UniqueTerm  rts, tlts ~ MapFields UniqueTerm  lts
+       , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
+       , SuperRecord.RecApply trts tlts IsUniqueTerm
+       , SuperRecord.TraversalCHelper flts trts frts IsUniqueTerm2
+       )
+    => RecTreeArgsDict rts lts
+
+treeArgsDict
+  :: forall rts lts trts tlts frts flts
+  .  ( trts ~ MapFields UniqueTerm  rts, tlts ~ MapFields UniqueTerm  lts
+     , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
+     , STypesI lts
+     , KnownNat ( SuperRecord.RecSize rts )
+     )
+  => RecTreeArgsDict rts lts
+treeArgsDict = case sTypesI @lts of
+  STyNil
+    | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize frts :~: SuperRecord.RecSize rts )
+    -> RecTreeArgsDict
+  sTyCons@STyCons
+    | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs ) ) <- sTyCons
+    , Refl <- ( unsafeCoerce Refl :: MapFields UniqueTerm lvs :~: SuperRecord.RemoveAccessTo l ( MapFields UniqueTerm lvs ) )
+    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy l trts :~: Just ( UniqueTerm v ) )
+    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos l trts :~: SuperRecord.RecSize lvs )
+    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize trts :~: SuperRecord.RecSize rts )
+    , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize lvs :~: SuperRecord.RecSize ( MapFields UniqueField lvs ) )
+    -> case treeArgsDict @rts @lvs of
+          RecTreeArgsDict -> RecTreeArgsDict
+
+
+--------------------------------------------------------------------------------
+-- Type-checker-specific data and instances.
+
+data TcLocalEnv
+  = TcLocalEnv
+  deriving stock ( Show, Generic )
+
+data TcGlobalEnv
+  = TcGlobalEnv
+    { tcGlobalVarTys :: !( Map Unique SomeSType )
+    , tyGlovalVars   :: !( Map Unique ( Located Text ) )
+    }
+  deriving stock ( Show, Generic )
+
+data TcMessage
+  = TcWarningMessage
+    { tcWarningMessage :: !TcWarning
+    , tcMessageState   :: !TcState
+    }
+  | TcErrorMessage
+    { tcErrorMessage :: !TcError
+    , tcMessageState :: !TcState
+    }
+  deriving stock ( Show, Generic )
+
+data TcError
+  = MismatchedTypes
+  { additionalErrorText :: !Text
+  , expectedLType       :: !( Text, Located SomeSType )
+  , actualLType         :: !( Text, Located SomeSType )
+  }
+  | UnexpectedType
+  { additionalErrorText :: !Text
+  , expectedType        :: !( Text, SomeSType )
+  , actualLType         :: !( Text, Located SomeSType )
+  }
+  | UnexpectedPatType
+  { additionaLErrorText :: !Text
+  , expectedPatType     :: !( Text, Located SomeSType )
+  , actualRHSType       :: !( Text, SomeSType )
+  }
+  | OverSaturatedFunctionApplication
+  { functionLType :: !( Located SomeSType )
+  , argument      :: !Span
+  }
+  | NoPatternName
+  { declarationSpan :: !Span
+  }
+  | OutOfScope
+  { outOfScopeVar :: !( Located UniqueName ) }
+  deriving stock ( Show, Generic )
+
+data TcWarning = TcWarning
+  deriving stock ( Show, Generic )
+
+type TcState = Env TcGlobalEnv TcLocalEnv
+
+emptyTcState :: TcState
+emptyTcState = Env ( TcGlobalEnv mempty mempty ) TcLocalEnv
+
+type TcM = ExceptT TcError ( RWST UniqueSupply ( DList TcMessage ) TcState IO )
+type MonadTc m =
+  ( MonadUnique m
+  , MonadState TcState m
+  , MonadWriter ( DList TcMessage ) m
+  , MonadError TcError m
+  )
+
+tcError
+  :: ( MonadError TcError m )
+  => TcError -> m a
+tcError err = throwError err
+
+{-
+tcWarning
+  :: ( MonadState TcState m, MonadWriter ( DList TcMessage ) m )
+  => TcWarning -> m ()
+tcWarning warn = do
+  st <- get
+  tell ( DList.singleton $ TcWarningMessage warn st )
+-}

src/app/MetaBrush/Render/Document.hs

@@ -5,13 +5,16 @@
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MagicHash             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE NegativeLiterals      #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeOperators         #-}
 
 module MetaBrush.Render.Document
   ( renderDocument, blankRender )
@@ -28,8 +31,8 @@ import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
   ( Int32 )
-import Data.Maybe
+import GHC.Exts
-  ( catMaybes )
+  ( Proxy#, proxy# )
 import GHC.Generics
   ( Generic, Generic1 )
 
@@ -44,8 +47,6 @@ import Data.Act
 -- containers
 import Data.Sequence
   ( Seq(..) )
-import qualified Data.Sequence as Seq
-  ( fromList )
 import Data.Set
   ( Set )
 
@@ -54,15 +55,21 @@ import Generic.Data
   ( Generically1(..) )
 
 -- generic-lens
-import Data.Generics.Product.Typed
+import Data.Generics.Product.Fields
-  ( HasType )
+  ( field' )
 
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
 -- lens
 import Control.Lens
-  ( view )
+  ( view, set )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( Intersect, rnil )
 
 -- transformers
 import Control.Monad.Trans.Class
@@ -77,8 +84,15 @@ import Math.Bezier.Cubic.Fit
   ( FitPoint(..), FitParameters )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..) )
+import Math.Bezier.Spline
+  ( Spline(..), SplinePts, PointType(..)
+  , SplineType(..), SplineTypeI, KnownSplineType(bifoldSpline)
+  , Curve(..)
+  , fromNextPoint
+  , catMaybesSpline
+  )
 import Math.Bezier.Stroke
-  ( StrokePoint(..), stroke )
+  ( CachedStroke(..), computeStrokeOutline )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Asset.Colours
@@ -90,15 +104,23 @@ import MetaBrush.Context
 import MetaBrush.Document
   ( Document(..), DocumentContent(..)
   , mkAABB
-  , Stroke(..), FocusState(..)
+  , Stroke(..), StrokeSpline
+  , FocusState(..)
   , HoverContext(..), Hoverable(..)
-  , PointData(..), BrushPointData(..)
+  , PointData(..), Brush(..), emptyBrush
   , _selection
+  , coords
   )
 import MetaBrush.Document.Selection
   ( dragUpdate )
+import MetaBrush.Document.Serialise
+  ( ) -- 'Serialisable' instances
 import MetaBrush.Document.Update
   ( DocChange(..) )
+import MetaBrush.MetaParameter.AST
+  ( AdaptableFunction(..), BrushFunction )
+import MetaBrush.MetaParameter.Interpolation
+  ( MapDiff )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Util
@@ -127,25 +149,32 @@ toAll action = Compose ( pure action )
 --------------------------------------------------------------------------------
 
 blankRender :: Colours -> Cairo.Render ()
-blankRender ( Colours {..} ) = pure ()
+blankRender _ = pure ()
 
 renderDocument
   :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
   -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
   -> Document 
-  -> Cairo.Render ()
+  -> ( Maybe Document, Cairo.Render () )
 renderDocument
-  cols params mode debug ( viewportWidth, viewportHeight ) 
+  cols fitParams mode debug ( viewportWidth, viewportHeight ) 
   modifiers mbMousePos mbHoldEvent mbPartialPath
   doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
-  = do
+    = ( mbUpdatedDoc, drawingInstructions )
 
+    where
+
+      drawingInstructions :: Cairo.Render ()
+      drawingInstructions = do
         Cairo.save
         Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
         Cairo.scale zoomFactor zoomFactor
         Cairo.translate ( -cx ) ( -cy )
+        for_ strokesWithOutlineInfo
+          ( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor )
+        renderSelectionRect
+        Cairo.restore
   
-    let
       renderSelectionRect :: Cairo.Render ()
       mbHoverContext :: Maybe HoverContext
       ( renderSelectionRect, mbHoverContext )
@@ -156,16 +185,19 @@ renderDocument
         = ( pure (), MouseHover <$> mbMousePos )
 
       modifiedStrokes :: [ Stroke ]
-      modifiedStrokes
+      noModifiedStrokes :: Bool
-        | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
+      ( modifiedStrokes, noModifiedStrokes )
+        | PathMode <- mode
+        , Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
         , Just p1 <- mbMousePos
         , p0 /= p1
         , let
             alternateMode :: Bool
             alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
-        , Just docUpdate <- dragUpdate mode p0 p1 dragAction alternateMode doc
+        , Just docUpdate <- dragUpdate p0 p1 dragAction alternateMode doc
-        = strokes . documentContent $ newDocument docUpdate
+        = ( strokes . documentContent $ newDocument docUpdate, False )
-        | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
+        | PathMode <- mode
+        , Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
         , let
             mbFinalPoint :: Maybe ( Point2D Double )
             mbControlPoint :: Maybe ( Point2D Double )
@@ -176,40 +208,107 @@ renderDocument
               = ( mbMousePos, Nothing )
         , Just finalPoint <- mbFinalPoint
         , let
-            previewPts :: Seq ( StrokePoint PointData )
+            previewSpline :: Spline Open CachedStroke ( PointData ( Super.Rec '[] ) )
-            previewPts
+            previewSpline = catMaybesSpline ( CachedStroke Nothing )
-              = Seq.fromList
+              ( PointData p0 Normal SuperRecord.rnil )
-              $ catMaybes
+              ( do
-              [ Just ( PathPoint p0 ( PointData Normal Empty ) )
-              , do
                   cp <- cp0
                   guard ( cp /= p0 )
-                  pure $ ControlPoint cp ( PointData Normal Empty )
+                  pure ( PointData cp Normal SuperRecord.rnil )
-              , do
+              )
+              ( do
                   cp <- mbControlPoint
                   guard ( cp /= finalPoint )
-                  pure $ ControlPoint cp ( PointData Normal Empty )
+                  pure ( PointData cp Normal SuperRecord.rnil )
-              , Just ( PathPoint finalPoint ( PointData Normal Empty ) )
+              )
-              ]
+              ( PointData finalPoint Normal SuperRecord.rnil )
-        = ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } )
+        = ( ( Stroke
+               { strokeSpline  = previewSpline
+               , strokeVisible = True
+               , strokeUnique  = undefined
+               , strokeName    = undefined
+               , strokeBrush   = emptyBrush
+               }
+            )
           : strokes content
+          , False 
+          )
         | otherwise
-        = strokes content
+        = ( strokes content, True )
 
-    for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor )
+      strokesWithOutlineInfo :: [ ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) ) ]
-    renderSelectionRect
+      strokesWithOutlineInfo =
+        fmap
+          ( \ stroke@(
+                Stroke
+                  { strokeSpline = spline :: StrokeSpline clo ( Super.Rec pointFields )
+                  , strokeBrush  =
+                      strokeBrush@(
+                        BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields }
+                      )
+                  , ..
+                  } ) ->
+            if strokeVisible
+            then
+              case ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) of
+                ( _ :: Proxy# usedFields ) ->
+                  let
+                    -- Get the adaptable brush shape (function),
+                    -- specialising it to the type we are using.
+                    toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
+                    brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
+                    ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
 
-    Cairo.restore
+                    -- Compute the outline using the brush function.
+                    newSpline :: Spline clo CachedStroke ( PointData ( Super.Rec pointFields ) )
+                    outline :: Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
+                    fitPts :: Seq FitPoint
+                    ( newSpline, outline, fitPts ) =
+                      computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
+                        fitParams ( toUsedParams . brushParams ) brushShapeFn spline
+                  in ( Stroke { strokeSpline = newSpline, .. } , Just ( outline, fitPts ) )
+            else ( stroke , Nothing )
+          )
+          modifiedStrokes
 
-    pure ()
+      mbUpdatedDoc :: Maybe Document
+      mbUpdatedDoc
+        | noModifiedStrokes
+        = let
+            newDoc :: Document
+            newDoc =
+              set ( field' @"documentContent" . field' @"strokes" ) 
+                ( modifiedStrokes )
+                doc
+          in Just newDoc
+        | otherwise
+        = Nothing -- TODO: update the original document in this case too (by undoing the modifications)
 
-renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Bool -> Double -> Stroke -> Compose Renders Cairo.Render ()
+
-renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom ( Stroke { strokePoints = pts, strokeVisible } )
+renderStroke
+  :: Colours -> Maybe HoverContext -> Mode -> Bool -> Double 
+  -> ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) )
+  -> Compose Renders Cairo.Render ()
+renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom
+  ( Stroke
+    { strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
+    , strokeVisible
+    , strokeBrush = BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields }
+    }
+  , mbOutlineData )
     | strokeVisible
-  = renderStrokePoints cols mode mbHoverContext zoom
+    , ( _ :: Proxy# usedFields ) <- proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields )
-      ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) )
+    , let
-      pts
+        -- Get the adaptable brush shape (function),
-  *> Compose blank { renderStrokes = drawStroke cols debug zoom ( stroke params pts ) }
+        -- specialising it to the type we are using.
+        toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
+        brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
+        ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
+    = renderStrokeSpline cols mode mbHoverContext zoom
+        ( when ( mode == BrushMode ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ( brushShapeFn . toUsedParams ) )
+        strokeSpline
+    *> for_ mbOutlineData \outlineData ->
+        Compose blank { renderStrokes = drawOutline cols debug zoom outlineData }
     | otherwise
     = pure ()
 
@@ -217,98 +316,102 @@ renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom (
 --
 -- Accepts a sub-function for additional rendering of each stroke point
 -- (e.g. overlay a brush shape over each stroke point).
-renderStrokePoints
+renderStrokeSpline
-  :: forall d
+  :: forall clo crvData pointData
-  .  ( Show d, HasType FocusState d )
+  .  ( Show pointData, KnownSplineType clo )
   => Colours -> Mode -> Maybe HoverContext -> Double
-  -> ( StrokePoint d -> Compose Renders Cairo.Render () )
+  -> ( PointData pointData -> Compose Renders Cairo.Render () )
-  -> Seq ( StrokePoint d )
+  -> Spline clo crvData ( PointData pointData )
   -> Compose Renders Cairo.Render ()
-renderStrokePoints _ _ _ _ _ Empty = pure ()
+renderStrokeSpline cols mode mbHover zoom renderSubcontent spline =
-renderStrokePoints cols mode mbHover zoom renderSubcontent ( pt0 :<| pts ) =
+  bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline
-  Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols mbHover zoom pt0 }
-  *> renderSubcontent pt0
-  *> go pt0 pts
-    where
-      go :: StrokePoint d -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render ()
-      go _ Empty = pure ()
-      go ( ControlPoint {} ) _ = error "renderStrokePoints: path starts with a control point"
-      -- Line.
-      go p0 ( p1 :<| ps )
-        | PathPoint {} <- p1
-        = Compose blank
-            { renderPPts
-              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p1
-            , renderPath
-              = unless ( mode == Meta ) $ drawLine cols zoom p0 p1
-             }
-        *> renderSubcontent p1
-        *> go p1 ps
-      -- Quadratic Bézier curve.
-      go p0 ( p1 :<| p2 :<| ps )
-        | ControlPoint {} <- p1
-        , PathPoint    {} <- p2
-        = Compose blank
-            { renderCLines
-              = when   ( mode == Path ) do
-                drawLine cols zoom p0 p1
-                drawLine cols zoom p1 p2
-            , renderCPts
-              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p1
-            , renderPPts
-              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p2
-            , renderPath
-              = unless ( mode == Meta ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
-            }
-        *> renderSubcontent p1
-        *> renderSubcontent p2
-        *> go p2 ps
-      -- Cubic Bézier curve.
-      go p0 ( p1 :<| p2 :<| p3 :<| ps )
-        | ControlPoint {} <- p1
-        , ControlPoint {} <- p2
-        , PathPoint    {} <- p3
-        = Compose blank
-            { renderCLines
-              = when   ( mode == Path ) do
-                drawLine cols zoom p0 p1
-                drawLine cols zoom p2 p3
-            , renderCPts
-              = when   ( mode == Path ) do
-                drawPoint cols mbHover zoom p1
-                drawPoint cols mbHover zoom p2
-            , renderPPts
-              = when   ( mode == Path ) $ drawPoint cols mbHover zoom p3
-            , renderPath
-              = unless ( mode == Meta ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
-            }
-        *> renderSubcontent p1
-        *> renderSubcontent p2
-        *> renderSubcontent p3
-        *> go p3 ps
-      go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 
-renderBrushShape :: Colours -> Maybe HoverContext -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render ()
+  where
-renderBrushShape cols mbHoverContext zoom pt =
+    renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render ()
+    renderSplinePoint sp0
+      =  Compose blank { renderPPts = when ( mode == PathMode ) $ drawPoint cols mbHover zoom PathPoint sp0 }
+      *> renderSubcontent sp0
+    renderSplineCurve
+      :: forall clo'
+      .  SplineTypeI clo'
+      => PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render ()
+    renderSplineCurve start p0 ( LineTo np1 _ )
+      = Compose blank
+          { renderPPts =
+            when   ( mode == PathMode ) $
+              for_ np1 \ p1 ->
+                drawPoint cols mbHover zoom PathPoint p1
+          , renderPath =
+            unless ( mode == MetaMode ) $
+                drawLine  cols         zoom PathPoint p0 ( fromNextPoint start np1 )
+          }
+      *> for_ np1 \ p1 -> renderSubcontent p1
+    renderSplineCurve start p0 ( Bezier2To p1 np2 _ )
+      = Compose blank
+          { renderCLines
+            = when   ( mode == PathMode ) do
+              drawLine cols zoom ControlPoint p0 p1
+              drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 )
+          , renderCPts
+            = when   ( mode == PathMode ) $ drawPoint cols mbHover zoom ControlPoint p1
+          , renderPPts
+            = when   ( mode == PathMode ) $
+                for_ np2 \ p2 ->
+                  drawPoint cols mbHover zoom PathPoint    p2
+          , renderPath
+            = unless ( mode == MetaMode ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } )
+          }
+      *> renderSubcontent p1
+      *> for_ np2 \ p2 -> renderSubcontent p2
+    renderSplineCurve start p0 ( Bezier3To p1 p2 np3 _ )
+      = Compose blank
+          { renderCLines
+            = when   ( mode == PathMode ) do
+              drawLine cols zoom ControlPoint p0 p1
+              drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 )
+          , renderCPts
+            = when   ( mode == PathMode ) do
+              drawPoint cols mbHover zoom ControlPoint p1
+              drawPoint cols mbHover zoom ControlPoint p2
+          , renderPPts
+            = when   ( mode == PathMode ) $
+                for_ np3 \ p3 ->
+                  drawPoint cols mbHover zoom PathPoint p3
+          , renderPath
+            = unless ( mode == MetaMode ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } )
+          }
+      *> renderSubcontent p1
+      *> renderSubcontent p2
+      *> for_ np3 \ p3 -> renderSubcontent p3
+
+renderBrushShape
+  :: Colours -> Maybe HoverContext -> Double
+  -> ( brushParams -> SplinePts Closed )
+  -> PointData brushParams
+  -> Compose Renders Cairo.Render ()
+renderBrushShape cols mbHoverContext zoom brushFn pt =
   let
     x, y :: Double
     Point2D x y = coords pt
-    brushPts :: Seq ( StrokePoint BrushPointData )
+    brushPts :: SplinePts Closed
-    brushPts = brushShape ( pointData pt )
+    brushPts = brushFn ( brushParams pt )
     mbHoverContext' :: Maybe HoverContext
     mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext
   in
     toAll do
       Cairo.save
       Cairo.translate x y
-    *> renderStrokePoints cols Path mbHoverContext' zoom ( const $ pure () ) brushPts
+    *> renderStrokeSpline cols PathMode mbHoverContext' zoom ( const $ pure () )
+        ( fmap ( \ p -> PointData p Normal () ) brushPts )
     *> Compose blank { renderPPts = drawCross cols zoom }
     *> toAll Cairo.restore
 
-drawPoint :: HasType FocusState d => Colours -> Maybe HoverContext -> Double -> StrokePoint d -> Cairo.Render ()
+drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
-drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
   = do
   let
+    x, y :: Double
+    Point2D x y = coords pt
     hsqrt3 :: Double
     hsqrt3 = sqrt 0.75
     selectionState :: FocusState
@@ -340,9 +443,11 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y }
 
   Cairo.restore
 
-drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y } )
+drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
   = do
   let
+    x, y :: Double
+    Point2D x y = coords pt
     selectionState :: FocusState
     selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
 
@@ -369,8 +474,8 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y
 
   Cairo.restore
 
-drawLine :: Colours -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render ()
+drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cairo.Render ()
-drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
+drawLine ( Colours { path, controlPoint } ) zoom pointType p1 p2 = do
   let
     x1, y1, x2, y2 :: Double
     Point2D x1 y1 = coords p1
@@ -380,11 +485,11 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
   Cairo.moveTo x1 y1
   Cairo.lineTo x2 y2
 
-  case ( p1, p2 ) of
+  case pointType of
-    ( PathPoint {}, PathPoint {} ) -> do
+    PathPoint -> do
       Cairo.setLineWidth ( 5 / zoom )
       withRGBA path Cairo.setSourceRGBA
-    _ -> do
+    ControlPoint -> do
       Cairo.setLineWidth ( 3 / zoom )
       withRGBA controlPoint Cairo.setSourceRGBA
   Cairo.stroke
@@ -418,16 +523,16 @@ drawCubicBezier ( Colours { path } ) zoom
 
   Cairo.restore
 
-drawStroke
+drawOutline
   :: Colours -> Bool -> Double
-  -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint )
+  -> ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint )
   -> Cairo.Render ()
-drawStroke cols@( Colours {..} ) debug zoom strokeData = do
+drawOutline cols@( Colours {..} ) debug zoom strokeData = do
   Cairo.save
   withRGBA brushStroke Cairo.setSourceRGBA
   case strokeData of
     ( Left outline, fitPts ) -> do
-      go outline
+      makeOutline outline
       case debug of
         False -> Cairo.fill
         True  -> do
@@ -437,8 +542,8 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
           Cairo.stroke
           ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
     ( Right ( fwd, bwd ), fitPts ) -> do
-      go fwd
+      makeOutline fwd
-      go bwd
+      makeOutline bwd
       case debug of
         False -> Cairo.fill
         True  -> do
@@ -448,36 +553,30 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
           Cairo.stroke
           ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
   Cairo.restore
-
   where
-    go :: Seq ( StrokePoint () ) -> Cairo.Render ()
+    makeOutline :: SplinePts Closed -> Cairo.Render ()
-    go ( p@( PP ( Point2D x y ) ) :<| ps ) = Cairo.moveTo x y *> go' p ps
+    makeOutline spline = bifoldSpline
-    go _ = pure ()
+      ( drawCurve ( splineStart spline ) )
+      ( \ ( Point2D x y ) -> Cairo.moveTo x y )
+      spline
 
-    go' :: StrokePoint () -> Seq ( StrokePoint () ) -> Cairo.Render ()
+    drawCurve :: forall clo. SplineTypeI clo => Point2D Double -> Point2D Double -> Curve clo () ( Point2D Double ) -> Cairo.Render ()
-    go' _ Empty = pure ()
+    drawCurve start ( Point2D x0 y0 ) crv = case crv of
-    -- Line.
+      LineTo mp1 _ ->
-    go' _ ( p1@( PP ( Point2D x1 y1 ) ) :<| ps ) =
+        let Point2D x1 y1 = fromNextPoint start mp1
-      do
+        in Cairo.lineTo x1 y1
-        Cairo.lineTo x1 y1
+      Bezier2To ( Point2D x1 y1 ) mp2 _ ->
-        go' p1 ps
+        let Point2D x2 y2 = fromNextPoint start mp2
-    -- Quadratic Bézier curve.
+        in Cairo.curveTo
-    go' ( PP ( Point2D x0 y0 ) ) ( CP ( Point2D x1 y1 ) :<| p2@( PP ( Point2D x2 y2 ) ) :<| ps ) =
-      do
-        Cairo.curveTo
               ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
               ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
               x2 y2
-        go' p2 ps
+      Bezier3To ( Point2D x1 y1 ) ( Point2D x2 y2 ) mp3 _ ->
-    -- Cubic Bézier curve.
+        let Point2D x3 y3 = fromNextPoint start mp3
-    go' _ ( CP ( Point2D x1 y1 ) :<| CP ( Point2D x2 y2 ) :<| p3@( PP ( Point2D x3 y3 ) ) :<| ps ) =
+        in Cairo.curveTo x1 y1 x2 y2 x3 y3
-      do
-        Cairo.curveTo x1 y1 x2 y2 x3 y3
-        go' p3 ps
-    go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 
 drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
-drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
+drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do
 
   hue <- get
   put ( hue + 0.01 )
@@ -492,7 +591,7 @@ drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
     Cairo.fill
     Cairo.restore
 
-drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
+drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
 
   hue <- get
   put ( hue + 0.01 )

src/app/MetaBrush/UI/Coordinates.hs

@@ -1,4 +1,9 @@
-{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeApplications           #-}
 
 module MetaBrush.UI.Coordinates
@@ -6,6 +11,10 @@ module MetaBrush.UI.Coordinates
   where
 
 -- base
+import Data.Coerce
+  ( coerce )
+import Data.Functor.Identity
+  ( Identity(..) )
 import Data.Semigroup
   ( ArgMin, Arg(..), Min(..) )
 
@@ -17,23 +26,23 @@ import Data.Act
     ( (-->) )
   )
 
--- containers
-import Data.Sequence
-  ( Seq(..) )
-
 -- MetaBrush
 import qualified Math.Bezier.Cubic     as Cubic
   ( Bezier(..), closestPoint )
 import qualified Math.Bezier.Quadratic as Quadratic
   ( Bezier(..), closestPoint )
-import Math.Bezier.Stroke
+import Math.Bezier.Spline
-  ( StrokePoint(..) )
+  ( Curve(..), Spline(..), SplineTypeI, KnownSplineType(bifoldSpline)
+  , fromNextPoint
+  )
 import Math.Module
-  ( (*^), squaredNorm, closestPointToSegment )
+  ( (*^), squaredNorm, closestPointOnSegment )
 import Math.Vector2D
-  ( Point2D(..), Vector2D(..) )
+  ( Point2D(..), Vector2D(..), Segment(..) )
 import MetaBrush.Document
-  ( Stroke(..), PointData(..) )
+  ( Stroke(..), PointData(..)
+  , coords
+  )
 
 --------------------------------------------------------------------------------
 
@@ -45,29 +54,40 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
 
 -- | Find the closest point in a set of strokes.
 closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
-closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = go pt0 pts
+closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
+  coerce $
+    bifoldSpline @_ @Identity
+      ( closestPointToCurve ( splineStart strokeSpline ) )
+      ( res . coords )
+      strokeSpline
   where
-    res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
+    res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
-    res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
+    res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
-    go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> ArgMin Double ( Maybe ( Point2D Double ) )
+
-    go ( ControlPoint {} ) _ = error "closestPoint: path starts with a control point"
+    closestPointToCurve
-    go p0 Empty = res ( coords p0 )
+      :: forall clo crvData brushParams
-    -- Line.
+      .  SplineTypeI clo
-    go ( PathPoint { coords = p0 } )
+      => PointData brushParams
-      ( sp1@( PathPoint { coords = p1 } ) :<| ps )
+      -> PointData brushParams
-      = res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 )
+      -> Curve clo crvData ( PointData brushParams )
-      <> go sp1 ps
+      -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
-    -- Quadratic Bézier curve.
+    closestPointToCurve start p0 ( LineTo p1 _ ) =
-    go ( PathPoint { coords = p0 } )
+      res ( snd $ closestPointOnSegment @( Vector2D Double ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) )
-      ( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps )
+    closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $
-      = fmap ( fmap ( Just . snd ) )
+      fmap ( fmap ( Just . snd ) )
-        ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c )
+        ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c )
-      <> go sp2 ps
+    closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
-    -- Cubic Bézier curve.
+      fmap ( fmap ( Just . snd ) )
-    go ( PathPoint { coords = p0 } )
+        ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
-      ( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps )
+closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
-      = fmap ( fmap ( Just . snd ) )
+
-        ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c )
+-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( Point2D Double ) )`
-      <> go sp3 ps
+newtype BoundedDouble = BoundedDouble Double
-    go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
+  deriving stock   Show
-closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing
+  deriving newtype ( Eq, Ord )
+instance Bounded BoundedDouble where
+  minBound = BoundedDouble ( -1 / 0 )
+  maxBound = BoundedDouble (  1 / 0 )
+instance Bounded ( Arg BoundedDouble ( Maybe b ) ) where
+  minBound = Arg minBound Nothing
+  maxBound = Arg maxBound Nothing

src/app/MetaBrush/UI/FileBar.hs

@@ -44,6 +44,10 @@ import qualified Control.Concurrent.STM      as STM
 import qualified Control.Concurrent.STM.TVar as STM
   ( writeTVar, readTVar, readTVarIO, modifyTVar' )
 
+-- transformers
+import Control.Monad.Trans.Reader
+  ( runReaderT )
+
 -- MetaBrush
 import MetaBrush.Action
   ( SwitchTo(..), Close(..), handleAction )
@@ -97,7 +101,7 @@ newFileTab
   -> IO ()
 newFileTab
   initialStage
-  uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
+  uiElts@( UIElements { fileBar = FileBar {..}, .. } )
   vars@( Variables {..} )
   mbDocHist
   newTabLoc
@@ -108,7 +112,7 @@ newFileTab
       Just docHist -> do pure docHist
       -- Create a new empty document.
       Nothing -> do
-        newDocUniq <- STM.atomically $ freshUnique uniqueSupply
+        newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
         pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
 
     let

src/app/MetaBrush/UI/ToolBar.hs

@@ -49,9 +49,9 @@ data Tool
   deriving stock ( Show, Eq )
 
 data Mode
-  = Path
+  = PathMode
-  | Brush
+  | BrushMode
-  | Meta
+  | MetaMode
   deriving stock ( Show, Eq )
 
 data ToolBar
@@ -82,13 +82,13 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
   metaTool  <- GTK.radioButtonNewFromWidget ( Just pathTool )
 
   _ <- GTK.onButtonClicked pathTool do
-    STM.atomically $ STM.writeTVar modeTVar Path
+    STM.atomically $ STM.writeTVar modeTVar PathMode
     GTK.widgetQueueDraw drawingArea
   _ <- GTK.onButtonClicked brushTool do
-    STM.atomically $ STM.writeTVar modeTVar Brush
+    STM.atomically $ STM.writeTVar modeTVar BrushMode
     GTK.widgetQueueDraw drawingArea
   _ <- GTK.onButtonClicked metaTool do
-    STM.atomically $ STM.writeTVar modeTVar Meta
+    STM.atomically $ STM.writeTVar modeTVar MetaMode
     GTK.widgetQueueDraw drawingArea
 
 

src/app/MetaBrush/UI/ToolBar.hs-boot

@@ -16,9 +16,9 @@ data Tool
 instance Show Tool
 
 data Mode
-  = Path
+  = PathMode
-  | Brush
+  | BrushMode
-  | Meta
+  | MetaMode
 
 instance Show Mode
 

src/app/MetaBrush/Unique.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE BlockArguments             #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 module MetaBrush.Unique
-  ( Unique, unsafeUnique
+  ( MonadUnique(freshUnique)
-  , freshUnique, uniqueText
+  , Unique, unsafeUnique
+  , uniqueText
   , UniqueSupply, newUniqueSupply
   , uniqueMapFromList
   )
@@ -41,9 +46,15 @@ import Data.Generics.Product.Typed
 import Control.Lens
   ( view )
 
+-- mtl
+import Control.Monad.Reader
+  ( MonadReader(..) )
+
 -- stm
 import Control.Concurrent.STM
   ( STM )
+import qualified Control.Concurrent.STM as STM
+  ( atomically )
 import qualified Control.Concurrent.STM.TVar as STM
   ( TVar, newTVarIO, readTVar, writeTVar )
 
@@ -53,11 +64,19 @@ import Data.Text
 import qualified Data.Text as Text
   ( pack )
 
+-- transformers
+import Control.Monad.IO.Class
+  ( MonadIO(..) )
+import Control.Monad.Trans.Class
+  ( lift )
+import Control.Monad.Trans.Reader
+  ( ReaderT )
+
 --------------------------------------------------------------------------------
 
 newtype Unique = Unique { unique :: Int64 }
   deriving stock   Show
-  deriving newtype ( Eq, Ord, Storable, NFData )
+  deriving newtype ( Eq, Ord, Enum, Storable, NFData )
 
 unsafeUnique :: Word32 -> Unique
 unsafeUnique i = Unique ( - fromIntegral i - 1 )
@@ -71,14 +90,29 @@ uniqueText ( Unique i )
 
 newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique }
 
-freshUnique :: UniqueSupply -> STM Unique
+instance Show UniqueSupply where { show _ = "Unique supply" }
-freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
-  uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
-  STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
-  pure uniq
 
 newUniqueSupply :: IO UniqueSupply
 newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
 
 uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
 uniqueMapFromList = Map.fromList . map ( view typed &&& id )
+
+class Monad m => MonadUnique m where
+  freshUnique :: m Unique
+
+instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where
+  freshUnique = do
+    UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) <$> ask
+    liftIO $ STM.atomically do
+      uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
+      STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
+      pure uniq
+
+instance MonadUnique ( ReaderT UniqueSupply STM ) where
+  freshUnique = do
+    UniqueSupply { uniqueSupplyTVar } <- ask
+    lift do
+      uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
+      STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
+      pure uniq

src/lib/Math/Bezier/Cubic.hs

@@ -179,7 +179,7 @@ ddist ( Bezier {..} ) c = [ a5, a4, a3, a2, a1, a0 ]
 closestPoint
   :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
   => Bezier p -> p -> ArgMin r ( r, p )
-closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
+closestPoint pts c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
   where
     roots :: [ r ]
     roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c )

src/lib/Math/Bezier/Cubic/Fit.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE DerivingStrategies  #-}
@@ -40,12 +41,16 @@ import Data.Act
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
-  ( fromList, singleton )
+  ( fromList )
 
 -- deepseq
 import Control.DeepSeq
   ( NFData )
 
+-- parallel
+import qualified Control.Parallel.Strategies as Parallel.Strategy
+  ( rdeepseq, parTuple2, using )
+
 -- primitive
 import Data.Primitive.PrimArray
   ( primArrayFromListN, unsafeThawPrimArray )
@@ -67,6 +72,10 @@ import qualified Data.Vector.Unboxed         as Unboxed.Vector
 -- MetaBrush
 import qualified Math.Bezier.Cubic as Cubic
   ( Bezier(..), bezier, ddist )
+import Math.Bezier.Spline
+  ( SplineType(..), SplinePts
+  , openCubicBezierCurveSpline
+  )
 import Math.Epsilon
   ( epsilon )
 import Math.Linear.Solve
@@ -119,7 +128,7 @@ data FitPoint
 fitSpline
   :: FitParameters
   -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
-  -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint )
+  -> ( SplinePts Open, Seq FitPoint )
 fitSpline ( FitParameters {..} ) = go 0
   where
     dt :: Double
@@ -127,26 +136,32 @@ fitSpline ( FitParameters {..} ) = go 0
     go
       :: Int
       -> ( Double -> ( Point2D Double, Vector2D Double ) )
-      -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint )
+      -> ( SplinePts Open, Seq FitPoint )
-    go subdiv curve =
+    go subdiv curveFn =
       let
         p, r :: Point2D Double
         tp, tr :: Vector2D Double
         qs :: [ Point2D Double ]
-        (p, tp) = curve 0
+        (p, tp) = curveFn 0
-        (r, tr) = curve 1
+        (r, tr) = curveFn 1
-        qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
+        qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
       in
         case fitPiece dist_tol t_tol maxIters p tp qs r tr of
           ( bez, Max ( Arg max_sq_error t_split ) )
             |  subdiv >= maxSubdiv
             || max_sq_error <= dist_tol ^ ( 2 :: Int )
-            -> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
+            -> ( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
             | let
                 t_split_eff :: Double
                 t_split_eff = min ( 1 - dt ) $ max dt t_split
-            -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff )
+                c1, c2 :: SplinePts Open
-            <> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) )
+                ps1, ps2 :: Seq FitPoint
+                ( ( c1, ps1 ), ( c2, ps2 ) )
+                  = ( go ( subdiv + 1 ) ( \ t -> curveFn $ t * t_split_eff )
+                    , go ( subdiv + 1 ) ( \ t -> curveFn $ t_split_eff + t * ( 1 - t_split_eff ) )
+                    ) `Parallel.Strategy.using`
+                       ( Parallel.Strategy.parTuple2 Parallel.Strategy.rdeepseq Parallel.Strategy.rdeepseq )
+            -> ( c1 <> c2, ps1 <> ps2 )
 
 -- | Fits a single cubic Bézier curve to the given data.
 --

src/lib/Math/Bezier/Quadratic.hs

@@ -147,7 +147,7 @@ ddist ( Bezier {..} ) c = [ a3, a2, a1, a0 ]
 closestPoint
   :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
   => Bezier p -> p -> ArgMin r ( r, p )
-closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots )
+closestPoint pts c = pickClosest ( 0 :| 1 : roots )
   where
     roots :: [ r ]
     roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c ) 

src/lib/Math/Bezier/Spline.hs

@@ -0,0 +1,523 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs               #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module Math.Bezier.Spline where
+
+-- base
+import Data.Bifoldable
+  ( Bifoldable(..) )
+import Data.Bifunctor
+  ( Bifunctor(..) )
+import Data.Bitraversable
+  ( Bitraversable(..) )
+import Data.Coerce
+  ( coerce )
+import Data.Functor.Const
+  ( Const(..) )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.Kind
+  ( Constraint )
+import Data.Monoid
+  ( Ap(..) )
+import Data.Semigroup
+  ( First(..) )
+import GHC.Generics
+  ( Generic, Generic1 )
+
+-- bifunctors
+import qualified Data.Bifunctor.Tannen as Biff
+  ( Tannen(..) )
+
+-- containers
+import Data.Sequence
+  ( Seq(..) )
+import qualified Data.Sequence as Seq
+  ( singleton, drop, splitAt )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData, NFData1 )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field )
+import Data.GenericLens.Internal
+  ( set )
+
+-- transformers
+import Control.Monad.Trans.Class
+  ( lift )
+import Control.Monad.Trans.State.Strict
+  ( StateT(runStateT), modify' )
+
+-- MetaBrush
+import qualified Math.Bezier.Cubic as Cubic
+  ( Bezier(..) )
+import Math.Vector2D
+  ( Point2D )
+
+--------------------------------------------------------------------------------
+
+data PointType
+  = PathPoint
+  | ControlPoint
+  deriving stock Show
+
+data SplineType = Open | Closed
+
+data SSplineType ( clo :: SplineType ) where
+  SOpen   :: SSplineType Open
+  SClosed :: SSplineType Closed
+
+class ( Traversable ( NextPoint clo )
+      , forall crvData. Traversable ( Curves clo crvData )
+      , Bitraversable ( Curves clo )
+      , forall ptData. Show ptData => Show ( NextPoint clo ptData )
+      , forall ptData crvData. ( Show ptData, Show crvData ) => Show ( Curves clo crvData ptData )
+      , forall ptData. NFData ptData => NFData ( NextPoint clo ptData )
+      , forall ptData crvData. ( NFData ptData, NFData crvData ) => NFData ( Curves clo crvData ptData )
+      )
+    => SplineTypeI ( clo :: SplineType ) where
+  -- | Singleton for the spline type
+  ssplineType :: SSplineType clo 
+instance SplineTypeI Open where
+  ssplineType = SOpen
+instance SplineTypeI Closed where
+  ssplineType = SClosed
+
+data    family   NextPoint ( clo :: SplineType ) ptData
+newtype instance NextPoint Open   ptData = NextPoint { nextPoint :: ptData }
+  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass ( NFData, NFData1 )
+data    instance NextPoint Closed ptData = BackToStart
+  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass ( NFData, NFData1 )
+
+fromNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData -> ptData
+fromNextPoint pt nxt
+  | SOpen <- ssplineType @clo
+  = case nxt of { NextPoint q -> q }
+  | otherwise
+  = pt
+
+toNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData
+toNextPoint pt = case ssplineType @clo of
+  SOpen   -> NextPoint pt
+  SClosed -> BackToStart
+
+data Curve ( clo :: SplineType ) crvData ptData
+  = LineTo
+  { curveEnd  :: !( NextPoint clo ptData )
+  , curveData :: !crvData
+  }
+  | Bezier2To
+  { controlPoint :: !ptData
+  , curveEnd     :: !( NextPoint clo ptData )
+  , curveData    :: !crvData
+  }
+  | Bezier3To
+  { controlPoint1 :: !ptData
+  , controlPoint2 :: !ptData
+  , curveEnd      :: !( NextPoint clo ptData )
+  , curveData     :: !crvData
+  }
+  deriving stock ( Generic, Generic1 )
+
+deriving stock    instance ( Show   ptData, Show   crvData, Show   ( NextPoint clo ptData ) ) => Show   ( Curve clo crvData ptData )
+deriving anyclass instance ( NFData ptData, NFData crvData, NFData ( NextPoint clo ptData ) ) => NFData ( Curve clo crvData ptData )
+
+deriving stock instance Functor     ( NextPoint clo ) => Functor     ( Curve clo crvData )
+deriving stock instance Foldable    ( NextPoint clo ) => Foldable    ( Curve clo crvData )
+deriving stock instance Traversable ( NextPoint clo ) => Traversable ( Curve clo crvData )
+
+instance Functor ( NextPoint clo ) => Bifunctor ( Curve clo ) where
+  bimap f g ( LineTo            np d ) = LineTo                        ( fmap g np ) ( f d )
+  bimap f g ( Bezier2To     cp  np d ) = Bezier2To ( g  cp )           ( fmap g np ) ( f d )
+  bimap f g ( Bezier3To cp1 cp2 np d ) = Bezier3To ( g cp1 ) ( g cp2 ) ( fmap g np ) ( f d )
+instance Foldable ( NextPoint clo ) => Bifoldable ( Curve clo ) where
+  bifoldMap f g ( LineTo            np d ) =                   foldMap g np <> f d
+  bifoldMap f g ( Bezier2To     cp  np d ) = g cp           <> foldMap g np <> f d
+  bifoldMap f g ( Bezier3To cp1 cp2 np d ) = g cp1 <> g cp2 <> foldMap g np <> f d
+instance Traversable ( NextPoint clo ) => Bitraversable ( Curve clo ) where
+  bitraverse f g ( LineTo            np d ) = LineTo    <$>                     traverse g np <*> f d
+  bitraverse f g ( Bezier2To     cp  np d ) = Bezier2To <$> g cp            <*> traverse g np <*> f d
+  bitraverse f g ( Bezier3To cp1 cp2 np d ) = Bezier3To <$> g cp1 <*> g cp2 <*> traverse g np <*> f d
+
+openCurveEnd :: Curve Open crvData ptData -> ptData
+openCurveEnd = nextPoint . curveEnd
+
+openCurveStart :: Curve Open crvData ptData -> ptData
+openCurveStart ( LineTo ( NextPoint p ) _ ) = p
+openCurveStart ( Bezier2To p _ _   ) = p
+openCurveStart ( Bezier3To p _ _ _ ) = p
+
+data family Curves ( clo :: SplineType ) crvData ptData
+
+newtype instance Curves Open crvData ptData
+  = OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) }
+  deriving stock   ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving newtype ( Semigroup, Monoid, NFData )
+
+deriving via Biff.Tannen Seq ( Curve Open )
+  instance Bifunctor ( Curves Open )
+deriving via Biff.Tannen Seq ( Curve Open )
+  instance Bifoldable ( Curves Open )
+instance Bitraversable ( Curves Open ) where
+  bitraverse f g ( OpenCurves { openCurves = curves } )
+    = OpenCurves <$> traverse ( bitraverse f g ) curves
+
+data instance Curves Closed crvData ptData
+  = NoCurves
+  | ClosedCurves
+    { prevOpenCurves  :: !( Seq ( Curve Open crvData ptData ) )
+    , lastClosedCurve :: !( Curve Closed crvData ptData )
+    }
+  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass NFData
+
+instance Bifunctor     ( Curves Closed ) where
+  bimap _ _ NoCurves = NoCurves
+  bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l )
+instance Bifoldable    ( Curves Closed ) where
+  bifoldMap _ _ NoCurves = mempty
+  bifoldMap f g ( ClosedCurves p l ) = foldMap ( bifoldMap f g ) p <> bifoldMap f g l
+instance Bitraversable ( Curves Closed ) where
+  bitraverse _ _ NoCurves = pure NoCurves
+  bitraverse f g ( ClosedCurves p l )
+    = ClosedCurves <$> ( traverse ( bitraverse f g ) p ) <*> bitraverse f g l
+
+
+data Spline ( clo :: SplineType ) crvData ptData
+  = Spline
+    { splineStart  :: !ptData
+    , splineCurves :: !( Curves clo crvData ptData )
+    }
+  deriving stock ( Generic, Generic1 )
+
+deriving stock    instance ( Show   ptData, Show   ( Curves clo crvData ptData ) )
+                        => Show   ( Spline clo crvData ptData )
+deriving anyclass instance ( NFData ptData, NFData ( Curves clo crvData ptData ) )
+                        => NFData ( Spline clo crvData ptData )
+deriving stock    instance Functor     ( Curves clo crvData ) => Functor     ( Spline clo crvData )
+deriving stock    instance Foldable    ( Curves clo crvData ) => Foldable    ( Spline clo crvData )
+deriving stock    instance Traversable ( Curves clo crvData ) => Traversable ( Spline clo crvData )
+
+instance KnownSplineType clo => Bifunctor ( Spline clo ) where
+  bimap fc fp = bimapSpline ( const $ bimap fc fp ) fp
+instance KnownSplineType clo => Bifoldable ( Spline clo ) where
+  bifoldMap fc fp = runIdentity . bifoldSpline @_ @Identity ( const $ bifoldMap ( coerce fc ) ( coerce fp ) ) ( coerce fp )
+instance KnownSplineType clo => Bitraversable ( Spline clo ) where
+  bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp
+
+type SplinePts clo = Spline clo () ( Point2D Double )
+
+
+bimapCurve
+  :: Functor ( NextPoint clo )
+  => ( crvData -> crvData' ) -> ( PointType -> ptData -> ptData' )
+  -> Curve clo crvData ptData -> Curve clo crvData' ptData'
+bimapCurve f g ( LineTo    p1       d ) = LineTo                                                ( g PathPoint <$> p1 ) ( f d )
+bimapCurve f g ( Bezier2To p1 p2    d ) = Bezier2To ( g ControlPoint p1 )                       ( g PathPoint <$> p2 ) ( f d )
+bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ControlPoint p1 ) ( g ControlPoint p2 ) ( g PathPoint <$> p3 ) ( f d )
+
+bifoldMapCurve
+  :: forall m clo crvData ptData
+  .  ( Monoid m, Foldable ( NextPoint clo ) )
+  => ( crvData -> m ) -> ( PointType -> ptData -> m )
+  -> Curve clo crvData ptData -> m
+bifoldMapCurve f g ( LineTo    p1       d ) =                                           ( foldMap ( g PathPoint ) p1 ) <> f d
+bifoldMapCurve f g ( Bezier2To p1 p2    d ) = g ControlPoint p1 <>                      ( foldMap ( g PathPoint ) p2 ) <> f d
+bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ControlPoint p1 <> g ControlPoint p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d
+
+bitraverseCurve
+  :: forall f clo crvData crvData' ptData ptData'
+  .  ( Applicative f, Traversable ( NextPoint clo ) )
+  => ( crvData -> f crvData' ) -> ( PointType -> ptData -> f ptData' )
+  -> Curve clo crvData ptData -> f ( Curve clo crvData' ptData' )
+bitraverseCurve f g ( LineTo    p1       d ) = LineTo    <$>                                             traverse ( g PathPoint ) p1 <*> f d
+bitraverseCurve f g ( Bezier2To p1 p2    d ) = Bezier2To <$> g ControlPoint p1 <*>                       traverse ( g PathPoint ) p2 <*> f d
+bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ControlPoint p1 <*> g ControlPoint p2 <*> traverse ( g PathPoint ) p3 <*> f d
+
+dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData )
+dropCurves i ( Spline { splineCurves = OpenCurves curves } ) = case Seq.drop ( i - 1 ) curves of
+  prev :<| next -> Just $ Spline { splineStart = openCurveEnd prev, splineCurves = OpenCurves next }
+  _             -> Nothing
+
+splitSplineAt :: Int -> Spline Open crvData ptData -> ( Spline Open crvData ptData, Spline Open crvData ptData )
+splitSplineAt i ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case Seq.splitAt i curves of
+  ( Empty, next ) ->
+    ( Spline { splineStart, splineCurves = OpenCurves Empty }, Spline { splineStart, splineCurves = OpenCurves next } )
+  ( prev@( _ :|> lastPrev ), next ) ->
+    ( Spline { splineStart, splineCurves = OpenCurves prev  }, Spline { splineStart = openCurveEnd lastPrev, splineCurves = OpenCurves next } )
+
+reverseSpline :: forall crvData ptData. Spline Open crvData ptData -> Spline Open crvData ptData
+reverseSpline spline@( Spline { splineStart = p0, splineCurves = OpenCurves curves } ) = case curves of
+  Empty        -> spline
+  prev :|> lst -> Spline { splineStart = openCurveEnd lst, splineCurves = OpenCurves ( go prev lst ) }
+    where
+      go :: Seq ( Curve Open crvData ptData ) -> Curve Open crvData ptData -> Seq ( Curve Open crvData ptData )
+      go Empty ( LineTo _ dat )          = Empty :|> LineTo          ( NextPoint p0 ) dat
+      go Empty ( Bezier2To p1 _ dat )    = Empty :|> Bezier2To p0    ( NextPoint p1 ) dat
+      go Empty ( Bezier3To p1 p2 _ dat ) = Empty :|> Bezier3To p0 p1 ( NextPoint p2 ) dat
+      go ( crvs :|> crv ) ( LineTo _ dat )          = go crvs crv :|> LineTo    ( curveEnd crv ) dat
+      go ( crvs :|> crv ) ( Bezier2To p1 _ dat )    = go crvs crv :|> Bezier2To ( openCurveEnd crv ) ( NextPoint p1 ) dat
+      go ( crvs :|> crv ) ( Bezier3To p1 p2 _ dat ) = go crvs crv :|> Bezier3To ( openCurveEnd crv ) p1 ( NextPoint p2 ) dat
+
+splineEnd :: Spline Open crvData ptData -> ptData
+splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case curves of
+  Empty           -> splineStart
+  _ :|> lastCurve -> openCurveEnd lastCurve
+
+catMaybesSpline :: crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData
+catMaybesSpline dat p0 Nothing     Nothing     p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo          ( NextPoint p3 ) dat ) }
+catMaybesSpline dat p0 ( Just p1 ) Nothing     p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To    p1 ( NextPoint p3 ) dat ) }
+catMaybesSpline dat p0 Nothing     ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To    p2 ( NextPoint p3 ) dat ) }
+catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) }
+
+-- | Connect two open curves.
+--
+-- It is assumed (not checked) that the end of the first curve is the start of the second curve.
+instance Semigroup ( Spline Open crvData ptData ) where
+  spline1@( Spline { splineStart, splineCurves = segs1 } ) <> spline2@( Spline { splineCurves = segs2 } )
+    | null segs1 = spline2
+    | null segs2 = spline1
+    | otherwise  = Spline { splineStart, splineCurves = segs1 <> segs2 }
+
+-- | Create a curve containing a single (open) cubic Bézier segment.
+openCubicBezierCurveSpline :: crvData -> Cubic.Bezier ptData -> Spline Open crvData ptData
+openCubicBezierCurveSpline crvData ( Cubic.Bezier {..} )
+  = Spline
+  { splineStart  = p0
+  , splineCurves = OpenCurves . Seq.singleton $
+    Bezier3To
+      { controlPoint1 = p1
+      , controlPoint2 = p2
+      , curveEnd      = NextPoint p3
+      , curveData     = crvData
+      }
+  }
+
+-- | Drop the end of an open curve segment to create a "closed" curve (i.e. one that returns to the start).
+dropCurveEnd :: Curve Open crvData ptData -> Curve Closed crvData ptData
+dropCurveEnd ( LineTo            _ dat ) = LineTo            BackToStart dat
+dropCurveEnd ( Bezier2To cp      _ dat ) = Bezier2To cp      BackToStart dat
+dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat
+
+class SplineTypeI clo => KnownSplineType clo where
+
+  type TraversalCt clo ( clo' :: SplineType ) :: Constraint
+
+  -- | Last point of a spline.
+  lastPoint :: Spline clo crvData ptData -> ptData
+
+  -- | Close a spline if necessary.
+  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline clo crvData ptData
+
+  -- | Indexed traversal of a spline.
+  ibitraverseSpline
+    :: forall f crvData ptData crvData' ptData' 
+    .  Applicative f
+    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
+       )
+    -> ( ptData -> f ptData' )
+    -> Spline clo crvData ptData
+    -> f ( Spline clo crvData' ptData' )
+
+  -- | Bi-witherable traversal of a spline.
+  biwitherSpline
+    :: forall f crvData ptData crvData' ptData'
+    .  Monad f
+    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) )
+       )
+    -> ( ptData -> f ( Maybe ptData' ) )
+    -> Spline clo crvData ptData
+    -> f ( Maybe ( Spline clo crvData' ptData' ) )
+
+  -- | Traversal of a spline.
+  bitraverseSpline
+    :: forall f crvData ptData crvData' ptData' 
+    .  Applicative f
+    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
+       )
+    -> ( ptData -> f ptData' )
+    -> Spline clo crvData ptData
+    -> f ( Spline clo crvData' ptData' )
+
+  bitraverseSpline fc fp = ibitraverseSpline ( const fc ) fp
+
+  -- | Indexed fold of a spline.
+  ibifoldSpline
+    :: forall f m crvData ptData
+    .  ( Applicative f, Monoid m )
+    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => Int -> ptData -> Curve clo' crvData ptData -> f m
+       )
+    -> ( ptData -> f m )
+    -> Spline clo crvData ptData
+    -> f m
+
+  ibifoldSpline fc fp
+    = coerce
+    . ibitraverseSpline @clo @( Const ( Ap f m ) ) ( coerce fc ) ( coerce fp )
+
+
+  -- | Fold of a spline.
+  bifoldSpline
+    :: forall f m crvData ptData
+    .  ( Applicative f, Monoid m )
+    => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => ptData -> Curve clo' crvData ptData -> f m )
+    -> ( ptData -> f m )
+    -> Spline clo crvData ptData
+    -> f m
+
+  bifoldSpline fc fp = ibifoldSpline ( const fc ) fp
+
+  -- | Bifunctor fmap of a spline.
+  bimapSpline
+    :: forall crvData ptData crvData' ptData' 
+    .  ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
+       => ptData -> Curve clo' crvData ptData -> Curve clo' crvData' ptData'
+       )
+    -> ( ptData -> ptData' )
+    -> Spline clo crvData  ptData
+    -> Spline clo crvData' ptData'
+  bimapSpline fc fp
+    = runIdentity 
+    . bitraverseSpline @clo @Identity ( coerce fc ) ( coerce fp )
+
+
+
+instance KnownSplineType Open where
+
+  type TraversalCt Open clo' = clo' ~ Open
+
+  lastPoint ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
+    case curves of
+      Empty           -> splineStart
+      _ :|> lastCurve -> openCurveEnd lastCurve
+  
+  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Open crvData ptData
+  adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
+    SOpen   -> spline
+    SClosed -> case splineCurves of
+      NoCurves              -> Spline { splineStart, splineCurves = OpenCurves Empty }
+      ClosedCurves prev lst -> Spline { splineStart, splineCurves = OpenCurves $ prev :|> set ( field @"curveEnd" ) ( NextPoint splineStart ) lst }
+
+  ibitraverseSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
+    ( \ p cs -> Spline p ( OpenCurves cs ) ) <$> fp splineStart <*> go 0 splineStart curves
+    where
+      go _ _  Empty           = pure Empty
+      go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs
+
+  biwitherSpline
+    :: forall f crvData ptData crvData' ptData'
+    .  Monad f
+    => ( Maybe ptData' -> Curve Open crvData ptData -> f ( Maybe ( Curve Open crvData' ptData' ) ) )
+    -> ( ptData -> f ( Maybe ptData' ) )
+    -> Spline Open crvData ptData
+    -> f ( Maybe ( Spline Open crvData' ptData' ) )
+  biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = do
+    mbStart' <- fp splineStart
+    ( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go mbStart' curves
+    case mbStart'' of
+      Nothing -> pure Nothing
+      Just ( First start' ) ->
+        pure ( Just $ Spline { splineStart = start', splineCurves = OpenCurves curves' } )
+      where
+        go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
+        go _       Empty            = pure Empty
+        go mbStart ( crv :<| crvs ) = do
+          mbCrv' <- lift $ fc mbStart crv
+          case mbCrv' of
+            Nothing   -> go mbStart crvs
+            Just crv' -> do
+              let
+                endpoint = openCurveEnd crv'
+              modify' ( <> Just ( First endpoint ) )
+              ( crv' :<| ) <$> go ( Just endpoint ) crvs
+
+instance KnownSplineType Closed where
+
+  type TraversalCt Closed clo' = ()
+
+  lastPoint ( Spline { splineStart } ) = splineStart
+
+  adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Closed crvData ptData
+  adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
+    SClosed -> spline
+    SOpen   -> case splineCurves of
+      OpenCurves ( Empty        ) -> Spline { splineStart, splineCurves = NoCurves }
+      OpenCurves ( prev :|> lst ) -> Spline { splineStart, splineCurves = ClosedCurves prev ( set ( field @"curveEnd" ) BackToStart lst ) }
+
+  ibitraverseSpline
+    :: forall f crvData ptData crvData' ptData' 
+    .  Applicative f
+    => ( forall clo'. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
+       => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
+       )
+    -> ( ptData -> f ptData' )
+    -> Spline Closed crvData ptData
+    -> f ( Spline Closed crvData' ptData' )
+  ibitraverseSpline _  fp ( Spline { splineStart = p0, splineCurves = NoCurves } ) = ( \ p -> Spline p NoCurves ) <$> fp p0
+  ibitraverseSpline fc fp ( Spline { splineStart = p0, splineCurves = ClosedCurves prevCurves lastCurve } ) =
+    ( \ p cs lst -> Spline p ( ClosedCurves cs lst ) ) <$> fp p0 <*> go 0 p0 prevCurves <*> fc n pn lastCurve
+      where
+        n :: Int
+        n = length prevCurves
+        pn :: ptData
+        pn = case prevCurves of
+          Empty          -> p0
+          _ :|> lastPrev -> openCurveEnd lastPrev
+        go _ _  Empty           = pure Empty
+        go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs
+
+  biwitherSpline _  fp ( Spline { splineStart, splineCurves = NoCurves } ) = fmap ( \ p -> Spline p NoCurves ) <$> fp splineStart
+  biwitherSpline fc fp ( Spline { splineStart, splineCurves = ClosedCurves prevCurves lastCurve } ) = do
+    mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
+    case mbSpline' of
+      Nothing -> do
+        _ <- fc Nothing lastCurve
+        pure Nothing
+      Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
+        case prevCurves' of
+          Empty -> do
+            mbLastCurve' <- fc ( Just start' ) lastCurve
+            case mbLastCurve' of
+              Nothing ->
+                pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
+              Just lastCurve' ->
+                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
+          ( prevPrevCurves' :|> prevLastCurve' ) -> do
+            let
+              prevPt' = openCurveEnd prevLastCurve'
+            mbLastCurve' <- fc ( Just prevPt' ) lastCurve
+            case mbLastCurve' of
+              Nothing ->
+                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
+              Just lastCurve' ->
+                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )

src/lib/Math/Bezier/Stroke.hs

@@ -3,34 +3,45 @@
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PolyKinds                  #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
 
 module Math.Bezier.Stroke
-  ( StrokePoint(PP, CP, ..)
+  ( Offset(..)
-  , Offset(..)
+  , CachedStroke(..), discardCache
-  , stroke, joinWithBrush
+  , computeStrokeOutline, joinWithBrush
   , withTangent
   , between, parallel
   )
   where
 
 -- base
+import Prelude
+  hiding ( unzip )
 import Control.Arrow
-  ( first )
+  ( first, (***) )
 import Control.Monad
-  ( guard )
+  ( guard, unless )
+import Data.Bifunctor
+  ( Bifunctor(bimap) )
+import Data.Foldable
+  ( for_ )
+import Data.List.NonEmpty
+  ( unzip )
 import Data.Maybe
   ( fromMaybe, mapMaybe )
 import GHC.Generics
-  ( Generic )
+  ( Generic, Generic1 )
 
 -- acts
 import Data.Act
@@ -44,189 +55,220 @@ import Data.Act
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
-  ( splitAt, drop, dropWhileL
+  ( singleton )
-  , zipWith, zipWith3, zipWith4
-  )
 
 -- deepseq
 import Control.DeepSeq
-  ( NFData )
+  ( NFData, NFData1 )
 
 -- generic-lens
-import Data.Generics.Product.Fields
-  ( field, field' )
 import Data.Generics.Product.Typed
   ( HasType(typed) )
 import Data.GenericLens.Internal
-  ( set, over, view )
+  ( set, view )
 
--- monad-par
+-- groups
-import Control.Monad.Par
+import Data.Group
-  ( Par )
+  ( Group )
-import qualified Control.Monad.Par as Par
+
-  ( get, runPar, spawn, spawnP )
+-- parallel
+import qualified Control.Parallel.Strategies as Strats
+  ( rdeepseq, parTuple2, using )
+
+-- transformers
+import Control.Monad.Trans.Class
+  ( lift )
+import Control.Monad.Trans.Except
+  ( Except, runExcept, throwE )
+import Control.Monad.Trans.State.Strict
+  ( StateT, runStateT, evalStateT, get, put )
+import Control.Monad.Trans.Writer.CPS
+  ( Writer, runWriter, tell )
 
 -- MetaBrush
 import qualified Math.Bezier.Cubic     as Cubic
 import Math.Bezier.Cubic.Fit
   ( FitPoint, FitParameters, fitSpline )
+import Math.Bezier.Spline
+  ( SplineType(..), SSplineType(..), SplineTypeI
+  , ssplineType, adjustSplineType
+  , NextPoint(..), fromNextPoint
+  , KnownSplineType
+    ( bitraverseSpline, ibifoldSpline, bimapSpline )
+  , Spline(..), SplinePts, Curves(..), Curve(..)
+  , openCurveStart, openCurveEnd
+  , splitSplineAt, dropCurves
+  )
 import qualified Math.Bezier.Quadratic as Quadratic
 import Math.Epsilon
   ( epsilon )
 import Math.Module
   ( Module((^-^), (*^)), Inner((^.^))
-  , lerp, squaredNorm
+  , lerp, squaredNorm, cross
   )
 import Math.Roots
   ( solveQuadratic )
 import Math.Vector2D
-  ( Point2D(..), Vector2D(..), cross )
+  ( Point2D(..), Vector2D(..) )
 
 --------------------------------------------------------------------------------
 
-data StrokePoint d
-  = PathPoint
-  { coords    :: !( Point2D Double )
-  , pointData :: d
-  }
-  | ControlPoint
-  { coords    :: !( Point2D Double )
-  , pointData :: d
-  }
-  deriving stock    ( Show, Generic )
-  deriving anyclass NFData
-
-instance Act ( Vector2D Double ) ( StrokePoint d ) where
-  (•) v = over ( field' @"coords" ) ( v • )
-instance Act ( Vector2D Double ) ( Seq ( StrokePoint d ) ) where
-  (•) v = fmap ( v • )
-
-pattern PP, CP :: Point2D Double -> StrokePoint ()
-pattern PP p = PathPoint    p ()
-pattern CP p = ControlPoint p ()
-
 data Offset
   = Offset
   { offsetIndex     :: !Int
   , offsetParameter :: !( Maybe Double )
   , offset          :: !( Vector2D Double )
---, curvature       :: !Double
   }
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
+data TwoSided a
+  = TwoSided
+  { fwd :: !a
+  , bwd :: !a
+  }
+  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass ( NFData, NFData1 )
+
+type OutlineData = TwoSided ( SplinePts Open, Seq FitPoint )
+instance Semigroup OutlineData where
+  TwoSided ( fwdSpline1, fwdPts1 ) ( bwdSpline1, bwdPts1 ) <> TwoSided ( fwdSpline2, fwdPts2 ) ( bwdSpline2, bwdPts2 ) =
+    TwoSided
+      ( fwdSpline1 <> fwdSpline2, fwdPts1 <> fwdPts2 )
+      ( bwdSpline2 <> bwdSpline1, bwdPts2 <> bwdPts1 )
+instance Monoid OutlineData where
+  mempty = TwoSided empt empt
+    where
+      empt :: ( SplinePts Open, Seq FitPoint )
+      empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
+
+newtype CachedStroke = CachedStroke { upToDateFit :: Maybe OutlineData }
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+
+discardCache :: HasType CachedStroke crvData => crvData -> crvData
+discardCache = set ( typed @CachedStroke ) ( CachedStroke Nothing )
+
+coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double
+coords = view typed
+
 --------------------------------------------------------------------------------
 
-stroke
+computeStrokeOutline ::
-  :: forall x d
+  forall diffParams ( clo :: SplineType ) brushParams crvData ptData
-  .  ( Show x, Show d
+  .  ( KnownSplineType clo
-     , HasType ( Seq ( StrokePoint x ) ) d
+     , Group  diffParams, Module Double diffParams
+     , Torsor diffParams brushParams
+     , HasType ( Point2D Double ) ptData
+     , HasType CachedStroke crvData
+     , NFData ptData, NFData crvData
      )
   => FitParameters
-  -> Seq ( StrokePoint d )
+  -> ( ptData -> brushParams )
-  -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint )
+  -> ( brushParams -> SplinePts Closed )
-stroke _ Empty = ( Left Empty, Empty )
+  -> Spline clo crvData ptData
-stroke _ ( spt0 :<| Empty ) = ( Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0, Empty )
+  -> ( Spline clo crvData ptData
-stroke params allPts@( spt0 :<| spt1 :<| spts )
+     , Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
-  | isClosed
+     , Seq FitPoint
-  = if null ( brushShape @x spt0 )
-    then ( Right mempty, mempty )
-    else ( Right ( fwdPts, bwdPts ), fwdFits <> bwdFits )
-  | otherwise
-  = if   null ( brushShape @x spt0 )
-    then ( Left Empty, Empty )
-    else ( Left ( startingCap <> fwdPts <> bwdPts ), fwdFits <> bwdFits )
-  where
-
-    startOffset, endOffset :: Vector2D Double
-    tgt_start, tgt_end :: Vector2D Double
-    brush_start, brush_end :: Seq ( StrokePoint x )
-    startOffset = Point2D 0 0 --> coords spt0
-    tgt_start = coords spt0 --> coords spt1
-    ( tgt_end, endOffset, brush_end ) = case allPts of
-      _ :|> sptnm1 :|> sptn -> ( coords sptnm1 --> coords sptn, Point2D 0 0 --> coords sptn, brushShape @x sptn )
-      _                     -> error "impossible"
-    brush_start = brushShape @x spt0
-
-    isClosed :: Bool
-    isClosed = case ( spt1 :<| spts ) of
-      ( _ :|> PathPoint { coords = lpt } )
-        | lpt == coords spt0
-        -> True
-      _ -> False
-
-    fwdPts, bwdPts :: Seq ( StrokePoint () )
-    fwdFits, bwdFits :: Seq FitPoint
-    ( ( fwdPts, fwdFits ), ( bwdPts, bwdFits ) ) = Par.runPar $ go spt0 ( spt1 :<| spts )
-
-    (<~>)
-      :: ( Monoid a, Monoid b )
-      => ( a, b )
-      -> ( a, b )
-      -> ( a, b )
-    (a1, b1) <~> (a2, b2) = ( a1 <> a2, b2 <> b1 )
-
-    -- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
-    -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
-    joinAndContinue
-      :: Vector2D Double
-      -> StrokePoint d
-      -> Seq ( StrokePoint d )
-      -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
-    joinAndContinue tgt sp0 ( sp1 :<| sps )
-      | tgt' `parallel` tgt
-      = go sp0 ( sp1 :<| sps )
-      | let
-          ptOffset :: Vector2D Double
-          ptOffset = Point2D 0 0 --> coords sp0
-      = do
-        let
-          brushJoin :: ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
-          brushJoin =
-            ( ( ptOffset • joinWithBrush ( withTangent           tgt    brush0 ) ( withTangent           tgt'  brush0 ) brush0, Empty )
-            , ( ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0, Empty )
      )
-        next <- go sp0 ( sp1 :<| sps )
+computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
-        pure ( brushJoin <~> next )
+  -- Open brush path with at least one segment.
-      where
+  SOpen
-        tgt' :: Vector2D Double
+    | OpenCurves curves <- splineCurves
-        tgt' = coords sp0 --> coords sp1
+    , firstCurve :<| _ <- curves
-        brush0 :: Seq ( StrokePoint () )
+    , prevCurves :|> lastCurve <- curves
-        brush0 = removePointData $ brushShape @x sp0
-    joinAndContinue _ _ Empty
-      -- Closed curve.
-      | isClosed
-      = pure $
-        if parallel tgt_start tgt_end
-        then mempty
-        else ( ( startOffset • joinWithBrush  ( withTangent           tgt_start   brush_start ) ( withTangent           tgt_end   brush_start ) brush_start, Empty )
-             , ( startOffset • joinWithBrush  ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start, Empty )
-             )
-      -- Open curve.
-      | otherwise
-      = pure
-        ( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty )
-        , ( Empty, Empty ) -- handled separately: see 'startingCap' below
-        )
-
-    -- Final cap for an open curve. Handled separately for correct stroke order.
-    startingCap :: Seq ( StrokePoint () ) 
-    startingCap
-      = startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start
-
-    go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
-    go _ Empty = pure mempty
-    -- Line.
-    go sp0 ( sp1 :<| sps )
-      | PathPoint {} <- sp1
     , let
+        endPt :: ptData
+        endPt = openCurveEnd lastCurve
+        startTgt, endTgt :: Vector2D Double
+        startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
+        endTgt = case prevCurves of
+          Empty          -> endTangent spt0 spt0                      lastCurve
+          _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
+        startBrush, endBrush :: SplinePts Closed
+        startBrush = brushShape spt0
+        endBrush = brushShape endPt
+        fwdPts, bwdPts :: SplinePts Open
+        fwdFits, bwdFits :: Seq FitPoint
+        newSpline :: Spline clo crvData ptData
+        ( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
+          = updateSpline startTgt
+        startCap, endCap :: SplinePts Open
+        startCap
+          = fmap ( MkVector2D ( coords spt0 ) • )
+          $ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush
+        endCap
+          = fmap ( MkVector2D ( coords endPt ) • )
+          $ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
+    -> ( newSpline
+       , Left  ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
+       , fwdFits <> bwdFits
+       )
+  -- Closed brush path with at least one segment.
+  SClosed
+    | ClosedCurves prevCurves lastCurve <- splineCurves
+    , let
+        startTgt, endTgt :: Vector2D Double
+        startTgt = case prevCurves of
+          Empty          -> startTangent spt0 spt0 lastCurve
+          firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
+        endTgt = case prevCurves of
+          Empty          -> endTangent spt0 spt0                      lastCurve
+          _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
+        fwdPts, bwdPts :: SplinePts Open
+        fwdFits, bwdFits :: Seq FitPoint
+        newSpline :: Spline clo crvData ptData
+        ( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
+          = updateSpline endTgt
+        fwdStartCap, bwdStartCap :: SplinePts Open
+        TwoSided fwdStartCap bwdStartCap
+          = fmap fst . snd . runWriter
+          $ tellBrushJoin endTgt spt0 startTgt
+    -> ( newSpline
+       , Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
+       , fwdFits <> bwdFits
+       )
+  -- Single point.
+  _ -> ( spline
+       , Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
+       , Empty
+       )
+  where
+
+    brushShape :: ptData -> SplinePts Closed
+    brushShape pt = brushFn ( ptParams pt )
+
+    updateSpline :: Vector2D Double -> ( Spline clo crvData ptData, OutlineData )
+    updateSpline lastTgt
+      = runWriter
+      . ( `evalStateT` lastTgt )
+      $ fmap ( adjustSplineType @clo )
+      $ bitraverseSpline
+          ( \ ptData curve -> do
+            prev_tgt <- get
+            let
+              tgt :: Vector2D Double
+              tgt = startTangent spt0 ptData curve
+            lift $ tellBrushJoin prev_tgt ptData tgt
+            curve' <- lift $ strokeOutline ptData curve
+            put ( endTangent spt0 ptData curve )
+            pure curve'
+          )
+          pure
+          ( adjustSplineType @Open spline )
+
+    strokeOutline
+       :: ptData -> Curve Open crvData ptData
+       -> Writer OutlineData ( Curve Open crvData ptData )
+    strokeOutline sp0 line@( LineTo { curveEnd = NextPoint sp1, curveData } ) =
+      let
         p0, p1 :: Point2D Double
         p0 = coords sp0
         p1 = coords sp1
         tgt :: Vector2D Double
         tgt = p0 --> p1
-          brush :: Double -> Seq ( StrokePoint () )
+        brush :: Double -> SplinePts Closed
-          brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 )
+        brush t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
         fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
         fwd t
           = ( off t
@@ -256,30 +298,21 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
               = 1e9 *^ ( off s --> off (s + 1e-9) )
               | otherwise
               = 1e9 *^ ( off (s - 1e-9) --> off s )
-      = do
+      in do
-        fwdIVar  <- Par.spawnP ( fitCurve fwd )
+        crvData' <- updateCurveData curveData fwd bwd
-        bwdIVar  <- Par.spawnP ( fitCurve bwd )
+        pure ( line { curveData = crvData' } )
-        nextIVar <- Par.spawn  ( joinAndContinue tgt sp1 sps )
+    strokeOutline sp0 bez2@( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
-        fwdCurve <- Par.get fwdIVar
+      let
-        bwdCurve <- Par.get bwdIVar
-        next     <- Par.get nextIVar
-        pure $ ( fwdCurve, bwdCurve ) <~> next
-    -- Quadratic Bézier curve.
-    go sp0 ( sp1 :<| sp2 :<| sps )
-      | ControlPoint {} <- sp1
-      , PathPoint    {} <- sp2
-      , let
         p0, p1, p2 :: Point2D Double
         p0 = coords sp0
         p1 = coords sp1
         p2 = coords sp2
-          tgt2 :: Vector2D Double
-          tgt2 = p1 --> p2
         bez :: Quadratic.Bezier ( Point2D Double )
         bez = Quadratic.Bezier {..}
-          brush :: Double -> Seq ( StrokePoint () )
+        brush :: Double -> SplinePts Closed
-          brush t = quadraticBezierBrush t
+        brush t = brushFn
-            ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
+                $ Quadratic.bezier @diffParams
+                ( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
         fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
         fwd t
           = ( off t
@@ -309,32 +342,22 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
               = 1e9 *^ ( off s --> off (s + 1e-9) )
               | otherwise
               = 1e9 *^ ( off (s - 1e-9) --> off s )
-      = do
+      in do
-        fwdIVar  <- Par.spawnP ( fitCurve fwd )
+        crvData' <- updateCurveData curveData fwd bwd
-        bwdIVar  <- Par.spawnP ( fitCurve bwd )
+        pure ( bez2 { curveData = crvData' } )
-        nextIVar <- Par.spawn  ( joinAndContinue tgt2 sp2 sps )
+    strokeOutline sp0 bez3@( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
-        fwdCurve <- Par.get fwdIVar
+      let
-        bwdCurve <- Par.get bwdIVar
-        next     <- Par.get nextIVar
-        pure $ ( fwdCurve, bwdCurve ) <~> next
-    -- Cubic Bézier curve.
-    go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
-      | ControlPoint {} <- sp1
-      , ControlPoint {} <- sp2
-      , PathPoint    {} <- sp3
-      , let
         p0, p1, p2, p3 :: Point2D Double
         p0 = coords sp0
         p1 = coords sp1
         p2 = coords sp2
         p3 = coords sp3
-          tgt3 :: Vector2D Double
-          tgt3 = p2 --> p3
         bez :: Cubic.Bezier ( Point2D Double )
         bez = Cubic.Bezier {..}
-          brush :: Double -> Seq ( StrokePoint () )
+        brush :: Double -> SplinePts Closed
-          brush t = cubicBezierBrush t
+        brush t = brushFn
-            ( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
+                $ Cubic.bezier @diffParams
+                ( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
         fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
         fwd t
           = ( off t
@@ -364,204 +387,283 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
               = 1e9 *^ ( off s --> off (s + 1e-9) )
               | otherwise
               = 1e9 *^ ( off (s - 1e-9) --> off s )
-      = do
+      in do
-        fwdIVar  <- Par.spawnP ( fitCurve fwd )
+        crvData' <- updateCurveData curveData fwd bwd
-        bwdIVar  <- Par.spawnP ( fitCurve bwd )
+        pure ( bez3 { curveData = crvData' } )
-        nextIVar <- Par.spawn  ( joinAndContinue tgt3 sp3 sps )
-        fwdCurve <- Par.get fwdIVar
-        bwdCurve <- Par.get bwdIVar
-        next     <- Par.get nextIVar
-        pure $ ( fwdCurve, bwdCurve ) <~> next
-    go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
 
-    fitCurve
+    updateCurveData
-      :: ( Double -> ( Point2D Double, Vector2D Double ) )
+      :: crvData
-      -> ( Seq ( StrokePoint () ), Seq FitPoint )
+      -> ( Double -> ( Point2D Double, Vector2D Double ) )
-    fitCurve = first splinePoints . fitSpline params
+      -> ( Double -> ( Point2D Double, Vector2D Double ) )
+      -> Writer OutlineData crvData
+    updateCurveData curveData fwd bwd = case upToDateFit $ view ( typed @CachedStroke ) curveData of
+      -- Cached fit data is available: use it.
+      Just ( TwoSided fwdData bwdData ) -> do
+        tell ( TwoSided fwdData bwdData )
+        pure curveData
+      -- No cached fit: compute the fit anew.
+      Nothing -> do
+        let
+          fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
+          ( fwdData, bwdData ) =
+            ( fitSpline fitParams fwd, fitSpline fitParams bwd )
+              `Strats.using`
+                ( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
+          outlineData :: OutlineData
+          outlineData = TwoSided fwdData bwdData
+        tell ( outlineData )
+        pure ( set ( typed @CachedStroke ) ( CachedStroke $ Just outlineData ) curveData )
+
+
+    -- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
+    -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
+    tellBrushJoin
+      :: Vector2D Double
+      -> ptData
+      -> Vector2D Double
+      -> Writer OutlineData ()
+    tellBrushJoin prevTgt sp0 tgt
+      | tgt `parallel` prevTgt
+      = pure ()
+      | otherwise
+      = tell brushJoin
+        where
+          ptOffset :: Vector2D Double
+          ptOffset = Point2D 0 0 --> coords sp0
+          brush0 :: SplinePts Closed
+          brush0 = brushShape sp0
+          fwdJoin, bwdJoin :: SplinePts Open
+          fwdJoin
+            = fmap ( ptOffset • )
+            $ joinWithBrush ( withTangent       prevTgt   brush0 ) ( withTangent               tgt   brush0 ) brush0 
+          bwdJoin
+            = fmap ( ptOffset • )
+            $ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0
+          brushJoin :: OutlineData
+          brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
 
 -----------------------------------
 -- Various utility functions
 -- used in the "stroke" function.
 -----
 
-brushShape :: forall x d. HasType ( Seq ( StrokePoint x ) ) d => StrokePoint d -> Seq ( StrokePoint x )
-brushShape = view typed . pointData
 
-removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
+startTangent, endTangent :: ( SplineTypeI clo, HasType ( Point2D Double ) ptData ) => ptData -> ptData -> Curve clo crvData ptData -> Vector2D Double
-removePointData = fmap ( set ( field @"pointData" ) () )
+startTangent sp p0 ( LineTo    mp1      _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
+startTangent _  p0 ( Bezier2To  p1 _    _ ) = coords p0 --> coords p1
+startTangent _  p0 ( Bezier3To  p1 _ _  _ ) = coords p0 --> coords p1
+endTangent   sp p0 ( LineTo         mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
+endTangent   sp _  ( Bezier2To   p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
+endTangent   sp _  ( Bezier3To _ p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
 
-lerpBrush :: forall d. Show d => Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
+lastTangent :: HasType ( Point2D Double ) ptData => Spline Closed crvData ptData -> Maybe ( Vector2D Double )
-lerpBrush t p0s p1s = Seq.zipWith f p0s p1s
+lastTangent ( Spline { splineCurves = NoCurves } ) = Nothing
-  where
+lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty          lst } ) = Just $ endTangent splineStart splineStart lst
-    f :: StrokePoint d -> StrokePoint d -> StrokePoint ()
+lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) lst } ) = Just $ endTangent splineStart ( openCurveEnd prev ) lst
-    f ( PathPoint { coords = p0 } )
-      ( PathPoint { coords = p1 } )
-        = PP $ lerp @( Vector2D Double ) t p0 p1
-    f ( ControlPoint { coords = p0 } )
-      ( ControlPoint { coords = p1 } )
-        = CP $ lerp @( Vector2D Double ) t p0 p1
-    f p1 p2 = error $ "stroke: incompatible brushes " <> show [ p1, p2 ]
-
-quadraticBezierBrush :: forall d. Show d => Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
-quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s
-  where
-    f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
-    f ( PathPoint { coords = p0 } )
-      ( PathPoint { coords = p1 } )
-      ( PathPoint { coords = p2 } )
-        = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
-    f ( ControlPoint { coords = p0 } )
-      ( ControlPoint { coords = p1 } )
-      ( ControlPoint { coords = p2 } )
-        = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
-    f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ]
-
-cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
-cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s
-  where
-    f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
-    f ( PathPoint { coords = p0 } )
-      ( PathPoint { coords = p1 } )
-      ( PathPoint { coords = p2 } )
-      ( PathPoint { coords = p3 } )
-         = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
-    f ( ControlPoint { coords = p0 } )
-      ( ControlPoint { coords = p1 } )
-      ( ControlPoint { coords = p2 } )
-      ( ControlPoint { coords = p3 } )
-        = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
-    f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
-
-
-splinePoints :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
-splinePoints Empty                              = Empty
-splinePoints ps@( Cubic.Bezier p0 _ _ _ :<| _ ) = PP p0 :<| go ps
-  where
-    go :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
-    go Empty = Empty
-    go ( Cubic.Bezier _ p1 p2 p3 :<| pts ) = CP p1 :<| CP p2 :<| PP p3 :<| go pts
 
 --------------------------------------------------------------------------------
 
 -- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
-joinWithBrush :: forall d. Show d => Offset -> Offset -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
+joinWithBrush :: forall crvData ptData. HasType ( Point2D Double ) ptData => Offset -> Offset -> Spline Closed crvData ptData -> SplinePts Open
 joinWithBrush
   ( Offset { offsetIndex = i1, offsetParameter = mb_t1 } )
   ( Offset { offsetIndex = i2, offsetParameter = mb_t2 } )
-  pts
+  spline
     | i2 > i1
     = let
-        pcs, lastAndRest :: Seq ( StrokePoint d )
+        pcs, lastAndRest :: Maybe ( SplinePts Open )
-        ( pcs, lastAndRest ) = Seq.splitAt ( i2 - i1 ) $ Seq.drop i1 pts
+        ( pcs, lastAndRest )
+          =  unzip
+          $ ( discardCurveData *** discardCurveData )
+          .  splitSplineAt ( i2 - i1 )
+         <$> dropCurves i1 openSpline
       in
-        snd ( splitFirstPiece t1 pcs ) <> dropFirstPiece pcs <> fst ( splitFirstPiece t2 lastAndRest )
+        fromMaybe empty $
+          mconcat
+            [ snd <$> ( splitFirstPiece t1 =<< pcs )
+            , dropFirstPiece =<< pcs
+            , fst <$> ( splitFirstPiece t2 =<< lastAndRest )
+            ]
     | i2 == i1 && mb_t2 >= mb_t1
     = let
-        pcs :: Seq ( StrokePoint d )
+        pcs :: Maybe ( SplinePts Open )
-        pcs = Seq.drop i1 pts
+        pcs = discardCurveData <$> dropCurves i1 openSpline
       in
-        fst ( splitFirstPiece t2 $ snd ( splitFirstPiece t1 pcs ) )
+        fromMaybe empty
+          ( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) )
     | otherwise
     = let
-        start, middle, end :: Seq ( StrokePoint d )
+        start, middle, end :: SplinePts Open
-        ( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts
+        ( ( middle, end ), start )
+          = ( ( discardCurveData *** discardCurveData ) *** discardCurveData )
+          $ first ( splitSplineAt i2 )
+          $ splitSplineAt i1 openSpline
       in
-        snd ( splitFirstPiece t1 start ) <> dropFirstPiece start <> removePointData middle <> fst ( splitFirstPiece t2 end )
+        fromMaybe empty $
+          mconcat
+            [ snd <$> splitFirstPiece t1 start
+            , dropFirstPiece start
+            , Just middle
+            , fst <$> splitFirstPiece t2 end
+            ]
   where
+    empty :: SplinePts Open
+    empty = Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }
+    openSpline :: Spline Open crvData ptData
+    openSpline = adjustSplineType spline
     t1, t2 :: Double
     t1 = fromMaybe 0.5 mb_t1
     t2 = fromMaybe 0.5 mb_t2
 
--- | Drop the first piece in a sequence of Bézier pieces.
+
-dropFirstPiece :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
+discardCurveData
-dropFirstPiece
+  :: ( Bifunctor f, HasType ( Point2D Double ) ptData )
-  = removePointData
+  => f crvData ptData -> f () ( Point2D Double )
-  . Seq.dropWhileL ( \case { ControlPoint {} -> True; _ -> False } )
+discardCurveData = bimap ( const () ) coords
-  . Seq.drop 1
+
+-- | Drop the first curve in a Bézier spline.
+dropFirstPiece :: HasType ( Point2D Double ) ptData => Spline Open crvData ptData -> Maybe ( SplinePts Open )
+dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of
+  Empty                    -> Nothing
+  fstPiece :<| laterPieces -> 
+    Just $ Spline
+      { splineStart  = coords ( openCurveEnd fstPiece )
+      , splineCurves = OpenCurves $ fmap discardCurveData laterPieces
+      }
 
 -- | Subdivide the first piece at the given parameter, discarding the subsequent pieces.
-splitFirstPiece :: Show d => Double -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
+splitFirstPiece :: HasType ( Point2D Double ) ptData => Double -> Spline Open crvData ptData -> Maybe ( SplinePts Open, SplinePts Open )
--- Line.
+splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves } ) = case curves of
-splitFirstPiece t ( sp0 :<| sp1 :<| _ )
+  Empty          -> Nothing
-  | PathPoint { coords = p0 } <- sp0
+  fstPiece :<| _ -> case fstPiece of
-  , PathPoint { coords = p1 } <- sp1
+    LineTo { curveEnd = NextPoint sp1 } ->
-  , let
+      let
-      p :: Point2D Double
+        p1, p :: Point2D Double
+        p1 = coords sp1
         p = lerp @( Vector2D Double ) t p0 p1
-  = ( PP p0 :<| PP p  :<| Empty
+      in
-    , PP p  :<| PP p1 :<| Empty
+        Just
+          ( Spline
+            { splineStart  = p0
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ LineTo { curveEnd = NextPoint p , curveData = () }
+            }
+          , Spline
+            { splineStart  = p 
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ LineTo { curveEnd = NextPoint p1, curveData = () }
+            }
           )
--- Quadratic Bézier curve.
+    Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } ->
-splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ )
+      let
-  | PathPoint    { coords = p0 } <- sp0
+        p1, p2, q1, p, r1 :: Point2D Double
-  , ControlPoint { coords = p1 } <- sp1
+        p1 = coords sp1
-  , PathPoint    { coords = p2 } <- sp2
+        p2 = coords sp2
-  , let
-      q1, p, r1 :: Point2D Double
         ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
           = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
-  = ( PP p0 :<| CP q1 :<| PP p  :<| Empty
+      in
-    , PP p  :<| CP r1 :<| PP p2 :<| Empty
+        Just
+          ( Spline
+            { splineStart  = p0
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ Bezier2To { controlPoint = q1, curveEnd = NextPoint p , curveData = () }
+            }
+          , Spline
+            { splineStart  = p
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ Bezier2To { controlPoint = r1, curveEnd = NextPoint p2, curveData = () }
+            }
           )
--- Cubic Bézier curve.
+    Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } ->
-splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ )
+      let
-  | PathPoint    { coords = p0 } <- sp0
+        p1, p2, p3, q1, q2, p, r1, r2 :: Point2D Double
-  , ControlPoint { coords = p1 } <- sp1
+        p1 = coords sp1
-  , ControlPoint { coords = p2 } <- sp2
+        p2 = coords sp2
-  , PathPoint    { coords = p3 } <- sp3
+        p3 = coords sp3
-  , let
-      q1, q2, p, r1, r2 :: Point2D Double
         ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
           = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t
-  = ( PP p0 :<| CP q1 :<| CP q2 :<| PP p  :<| Empty
+      in
-    , PP p  :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty
+        Just
+          ( Spline
+            { splineStart  = p0
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ Bezier3To { controlPoint1 = q1, controlPoint2 = q2, curveEnd = NextPoint p , curveData = () }
+            }
+          , Spline
+            { splineStart  = p
+            , splineCurves = OpenCurves . Seq.singleton
+                           $ Bezier3To { controlPoint1 = r1, controlPoint2 = r2, curveEnd = NextPoint p3, curveData = () }
+            }
           )
--- Anything else.
+  where
-splitFirstPiece _ _ = ( Empty, Empty ) -- error ( "splitFirstPiece: unexpected stroke point data" <> show pcs )
+    p0 :: Point2D Double
+    p0 = coords sp0
 
 --------------------------------------------------------------------------------
 
 -- | Finds the point at which a convex nib (given by a piecewise Bézier curve) has the given tangent vector.
 --
 -- Does /not/ check that the provided nib shape is convex.
-withTangent :: forall d. Vector2D Double -> Seq ( StrokePoint d ) -> Offset
+withTangent
-withTangent tgt ( spt0 :<| spt1 :<| spts ) =
+  :: forall crvData ptData
-  let
+  .  ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
-    tgt0 :: Vector2D Double
+  => Vector2D Double -> Spline Closed crvData ptData -> Offset
-    tgt0 = coords spt0 --> coords spt1
+withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of
-  in
+  Nothing -> 
-    if parallel tgt tgt0
+    Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
-    then Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
+  Just tgt_last ->
-    else go 0 tgt0 spt0 spt1 spts
+    case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of
-
+      Left off -> off
+      _ -> error $
+            "withTangent: could not find any point with given tangent vector\n\
+            \tangent vector: " <> show tgt_wanted <> "\n\
+            \spline: " <> show spline <> "\n"
   where
-    go :: Int -> Vector2D Double -> StrokePoint d -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
+    go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) ()
-    go _ _    ( ControlPoint { } ) _ _ = error "withTangent: path starts with a control point"
+    go i cp cseg = do
-    -- Line.
+      tgt_prev <- get
-    go i tgt0
+      let
-      ( PathPoint { coords = p0 } )
+        p :: Point2D Double
-      ( sp1@( PathPoint { coords = p1 } ) )
+        p = coords cp
-      ps
+        seg :: Curve Open crvData ( Point2D Double )
-      | parallel tgt tgt0
+        seg = fmap coords cseg
-      = Offset i Nothing ( MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 )
+        tgt_start, tgt_end :: Vector2D Double
+        tgt_start = startTangent splineStart cp cseg
+        tgt_end   = endTangent   splineStart cp cseg
+      -- Handle corner.
+      unless ( parallel tgt_prev tgt_start ) do
+        for_ ( between tgt_wanted tgt_prev tgt_start ) \ _ ->
+          lift . throwE $
+            Offset
+              { offsetIndex     = i
+              , offsetParameter = Just 0
+              , offset          = MkVector2D p
+              }
+      -- Handle segment.
+      lift $ handleSegment i p seg tgt_start
+      put tgt_end
+
+    handleSegment :: Int -> Point2D Double -> Curve Open crvData ( Point2D Double ) -> Vector2D Double -> Except Offset ()
+    handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0
+      | parallel tgt_wanted tgt0
+      , let
+          offset :: Vector2D Double
+          offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1
+      = throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } )
       | otherwise
-      = continue ( i + 1 ) tgt0 sp1 ps
+      = pure ()
-    -- Quadratic Bézier curve.
+    handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 =
-    go i tgt0
-      ( PathPoint    { coords = p0 } )
-      ( ControlPoint { coords = p1 } )
-      ( sp2@( PathPoint { coords = p2 } ) :<| ps ) =
       let
         tgt1 :: Vector2D Double
         tgt1 = p1 --> p2
-      in case between tgt tgt0 tgt1 of
+      in for_ ( between tgt_wanted tgt0 tgt1 ) \ t ->
-          Just t  -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t )
+          throwE $
-          Nothing -> continue ( i + 2 ) tgt1 sp2 ps
+            Offset
-    -- Cubic Bézier curve.
+              { offsetIndex     = i
-    go i tgt0
+              , offsetParameter = Just t
-      ( PathPoint    { coords = p0 } )
+              , offset          = MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
-      ( ControlPoint { coords = p1 } )
+              }
-      ( ControlPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) =
+    handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 =
       let
         tgt1, tgt2 :: Vector2D Double
         tgt1 = p1 --> p2
@@ -569,42 +671,30 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
         bez :: Cubic.Bezier ( Point2D Double )
         bez = Cubic.Bezier {..}
         c01, c12, c23 :: Double
-        c01 = tgt `cross` tgt0
+        c01 = tgt_wanted `cross` tgt0
-        c12 = tgt `cross` tgt1
+        c12 = tgt_wanted `cross` tgt1
-        c23 = tgt `cross` tgt2
+        c23 = tgt_wanted `cross` tgt2
         correctTangentParam :: Double -> Maybe Double
         correctTangentParam t
           | t > -epsilon && t < 1 + epsilon
-          , tgt ^.^ Cubic.bezier' bez t > epsilon
+          , tgt_wanted ^.^ Cubic.bezier' bez t > epsilon
           = Just ( max 0 ( min 1 t ) )
           | otherwise
           = Nothing
       in
-        case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of
-          ( t : _ )
-            -> Offset i ( Just t ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t )
-          _
-            | Just s <- between tgt tgt0 tgt2
-            -- Fallback in case we couldn't solve the quadratic for some reason.
-            -> Offset i ( Just s ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez s )
-            -- Otherwise: go to next piece of the curve.
-            | otherwise
-            -> continue ( i + 3 ) tgt2 sp3 ps
-    go _ _ _ _ _
-      = error "withTangent: unrecognised path type (more than two consecutive control points)"
-
-    -- Handles corners in the Bézier curve.
-    continue :: Int -> Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
-    continue _ _    _  Empty         = Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
-    continue i ptgt p0 ( p1 :<| ps ) =
         let
-        tgt0 :: Vector2D Double
+          mbParam :: Maybe Double
-        tgt0 = coords p0 --> coords p1
+          mbParam =
-      in case between tgt ptgt tgt0 of
+            case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of
-        Just _  -> Offset i ( Just 0 ) ( MkVector2D $ coords p0 )
+              ( t : _ ) -> Just t
-        Nothing -> go i tgt0 p0 p1 ps
+              _         -> between tgt_wanted tgt0 tgt2 -- fallback in case we couldn't solve the quadratic for some reason
-
+        in for_ mbParam \ t ->
-withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)"
+            throwE $
+              Offset
+                { offsetIndex     = i
+                , offsetParameter = Just t
+                , offset          = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t
+                }
 
 -- | Finds whether the query vector @ u @ lies between the two provided vectors @ v0 @, @ v1 @.
 --

src/lib/Math/Module.hs

@@ -10,7 +10,8 @@ module Math.Module
   ( Module(..), lerp
   , Inner(..)
   , squaredNorm, quadrance, distance
-  , proj, projC, closestPointToSegment
+  , proj, projC, closestPointOnSegment
+  , cross
   )
   where
 
@@ -18,7 +19,7 @@ module Math.Module
 import Control.Applicative
   ( liftA2 )
 import Data.Monoid
-  ( Ap(..) )
+  ( Ap(..), Sum(..) )
 
 -- acts
 import Data.Act
@@ -28,6 +29,14 @@ import Data.Act
     ( (-->) )
   )
 
+-- groups
+import Data.Group
+  ( invert )
+
+-- MetaBrush
+import Math.Vector2D
+  ( Vector2D(..), Segment(..) )
+
 --------------------------------------------------------------------------------
 
 infixl 6 ^+^, ^-^
@@ -35,8 +44,9 @@ infix  9 ^*, *^
 
 class Num r => Module r m | m -> r where
 
-  {-# MINIMAL (^+^), ( (^*) | (*^) ) #-}
+  {-# MINIMAL origin, (^+^), ( (^*) | (*^) ) #-}
 
+  origin :: m
   (^+^) :: m -> m -> m
   (^-^) :: m -> m -> m
   (*^) :: r -> m -> m
@@ -47,6 +57,7 @@ class Num r => Module r m | m -> r where
   m ^-^ n = m ^+^ (-1) *^ n
 
 instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where
+  origin = pure origin
   (^+^)  = liftA2 (^+^)
   (^-^)  = liftA2 (^-^)
   (*^) r = fmap ( r *^ )
@@ -79,11 +90,11 @@ proj x y = projC x y *^ y
 projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
 projC x y = x ^.^ y / squaredNorm y
 
-closestPointToSegment
+closestPointOnSegment
   :: forall v r p
   . ( Inner r v, Torsor v p, Fractional r, Ord r )
-  => p -> p -> p -> ( r, p )
+  => p -> Segment p -> ( r, p )
-closestPointToSegment c p0 p1
+closestPointOnSegment c ( Segment p0 p1 )
   | t <= 0
   = ( 0, p0 )
   | t >= 1
@@ -95,3 +106,36 @@ closestPointToSegment c p0 p1
     v01 = p0 --> p1
     t :: r
     t = projC ( p0 --> c ) v01
+
+
+instance Num a => Module a ( Sum a ) where
+
+  origin = Sum 0
+
+  (^+^) = (<>)
+  ( Sum x ) ^-^ ( Sum y ) = Sum ( x - y )
+
+  c *^ ( Sum x ) = Sum ( c * x )
+  ( Sum x ) ^* c = Sum ( x * c )
+
+instance Num a => Inner a ( Sum a ) where
+  Sum a ^.^ Sum b = a * b
+
+
+instance Num a => Module a ( Vector2D a ) where
+
+  origin = pure 0
+
+  (^+^) = (<>)
+  p ^-^ q = p <> invert q
+
+  c *^ p = fmap ( c * ) p
+  p ^* c = fmap ( * c ) p
+
+instance Num a => Inner a ( Vector2D a ) where
+  ( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
+    = x1 * x2 + y1 * y2
+
+cross :: Num a => Vector2D a -> Vector2D a -> a
+cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
+  = x1 * y2 - x2 * y1

src/lib/Math/Vector2D.hs

@@ -9,7 +9,7 @@
 
 module Math.Vector2D
   ( Point2D(..), Vector2D(.., Vector2D), Mat22(..)
-  , cross
+  , Segment(..)
   )
   where
 
@@ -33,16 +33,12 @@ import Generic.Data
 
 -- groups
 import Data.Group
-  ( Group ( invert ) )
+  ( Group )
 
 -- groups-generic
 import Data.Group.Generics
   ( )
 
--- MetaBrush
-import Math.Module
-  ( Module(..), Inner(..) )
-
 --------------------------------------------------------------------------------
 
 data Point2D a = Point2D !a !a
@@ -63,24 +59,21 @@ newtype Vector2D a = MkVector2D { tip :: Point2D a }
 pattern Vector2D :: a -> a -> Vector2D a
 pattern Vector2D x y = MkVector2D ( Point2D x y )
 
-instance Num a => Module a ( Vector2D a ) where
-  (^+^) = (<>)
-  p ^-^ q = p <> invert q
-
-  c *^ p = fmap ( c * ) p
-  p ^* c = fmap ( * c ) p
-
-instance Num a => Inner a ( Vector2D a ) where
-  ( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
-    = x1 * x2 + y1 * y2
-
-cross :: Num a => Vector2D a -> Vector2D a -> a
-cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
-  = x1 * y2 - x2 * y1
-
 data Mat22 a
   = Mat22 !a !a !a !a
   deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
   deriving Applicative
     via Generically1 Mat22
   deriving anyclass ( NFData, NFData1 )
+
+data Segment p =
+  Segment
+    { segmentStart :: !p
+    , segmentEnd   :: !p
+    }
+  deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving ( Semigroup, Monoid, Group )
+    via GenericProduct ( Segment p )
+  deriving Applicative
+    via Generically1 Segment
+  deriving anyclass ( NFData, NFData1 )