Refactors in preparation for stroke hierarchy

MetaBrush.cabal

@@ -183,17 +183,22 @@ library metabrushes
         Haskell2010
 
     exposed-modules:
-        MetaBrush.Assert
+        MetaBrush.Action
+      , MetaBrush.Assert
       , MetaBrush.Asset.Brushes
       , MetaBrush.Brush
       , MetaBrush.Brush.Widget
       , MetaBrush.Document
-      , MetaBrush.Document.Draw
+      , MetaBrush.Document.Diff
       , MetaBrush.Document.History
       , MetaBrush.Document.Serialise
-      , MetaBrush.Document.SubdivideStroke
+      , MetaBrush.Draw
+      , MetaBrush.Guide
+      , MetaBrush.Hover
+      , MetaBrush.Layer
       , MetaBrush.Records
       , MetaBrush.Serialisable
+      , MetaBrush.Stroke
       , MetaBrush.Unique
       , MetaBrush.Util
 
@@ -219,8 +224,10 @@ executable MetaBrush
         Haskell2010
 
     other-modules:
-        MetaBrush.Action
+        MetaBrush.Application
-      , MetaBrush.Application
+      , MetaBrush.Application.Action
+      , MetaBrush.Application.Context
+      , MetaBrush.Application.UpdateDocument
       , MetaBrush.Asset.CloseTabButton
       , MetaBrush.Asset.Colours
       , MetaBrush.Asset.Cursor
@@ -229,13 +236,11 @@ executable MetaBrush
       , MetaBrush.Asset.TickBox
       , MetaBrush.Asset.Tools
       , MetaBrush.Asset.WindowIcons
-      , MetaBrush.Context
-      , MetaBrush.Document.Selection
-      , MetaBrush.Document.Update
       , MetaBrush.Event
       , MetaBrush.GTK.Util
       , MetaBrush.Render.Document
       , MetaBrush.Render.Rulers
+      , MetaBrush.Time
       , MetaBrush.UI.Coordinates
       , MetaBrush.UI.FileBar
       , MetaBrush.UI.InfoBar
@@ -243,7 +248,6 @@ executable MetaBrush
       , MetaBrush.UI.Panels
       , MetaBrush.UI.ToolBar
       , MetaBrush.UI.Viewport
-      , MetaBrush.Time
 
     ghc-options:
       -threaded

app/Main.hs

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

brush-strokes/brush-strokes.cabal

@@ -14,7 +14,7 @@ extra-source-files:
 
 flag use-simd
   description: Use SIMD instructions to implement interval arithmetic.
-  default: True
+  default: False
   manual:  True
 
 flag use-fma

brush-strokes/src/cusps/inspect/Math/Interval/Abstract.hs

@@ -20,6 +20,8 @@ import Data.Foldable
   ( toList )
 import Data.List
   ( intersperse )
+import Data.List.NonEmpty
+  ( unzip )
 import Data.Proxy
   ( Proxy(..) )
 import Data.Typeable
@@ -54,7 +56,7 @@ import Math.Differentiable
 import Math.Interval
 import Math.Linear
   ( ℝ(..), T(..)
-  , Vec(..), (!), unzip
+  , Vec(..), (!)
   , Fin(..), RepDim, Representable(..), RepresentableQ(..)
   )
 import Math.Module

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

@@ -62,8 +62,18 @@ import Math.Linear
 
 data PointType
   = PathPoint
-  | ControlPoint
+  | ControlPoint ControlPoint
-  deriving stock Show
+  deriving stock ( Eq, Ord, Show, Generic )
+  deriving anyclass NFData
+
+data ControlPoint
+  = Bez2Cp
+  | Bez3Cp1
+  | Bez3Cp2
+  deriving stock ( Eq, Ord, Show, Generic )
+  deriving anyclass NFData
+
+--------------------------------------------------------------------------------
 
 data SplineType = Open | Closed
 
@@ -224,27 +234,27 @@ 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 ( 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 ( Bezier2To p1 p2    d ) = Bezier2To ( g ( ControlPoint Bez2Cp  ) 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 )
+bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ( ControlPoint Bez3Cp1 ) p1 ) ( g ( ControlPoint Bez3Cp2 ) 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 ( 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 ( Bezier2To p1 p2    d ) = g ( ControlPoint Bez2Cp  ) 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
+bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ( ControlPoint Bez3Cp1 ) p1 <> g ( ControlPoint Bez3Cp2 ) 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 ( 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 ( Bezier2To p1 p2    d ) = Bezier2To <$> g ( ControlPoint Bez2Cp  ) 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
+bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ( ControlPoint Bez3Cp1 ) p1 <*> g ( ControlPoint Bez3Cp2 ) p2 <*> traverse ( g PathPoint ) p3 <*> f d
 
 dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData )
 dropCurves i spline@( Spline { splineCurves = OpenCurves curves } )
@@ -321,15 +331,18 @@ dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat
 -- as the result type depends on whether a starting point has been found yet or not.
 data CurrentStart ( hasStart :: Bool ) ptData where
   NoStartFound :: CurrentStart False ptData
-  CurrentStart :: !ptData -> CurrentStart True ptData
+  CurrentStart ::
+    { wasOriginalStart :: Bool
+    , startPoint :: !ptData
+    } -> CurrentStart True ptData
 
 deriving stock    instance Show ptData => Show ( CurrentStart hasStart ptData )
 deriving stock    instance Functor     ( CurrentStart hasStart )
 deriving stock    instance Foldable    ( CurrentStart hasStart )
 deriving stock    instance Traversable ( CurrentStart hasStart )
 instance NFData ptData => NFData ( CurrentStart hasStart ptData ) where
-  rnf NoStartFound             = ()
+  rnf NoStartFound                 = ()
-  rnf ( CurrentStart ptData ) = rnf ptData
+  rnf ( CurrentStart orig ptData ) = rnf orig `seq` rnf ptData
 
 -- | The result of a wither operation on a spline.
 --
@@ -468,13 +481,13 @@ instance KnownSplineType Open where
     -> 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
+    ( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go ( (, True ) <$> 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 :: Maybe ( ptData', Bool ) -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
         go _       Empty            = pure Empty
         go Nothing ( crv :<| crvs ) = do
           mbCrv' <- lift $ fc NoStartFound crv
@@ -483,14 +496,14 @@ instance KnownSplineType Open where
             UseStartPoint ptData'' mbCrv'' -> do
               modify' ( <> Just ( First ptData'' ) )
               case mbCrv'' of
-                Nothing    ->                   go ( Just ptData'' ) crvs
+                Nothing    ->                   go ( Just ( ptData'', False ) ) crvs
-                Just crv'' -> ( crv'' :<| ) <$> go ( Just ptData'' ) crvs
+                Just crv'' -> ( crv'' :<| ) <$> go ( Just ( ptData'', False ) ) crvs
-        go ( Just ptData' ) ( crv :<| crvs ) = do
+        go ( Just ( ptData', orig ) ) ( crv :<| crvs ) = do
-          mbCrv' <- lift $ fc ( CurrentStart ptData' ) crv
+          mbCrv' <- lift $ fc ( CurrentStart orig ptData' ) crv
           case mbCrv' of
-            Dismiss -> go ( Just ptData' ) crvs
+            Dismiss -> go ( Just ( ptData', False ) ) crvs
             UseCurve crv'' ->
-              ( crv'' :<| ) <$> go ( Just $ openCurveEnd crv'' ) crvs
+              ( crv'' :<| ) <$> go ( Just ( openCurveEnd crv'', True ) ) crvs
 
 instance KnownSplineType Closed where
 
@@ -527,36 +540,9 @@ instance KnownSplineType Closed where
         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 closedSpline = do
-  biwitherSpline fc fp ( Spline { splineStart, splineCurves = ClosedCurves prevCurves lastCurve } ) = do
+    spline' <- biwitherSpline fc fp ( adjustSplineType @Open closedSpline )
-    mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
+    return $ adjustSplineType @Closed <$> spline'
-    case mbSpline' of
-      Nothing -> do
-        mbCrv' <- fc NoStartFound lastCurve
-        case mbCrv' of
-          Dismiss -> pure Nothing
-          UseStartPoint ptData'' mbCrv'' ->
-            case mbCrv'' of
-              Nothing    -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = NoCurves } )
-              Just crv'' -> pure $ Just ( Spline { splineStart = ptData'', splineCurves = ClosedCurves Empty crv'' } )
-      Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
-        case prevCurves' of
-          Empty -> do
-            mbLastCurve' <- fc ( CurrentStart start' ) lastCurve
-            case mbLastCurve' of
-              Dismiss ->
-                pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
-              UseCurve lastCurve' ->
-                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
-          ( prevPrevCurves' :|> prevLastCurve' ) -> do
-            let
-              prevPt' = openCurveEnd prevLastCurve'
-            mbLastCurve' <- fc ( CurrentStart prevPt' ) lastCurve
-            case mbLastCurve' of
-              Dismiss ->
-                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
-              UseCurve lastCurve' ->
-                pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )
 
 showSplinePoints :: forall clo ptData crvData
                  .  (KnownSplineType clo, Show ptData)

brush-strokes/src/metafont/MetaBrush/MetaFont/Convert.hs

@@ -72,7 +72,7 @@ import Math.Linear
 import MetaBrush.DSL.Interpolation
   ( Interpolatable(Diff) )
 import MetaBrush.Document
-  ( PointData(..), FocusState(Normal) )
+  ( PointData(..) )
 
 --------------------------------------------------------------------------------
 

hie.yaml

@@ -1,12 +0,0 @@
-cradle:
-  cabal:
-    - path: "./brush-strokes/src"
-      component: "lib:brush-strokes"
-    - path: "./src/metabrushes"
-      component: "lib:metabrushes"
-    - path: "./src/convert"
-      component: "exe:convert-metafont"
-    - path: "./src/app"
-      component: "exe:MetaBrush"
-    - path: "./app"
-      component: "exe:MetaBrush"

src/app/MetaBrush/Application.hs

@@ -24,13 +24,10 @@ import GHC.Conc
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( empty )
 import qualified Data.Sequence as Seq
-  ( fromList )
 import Data.Set
   ( Set )
 import qualified Data.Set as Set
-  ( empty )
 
 -- directory
 import qualified System.Directory as Directory
@@ -87,27 +84,24 @@ import Math.Linear
   ( ℝ(..) )
 
 -- MetaBrush
-import MetaBrush.Action
+import MetaBrush.Application.Action
   ( ActionOrigin(..) )
 import qualified MetaBrush.Asset.Brushes as Asset.Brushes
 import MetaBrush.Asset.Colours
   ( getColours )
 import MetaBrush.Asset.Logo
   ( drawLogo )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( UIElements(..), Variables(..)
   , Modifier(..)
   , HoldAction(..), PartialPath(..)
   )
+import MetaBrush.Application.UpdateDocument
+  ( activeDocument, withActiveDocument )
 import MetaBrush.Document
-  ( emptyDocument
+  ( Document(..), emptyDocument )
-  , Stroke(..), StrokeHierarchy(..), FocusState(..)
-  , PointData(..)
-  )
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory )
-import MetaBrush.Document.Update
-  ( activeDocument, withActiveDocument )
 import MetaBrush.Event
   ( handleEvents )
 import MetaBrush.GTK.Util
@@ -117,6 +111,7 @@ import MetaBrush.Render.Document
   ( blankRender, getDocumentRender )
 import MetaBrush.Render.Rulers
   ( renderRuler )
+import MetaBrush.Stroke
 import MetaBrush.UI.FileBar
   ( FileBar(..), FileBarTab, createFileBar )
 import MetaBrush.UI.InfoBar
@@ -125,6 +120,8 @@ import MetaBrush.UI.Menu
   ( createMenuBar, createMenuActions )
 import MetaBrush.UI.Panels
   ( createPanelBar )
+--import MetaBrush.UI.StrokeTreeView
+--  ( newStrokeView )
 import MetaBrush.UI.ToolBar
   ( Tool(..), Mode(..), createToolBar )
 import MetaBrush.UI.Viewport
@@ -133,10 +130,7 @@ import MetaBrush.UI.Viewport
   , createViewport
   )
 import MetaBrush.Unique
-  ( newUniqueSupply
+  ( Unique, freshUnique, newUniqueSupply )
-  , Unique, freshUnique
-  , uniqueMapFromList
-  )
 import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
 import qualified Paths_MetaBrush as Cabal
@@ -156,43 +150,51 @@ runApplication application = do
   strokeUnique <- runReaderT freshUnique uniqueSupply
 
   let
-
+    testStroke =
-    testDocuments :: Map Unique DocumentHistory
+      Stroke
-    testDocuments = newHistory <$> uniqueMapFromList
+        { strokeBrush  = Just Asset.Brushes.ellipse --tearDrop
-      [ emptyDocument "Test" docUnique
+        , strokeSpline =
-      & ( field' @"documentContent" . field' @"strokes" ) .~
+--          Spline
-        ( Seq.fromList
+--            { splineStart  = mkPoint ( ℝ2 -20 -20 ) 5
-          [ StrokeLeaf $ Stroke
+--            , splineCurves = OpenCurves $ Seq.fromList
-            { strokeName    = "Stroke 1"
+--              [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 20 20 ) 5 ), curveData = invalidateCache undefined }
-            , strokeVisible = True
+--              ]
-            , strokeUnique  = strokeUnique
+--            }
-            , strokeBrush   = Just Asset.Brushes.ellipse --tearDrop
+          Spline
-            , strokeSpline  =
+            { splineStart  = mkPoint ( ℝ2 0 0 ) 10 25 0
---              Spline
+            , splineCurves = OpenCurves $ Seq.fromList
---                { splineStart  = mkPoint ( ℝ2 -20 -20 ) 5
+              [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100   0 ) 15 40     0     ), curveData = CurveData 0 $ invalidateCache undefined }
---                , splineCurves = OpenCurves $ Seq.fromList
+              , LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10  10 )  8 5 ( pi / 4 ) ), curveData = CurveData 1 $ invalidateCache undefined }
---                  [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 20 20 ) 5 ), curveData = invalidateCache undefined }
+              , LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = CurveData 2 $ invalidateCache undefined }
---                  ]
+              ]
---                }
-              Spline
-                { splineStart  = mkPoint ( ℝ2 0 0 ) 10 25 0
-                , splineCurves = OpenCurves $ Seq.fromList
-                  [ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 100 0 ) 15 40 0 ), curveData = invalidateCache undefined }
-                  , LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10  10 )  8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
-                  , LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
-                  ]
-                }
             }
-          ]
+        }
-        )
-      ]
         where
           mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
-          mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
+          mkPoint pt a b phi = PointData pt ( MkR $ ℝ3 a b phi )
-          --mkPoint :: ℝ 2 -> Double -> PointData ( Record Asset.Brushes.CircleBrushFields )
+
-          --mkPoint pt r = PointData pt Normal ( MkR $ ℝ1 r )
+    testLayers :: Layers
-          --mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.TearDropBrushFields )
+    testLayers =
-          --mkPoint pt w h phi = PointData pt Normal ( MkR $ ℝ3 w h phi )
+      [ StrokeLayer
+        { layerUnique  = strokeUnique
+        , layerName    = "Stroke 1"
+        , layerVisible = True
+        , layerLocked  = False
+        , layerStroke  = testStroke
+        }
+      ]
+
+    ( layerMeta, testStrokes ) = layersStrokeHierarchy testLayers
+
+    testDoc :: Document
+    testDoc
+      = emptyDocument "Test"
+      & ( field' @"documentContent"  . field' @"strokeHierarchy" ) .~ testStrokes
+      & ( field' @"documentMetadata" . field' @"layerMetadata"   ) .~ layerMeta
+
+    testDocuments :: Map Unique DocumentHistory
+    testDocuments = newHistory <$> Map.fromList
+      [ ( docUnique, testDoc ) ]
 
   recomputeStrokesTVar <- STM.newTVarIO @Bool                                    False
   documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
@@ -223,6 +225,10 @@ runApplication application = do
   cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
                               Just defaultRootIsolationOptions
 
+  --testDocsStrokeListModels <-
+  --  for testDocuments ( newStrokeView . strokes . documentContent . present )
+  strokeListModelsTVar <- STM.newTVarIO @( Map Unique GTK.SelectionModel ) Map.empty --testDocsStrokeListModels
+
   -- Put all these stateful variables in a record for conciseness.
   let
     variables :: Variables
@@ -335,7 +341,7 @@ runApplication application = do
         case needsRecomputation of
           False -> STM.retry
           True  -> do
-            mbDocNow <- fmap present <$> activeDocument variables
+            mbDocNow <- fmap ( present . snd ) <$> activeDocument variables
             case mbDocNow of
               Nothing -> pure ( pure . const $ blankRender colours )
               Just doc -> do
@@ -385,7 +391,7 @@ runApplication application = do
     viewportWidth  <- GTK.widgetGetWidth  viewportDrawingArea
     viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
     -- Get the Cairo instructions for rendering the current document
-    mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
+    mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument variables )
     render <- case mbDoc of
       Nothing -> pure ( blankRender colours )
       Just _  -> STM.atomically do
@@ -404,7 +410,7 @@ runApplication application = do
         viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
         width          <- GTK.widgetGetWidth  rulerDrawingArea
         height         <- GTK.widgetGetHeight rulerDrawingArea
-        mbRender       <- STM.atomically $ withActiveDocument variables \ doc -> do
+        mbRender       <- STM.atomically $ withActiveDocument variables \ _ doc -> do
           mbMousePos   <- STM.readTVar mousePosTVar
           mbHoldAction <- STM.readTVar mouseHoldTVar
           showGuides   <- STM.readTVar showGuidesTVar
@@ -422,6 +428,11 @@ runApplication application = do
 
   _ <- createToolBar variables colours toolBar
 
+  ---------------------------------------------------------
+  -- Panels bar
+
+  panelsBar <- createPanelBar panelBox
+
   ---------------------------------------------------------
   -- Info bar
 
@@ -439,6 +450,7 @@ runApplication application = do
         colours variables
         application window windowKeys titleBar titleLabel viewport infoBar
         menuBar menuActions
+        panelsBar
 
     let
       uiElements :: UIElements
@@ -453,11 +465,6 @@ runApplication application = do
   GTK.boxAppend mainView viewportGrid
   GTK.boxAppend mainView infoBarArea
 
-  ---------------------------------------------------------
-  -- Panels
-
-  createPanelBar panelBox
-
   ---------------------------------------------------------
   -- Actions
 
@@ -466,8 +473,9 @@ runApplication application = do
   ---------------------------------------------------------
   -- Finishing up
 
-  mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
+  mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument variables )
-  updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
+  updateInfoBar viewportDrawingArea infoBar variables ( fmap documentMetadata mbDoc )
+    -- need to update the info bar after widgets have been realized
 
   widgetShow window
 

src/app/MetaBrush/Application/Action.hs

@@ -1,14 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
-
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module MetaBrush.Action where
+module MetaBrush.Application.Action where
 
 -- base
+import Control.Arrow
+  ( second )
 import Control.Monad
   ( guard, when, unless, void )
-import Control.Monad.ST
-  ( RealWorld )
 import Data.Foldable
   ( for_ )
 import Data.List
@@ -34,9 +33,7 @@ import Data.Act
 
 -- containers
 import qualified Data.Map as Map
-  ( insert, lookup )
 import qualified Data.Set as Set
-  ( delete, insert )
 
 -- directory
 import System.Directory
@@ -85,66 +82,62 @@ import qualified Control.Concurrent.STM as STM
 import qualified Control.Concurrent.STM.TVar as STM
   ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
 
+-- transformers
+import qualified Control.Monad.Trans.Reader as Reader
+
 -- text
 import Data.Text
   ( Text )
 import qualified Data.Text as Text
-  ( intercalate, pack )
+  ( pack )
 
 -- brush-strokes
 import Math.Bezier.Spline
-  ( Spline(..), SplineType(Open)
-  , catMaybesSpline
-  )
 import Math.Bezier.Stroke
-  ( CachedStroke(..), invalidateCache )
+  ( invalidateCache )
 import Math.Module
-  ( Module((*^)), quadrance )
+  ( Module((*^)) )
 import Math.Linear
   ( ℝ(..), T(..) )
 
 -- MetaBrush
-import MetaBrush.Asset.WindowIcons
+import MetaBrush.Action
-  ( drawClose )
+import MetaBrush.Application.Context
-import qualified MetaBrush.Brush.Widget as Brush
-  ( describeWidgetAction )
-import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , Modifier(..), modifierKey
   , HoldAction(..), GuideAction(..), PartialPath(..)
   )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..), PointData(..), FocusState(..)
+  ( Document(..), DocumentContent(..), DocumentMetadata(..)
-  , Guide(..), selectedGuide, addGuide
+  , Zoom(..)
+  , Guide(..)
+  , StrokePoints(..)
   )
-import MetaBrush.Document.Draw
+import MetaBrush.Application.UpdateDocument
-  ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
+  ( activeDocument
+  , DocumentUpdate(..)
+  , PureDocModification(..), DocModification(..)
+  , ActiveDocChange (..)
+  , modifyingCurrentDocument
+  , updateUIAction, updateHistoryState
+  )
+import MetaBrush.Asset.WindowIcons
+  ( drawClose )
+import MetaBrush.Document.Diff
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory
   , back, fwd
   )
-import MetaBrush.Document.Selection
-  ( SelectionMode(..), selectionMode
-  , selectAt, selectRectangle
-  , DragMoveSelect(..), dragMoveSelect
-  , UpdateInfo(..)
-  , deleteSelected
-  , dragUpdate, pressingControl
-  , BrushWidgetActionState(..)
-  , applyBrushWidgetAction
-  )
 import MetaBrush.Document.Serialise
   ( saveDocument, loadDocument )
-import MetaBrush.Document.SubdivideStroke
+import MetaBrush.Draw
-  ( subdivide )
-import MetaBrush.Document.Update
-  ( activeDocument
-  , DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
-  , modifyingCurrentDocument
-  , updateUIAction, updateHistoryState
-  )
 import MetaBrush.GTK.Util
   ( widgetShow )
+import MetaBrush.Hover
+  ( inPointClickRange )
+import MetaBrush.Guide
+import MetaBrush.Layer
+import MetaBrush.Stroke
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@@ -154,9 +147,9 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
 import MetaBrush.UI.ToolBar
   ( Tool(..), Mode(..) )
 import MetaBrush.UI.Viewport
-  ( Viewport(..), Ruler(..) )
+  ( Viewport(..) )
 import MetaBrush.Unique
-  ( Unique )
+  ( Unique, freshUnique )
 import MetaBrush.GTK.Util
   ( (>=?=>), (>>?=)
   , widgetAddClass, widgetAddClasses
@@ -233,9 +226,10 @@ instance HandleAction OpenFile where
               case mbDoc of
                 Left errMessage -> openFileWarningDialog window filePath errMessage
                 Right doc -> do
+                  newDocUnique <- Reader.runReaderT freshUnique uniqueSupply
                   let newDocHist = newHistory doc
-                  newFileTab uiElts vars (Just newDocHist) tabLoc
+                  newFileTab uiElts vars ( Just ( newDocUnique, newDocHist ) ) tabLoc
-                  updateHistoryState uiElts (Just newDocHist)
+                  updateHistoryState uiElts ( Just newDocHist )
           Nothing -> return ()
 
 openFileWarningDialog
@@ -303,10 +297,11 @@ instance HandleAction OpenFolder where
                 case mbDoc of
                   Left errMessage -> openFileWarningDialog window filePath errMessage
                   Right doc -> do
+                    newDocUnique <- Reader.runReaderT freshUnique uniqueSupply
                     let
                       newDocHist :: DocumentHistory
                       newDocHist = newHistory doc
-                    newFileTab uiElts vars ( Just newDocHist ) tabLoc
+                    newFileTab uiElts vars ( Just ( newDocUnique, newDocHist ) ) tabLoc
                     updateHistoryState uiElts ( Just newDocHist )
 
 ---------------------------
@@ -335,14 +330,14 @@ data SaveFormat
 
 save :: UIElements -> Variables -> Bool -> IO ()
 save uiElts vars keepOpen = do
-  mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
+  mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument vars )
   for_ mbDoc \case
-    doc@( Document { mbFilePath, documentContent } )
+    doc@( Document { documentMetadata = Metadata { documentFilePath }, documentContent } )
-      | Nothing <- mbFilePath
+      | Nothing <- documentFilePath
       -> saveAs uiElts vars keepOpen
       | False <- unsavedChanges documentContent
       -> pure ()
-      | Just filePath <- mbFilePath
+      | Just filePath <- documentFilePath
       -> modifyingCurrentDocument uiElts vars \ _ -> do
         let
           modif :: DocumentUpdate
@@ -361,7 +356,7 @@ saveAs uiElts vars keepOpen =
 export :: UIElements -> Variables -> IO ()
 export uiElts vars@( Variables { .. } ) = do
   mbRender <- STM.atomically $ do
-    mbDoc <- fmap present <$> activeDocument vars
+    mbDoc <- fmap ( present . snd ) <$> activeDocument vars
     case mbDoc of
       Nothing -> return Nothing
       Just _  -> Just <$> STM.readTVar documentRenderTVar
@@ -435,29 +430,29 @@ instance HandleAction Close where
     vars@( Variables {..} )
     close = do
       mbDoc <- case close of
-        CloseActive      -> fmap ( ( , True ) . present ) <$> STM.atomically ( activeDocument vars )
+        CloseActive      -> fmap ( second ( ( , True ) . present ) ) <$> STM.atomically ( activeDocument vars )
         CloseThis unique -> do
-          mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
+          mbCurrentDoc <- fmap ( second present ) <$> STM.atomically ( activeDocument vars )
           mbDoc        <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
           for mbDoc \ doc ->
-            pure ( doc, maybe False ( ( == unique ) . documentUnique ) mbCurrentDoc )
+            pure ( unique, ( doc, maybe False ( ( == unique ) . fst ) mbCurrentDoc ) )
       case mbDoc of
         Nothing -> pure () -- could show a warning message
-        Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
+        Just ( closeDocUnique, ( Document { documentMetadata = Metadata { documentName }, documentContent }, isActiveDoc ) )
           | unsavedChanges documentContent
           -> do
             dialogWindow <- GTK.windowNew
             GTK.setWindowDecorated dialogWindow False
-            GTK.windowSetTransientFor dialogWindow (Just window)
+            GTK.windowSetTransientFor dialogWindow ( Just window )
 
             contentBox <- GTK.boxNew GTK.OrientationVertical 30
             GTK.widgetSetMarginStart  contentBox 20
             GTK.widgetSetMarginEnd    contentBox 20
             GTK.widgetSetMarginTop    contentBox 20
             GTK.widgetSetMarginBottom contentBox 20
-            GTK.windowSetChild dialogWindow (Just contentBox)
+            GTK.windowSetChild dialogWindow ( Just contentBox )
 
-            label <- GTK.labelNew $ Just $ "\n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?"
+            label <- GTK.labelNew $ Just $ "\n\"" <> documentName <> "\" contains unsaved changes.\nClose anyway?"
             GTK.boxAppend contentBox label
 
             buttonBox <- GTK.boxNew GTK.OrientationHorizontal 0
@@ -479,7 +474,7 @@ instance HandleAction Close where
               widgetAddClass button "dialogButton"
 
             void $ GTK.onButtonClicked closeButton $ do
-              closeDocument isActiveDoc documentUnique
+              closeDocument isActiveDoc closeDocUnique
               GTK.windowDestroy dialogWindow
             void $ GTK.onButtonClicked saveCloseButton $ do
               save uiElts vars False
@@ -490,7 +485,7 @@ instance HandleAction Close where
             GTK.widgetSetVisible dialogWindow True
 
           | otherwise
-          -> closeDocument isActiveDoc documentUnique
+          -> closeDocument isActiveDoc closeDocUnique
 
       where
         closeDocument :: Bool -> Unique -> IO ()
@@ -499,7 +494,8 @@ instance HandleAction Close where
           when isActiveDoc do
             uiUpdateAction <- STM.atomically do
               STM.writeTVar activeDocumentTVar Nothing
-              uiUpdateAction <- updateUIAction uiElts vars
+              let change = ActiveDocChange { mbOldDocUnique = Just unique }
+              uiUpdateAction <- updateUIAction change uiElts vars
               pure do
                 uiUpdateAction
                 updateHistoryState uiElts Nothing
@@ -535,7 +531,8 @@ instance HandleAction SwitchFromTo where
         uiUpdateAction <- STM.atomically do
           STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
           mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
-          uiUpdateAction <- updateUIAction uiElts vars
+          let change = ActiveDocChange { mbOldDocUnique = mbPrevActiveDocUnique }
+          uiUpdateAction <- updateUIAction change uiElts vars
           pure do
             uiUpdateAction
             for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do
@@ -593,7 +590,7 @@ updateHistory f uiElts vars@( Variables {..} ) = do
               newDocHistory :: DocumentHistory
               newDocHistory = f docHistory
             STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDocHistory )
-            uiUpdateAction <- updateUIAction uiElts vars
+            uiUpdateAction <- updateUIAction NoActiveDocChange uiElts vars
             pure do
               updateHistoryState uiElts ( Just newDocHistory )
               uiUpdateAction
@@ -662,31 +659,21 @@ instance HandleAction Delete where
           -- Delete selected points on pressing 'Delete' in path mode.
           Selection
             | PathMode <- mode
-            -> modifyingCurrentDocument uiElts vars \ doc -> do
+            -> modifyingCurrentDocument uiElts vars \ doc ->
-                let
+                case deleteSelected doc of
-                  newDocument :: Document
+                  Nothing ->
-                  updateInfo :: UpdateInfo
+                    pure Don'tModifyDoc
-                  ( newDocument, updateInfo ) = deleteSelected doc
+                  Just ( doc', affectedPoints, delStrokes ) -> do
-                case updateInfo of
+                    -- TODO: this would also be a hierarchy diff...
-                  UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
+                    -- but for now we will just have emtpy strokes in the
-                    | null strokesAffected
+                    -- layers view.
-                    -> pure Don'tModifyDoc
+                    let diff = HistoryDiff $ ContentDiff $
-                    | let
+                               DeletePoints
-                        ppDel, cpDel, changeText :: Text
+                                 { deletedPoints = affectedPoints
-                        ppDel
+                                 , deletedStrokes = delStrokes
-                          | pathPointsAffected == 0
+                                 }
-                          = ""
+                    pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
-                          | otherwise
+  -- TODO: handle deletion of layers by checking the current focus.
-                          = Text.pack ( show pathPointsAffected ) <> " path points"
-                        cpDel
-                          | controlPointsAffected == 0
-                          = ""
-                          | otherwise
-                          = Text.pack ( show controlPointsAffected ) <> " control points"
-                        changeText =
-                          "Delete " <> Text.intercalate " and" [ ppDel, cpDel ]
-                          <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
-                    -> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
           _ -> pure ()
 
 -------------------
@@ -816,11 +803,12 @@ instance HandleAction MouseMove where
     = do
       viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
       viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
-      modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do
+      modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata } ) -> do
         modifiers   <- STM.readTVar modifiersTVar
         let
+          Metadata { documentZoom = zoom, viewportCenter } = documentMetadata
           toViewport :: ℝ 2 -> ℝ 2
-          toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+          toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
           pos :: ℝ 2
           pos = toViewport ( ℝ2 x y )
         STM.writeTVar mousePosTVar ( Just pos )
@@ -841,22 +829,34 @@ instance HandleAction MouseMove where
           | BrushMode <- mode
           -> do mbHoldAction <- STM.readTVar mouseHoldTVar
                 case mbHoldAction of
-                  Just ( BrushWidgetAction { brushWidgetAction } ) ->
+                  Just ( BrushWidgetAction { brushWidgetAction = brushAction } ) ->
-                    case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
+                    case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushAction ) doc of
                       Nothing ->
                         pure Don'tModifyDoc
-                      Just ( widgetAction, newDocument ) -> do
+                      Just ( newDocument, _ ) -> do
-                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
+                        -- This is just for preview, so TrivialDiff.
-                        pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
+                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos brushAction )
+                        pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
                   _ -> pure Don'tModifyDoc
           | otherwise
           -> pure Don'tModifyDoc
-      mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
+      mbDoc <- fmap ( present . snd ) <$> STM.atomically ( activeDocument vars )
-      for_ mbDoc \doc ->
+      for_ mbDoc \ doc ->
-        updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
+        updateInfoBar viewportDrawingArea infoBar vars ( Just $ documentMetadata doc )
       for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
         GTK.widgetQueueDraw drawingArea
 
+selectionMode :: Foldable f => f Modifier -> SelectionMode
+selectionMode = foldMap \case
+  Alt   _ -> Subtract
+  Shift _ -> Add
+  _       -> New
+
+pressingControl :: Foldable f => f Modifier -> Bool
+pressingControl = any \case
+  Control {} -> True
+  _ -> False
+
 -----------------
 -- Mouse click --
 -----------------
@@ -891,10 +891,12 @@ instance HandleAction MouseClick where
       1 -> do
         viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
         viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
-        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
+        modifyingCurrentDocument uiElts vars \ doc -> do
           let
+            meta@( Metadata { documentZoom = zoom, viewportCenter } )
+              = documentMetadata doc
             toViewport :: ℝ 2 -> ℝ 2
-            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+            toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
             pos :: ℝ 2
             pos = toViewport mouseClickCoords
           STM.writeTVar mousePosTVar ( Just pos )
@@ -919,14 +921,21 @@ instance HandleAction MouseClick where
                         case selectionMode modifiers of
                           -- Drag move: not holding shift or alt, click has selected something.
                           New
-                            | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
+                            | Just dragMove <- dragMoveSelect pos doc
                             -> do
                               STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
                               case dragMove of
-                                ClickedOnSelected ->
+                                ClickedOnPoint { dragPoint = (u, i), dragPointWasSelected } ->
-                                  pure Don'tModifyDoc
+                                  if dragPointWasSelected
-                                ClickedOnUnselected ->
+                                  -- Clicked on a selected point: preserve selection.
-                                  pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+                                  then pure Don'tModifyDoc
+                                  else do
+                                    -- Clicked on an unselected point: only select that point.
+                                    let newDoc = set ( field' @"documentMetadata" . field' @"selectedPoints" )
+                                                 ( StrokePoints $ Map.singleton u ( Set.singleton i ) )
+                                                 doc
+                                    pure ( UpdateDoc $ UpdateDocumentTo newDoc TrivialDiff )
+                                -- Clicked on curve: preserve old selection.
                                 ClickedOnCurve {} ->
                                   pure Don'tModifyDoc
                           -- Rectangular selection.
@@ -940,24 +949,29 @@ instance HandleAction MouseClick where
                         case mbPartialPath of
                           -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
                           Nothing -> do
-                            ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
+                            ( newDocument, drawAnchor ) <-
                               getOrCreateDrawAnchor uniqueSupply pos doc
                             STM.writeTVar partialPathTVar
                               ( Just $ PartialPath
-                                { partialStartPos     = anchorPt
+                                { partialPathAnchor   = drawAnchor
                                 , partialControlPoint = Nothing
-                                , partialPathAnchor   = drawAnchor
                                 , firstPoint          = True
                                 }
                               )
-                            case mbExistingAnchorName of
+                            if anchorIsNew drawAnchor
-                              Nothing ->
+                            then do
-                                let
+                              let
-                                  changeText :: Text
+                                diff :: Diff
-                                  changeText = "Begin new stroke"
+                                diff = HistoryDiff $ HierarchyDiff
-                                in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                                     $ NewLayer
-                              Just _ ->
+                                        { newUnique   = anchorStroke drawAnchor
-                                pure Don'tModifyDoc
+                                        , newPosition = WithinParent Root 0
+                                           -- TODO: add the stroke above the selected layer
+                                           -- or something of the sort.
+                                        }
+                              pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
+                            else
+                              pure Don'tModifyDoc
                           -- Path already started: indicate that we are continuing a path.
                           Just pp -> do
                             STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
@@ -970,11 +984,15 @@ instance HandleAction MouseClick where
                             -> Just brushWidgetAction
                           _ -> Nothing
                     case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
-                      Just ( actionState@( BrushWidgetActionState { brushWidgetAction = act } ), newDocument ) -> do
+                      Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
                         STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
-                        let changeText :: Text
+                        let diff = HistoryDiff $ ContentDiff
-                            changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
+                                 $ UpdateBrushParameters
-                        pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                                    { updateBrushStroke = brushWidgetStrokeUnique actionState
+                                    , updateBrushPoint  = brushWidgetPointIndex actionState
+                                    , updateBrushAction = act
+                                    }
+                        pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
                       _ ->
                         pure Don'tModifyDoc
 
@@ -992,11 +1010,11 @@ instance HandleAction MouseClick where
                       case subdivide pos doc of
                         Nothing              ->
                           pure Don'tModifyDoc
-                        Just ( newDocument, loc ) -> do
+                        Just ( newDocument, subdiv ) -> do
                           let
-                            changeText :: Text
+                            diff = HistoryDiff $ ContentDiff
-                            changeText = "Subdivide " <> loc
+                                 $ SubdivideStroke subdiv
-                          pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                          pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
 
                   -- Ignore double click event otherwise.
                   _ -> pure Don'tModifyDoc
@@ -1005,12 +1023,12 @@ instance HandleAction MouseClick where
               showGuides <- STM.readTVar showGuidesTVar
               when showGuides do
                 let
-                  mbGuide :: Maybe Guide
+                  mbGuide :: Maybe ( Unique, Guide )
-                  mbGuide = selectedGuide pos doc
+                  mbGuide = selectedGuide pos zoom ( documentGuides meta )
                   guideAction :: GuideAction
                   guideAction
-                    | Just guide <- mbGuide
+                    | Just ( guideUnique, _guide ) <- mbGuide
-                    = MoveGuide ( guideUnique guide )
+                    = MoveGuide guideUnique
                     | otherwise
                     = CreateGuide ruler
                 STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
@@ -1043,10 +1061,11 @@ instance HandleAction MouseRelease where
       1 -> do
         viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
         viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
-        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
+        modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata } ) -> do
           let
+            Metadata { documentZoom = zoom, viewportCenter } = documentMetadata
             toViewport :: ℝ 2 -> ℝ 2
-            toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+            toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
             pos :: ℝ 2
             pos = toViewport ( ℝ2 x y )
           STM.writeTVar mousePosTVar  ( Just pos )
@@ -1060,12 +1079,9 @@ instance HandleAction MouseRelease where
                   | createGuide
                   -> do
                     newDocument <- addGuide uniqueSupply ruler pos doc
-                    let
+                    pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
-                      changeText :: Text
-                      changeText = "Create guide"
-                    pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                   | otherwise
-                  -> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc )
+                  -> pure ( UpdateDoc $ UpdateDocumentTo doc TrivialDiff )
                   -- ^^ force an UI update when releasing a guide inside a ruler area
                   where
                     createGuide :: Bool
@@ -1080,22 +1096,18 @@ instance HandleAction MouseRelease where
                         newDocument :: Document
                         newDocument =
                           over
-                            ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
+                            ( field' @"documentMetadata" . field' @"documentGuides" . ix guideUnique . field' @"guidePoint" )
                             ( ( holdStartPos --> pos :: T ( ℝ 2 ) ) • )
                             doc
-                        changeText :: Text
+                      in pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
-                        changeText = "Move guide"
-                      in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                   | otherwise
                   -> let
                         newDocument :: Document
                         newDocument =
-                           set ( field' @"documentContent" . field' @"guides" . at guideUnique )
+                           set ( field' @"documentMetadata" . field' @"documentGuides" . at guideUnique )
                             Nothing
                             doc
-                        changeText :: Text
+                      in pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
-                        changeText = "Delete guide"
-                      in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                   where
                     l, t :: Double
                     ℝ2 l t = toViewport ( ℝ2 0 0 )
@@ -1119,17 +1131,27 @@ instance HandleAction MouseRelease where
                     Just hold
                       | PathMode <- mode
                       , DragMoveHold { holdStartPos = pos0, dragAction } <- hold
-                      , quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
+                      , not $ inPointClickRange zoom pos0 pos
                       -> let
                             alternateMode :: Bool
                             alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
                           in case dragUpdate pos0 pos dragAction alternateMode doc of
-                            Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
+                            Just ( doc', affectedPts ) ->
+                              let diff = HistoryDiff $ ContentDiff
+                                       $ DragMove
+                                           { dragMoveSelection = dragAction
+                                           , dragVector        = pos0 --> pos
+                                           , draggedPoints     = affectedPts
+                                           }
+                              in pure $ UpdateDoc ( UpdateDocumentTo doc' diff )
                             Nothing  -> pure Don'tModifyDoc
                       | SelectionHold pos0 <- hold
-                      , quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
+                      , not $ inPointClickRange zoom pos0 pos
-                      -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
+                      , let mbDoc' = fst <$> selectRectangle selMode pos0 pos doc
-                    _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
+                      -> pure ( UpdateDoc $ UpdateDocumentTo ( fromMaybe doc mbDoc' ) TrivialDiff )
+                    _ ->
+                      let mbDoc' = fst <$> selectAt selMode pos doc
+                      in pure ( UpdateDoc $ UpdateDocumentTo ( fromMaybe doc mbDoc' ) TrivialDiff )
 
                 Pen -> case mode of
                   PathMode -> do
@@ -1145,13 +1167,14 @@ instance HandleAction MouseRelease where
                       --  - release at different point as click: finish current segment, adding a control point.
                       Just
                         ( PartialPath
-                          { partialStartPos     = p1
+                          { partialPathAnchor   = anchor
                           , partialControlPoint = mbCp2
-                          , partialPathAnchor   = anchor
                           , firstPoint
                           }
                         ) -> do
                         let
+                          p1 :: ℝ 2
+                          p1 = anchorPos anchor
                           pathPoint :: ℝ 2
                           mbControlPoint :: Maybe ( ℝ 2 )
                           partialControlPoint :: Maybe ( ℝ 2 )
@@ -1160,60 +1183,72 @@ instance HandleAction MouseRelease where
                             = ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
                             | otherwise
                             = ( pos, Nothing, Nothing )
-                        ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
+                          i0
+                            | anchorIsAtEnd anchor
+                            = case anchorIndex anchor of
+                                FirstPoint -> 0
+                                PointIndex { pointCurve = i } -> i + 1
+                            | otherwise
+                            = case anchorIndex anchor of
+                                FirstPoint -> -1
+                                PointIndex { pointCurve = i } -> i - 1
+                        ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
                         if not firstPoint && anchorsAreComplementary anchor otherAnchor
                         -- Close path.
                         then do
                           STM.writeTVar partialPathTVar Nothing
                           let
-                            newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
+                            newSegment :: Spline Open CurveData ( PointData () )
-                            newSegment = catMaybesSpline ( invalidateCache undefined )
+                            newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) )
-                              ( PointData p1 Normal () )
+                              ( PointData p1 () )
                               ( do
                                   cp <- mbCp2
                                   guard ( cp /= p1 )
-                                  pure ( PointData cp Normal () )
+                                  pure ( PointData cp () )
                               )
                               ( do
                                   cp <- mbControlPoint
-                                  guard ( cp /= otherAnchorPt )
+                                  guard ( cp /= anchorPos otherAnchor )
-                                  pure ( PointData cp Normal () )
+                                  pure ( PointData cp () )
                               )
-                              ( PointData otherAnchorPt Normal () )
+                              ( PointData ( anchorPos otherAnchor) () )
                             newDocument :: Document
                             newDocument = addToAnchor anchor newSegment doc
-                            changeText :: Text
+                            diff = HistoryDiff $ ContentDiff
-                            changeText = "Close stroke"
+                                 $ CloseStroke { closedStroke = anchorStroke anchor }
-                          pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                          pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
                         else
                           if firstPoint
                           -- Continue current partial path.
                           then do
-                            STM.writeTVar partialPathTVar ( Just $ PartialPath p1        partialControlPoint anchor False )
+                            STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False )
                             pure Don'tModifyDoc
                           -- Finish current partial path.
                           else do
-                            STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
+                            STM.writeTVar partialPathTVar ( Just $ PartialPath ( anchor { anchorPos = pathPoint } ) partialControlPoint False )
                             let
-                              newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () )
+                              newSegment :: Spline Open CurveData ( PointData () )
-                              newSegment = catMaybesSpline ( invalidateCache undefined )
+                              newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) )
-                                ( PointData p1 Normal () )
+                                ( PointData p1 () )
                                 ( do
                                     cp <- mbCp2
                                     guard ( cp /= p1 )
-                                    pure ( PointData cp Normal () )
+                                    pure ( PointData cp () )
                                 )
                                 ( do
                                     cp <- mbControlPoint
                                     guard ( cp /= pathPoint )
-                                    pure ( PointData cp Normal () )
+                                    pure ( PointData cp () )
                                 )
-                                ( PointData pathPoint Normal () )
+                                ( PointData pathPoint () )
                               newDocument :: Document
                               newDocument = addToAnchor anchor newSegment doc
-                              changeText :: Text
+                              diff = HistoryDiff $ ContentDiff
-                              changeText = "Continue stroke"
+                                   $ ContinueStroke
-                            pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
+                                       { continuedStroke = anchorStroke anchor
+                                       , newSegment = bimapSpline ( \ _ crv -> bimapCurve ( \ _ -> () ) ( \ _ _ -> () ) crv ) ( \ _ -> () ) newSegment
+                                       }
+                            pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
                   BrushMode -> do
                     STM.writeTVar mouseHoldTVar Nothing
                     pure Don'tModifyDoc
@@ -1255,7 +1290,8 @@ instance HandleAction Scroll where
       --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
 
       unless ( dx == 0 && dy == 0 ) do
-        modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
+        modifyingCurrentDocument uiElts vars \ doc@( Document { documentMetadata = oldMetadata }) -> do
+          let Metadata { viewportCenter = oldCenter, documentZoom = Zoom { zoomFactor = oldZoomFactor } } = oldMetadata
           modifiers <- STM.readTVar modifiersTVar
           let
             mousePos :: ℝ 2
@@ -1276,22 +1312,31 @@ instance HandleAction Scroll where
                   newCenter
                     = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: T ( ℝ 2 ) )
                     • oldCenter
-                in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
+                  newMetadata =
+                    oldMetadata
+                      { documentZoom = Zoom newZoomFactor
+                      , viewportCenter = newCenter }
+
+                in ( doc { documentMetadata = newMetadata }, mousePos )
               -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
               | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
               = let
                   newCenter :: ℝ 2
                   newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dy 0 ) • oldCenter
-                in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
+                in ( set ( field' @"documentMetadata" . field' @"viewportCenter" ) newCenter doc
+                   , ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos
+                   )
               -- Vertical scrolling.
               | otherwise
               = let
                   newCenter :: ℝ 2
                   newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dx dy ) • oldCenter
-                in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
+                in (  set ( field' @"documentMetadata" . field' @"viewportCenter" ) newCenter doc
+                   , ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos
+                   )
           for_ mbMousePos \ _ ->
             STM.writeTVar mousePosTVar ( Just finalMousePos )
-          pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+          pure ( UpdateDoc $ UpdateDocumentTo newDoc TrivialDiff )
 
 --------------------
 -- Keyboard press --

src/app/MetaBrush/Application/Action.hs-boot

@@ -1,4 +1,4 @@
-module MetaBrush.Action where
+module MetaBrush.Application.Action where
 
 -- base
 import Data.Word
@@ -18,7 +18,7 @@ import Data.Text
 -- MetaBrush
 import Math.Linear
   ( ℝ(..), T(..) )
-import {-# SOURCE #-} MetaBrush.Context
+import {-# SOURCE #-} MetaBrush.Application.Context
   ( UIElements, Variables )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( TabLocation(..) )

src/app/MetaBrush/Application/Context.hs

@@ -1,4 +1,4 @@
-module MetaBrush.Context
+module MetaBrush.Application.Context
   ( UIElements(..), Variables(..)
   , LR(..), Modifier(..), modifierKey
   , HoldAction(..), GuideAction(..), PartialPath(..)
@@ -38,27 +38,35 @@ import qualified Control.Concurrent.STM.TVar as STM
 import Data.HashMap.Strict
   ( HashMap )
 
--- MetaBrush
+-- brush-strokes
 import Math.Bezier.Cubic.Fit
   ( FitParameters )
 import Math.Bezier.Stroke
   ( RootSolvingAlgorithm )
 import Math.Linear
   ( ℝ(..) )
-import {-# SOURCE #-} MetaBrush.Action
+import Math.Root.Isolation
+  ( RootIsolationOptions )
+
+-- MetaBrush
+import MetaBrush.Action
+  ( BrushWidgetActionState )
+import {-# SOURCE #-} MetaBrush.Application.Action
   ( ActionName )
 import MetaBrush.Asset.Colours
   ( Colours )
-import MetaBrush.Document.Draw
+import MetaBrush.Document.Diff
+  ( DragMoveSelect )
+import MetaBrush.Draw
   ( DrawAnchor )
 import MetaBrush.Document.History
   ( DocumentHistory(..) )
-import MetaBrush.Document.Selection
-  ( DragMoveSelect, BrushWidgetActionState )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( FileBar, FileBarTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
+import MetaBrush.UI.Panels
+  ( PanelsBar )
 import {-# SOURCE #-} MetaBrush.UI.ToolBar
   ( Tool, Mode )
 import MetaBrush.UI.Viewport
@@ -66,6 +74,7 @@ import MetaBrush.UI.Viewport
 import MetaBrush.Unique
   ( UniqueSupply, Unique )
 
+
 --------------------------------------------------------------------------------
 
 data UIElements
@@ -80,28 +89,31 @@ data UIElements
   , infoBar     :: !InfoBar
   , menuBar     :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
   , menuActions :: !( HashMap ActionName GIO.SimpleAction )
+  , panelsBar   :: !PanelsBar
   , colours     :: !Colours
   }
 
 data Variables
   = Variables
-  { uniqueSupply         :: !UniqueSupply
+  { uniqueSupply           :: !UniqueSupply
-  , recomputeStrokesTVar :: !( STM.TVar Bool                                    )
+  , recomputeStrokesTVar   :: !( STM.TVar Bool                                    )
-  , documentRenderTVar   :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
+  , documentRenderTVar     :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
-  , activeDocumentTVar   :: !( STM.TVar ( Maybe Unique )                        )
+  , activeDocumentTVar     :: !( STM.TVar ( Maybe Unique )                        )
-  , openDocumentsTVar    :: !( STM.TVar ( Map Unique DocumentHistory )          )
+  , openDocumentsTVar      :: !( STM.TVar ( Map Unique DocumentHistory )          )
-  , mousePosTVar         :: !( STM.TVar ( Maybe ( ℝ 2 ) )                       )
+  , strokeListModelsTVar   :: !( STM.TVar ( Map Unique GTK.SelectionModel )       )
-  , mouseHoldTVar        :: !( STM.TVar ( Maybe HoldAction )                    )
+  , mousePosTVar           :: !( STM.TVar ( Maybe ( ℝ 2 ) )                       )
-  , modifiersTVar        :: !( STM.TVar ( Set Modifier )                        )
+  , mouseHoldTVar          :: !( STM.TVar ( Maybe HoldAction )                    )
-  , toolTVar             :: !( STM.TVar Tool                                    )
+  , modifiersTVar          :: !( STM.TVar ( Set Modifier )                        )
-  , modeTVar             :: !( STM.TVar Mode                                    )
+  , toolTVar               :: !( STM.TVar Tool                                    )
-  , debugTVar            :: !( STM.TVar Bool                                    )
+  , modeTVar               :: !( STM.TVar Mode                                    )
-  , partialPathTVar      :: !( STM.TVar ( Maybe PartialPath )                   )
+  , debugTVar              :: !( STM.TVar Bool                                    )
-  , fileBarTabsTVar      :: !( STM.TVar ( Map Unique FileBarTab )               )
+  , partialPathTVar        :: !( STM.TVar ( Maybe PartialPath )                   )
-  , showGuidesTVar       :: !( STM.TVar Bool                                    )
+  , fileBarTabsTVar        :: !( STM.TVar ( Map Unique FileBarTab )               )
-  , maxHistorySizeTVar   :: !( STM.TVar Int                                     )
+  , showGuidesTVar         :: !( STM.TVar Bool                                    )
-  , fitParametersTVar    :: !( STM.TVar FitParameters                           )
+  , maxHistorySizeTVar     :: !( STM.TVar Int                                     )
-  , rootsAlgoTVar        :: !( STM.TVar RootSolvingAlgorithm                    )
+  , fitParametersTVar      :: !( STM.TVar FitParameters                           )
+  , rootsAlgoTVar          :: !( STM.TVar RootSolvingAlgorithm                    )
+  , cuspFindingOptionsTVar :: !( STM.TVar ( Maybe ( RootIsolationOptions 2 3 ) )  )
   }
 
 --------------------------------------------------------------------------------
@@ -159,9 +171,8 @@ data HoldAction
 -- | Keep track of a path that is in the middle of being drawn.
 data PartialPath
   = PartialPath
-  { partialStartPos     :: !( ℝ 2 )
+  { partialPathAnchor   :: !DrawAnchor
   , partialControlPoint :: !( Maybe ( ℝ 2 ) )
-  , partialPathAnchor   :: !DrawAnchor
   , firstPoint          :: !Bool
   }
   deriving stock Show

src/app/MetaBrush/Application/Context.hs-boot

@@ -1,4 +1,4 @@
-module MetaBrush.Context
+module MetaBrush.Application.Context
   ( UIElements, Variables
   , Modifier(..), LR(..) )
   where

src/app/MetaBrush/Application/UpdateDocument.hs

@@ -1,18 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module MetaBrush.Document.Update
+module MetaBrush.Application.UpdateDocument where
-  ( activeDocument, withActiveDocument
-  , DocChange(..), DocumentUpdate(..)
-  , PureDocModification(..), DocModification(..)
-  , modifyingCurrentDocument
-  , updateUIAction
-  , updateHistoryState
-  )
-where
 
 -- base
 import Control.Arrow
-  ( (&&&) )
+  ( (&&&), second )
 import Control.Monad
   ( join )
 import Data.Coerce
@@ -67,48 +59,51 @@ import qualified Data.HashMap.Lazy as HashMap
   ( lookup )
 
 -- MetaBrush
-import {-# SOURCE #-} MetaBrush.Action
+import {-# SOURCE #-} MetaBrush.Application.Action
   ( ActionName(..) )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..) )
+  ( Document(..), DocumentContent(..), DocumentMetadata(..)
+  )
+import MetaBrush.Document.Diff
 import MetaBrush.Document.History
   ( DocumentHistory(..), atStart, atEnd
   , newFutureStep, affirmPresent
   )
+import MetaBrush.GTK.Util
+  ( (>>?=) )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( FileBarTab(..), removeFileTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( updateInfoBar )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
-import MetaBrush.GTK.Util
+import MetaBrush.Unique
-  ( (>>?=) )
+  ( Unique )
 
 --------------------------------------------------------------------------------
 
 -- | Read the currently active document from the stateful variables.
-activeDocument :: Variables -> STM ( Maybe DocumentHistory )
+activeDocument :: Variables -> STM ( Maybe ( Unique, DocumentHistory ) )
 activeDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
   =    STM.readTVar activeDocumentTVar
-  >>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar )
+  >>?= ( \ unique -> fmap ( unique , ) . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
 
 -- | Do something with the currently active document.
 --
 -- Does nothing if no document is currently active.
-withActiveDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
+withActiveDocument :: Variables -> ( Unique -> Document -> STM a ) -> STM ( Maybe a )
-withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument vars )
+withActiveDocument vars f = traverse ( uncurry f ) =<< ( fmap ( second present ) <$> activeDocument vars )
-
-
-data DocChange
-  = TrivialChange { newDocument :: !Document }
-  | HistoryChange { newDocument :: !Document, changeText :: !Text }
 
+-- TODO: not sure why we need this datatype.
 data DocumentUpdate
   = CloseDocument
   | SaveDocument     !( Maybe FilePath )
-  | UpdateDocumentTo !DocChange
+  | UpdateDocumentTo
+    { newDocument  :: !Document
+    , documentDiff :: !Diff
+    }
 
 data PureDocModification
   = Don'tModifyDoc
@@ -154,69 +149,83 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables
     Ap uiUpdateAction <- lift . getAp $ flip ( foldMapOf docFold ) modif $ Ap . \case
       CloseDocument -> do
         STM.modifyTVar' openDocumentsTVar ( Map.delete unique )
-        coerce ( updateUIAction uiElts vars )
+        let change = ActiveDocChange { mbOldDocUnique = Just unique }
+        coerce ( updateUIAction change uiElts vars )
       SaveDocument Nothing -> do
         STM.modifyTVar' openDocumentsTVar ( Map.adjust affirmPresent unique )
-        coerce ( updateUIAction uiElts vars )
+        coerce ( updateUIAction NoActiveDocChange uiElts vars )
       SaveDocument ( Just newFilePath ) -> do
         STM.modifyTVar' openDocumentsTVar
           ( Map.adjust
             ( affirmPresent
-            . set ( field' @"present" . field' @"mbFilePath" )
+            . set ( field' @"present" . field' @"documentMetadata" . field' @"documentFilePath" )
             ( Just newFilePath )
             )
             unique
           )
-        coerce ( updateUIAction uiElts vars )
+        coerce ( updateUIAction NoActiveDocChange uiElts vars )
-      UpdateDocumentTo ( TrivialChange { newDocument } ) -> do
+      UpdateDocumentTo { newDocument, documentDiff = diff } ->
-        STM.modifyTVar' openDocumentsTVar
+        case diff of
-          ( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
+          TrivialDiff -> do
-        coerce ( updateUIAction uiElts vars )
+            -- Non-content change.
-      UpdateDocumentTo ( HistoryChange { newDocument, changeText } ) -> do
+            STM.modifyTVar' openDocumentsTVar
-        STM.modifyTVar' openDocumentsTVar
+              ( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
-          ( Map.adjust
+            coerce ( updateUIAction NoActiveDocChange uiElts vars )
-            ( newFutureStep maxHistSize
+          HistoryDiff histDiff -> do
-            . set ( field' @"documentContent" . field' @"unsavedChanges" ) True
+            -- Content change.
-            . set ( field' @"documentContent" . field' @"latestChange"   ) changeText
+            STM.modifyTVar' openDocumentsTVar
-            $ newDocument
+              ( Map.adjust
-            )
+                ( newFutureStep maxHistSize
-            unique
+                . set ( field' @"documentContent" . field' @"unsavedChanges" ) True
-          )
+                $ newDocument
-        uiUpdateAction <- updateUIAction uiElts vars
+                )
-        pure $ Ap do
+                unique
-          uiUpdateAction
+              )
-          for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True  )
+            uiUpdateAction <- updateUIAction NoActiveDocChange uiElts vars
-          for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
+            pure $ Ap do
+              uiUpdateAction
+              for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True  )
+              for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
     pure
       do
         forOf_ docFold modif \ mbNewDoc -> do
           case mbNewDoc of
-            CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc )
+            CloseDocument -> removeFileTab uiElts vars unique
             _             -> pure ()
         uiUpdateAction
         sequenceAOf_ actionFold modif
   sequenceA_ mbAction
 
+-- | A change in which document is currently active.
+data ActiveDocChange
+  -- | Continue with the same document (or lack of document).
+  = NoActiveDocChange
+  -- | Change between documents, or open/close a document.
+  | ActiveDocChange
+    { mbOldDocUnique :: Maybe Unique
+    }
 
-updateUIAction :: UIElements -> Variables -> STM ( IO () )
+updateUIAction :: ActiveDocChange -> UIElements -> Variables -> STM ( IO () )
-updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
+updateUIAction _docChange uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
   mbDocHist <- activeDocument vars
   let
-    mbDoc :: Maybe Document
+    mbDoc :: Maybe ( Unique, Document )
-    mbDoc = present <$> mbDocHist
+    mbDoc = second present <$> mbDocHist
     mbTitleText :: Maybe ( Text, Bool )
-    mbTitleText = fmap ( displayName &&& unsavedChanges . documentContent ) mbDoc
+    mbTitleText = fmap ( ( documentName . documentMetadata &&& unsavedChanges . documentContent ) . snd ) mbDoc
-  mbActiveTabDoc <- fmap join $ for mbDoc \ doc -> do
+  mbActiveTabDoc <- fmap join $ for mbDoc \ ( docUnique, _doc ) -> do
-    mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
+    mbActiveTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
     pure ( (,) <$> mbActiveTab <*> mbDoc )
+  --strokeModels <- STM.readTVar strokeListModelsTVar
   pure do
     updateTitle window titleLabel mbTitleText
-    updateInfoBar viewportDrawingArea infoBar vars mbDoc
+    updateInfoBar viewportDrawingArea infoBar vars ( fmap ( documentMetadata . snd ) mbDoc )
-    for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do
+    --switchStrokeView (strokesListView $ panelsBar) strokeModels (fst <$> mbDoc)
-      GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc )
+    for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, ( _, activeDoc ) ) -> do
+      GTK.buttonSetLabel fileBarTabButton ( documentName $ documentMetadata activeDoc )
       GTK.widgetQueueDraw fileBarTab
       GTK.widgetQueueDraw fileBarTabCloseArea
-      updateHistoryState uiElts mbDocHist
+      updateHistoryState uiElts ( fmap snd mbDocHist )
       STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
 
 updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()

src/app/MetaBrush/Application/UpdateDocument.hs-boot

@@ -1,27 +1,27 @@
-module MetaBrush.Document.Update
+module MetaBrush.Application.UpdateDocument
-  ( DocChange(..), DocumentUpdate(..)
+  ( DocumentUpdate(..)
   , PureDocModification(..), DocModification(..)
+  , ActiveDocChange(..)
   )
 where
 
--- text
-import Data.Text
-  ( Text )
-
 -- MetaBrush
 import MetaBrush.Document
   ( Document(..) )
+import MetaBrush.Document.Diff
+  ( Diff )
+import MetaBrush.Unique
+  ( Unique )
 
 --------------------------------------------------------------------------------
 
-data DocChange
-  = TrivialChange { newDocument :: !Document }
-  | HistoryChange { newDocument :: !Document, changeText :: !Text }
-
 data DocumentUpdate
   = CloseDocument
   | SaveDocument     !( Maybe FilePath )
-  | UpdateDocumentTo !DocChange
+  | UpdateDocumentTo
+    { newDocument  :: !Document
+    , documentDiff :: !Diff
+    }
 
 data PureDocModification
   = Don'tModifyDoc
@@ -34,3 +34,9 @@ data DocModification
     { modifDocument   :: !DocumentUpdate
     , postModifAction :: IO ()
     }
+
+data ActiveDocChange
+  = NoActiveDocChange
+  | ActiveDocChange
+    { mbOldDocUnique :: Maybe Unique
+    }

src/app/MetaBrush/Event.hs

@@ -25,17 +25,19 @@ import qualified GI.Gtk as GTK
 import qualified Control.Concurrent.STM.TVar as STM
   ( readTVarIO )
 
--- MetaBrush
+-- brush-strokes
 import Math.Linear
   ( ℝ(..), T(..) )
-import MetaBrush.Action
+
+-- MetaBrush
+import MetaBrush.Application.Action
   ( HandleAction(..)
   , ActionOrigin(..)
   , MouseMove(..), MouseClick(..), MouseClickType(..), MouseRelease(..)
   , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
   , quitEverything
   )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.UI.Viewport
   ( Viewport(..), ViewportEventControllers(..), Ruler(..) )

src/app/MetaBrush/Render/Document.hs

@@ -21,6 +21,8 @@ import Data.Functor.Compose
   ( Compose(..) )
 import Data.Int
   ( Int32 )
+import Data.Maybe
+  ( fromMaybe )
 import GHC.Generics
   ( Generic, Generic1, Generically1(..) )
 
@@ -33,10 +35,12 @@ import Data.Act
   )
 
 -- containers
+import qualified Data.Map.Strict as Map
 import Data.Sequence
   ( Seq(..) )
 import Data.Set
   ( Set )
+import qualified Data.Set as Set
 
 -- deepseq
 import Control.DeepSeq
@@ -45,17 +49,14 @@ import Control.DeepSeq
 -- gi-cairo-render
 import qualified GI.Cairo.Render as Cairo
 
--- lens
-import Control.Lens
-  ( view )
-
 -- transformers
 import Control.Monad.Trans.Class
   ( lift )
 import Control.Monad.Trans.State.Strict
   ( StateT, evalStateT, get, put )
+import Control.Monad.Trans.Writer.CPS as Writer
 
--- MetaBrush
+-- brush-strokes
 import Calligraphy.Brushes
   ( Brush(..) )
 import Math.Algebra.Dual
@@ -67,14 +68,8 @@ import Math.Bezier.Cubic.Fit
 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
-  ( Cusp(..), CachedStroke(..), invalidateCache
+  ( Cusp(..), invalidateCache
   , computeStrokeOutline
   , RootSolvingAlgorithm
   )
@@ -86,42 +81,32 @@ import Math.Module
   ( Module((*^)), normalise )
 import Math.Root.Isolation
   ( RootIsolationOptions )
+
+-- MetaBrush
+import MetaBrush.Action
+  ( dragUpdate )
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Brush
   ( NamedBrush(..), WithParams(..) )
 import qualified MetaBrush.Brush.Widget as Brush
   ( Widget(..), WidgetElements(..), widgetElements )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( Modifier(..)
   , HoldAction(..), PartialPath(..)
   )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..)
-  , mkAABB
-  , Stroke(..), visibleStrokes
-  , StrokeSpline
-  , FocusState(..)
-  , HoverContext(..), Hoverable(..)
-  , PointData(..)
-  , _selection
-  , coords
-  )
-import MetaBrush.Document.Draw
-  ( withAnchorBrushData )
-import MetaBrush.Document.Selection
-  ( dragUpdate )
 import MetaBrush.Document.Serialise
   ( ) -- 'Serialisable' instances
-import MetaBrush.Document.Update
+import MetaBrush.Draw
-  ( DocChange(..) )
+import MetaBrush.Hover
+  ( mkAABB, HoverContext(..), Hoverable(..) )
 import MetaBrush.Records
+import MetaBrush.Stroke
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Unique
-  ( unsafeUnique )
+  ( Unique )
-import MetaBrush.Util
-  ( traverseMaybe )
 import MetaBrush.GTK.Util
   ( withRGBA )
 
@@ -168,12 +153,19 @@ getDocumentRender
   rootAlgo mbCuspOptions fitParams
   mode debug
   modifiers mbMousePos mbHoldEvent mbPartialPath
-  doc@( Document { viewportCenter = ℝ2 cx cy, zoomFactor, documentContent = content } )
+  doc@( Document
+        { documentMetadata =
+            Metadata
+              { viewportCenter = ℝ2 cx cy
+              , documentZoom   = zoom@( Zoom { zoomFactor } )
+              , selectedPoints = selPts
+              }
+        } )
     = do
 
       let
         -- Get any modifications from in-flight user actions (e.g. in the middle of dragging something).
-        modifiedStrokes :: Seq Stroke
+        modifiedStrokes :: [ ( Maybe Unique, Stroke ) ]
         modifiedStrokes = case mode of
           PathMode
             | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
@@ -182,13 +174,14 @@ getDocumentRender
             , let
                 alternateMode :: Bool
                 alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
-                afterDrag :: Maybe DocChange
+                afterDrag :: Maybe ( Document, StrokePoints )
                 afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
             -> case afterDrag of
-                Just docUpdate -> foldMap visibleStrokes . strokes . documentContent $ newDocument docUpdate
+                Just ( docUpdate, _ ) -> getVisibleStrokes docUpdate
-                _              -> foldMap visibleStrokes . strokes $ content
+                Nothing               -> getVisibleStrokes doc
-            | Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath
+            | Just ( PartialPath anchor cp0 firstPoint ) <- mbPartialPath
             , let
+                p0 = anchorPos anchor
                 mbFinalPoint :: Maybe ( ℝ 2 )
                 mbControlPoint :: Maybe ( ℝ 2 )
                 ( mbFinalPoint, mbControlPoint )
@@ -203,34 +196,34 @@ getDocumentRender
                 previewStroke :: Stroke
                 previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) ->
                   let
-                    previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Record pointFields ) )
+                    previewSpline :: Spline Open CurveData ( PointData ( Record pointFields ) )
-                    previewSpline = catMaybesSpline ( invalidateCache undefined )
+                    previewSpline = catMaybesSpline ( CurveData 987654321 ( invalidateCache undefined ) )
-                      ( PointData p0 Normal pointData )
+                      ( PointData p0 pointData )
                       ( do
                           cp <- cp0
                           guard ( cp /= p0 )
-                          pure ( PointData cp Normal pointData )
+                          pure ( PointData cp pointData )
                       )
                       ( do
                           cp <- mbControlPoint
                           guard ( cp /= finalPoint )
-                          pure ( PointData cp Normal pointData )
+                          pure ( PointData cp pointData )
                       )
-                      ( PointData finalPoint Normal pointData )
+                      ( PointData finalPoint pointData )
                   in
                     Stroke
-                      { strokeSpline   = previewSpline
+                      { strokeSpline = previewSpline
-                      , strokeVisible  = True
+                      , strokeBrush  = mbBrush
-                      , strokeUnique   = unsafeUnique 987654321
-                      , strokeName     = "Preview stroke (temporary)"
-                      , strokeBrush    = mbBrush
                       }
-              -> previewStroke :<| foldMap visibleStrokes ( strokes content )
+              -> ( Nothing, previewStroke ) : getVisibleStrokes doc
-          _ -> foldMap visibleStrokes ( strokes content )
+          _ -> getVisibleStrokes doc
 
       strokesRenderData <-
-        traverseMaybe
+        traverse
-         ( sequenceA . strokeRenderData rootAlgo mbCuspOptions fitParams )
+         ( \ ( mbUnique, stroke ) ->
+             ( mbUnique, ) <$>
+               strokeRenderData rootAlgo mbCuspOptions fitParams stroke
+         )
          modifiedStrokes
 
       let
@@ -248,14 +241,28 @@ getDocumentRender
           Cairo.save
           Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
           Cairo.scale zoomFactor zoomFactor
-          Cairo.translate ( -cx ) ( -cy )
+          Cairo.translate -cx -cy
           for_ strokesRenderData
-            ( compositeRenders . getCompose . renderStroke cols mbHoverContext mode RenderingPath debug zoomFactor )
+            ( compositeRenders . getCompose . renderStroke cols selPts mbHoverContext mode RenderingPath debug zoom )
           renderSelectionRect
           Cairo.restore
 
       strokesRenderData `deepseq` pure drawingInstructions
 
+getVisibleStrokes :: Document -> [ ( Maybe Unique, Stroke ) ]
+getVisibleStrokes ( Document { documentMetadata, documentContent } ) =
+  let res =
+        Writer.execWriter $
+          forStrokeHierarchy
+             ( layerMetadata documentMetadata )
+             ( strokeHierarchy documentContent )
+             ( \ uniq stroke ( StrokeMetadata { strokeVisible } ) -> do
+                when strokeVisible $
+                  Writer.tell [ ( Just uniq, stroke ) ]
+                return PreserveStroke
+             )
+  in if null res then error ( show $ strokeHierarchy documentContent ) else res
+
 -- | Utility type to gather information needed to render a stroke.
 --   - No outline: just the underlying spline.
 --   - Outline: keep track of the function which returns brush shape.
@@ -299,15 +306,13 @@ strokeRenderData
   -> Maybe ( RootIsolationOptions 2 3 )
   -> FitParameters
   -> Stroke
-  -> Maybe ( ST RealWorld StrokeRenderData )
+  -> ST RealWorld StrokeRenderData
 strokeRenderData rootAlgo mbCuspOptions fitParams
   ( Stroke
     { strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
     , strokeBrush  = ( strokeBrush :: Maybe ( NamedBrush brushFields ) )
-    , ..
     }
-  ) | strokeVisible
+  ) = case strokeBrush of
-    = Just $ case strokeBrush of
         Just ( NamedBrush { brushFunction = fn, brushWidget = widget } )
           | WithParams
              { defaultParams = brush_defaults
@@ -350,109 +355,117 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
                             ( widget, \ params -> embedUsedParams $ toUsedParams params )
                         }
         _ -> pure $
-                StrokeRenderData
+              StrokeRenderData
-                  { strokeDataSpline = spline }
+                { strokeDataSpline = spline }
-  | otherwise
-  = Nothing
 
 renderStroke
-  :: Colours -> Maybe HoverContext -> Mode -> RenderMode -> Bool -> Double
+  :: Colours
-  -> StrokeRenderData
+  -> StrokePoints -> Maybe HoverContext
+  -> Mode
+  -> RenderMode -> Bool -> Zoom
+  -> ( Maybe Unique, StrokeRenderData )
   -> Compose Renders Cairo.Render ()
-renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
+renderStroke cols@( Colours { brush } ) selPts mbHoverContext mode rdrMode debug zoom ( mbUnique, strokeData ) =
-  StrokeRenderData { strokeDataSpline } ->
+  case strokeData of
-    renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
+    StrokeRenderData { strokeDataSpline } ->
-  StrokeWithOutlineRenderData
+      renderStrokeSpline cols mode rdrMode strokeSelPts mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
-    { strokeDataSpline
+    StrokeWithOutlineRenderData
-    , strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
+      { strokeDataSpline
-    , strokeBrushFunction
+      , strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
-    , strokeWidgetData = ( widget, widgetParams )
+      , strokeBrushFunction
-    } ->
+      , strokeWidgetData = ( widget, widgetParams )
-    renderStrokeSpline cols mode rdrMode mbHoverContext zoom
+      } ->
-      ( when ( mode == BrushMode )
+      renderStrokeSpline cols mode rdrMode strokeSelPts mbHoverContext zoom
-      . ( \ pt ->
+        ( when ( mode == BrushMode )
-          renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom )
+        . ( \ pt ->
-            strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
+            renderBrushShape ( cols { path = brush } ) mbHoverContext ( Zoom $ 2 * zoomFactor zoom )
-            pt
+              strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
+              pt
+          )
         )
-      )
+        strokeDataSpline
-      strokeDataSpline
+      *> Compose blank
-    *> Compose blank
+          { renderStrokes = drawOutline cols debug zoom strokeOutlineData
-        { renderStrokes = drawOutline cols debug zoom strokeOutlineData
+          , renderDebug   =
-        , renderDebug   =
+              when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
-            when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
+          }
-        }
+  where
+    strokeSelPts =
+      case mbUnique of
+        Nothing -> Set.empty
+        Just u  -> fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
 
 -- | Render a sequence of stroke points.
 --
 -- Accepts a sub-function for additional rendering of each stroke point
 -- (e.g. overlay a brush shape over each stroke point).
 renderStrokeSpline
-  :: forall clo crvData pointData
+  :: forall clo pointData
   .  ( Show pointData, KnownSplineType clo )
-  => Colours -> Mode -> RenderMode -> Maybe HoverContext -> Double
+  => Colours -> Mode -> RenderMode
+  -> Set PointIndex -> Maybe HoverContext -> Zoom
   -> ( PointData pointData -> Compose Renders Cairo.Render () )
-  -> Spline clo crvData ( PointData pointData )
+  -> Spline clo CurveData ( PointData pointData )
   -> Compose Renders Cairo.Render ()
-renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
+renderStrokeSpline cols mode rdrMode selPts mbHover zoom renderSubcontent spline =
-  bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline
+  bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline
 
   where
-    renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render ()
+    renderSplinePoint :: PointIndex -> PointData pointData -> Compose Renders Cairo.Render ()
-    renderSplinePoint sp0
+    renderSplinePoint i sp0
       = Compose blank
           { renderPPts =
             when ( rdrMode == RenderingPath ) do
-              drawPoint cols mbHover zoom PathPoint sp0
+              drawPoint cols selPts mbHover zoom i sp0
           }
       *> renderSubcontent sp0
     renderSplineCurve
       :: forall clo'
       .  SplineTypeI clo'
-      => PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render ()
+      => PointData pointData -> PointData pointData -> Curve clo' CurveData ( PointData pointData ) -> Compose Renders Cairo.Render ()
-    renderSplineCurve start p0 ( LineTo np1 _ )
+    renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) )
       = Compose blank
           { renderPPts = when ( rdrMode == RenderingPath ) do
             for_ np1 \ p1 ->
-              drawPoint cols mbHover zoom PathPoint p1
+              drawPoint cols selPts mbHover zoom ( PointIndex curveIndex 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 _ )
+    renderSplineCurve start p0 ( Bezier2To p1 np2 ( CurveData { curveIndex } ) )
       = Compose blank
           { renderCLines
             = when ( rdrMode == RenderingPath ) do
-              drawLine cols zoom ControlPoint p0 p1
+              drawLine cols zoom ( ControlPoint Bez2Cp ) p0 p1
-              drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 )
+              drawLine cols zoom ( ControlPoint Bez2Cp ) p1 ( fromNextPoint start np2 )
           , renderCPts
             = when ( rdrMode == RenderingPath ) do
-              drawPoint cols mbHover zoom ControlPoint p1
+              drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez2Cp ) p1
           , renderPPts
             = when ( rdrMode == RenderingPath ) do
                 for_ np2 \ p2 ->
-                  drawPoint cols mbHover zoom PathPoint p2
+                  drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p2
           , renderPath
             = unless ( mode == MetaMode ) do
               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 _ )
+    renderSplineCurve start p0 ( Bezier3To p1 p2 np3 ( CurveData { curveIndex } ) )
       = Compose blank
           { renderCLines
             = when ( rdrMode == RenderingPath ) do
-              drawLine cols zoom ControlPoint p0 p1
+              drawLine cols zoom ( ControlPoint Bez3Cp1 ) p0 p1
-              drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 )
+              drawLine cols zoom ( ControlPoint Bez3Cp2 ) p2 ( fromNextPoint start np3 )
           , renderCPts
             = when ( rdrMode == RenderingPath ) do
-              drawPoint cols mbHover zoom ControlPoint p1
+              drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp1 ) p1
-              drawPoint cols mbHover zoom ControlPoint p2
+              drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp2 ) p2
           , renderPPts
             = when ( rdrMode == RenderingPath ) do
                 for_ np3 \ p3 ->
-                  drawPoint cols mbHover zoom PathPoint p3
+                  drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ PathPoint ) p3
           , renderPath
             = unless ( mode == MetaMode ) do
                 drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } )
@@ -462,7 +475,7 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
       *> for_ np3 \ p3 -> renderSubcontent p3
 
 renderBrushShape
-  :: Colours -> Maybe HoverContext -> Double
+  :: Colours -> Maybe HoverContext -> Zoom
   -> ( pointParams -> SplinePts Closed )
   -> Brush.WidgetElements
   -> PointData pointParams
@@ -479,25 +492,36 @@ renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
     toAll do
       Cairo.save
       Cairo.translate x y
-    *> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
+    *> renderStrokeSpline cols BrushMode RenderingBrush Set.empty mbHoverContext' zoom ( const $ pure () )
-        ( fmap ( \ p -> PointData p Normal () ) brushPts )
+        ( noCurveData brushPts )
     *> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
     *> toAll Cairo.restore
+  where
+    noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed CurveData ( PointData () )
+    noCurveData =
+      bimapSpline
+        ( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) )
+        ( \ p -> PointData p () )
 
-drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
+drawPoint :: Colours -> Set PointIndex -> Maybe HoverContext -> Zoom -> PointIndex -> PointData brushData -> Cairo.Render ()
-drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
+drawPoint ( Colours {..} ) selPts mbHover zoom@( Zoom { zoomFactor } ) i pt
+  | i == FirstPoint || pointType i == PathPoint
   = do
   let
     x, y :: Double
     ℝ2 x y = coords pt
     hsqrt3 :: Double
     hsqrt3 = sqrt 0.75
-    selectionState :: FocusState
+    isSelected = i `Set.member` selPts
-    selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
+    hover
+      | Just hov <- mbHover
+      = hovered hov zoom ( ℝ2 x y )
+      | otherwise
+      = False
 
   Cairo.save
   Cairo.translate x y
-  Cairo.scale ( 3 / zoom ) ( 3 / zoom )
+  Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
 
   Cairo.moveTo  1         0
   Cairo.lineTo  0.5  hsqrt3
@@ -508,43 +532,50 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
   Cairo.closePath
 
   Cairo.setLineWidth 1.0
-  case selectionState of
+  if isSelected
-    Selected -> withRGBA pathPoint        Cairo.setSourceRGBA
+  then withRGBA pathPoint        Cairo.setSourceRGBA
-    _        -> withRGBA pathPointOutline Cairo.setSourceRGBA
+  else withRGBA pathPointOutline Cairo.setSourceRGBA
   Cairo.strokePreserve
 
-  case selectionState of
+  if | isSelected
-    Normal   -> withRGBA pathPoint     Cairo.setSourceRGBA
+     -> withRGBA pointSelected Cairo.setSourceRGBA
-    Hover    -> withRGBA pointHover    Cairo.setSourceRGBA
+     | hover
-    Selected -> withRGBA pointSelected Cairo.setSourceRGBA
+     -> withRGBA pointHover    Cairo.setSourceRGBA
+     | otherwise
+     -> withRGBA pathPoint     Cairo.setSourceRGBA
   Cairo.fill
 
   Cairo.restore
-
+  | otherwise
-drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
   = do
   let
     x, y :: Double
     ℝ2 x y = coords pt
-    selectionState :: FocusState
+    isSelected = i `Set.member` selPts
-    selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
+    hover
+      | Just hov <- mbHover
+      = hovered hov zoom ( ℝ2 x y )
+      | otherwise
+      = False
 
   Cairo.save
   Cairo.translate x y
-  Cairo.scale ( 3 / zoom ) ( 3 / zoom )
+  Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
 
   Cairo.arc 0 0 1 0 ( 2 * pi )
 
   Cairo.setLineWidth 1.0
-  case selectionState of
+  if isSelected
-    Selected -> withRGBA controlPoint        Cairo.setSourceRGBA
+  then withRGBA controlPoint        Cairo.setSourceRGBA
-    _        -> withRGBA controlPointOutline Cairo.setSourceRGBA
+  else withRGBA controlPointOutline Cairo.setSourceRGBA
   Cairo.strokePreserve
 
-  case selectionState of
+  if | isSelected
-    Normal   -> withRGBA controlPoint  Cairo.setSourceRGBA
+     -> withRGBA pointSelected Cairo.setSourceRGBA
-    Hover    -> withRGBA pointHover    Cairo.setSourceRGBA
+     | hover
-    Selected -> withRGBA pointSelected Cairo.setSourceRGBA
+     -> withRGBA pointHover    Cairo.setSourceRGBA
+     | otherwise
+     -> withRGBA controlPoint  Cairo.setSourceRGBA
   Cairo.fill
 
   withRGBA controlPoint Cairo.setSourceRGBA
@@ -552,8 +583,8 @@ drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
 
   Cairo.restore
 
-drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cairo.Render ()
+drawLine :: Colours -> Zoom -> PointType -> PointData b -> PointData b -> Cairo.Render ()
-drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
+drawLine ( Colours { path, controlPointLine } ) ( Zoom zoom ) pointType p1 p2 = do
   let
     x1, y1, x2, y2 :: Double
     ℝ2 x1 y1 = coords p1
@@ -567,20 +598,20 @@ drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
     PathPoint -> do
       Cairo.setLineWidth ( 5 / zoom )
       withRGBA path Cairo.setSourceRGBA
-    ControlPoint -> do
+    ControlPoint {} -> do
       Cairo.setLineWidth ( 3 / zoom )
       withRGBA controlPointLine Cairo.setSourceRGBA
   Cairo.stroke
 
   Cairo.restore
 
-drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
+drawQuadraticBezier :: Colours -> Zoom -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
 drawQuadraticBezier cols zoom bez =
   drawCubicBezier cols zoom
     ( Cubic.fromQuadratic @( T ( ℝ 2 ) ) bez )
 
-drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
+drawCubicBezier :: Colours -> Zoom -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
-drawCubicBezier ( Colours { path } ) zoom
+drawCubicBezier ( Colours { path } ) ( Zoom { zoomFactor } )
   ( Cubic.Bezier
     { p0 = ℝ2 x0 y0
     , p1 = ℝ2 x1 y1
@@ -595,17 +626,17 @@ drawCubicBezier ( Colours { path } ) zoom
   Cairo.moveTo x0 y0
   Cairo.curveTo x1 y1 x2 y2 x3 y3
 
-  Cairo.setLineWidth ( 6 / zoom )
+  Cairo.setLineWidth ( 6 / zoomFactor )
   withRGBA path Cairo.setSourceRGBA
   Cairo.stroke
 
   Cairo.restore
 
 drawOutline
-  :: Colours -> Bool -> Double
+  :: Colours -> Bool -> Zoom
   -> Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
   -> Cairo.Render ()
-drawOutline ( Colours {..} ) debug zoom strokeData = do
+drawOutline ( Colours {..} ) debug ( Zoom { zoomFactor } ) strokeData = do
   Cairo.save
   withRGBA brushStroke Cairo.setSourceRGBA
   case strokeData of
@@ -616,7 +647,7 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
         True  -> do
           Cairo.fillPreserve
           Cairo.setSourceRGBA 0 0 0 0.75
-          Cairo.setLineWidth ( 2 / zoom )
+          Cairo.setLineWidth ( 2 / zoomFactor )
           Cairo.stroke
     Right ( fwd, bwd ) -> do
       makeOutline fwd
@@ -626,7 +657,7 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
         True  -> do
           Cairo.fillPreserve
           Cairo.setSourceRGBA 0 0 0 0.75
-          Cairo.setLineWidth ( 2 / zoom )
+          Cairo.setLineWidth ( 2 / zoomFactor )
           Cairo.stroke
   Cairo.restore
   where
@@ -651,16 +682,16 @@ drawOutline ( Colours {..} ) debug zoom strokeData = do
         let ℝ2 x3 y3 = fromNextPoint start mp3
         in Cairo.curveTo x1 y1 x2 y2 x3 y3
 
-drawDebugInfo :: Colours -> Double
+drawDebugInfo :: Colours -> Zoom
               -> ( Seq FitPoint, [ Cusp ] )
               -> Cairo.Render ()
-drawDebugInfo cols zoom ( fitPts, cusps ) = do
+drawDebugInfo cols zoom@( Zoom { zoomFactor } ) ( fitPts, cusps ) = do
-  Cairo.setLineWidth ( 2 / zoom )
+  Cairo.setLineWidth ( 2 / zoomFactor )
   ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
   for_ cusps ( drawCusp cols zoom )
 
-drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
+drawFitPoint :: Colours -> Zoom -> FitPoint -> StateT Double Cairo.Render ()
-drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
+drawFitPoint _ ( Zoom { zoomFactor } ) ( FitPoint { fitPoint = ℝ2 x y } ) = do
 
   hue <- get
   put ( hue + 0.01 )
@@ -670,12 +701,12 @@ drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
   lift do
     Cairo.save
     Cairo.translate x y
-    Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
+    Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
     Cairo.setSourceRGBA r g b 0.8
     Cairo.fill
     Cairo.restore
 
-drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
+drawFitPoint _ ( Zoom { zoomFactor } )  ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
 
   hue <- get
   put ( hue + 0.01 )
@@ -687,36 +718,36 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty }
     Cairo.translate x y
     Cairo.moveTo 0 0
     Cairo.lineTo ( 0.05 * tx ) ( 0.05 * ty )
-    Cairo.setLineWidth ( 4 / zoom )
+    Cairo.setLineWidth ( 4 / zoomFactor )
     Cairo.setSourceRGBA r g b 1.0
     Cairo.stroke
-    Cairo.arc 0 0 ( 2 / zoom ) 0 ( 2 * pi )
+    Cairo.arc 0 0 ( 2 / zoomFactor ) 0 ( 2 * pi )
     Cairo.fill
     Cairo.restore
 
-drawCusp :: Colours -> Double -> Cusp -> Cairo.Render ()
+drawCusp :: Colours -> Zoom -> Cusp -> Cairo.Render ()
-drawCusp _ zoom
+drawCusp _ ( Zoom { zoomFactor } )
   ( Cusp { cuspPathCoords   = D21 { _D21_v  = ℝ2 px py
                                   , _D21_dx = tgt }
          , cuspStrokeCoords = ℝ2 cx cy } ) = do
 
     -- Draw a line perpendicular to the underlying path at the cusp.
     let
-      !( V2 tx ty ) = ( 6 / zoom ) *^ normalise tgt
+      !( V2 tx ty ) = ( 6 / zoomFactor ) *^ normalise tgt
     Cairo.save
     Cairo.translate px py
     Cairo.moveTo -ty  tx
     Cairo.lineTo  ty -tx
     --withRGBA path Cairo.setSourceRGBA
     Cairo.setSourceRGBA 0 0 0 0.75
-    Cairo.setLineWidth ( 2 / zoom )
+    Cairo.setLineWidth ( 2 / zoomFactor )
     Cairo.stroke
     Cairo.restore
 
     -- Draw a circle around the outline cusp point.
     Cairo.save
     Cairo.translate cx cy
-    Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
+    Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
     Cairo.setSourceRGBA 0 0 0 0.75
     Cairo.stroke
     Cairo.restore
@@ -762,45 +793,45 @@ drawCross ( Colours {..} ) zoom = do
   Cairo.restore
 -}
 
-renderBrushWidgetElements :: Colours -> Double -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
+renderBrushWidgetElements :: Colours -> Zoom -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
-renderBrushWidgetElements ( Colours { .. } ) zoom mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
+renderBrushWidgetElements ( Colours { .. } ) zoom@( Zoom { zoomFactor } ) mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
   Compose blank
     { renderBrushWidgets = do
       for_ lns $ \ seg@( Segment ( T p0@( ℝ2 x1 y1 ) ) ( T p1@( ℝ2 x2 y2 ) ) ) -> do
-        let lineFocus
+        let lineHover
                -- Don't do rectangle hover highlighting; doesn't make sense here.
-               | Just ( MouseHover {} ) <- mbHover
+               | Just ( mouseHover@( MouseHover {} ) ) <- mbHover
                -- Only focus the line if we aren't focusing a point,
                -- as line focus corresponds to horizontal/vertical scaling
                -- as opposed to 2D scaling.
-               , Normal <- hovered mbHover zoom p0
+               , not $ hovered mouseHover zoom p0
-               , Normal <- hovered mbHover zoom p1
+               , not $ hovered mouseHover zoom p1
-               = hovered mbHover zoom ( fmap unT seg )
+               = hovered mouseHover zoom ( fmap unT seg )
                | otherwise
-               = Normal
+               = False
         Cairo.save
         Cairo.moveTo x1 y1
         Cairo.lineTo x2 y2
-        Cairo.setLineWidth ( 2 / zoom )
+        Cairo.setLineWidth ( 2 / zoomFactor )
-        case lineFocus of
+        if lineHover
-          Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
+        then withRGBA brushWidgetHover Cairo.setSourceRGBA
-          _     -> withRGBA brushWidget      Cairo.setSourceRGBA
+        else withRGBA brushWidget      Cairo.setSourceRGBA
         Cairo.stroke
         Cairo.restore
       for_ pts $ \ ( T p@( ℝ2 x y ) ) -> do
-        let ptFocus
+        let ptHover
               -- Don't do rectangle hover highlighting; doesn't make sense here.
-              | Just ( MouseHover {} ) <- mbHover
+              | Just ( mouseHover@( MouseHover {} ) ) <- mbHover
-              = hovered mbHover zoom p
+              = hovered mouseHover zoom p
               | otherwise
-              = Normal
+              = False
         Cairo.save
         Cairo.translate x y
-        Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
+        Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
-        Cairo.setLineWidth ( 2 / zoom )
+        Cairo.setLineWidth ( 2 / zoomFactor )
-        case ptFocus of
+        if ptHover
-          Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
+        then withRGBA brushWidgetHover Cairo.setSourceRGBA
-          _     -> withRGBA brushWidget      Cairo.setSourceRGBA
+        else withRGBA brushWidget      Cairo.setSourceRGBA
         Cairo.fill
         Cairo.restore
     }

src/app/MetaBrush/Render/Rulers.hs

@@ -29,8 +29,9 @@ import Data.Act
   )
 
 -- containers
-import qualified Data.Map as Map
+import Data.Map.Strict
-  ( adjust )
+  ( Map )
+import qualified Data.Map.Strict as Map
 
 -- generic-lens
 import Data.Generics.Product.Fields
@@ -41,28 +42,25 @@ import qualified GI.Cairo.Render as Cairo
 
 -- lens
 import Control.Lens
-  ( set, over )
+  ( over )
 
 -- MetaBrush
 import Math.Linear
   ( ℝ(..), T(..) )
-import MetaBrush.Action
+import MetaBrush.Application.Action
   ( ActionOrigin(..) )
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( HoldAction(..), GuideAction(..) )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..)
+import MetaBrush.Hover
-  , FocusState(..), Hoverable(..), HoverContext(..)
-  , Guide(..)
-  )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.Viewport
   ( Ruler(..) )
 import MetaBrush.Unique
-  ( unsafeUnique )
+  ( Unique )
 import MetaBrush.GTK.Util
   ( withRGBA )
 
@@ -76,10 +74,20 @@ renderRuler
 renderRuler
   cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
   mbMousePos mbHoldEvent showGuides
-  ( Document { viewportCenter = center@( ℝ2 cx cy ), zoomFactor, documentContent = Content { guides } } ) = do
+  ( Document
+    { documentMetadata =
+      Metadata
+        { viewportCenter = center@( ℝ2 cx cy )
+        , documentZoom   = zoom@( Zoom { zoomFactor } )
+        , documentGuides = guides0
+        }
+    } ) = do
 
     let
-      modifiedGuides :: [ Guide ]
+      guides1 :: Map Unique ( Guide, Bool )
+      guides1 = fmap ( , False ) guides0
+
+      modifiedGuides :: [ ( Guide, Bool ) ]
       modifiedGuides
         | Just ( GuideAction { holdStartPos = mousePos0, guideAction = act } ) <- mbHoldEvent
         , Just mousePos <- mbMousePos
@@ -91,26 +99,26 @@ renderRuler
                   translate = ( ( mousePos0 --> mousePos :: T ( ℝ 2 ) ) • )
                 in toList
                  $ Map.adjust
-                   ( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected )
+                      ( \ ( g, _ ) -> ( over ( field' @"guidePoint" ) translate g, True ) )
-                   guideUnique
+                      guideUnique
-                   guides
+                      guides1
             CreateGuide ruler
               -> let
-                  addNewGuides :: [ Guide ] -> [ Guide ]
+                  addNewGuides :: [ ( Guide, Bool ) ] -> [ ( Guide, Bool ) ]
                   addNewGuides gs = case ruler of
                     RulerCorner
-                      -> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
+                      -> ( Guide { guidePoint = mousePos, guideNormal = V2 0 1 }, True )
-                       : Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
+                       : ( Guide { guidePoint = mousePos, guideNormal = V2 1 0 }, True )
                        : gs
                     LeftRuler
-                      -> Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 }
+                      -> ( Guide { guidePoint = mousePos, guideNormal = V2 1 0 }, True )
                        : gs
                     TopRuler
-                      -> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 }
+                      -> ( Guide { guidePoint = mousePos, guideNormal = V2 0 1 }, True )
                        : gs
-                 in addNewGuides ( toList guides )
+                 in addNewGuides ( toList guides1 )
         | otherwise
-        = toList guides
+        = toList guides1
 
       mbHoverContext :: Maybe HoverContext
       mbHoverContext
@@ -129,7 +137,7 @@ renderRuler
     -- Render tick marks.
     renderTicks
     -- Render guides.
-    when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) )
+    when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoom ) )
     -- Render mouse cursor indicator.
     for_ mbMousePos \ ( ℝ2 mx my ) ->
       case actionOrigin of
@@ -179,7 +187,7 @@ renderRuler
         TopRuler -> do
           Cairo.translate 0 dy
     toViewport :: ℝ 2 -> ℝ 2
-    toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
+    toViewport = toViewportCoordinates zoom ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
 
     setTickRenderContext :: Cairo.Render ()
     setTickRenderContext = do
@@ -280,19 +288,24 @@ data Tick
   }
   deriving stock Show
 
-renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render ()
+renderGuide :: Colours -> Maybe HoverContext -> Zoom -> ( Guide, Bool ) -> Cairo.Render ()
-renderGuide ( Colours {..} ) mbHoverContext zoom
+renderGuide ( Colours {..} ) mbHover zoom@( Zoom { zoomFactor } )
-  gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny, guideFocus } )
+  ( gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny } ), guideSelected )
   = do
 
     Cairo.save
     Cairo.translate x y
-    Cairo.scale ( 1 / zoom ) ( 1 / zoom )
+    Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
 
     Cairo.setLineWidth 1
-    case guideFocus <> hovered mbHoverContext zoom gd of
+    let isHovered
-      Normal -> withRGBA guide      Cairo.setSourceRGBA
+          | Just hov <- mbHover
-      _      -> withRGBA pointHover Cairo.setSourceRGBA
+          = hovered hov zoom gd
+          | otherwise
+          = False
+    if guideSelected || isHovered
+    then withRGBA pointHover Cairo.setSourceRGBA
+    else withRGBA guide      Cairo.setSourceRGBA
 
     Cairo.moveTo (  1e5 * ny ) ( -1e5 * nx )
     Cairo.lineTo ( -1e5 * ny ) (  1e5 * nx )

src/app/MetaBrush/UI/Coordinates.hs

@@ -18,7 +18,7 @@ import Data.Act
     ( (-->) )
   )
 
--- MetaBrush
+-- brush-strokes
 import qualified Math.Bezier.Cubic     as Cubic
   ( Bezier(..), closestPoint )
 import qualified Math.Bezier.Quadratic as Quadratic
@@ -31,22 +31,24 @@ import Math.Module
   ( (*^), squaredNorm, closestPointOnSegment )
 import Math.Linear
   ( ℝ(..), T(..), Segment(..) )
+
+-- MetaBrush
 import MetaBrush.Document
-  ( Stroke(..), PointData(..)
+  ( Zoom(..) )
-  , coords
+import MetaBrush.Stroke
-  )
+  ( Stroke(..), PointData, coords )
 
 --------------------------------------------------------------------------------
 
 -- | Convert a position relative to the drawing area into viewport coordinates.
-toViewportCoordinates :: Double -> ( Double, Double ) -> ℝ 2 -> ℝ 2 -> ℝ 2
+toViewportCoordinates :: Zoom -> ( Double, Double ) -> ℝ 2 -> ℝ 2 -> ℝ 2
-toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( ℝ2 x y )
+toViewportCoordinates ( Zoom { zoomFactor } ) ( viewportWidth, viewportHeight ) viewportCenter ( ℝ2 x y )
   = ( recip zoomFactor *^ ( ℝ2 ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> ℝ2 x y :: T ( ℝ 2 ) ) )
   • viewportCenter
 
--- | Find the closest point in a set of strokes.
+-- | Find the closest point on a stroke.
 closestPoint :: ℝ 2 -> Stroke -> ArgMin Double ( Maybe ( ℝ 2 ) )
-closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
+closestPoint c ( Stroke { strokeSpline } ) =
   coerce $
     bifoldSpline @_ @Identity
       ( closestPointToCurve ( splineStart strokeSpline ) )
@@ -71,7 +73,6 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
     closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
       fmap ( fmap ( Just . snd ) )
         ( Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
-closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( ℝ 2 ) ) )
 
 -- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( ℝ 2 ) )`
 newtype BoundedDouble = BoundedDouble Double

src/app/MetaBrush/UI/FileBar.hs

@@ -11,13 +11,12 @@ module MetaBrush.UI.FileBar
 import Control.Monad
   ( join, void )
 import Data.Foldable
-  ( for_, sequenceA_ )
+  ( sequenceA_ )
 import Data.Traversable
   ( for )
 
 -- containers
 import qualified Data.Map.Strict as Map
-  ( lookup, insert, delete )
 
 -- gi-cairo-connector
 import qualified GI.Cairo.Render.Connector as Cairo
@@ -44,24 +43,23 @@ import Data.HashMap.Lazy
   ( HashMap )
 
 -- MetaBrush
-import {-# SOURCE #-} MetaBrush.Action
+import {-# SOURCE #-} MetaBrush.Application.Action
   ( ActionName, SwitchFromTo(..), Close(..), handleAction )
 import MetaBrush.Asset.CloseTabButton
   ( drawCloseTabButton )
 import MetaBrush.Asset.Colours
   ( Colours )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..)
-  , emptyDocument
-  )
 import MetaBrush.Document.History
   ( DocumentHistory(..), newHistory )
-import MetaBrush.Document.Update
+import MetaBrush.Application.UpdateDocument
-  ( updateUIAction )
+  ( updateUIAction, ActiveDocChange (..) )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
+import MetaBrush.UI.Panels
+  ( PanelsBar )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Unique
@@ -93,7 +91,7 @@ data TabLocation
 newFileTab
   :: UIElements
   -> Variables
-  -> Maybe DocumentHistory
+  -> Maybe ( Unique, DocumentHistory )
   -> TabLocation
   -> IO ()
 newFileTab
@@ -103,21 +101,18 @@ newFileTab
   newTabLoc
   = do
 
-    newDocHist <- case mbDocHist of
+    ( thisTabDocUnique, thisTabDocHist ) <-
-      -- Use the provided document (e.g. document read from a file).
+      case mbDocHist of
-      Just docHist -> do pure docHist
+        -- Use the provided document (e.g. document read from a file).
-      -- Create a new empty document.
+        Just docHist -> pure docHist
-      Nothing -> do
+        -- Create a new empty document.
-        newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
+        Nothing -> do
-        pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
+          newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
-
+          pure ( newDocUniq, newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) )
-    let
-      thisTabDocUnique :: Unique
-      thisTabDocUnique = documentUnique ( present newDocHist )
 
     -- TODO: make the file tab an EditableLabel
     -- File tab elements.
-    pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist )
+    pgButton <- GTK.toggleButtonNewWithLabel ( documentName $ documentMetadata $ present thisTabDocHist )
     GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
     closeFileButton <- GTK.buttonNew
     closeFileArea <- GTK.drawingAreaNew
@@ -163,10 +158,12 @@ newFileTab
           }
     -- Update the state: switch to this new document.
     uiUpdateAction <- STM.atomically do
-      STM.modifyTVar' openDocumentsTVar  ( Map.insert thisTabDocUnique newDocHist )
+      STM.modifyTVar' openDocumentsTVar  ( Map.insert thisTabDocUnique thisTabDocHist )
       STM.modifyTVar' fileBarTabsTVar    ( Map.insert thisTabDocUnique fileBarTab )
-      STM.writeTVar   activeDocumentTVar ( Just thisTabDocUnique )
+      mbOldDoc <- STM.readTVar  activeDocumentTVar
-      updateUIAction uiElts vars
+      STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
+      let change = ActiveDocChange { mbOldDocUnique = mbOldDoc }
+      updateUIAction change uiElts vars
     uiUpdateAction
 
     void $ GTK.afterToggleButtonToggled pgButton do
@@ -214,11 +211,12 @@ createFileBar
   -> GTK.Application -> GTK.ApplicationWindow -> GTK.EventControllerKey
   -> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
   -> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
+  -> PanelsBar
   -> IO FileBar
 createFileBar
   colours
   vars@( Variables { openDocumentsTVar } )
-  application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
+  application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions panelsBar
   = do
 
     -- Create file bar: box containing scrollable tabs, and a "+" button after it.
@@ -251,10 +249,10 @@ createFileBar
       uiElements = UIElements {..}
 
     documents <- STM.readTVarIO openDocumentsTVar
-    for_ documents \ doc ->
+    ( `Map.foldMapWithKey` documents ) \ docUnique doc ->
       newFileTab
         uiElements vars
-        ( Just doc )
+        ( Just ( docUnique, doc ) )
         LastTab
 
     void $ GTK.onButtonClicked newFileButton do
@@ -279,5 +277,5 @@ removeFileTab
         STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
         STM.modifyTVar' fileBarTabsTVar   ( Map.delete docUnique )
         pure ( GTK.boxRemove fileTabsBox tab )
-  
+
     sequenceA_ cleanupAction

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

@@ -8,7 +8,7 @@ module MetaBrush.UI.FileBar
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import {-# SOURCE #-} MetaBrush.Context
+import {-# SOURCE #-} MetaBrush.Application.Context
   ( Variables, UIElements )
 import MetaBrush.Document.History
   ( DocumentHistory )
@@ -37,5 +37,5 @@ data TabLocation
 
 instance Show TabLocation
 
-newFileTab :: UIElements -> Variables -> Maybe DocumentHistory -> TabLocation -> IO ()
+newFileTab :: UIElements -> Variables -> Maybe ( Unique, DocumentHistory ) -> TabLocation -> IO ()
 removeFileTab :: UIElements -> Variables -> Unique -> IO ()

src/app/MetaBrush/UI/InfoBar.hs

@@ -43,10 +43,10 @@ import MetaBrush.Asset.Cursor
   ( drawCursorIcon )
 import MetaBrush.Asset.InfoBar
   ( drawMagnifier, drawTopLeftCornerRect )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( Variables(..) )
 import MetaBrush.Document
-  ( Document(..) )
+  ( DocumentMetadata(..), Zoom(..) )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.GTK.Util
@@ -151,7 +151,7 @@ createInfoBar colours = do
 
   pure ( InfoBar {..} )
 
-updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
+updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()
 updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar } ) mbDoc
   = do
     viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
@@ -162,10 +162,10 @@ updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar }
         GTK.labelSetText   cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
         GTK.labelSetText  topLeftPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
         GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
-      Just ( Document { zoomFactor, viewportCenter } ) -> do
+      Just ( Metadata { documentZoom = zoom@( Zoom { zoomFactor } ), viewportCenter } ) -> do
         let
           toViewport :: ℝ 2 -> ℝ 2
-          toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
+          toViewport = toViewportCoordinates zoom ( viewportWidth, viewportHeight ) viewportCenter
           ℝ2 l t = toViewport ( ℝ2 0 0 )
           ℝ2 r b = toViewport ( ℝ2 viewportWidth viewportHeight )
         mbMousePos <- STM.readTVarIO mousePosTVar

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

@@ -6,10 +6,10 @@ module MetaBrush.UI.InfoBar
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import {-# SOURCE #-} MetaBrush.Context
+import {-# SOURCE #-} MetaBrush.Application.Context
   ( Variables )
 import MetaBrush.Document
-  ( Document )
+  ( DocumentMetadata )
 
 --------------------------------------------------------------------------------
 
@@ -21,4 +21,4 @@ data InfoBar
   }
 
 updateInfoBar
-  :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
+  :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe DocumentMetadata -> IO ()

src/app/MetaBrush/UI/Menu.hs

@@ -39,9 +39,9 @@ import qualified Data.HashSet as HashSet
   ( fromList, toMap )
 
 -- MetaBrush
-import MetaBrush.Action
+import MetaBrush.Application.Action
   hiding ( save, saveAs )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.Asset.Colours
   ( Colours )

src/app/MetaBrush/UI/Panels.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module MetaBrush.UI.Panels
-  ( createPanelBar )
+  ( PanelsBar(..)
+  , createPanelBar
+  )
   where
 
 -- base
@@ -16,11 +18,21 @@ import qualified GI.Gtk as GTK
 -- MetaBrush
 import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
+--import MetaBrush.UI.StrokeTreeView
+--  ( newStrokesView )
 
 --------------------------------------------------------------------------------
 
+data PanelsBar
+  = PanelsBar
+  { strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox
+      :: GTK.Box
+  , strokesListView
+      :: GTK.ListView
+  }
+
 -- | Creates the right hand side panel UI.
-createPanelBar :: GTK.Box -> IO ()
+createPanelBar :: GTK.Box -> IO PanelsBar
 createPanelBar panelBox = do
 
   widgetAddClass panelBox "panels"
@@ -38,10 +50,10 @@ createPanelBar panelBox = do
   GTK.panedSetStartChild pane1 ( Just panels1 )
   GTK.panedSetEndChild   pane1 ( Just panels2 )
 
-  strokesPanel   <- GTK.boxNew GTK.OrientationVertical 0
+  strokesPanelBox   <- GTK.boxNew GTK.OrientationVertical 0
-  brushesPanel   <- GTK.boxNew GTK.OrientationVertical 0
+  brushesPanelBox   <- GTK.boxNew GTK.OrientationVertical 0
-  transformPanel <- GTK.boxNew GTK.OrientationVertical 0
+  transformPanelBox <- GTK.boxNew GTK.OrientationVertical 0
-  historyPanel   <- GTK.boxNew GTK.OrientationVertical 0
+  historyPanelBox   <- GTK.boxNew GTK.OrientationVertical 0
 
   strokesTab   <- GTK.labelNew ( Just "Strokes" )
   brushesTab   <- GTK.labelNew ( Just "Brushes" )
@@ -51,33 +63,35 @@ createPanelBar panelBox = do
   for_ [ strokesTab, brushesTab, transformTab, historyTab ] \ tab -> do
     widgetAddClasses tab [ "plain", "text", "panelTab" ]
 
-  for_ [ strokesPanel, brushesPanel, transformPanel, historyPanel ] \ panel -> do
+  for_ [ strokesPanelBox, brushesPanelBox, transformPanelBox, historyPanelBox ] \ panel -> do
     widgetAddClass panel "panel"
 
-  void $ GTK.notebookAppendPage panels1   strokesPanel ( Just   strokesTab )
+  void $ GTK.notebookAppendPage panels1   strokesPanelBox ( Just   strokesTab )
-  void $ GTK.notebookAppendPage panels1   brushesPanel ( Just   brushesTab )
+  void $ GTK.notebookAppendPage panels1   brushesPanelBox ( Just   brushesTab )
 
-  void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab )
+  void $ GTK.notebookAppendPage panels2 transformPanelBox ( Just transformTab )
-  void $ GTK.notebookAppendPage panels2   historyPanel ( Just   historyTab )
+  void $ GTK.notebookAppendPage panels2   historyPanelBox ( Just   historyTab )
 
-  GTK.notebookSetTabReorderable panels1   strokesPanel True
+  GTK.notebookSetTabReorderable panels1   strokesPanelBox True
-  GTK.notebookSetTabDetachable  panels1   strokesPanel True
+  GTK.notebookSetTabDetachable  panels1   strokesPanelBox True
-  GTK.notebookSetTabReorderable panels1   brushesPanel True
+  GTK.notebookSetTabReorderable panels1   brushesPanelBox True
-  GTK.notebookSetTabDetachable  panels1   brushesPanel True
+  GTK.notebookSetTabDetachable  panels1   brushesPanelBox True
 
-  GTK.notebookSetTabReorderable panels2 transformPanel True
+  GTK.notebookSetTabReorderable panels2 transformPanelBox True
-  GTK.notebookSetTabDetachable  panels2 transformPanel True
+  GTK.notebookSetTabDetachable  panels2 transformPanelBox True
-  GTK.notebookSetTabReorderable panels2   historyPanel True
+  GTK.notebookSetTabReorderable panels2   historyPanelBox True
-  GTK.notebookSetTabDetachable  panels2   historyPanel True
+  GTK.notebookSetTabDetachable  panels2   historyPanelBox True
 
-  strokesContent   <- GTK.labelNew ( Just "Strokes tab content..." )
   brushesContent   <- GTK.labelNew ( Just "Brushes tab content..." )
   transformContent <- GTK.labelNew ( Just "Transform tab content..." )
   historyContent   <- GTK.labelNew ( Just "History tab content..." )
 
-  GTK.boxAppend   strokesPanel   strokesContent
+  GTK.boxAppend   brushesPanelBox   brushesContent
-  GTK.boxAppend   brushesPanel   brushesContent
+  GTK.boxAppend transformPanelBox transformContent
-  GTK.boxAppend transformPanel transformContent
+  GTK.boxAppend   historyPanelBox   historyContent
-  GTK.boxAppend   historyPanel   historyContent
 
-  pure ()
+  --GTK.boxAppend strokesPanelBox strokesListView
+
+  return $
+    PanelsBar { strokesPanelBox, strokesListView = error "todo"
+              , brushesPanelBox, transformPanelBox, historyPanelBox }

src/app/MetaBrush/UI/ToolBar.hs

@@ -34,7 +34,7 @@ import MetaBrush.Asset.Cursor
   ( drawCursorIcon )
 import MetaBrush.Asset.Tools
   ( drawBug, drawBrush, drawMeta, drawPath, drawPen )
-import MetaBrush.Context
+import MetaBrush.Application.Context
   ( Variables(..) )
 import MetaBrush.GTK.Util
   ( widgetAddClass )

src/app/MetaBrush/UI/Viewport.hs

@@ -17,7 +17,7 @@ import qualified GI.Gtk as GTK
 -- MetaBrush
 import MetaBrush.GTK.Util
   ( widgetAddClass, widgetAddClasses )
-import MetaBrush.Document
+import MetaBrush.Guide
   ( Ruler(..) )
 
 --------------------------------------------------------------------------------

src/metabrushes/MetaBrush/Brush/Widget.hs

@@ -18,6 +18,16 @@ import Data.Kind
   ( Type )
 import GHC.TypeLits
   ( Symbol )
+import GHC.Generics
+  ( Generic )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData )
+
+-- text
+import Data.Text
+  ( Text )
 
 -- brush-strokes
 import Math.Linear
@@ -29,10 +39,6 @@ import Math.Module
   , norm
   )
 
--- text
-import Data.Text
-  ( Text )
-
 -- metabrushes
 import MetaBrush.Records
   ( Record(..) )
@@ -91,7 +97,8 @@ data WhatScale
   = ScaleXY
   | ScaleX
   | ScaleY
-  deriving stock ( Eq, Ord, Show )
+  deriving stock ( Eq, Ord, Show, Generic )
+  deriving anyclass NFData
 
 -- | Keep track of state in a brush widget action, e.g.
 -- scaling or rotating a brush.
@@ -99,7 +106,8 @@ data WidgetAction
   = ScaleAction WhatScale
   | RotateAction
     --{ windingNumber :: Int }
-  deriving stock ( Eq, Ord, Show )
+  deriving stock ( Eq, Ord, Show, Generic )
+  deriving anyclass NFData
 
 describeWidgetAction :: WidgetAction -> Text
 describeWidgetAction ( ScaleAction {} ) = "scaling"

src/metabrushes/MetaBrush/Document.hs

@@ -1,453 +1,145 @@
-{-# LANGUAGE OverloadedStrings    #-}
+module MetaBrush.Document where
-{-# LANGUAGE UndecidableInstances #-}
-
-module MetaBrush.Document
-  ( AABB(..), mkAABB
-  , Document(..), DocumentContent(..)
-  , emptyDocument
-  , Stroke(..), StrokeHierarchy(..), visibleStrokes
-  , StrokeSpline, _strokeSpline, overStrokeSpline
-  , PointData(..), BrushPointData(..), DiffPointData(..)
-  , FocusState(..), Hoverable(..), HoverContext(..)
-  , Guide(..), Ruler(..)
-  , _selection, _coords, coords
-  , addGuide, selectedGuide
-  )
-  where
 
 -- base
-import Control.Monad.ST
-  ( RealWorld )
-import Data.Coerce
-  ( coerce )
-import Data.Functor.Identity
-  ( Identity(..) )
-import Data.Semigroup
-  ( Arg(..), Min(..), ArgMin )
-import Data.Typeable
-  ( Typeable )
 import GHC.Generics
-  ( Generic, Generic1 )
+  ( Generic )
-import GHC.TypeLits
-  ( Symbol )
-
--- acts
-import Data.Act
-  ( Act(..), Torsor(..) )
 
 -- containers
 import Data.Map.Strict
   ( Map )
 import qualified Data.Map.Strict as Map
-  ( empty, insert )
+import Data.Set
-import Data.Sequence
+  ( Set )
-  ( Seq(..) )
+import qualified Data.Set as Set
-import qualified Data.Sequence as Seq
-  ( empty, singleton )
 
 -- deepseq
 import Control.DeepSeq
-  ( NFData(..), NFData1, deepseq )
+  ( NFData(..) )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- groups
-import Data.Group
-  ( Group(..) )
-
--- lens
-import Control.Lens
-  ( Lens'
-  , set, view, over
-  )
-
--- stm
-import Control.Concurrent.STM
-  ( STM )
 
 -- text
 import Data.Text
   ( Text )
 
--- transformers
+-- brush-strokes
-import Control.Monad.Trans.Reader
+import Math.Linear
-  ( ReaderT, runReaderT )
+  ( ℝ(..), T(..) )
 
 -- MetaBrush
-import Math.Bezier.Spline
+import MetaBrush.Layer
-  ( Spline(..), KnownSplineType )
+  ( LayerMetadata, emptyHierarchy )
-import Math.Bezier.Stroke
+import MetaBrush.Stroke
-  ( CachedStroke )
+  ( StrokeHierarchy, PointIndex )
-import Math.Module
-  ( Module
-    ( origin, (^+^), (^-^), (*^) )
-  , Inner((^.^))
-  , squaredNorm, quadrance
-  , closestPointOnSegment
-  )
-import Math.Linear
-  ( ℝ(..), T(..), Segment(..) )
-import MetaBrush.Brush
-  ( NamedBrush, PointFields )
-import MetaBrush.Records
 import MetaBrush.Unique
-  ( UniqueSupply, Unique, freshUnique )
+  ( Unique )
 
 --------------------------------------------------------------------------------
 
-data AABB
-  = AABB
-  { topLeft, botRight :: !( ℝ 2 ) }
-  deriving stock    ( Show, Generic )
-  deriving anyclass NFData
-
-mkAABB :: ℝ 2 -> ℝ 2 -> AABB
-mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
-  where
-    ( xmin, xmax )
-      | x1 > x2   = ( x2, x1 )
-      | otherwise = ( x1, x2 )
-    ( ymin, ymax )
-      | y1 > y2   = ( y2, y1 )
-      | otherwise = ( y1, y2 )
-
 -- | Document, together with some extra metadata.
 data Document
   = Document
-  { displayName     :: !Text
+  { documentContent  :: !DocumentContent
-  , mbFilePath      :: !( Maybe FilePath )
+    -- ^ Main document content, which we keep track throughout history.
-  , viewportCenter  :: !( ℝ 2 )
+  , documentMetadata :: !DocumentMetadata
-  , zoomFactor      :: !Double
+    -- ^ Metadata about the document, that we don't track throughout history.
-  , documentUnique  :: Unique
-  , documentContent :: !DocumentContent
   }
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
--- | Main content of document (data which we kept track of throughout history).
+newtype Zoom = Zoom { zoomFactor :: Double }
+  deriving stock ( Show, Eq, Ord )
+  deriving newtype NFData
+
+-- | A collection of points, indexed first by the stroke they belong to
+-- and then their position in that stroke.
+newtype StrokePoints = StrokePoints { strokePoints :: Map Unique ( Set PointIndex ) }
+  deriving newtype ( Eq, Show, NFData )
+    -- Invariant: the sets are never empty.
+
+instance Semigroup StrokePoints where
+  ( StrokePoints pts1 ) <> ( StrokePoints pts2 ) =
+    StrokePoints ( Map.unionWith Set.union pts1 pts2 )
+instance Monoid StrokePoints where
+  mempty = StrokePoints Map.empty
+
+-- | Remove the second set of points from the first.
+differenceStrokePoints :: StrokePoints -> StrokePoints -> StrokePoints
+differenceStrokePoints ( StrokePoints pts1 ) ( StrokePoints pts2 ) =
+  StrokePoints $
+    Map.differenceWith remove pts1 pts2
+      where
+        remove :: Set PointIndex -> Set PointIndex -> Maybe ( Set PointIndex )
+        remove old new =
+          let new' = old Set.\\ new
+          in if null new'
+             then Nothing
+             else Just new'
+
+noStrokePoints :: StrokePoints -> Bool
+noStrokePoints ( StrokePoints pts ) = null pts
+
+elemStrokePoint :: Unique -> PointIndex -> StrokePoints -> Bool
+elemStrokePoint u i ( StrokePoints pts ) =
+  case Map.lookup u pts of
+    Nothing -> False
+    Just is -> Set.member i is
+
+-- | Metadata about a document and its content, that we don't track through
+-- history.
+data DocumentMetadata =
+  Metadata
+    { documentName     :: !Text
+    , documentFilePath :: !( Maybe FilePath )
+    , viewportCenter   :: !( ℝ 2 )
+    , documentZoom     :: !Zoom
+    , documentGuides   :: !( Map Unique Guide )
+    , layerMetadata    :: !LayerMetadata
+    , selectedPoints   :: !StrokePoints
+    }
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+
+-- | Main content of document (data which we keep track of throughout history).
 data DocumentContent
   = Content
-  { unsavedChanges :: !Bool
+  { unsavedChanges  :: !Bool
-  , latestChange   :: !Text
+    -- ^ Whether this current content is unsaved.
-  , guides         :: !( Map Unique Guide )
+  , strokeHierarchy :: !StrokeHierarchy
-  , strokes        :: !( Seq StrokeHierarchy )
+    -- ^ Hierarchical structure of layers and groups.
   }
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
--- | Hierarchy for groups of strokes.
+-- | A guide, i.e. a horizontal or vertical line used for alignment.
-data StrokeHierarchy
-  = StrokeGroup
-    { groupName     :: !Text
-    , groupVisible  :: !Bool
-    , groupContents :: !( Seq StrokeHierarchy )
-    }
-  | StrokeLeaf
-    { strokeLeaf :: !Stroke }
-  deriving stock    ( Show, Generic )
-  deriving anyclass NFData
-
-visibleStrokes :: StrokeHierarchy -> Seq Stroke
-visibleStrokes ( StrokeGroup { groupVisible, groupContents } )
-  | groupVisible
-  = foldMap visibleStrokes groupContents
-  | otherwise
-  = Empty
-visibleStrokes ( StrokeLeaf { strokeLeaf } )
-  | strokeVisible strokeLeaf
-  = Seq.singleton strokeLeaf
-  | otherwise
-  = Empty
-
-type StrokeSpline clo brushParams =
-  Spline clo ( CachedStroke RealWorld ) ( PointData brushParams )
-
-data Stroke where
-  Stroke
-    :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
-    .  ( KnownSplineType clo
-       , pointParams ~ Record pointFields
-       , PointFields pointFields, Typeable pointFields
-       )
-    =>
-      { strokeName     :: !Text
-      , strokeVisible  :: !Bool
-      , strokeUnique   :: Unique
-      , strokeBrush    :: !( Maybe ( NamedBrush brushFields ) )
-      , strokeSpline   :: !( StrokeSpline clo pointParams )
-      }
-    -> Stroke
-deriving stock instance Show Stroke
-instance NFData Stroke where
-  rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrush, strokeSpline } )
-    = deepseq strokeSpline
-    . deepseq strokeBrush
-    . deepseq strokeUnique
-    . deepseq strokeVisible
-    $ rnf strokeName
-
-_strokeSpline
-  :: forall f
-  .  Functor f
-  => (  forall clo pointParams ( pointFields :: [ Symbol ] )
-     .  ( KnownSplineType clo
-        , pointParams ~ Record pointFields
-        , PointFields pointFields
-        )
-     => 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 :: [ Symbol ] )
-     .  ( KnownSplineType clo
-        , pointParams ~ Record pointFields
-        , PointFields pointFields
-        )
-     => StrokeSpline clo pointParams
-     -> StrokeSpline clo pointParams
-     )
-  -> Stroke -> Stroke
-overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
-
-
-data PointData params
-  = PointData
-  { pointCoords :: !( ℝ 2 )
-  , pointState  :: FocusState
-  , brushParams :: !params
-  }
-  deriving stock ( Show, Generic )
-  deriving anyclass NFData
-
-instance Act (T ( ℝ 2 )) (PointData params) where
-  v • ( dat@( PointData { pointCoords = p } ) ) =
-    dat { pointCoords = v • p }
-
-data BrushPointData
-  = BrushPointData
-  { brushPointState :: FocusState }
-  deriving stock ( Show, Generic )
-  deriving anyclass NFData
-
-data FocusState
-  = Normal
-  | Hover
-  | Selected
-  deriving stock ( Show, Eq, Generic )
-  deriving anyclass NFData
-
-instance Semigroup FocusState where
-  Selected <> _        = Selected
-  Normal   <> s        = s
-  _        <> Selected = Selected
-  s        <> Normal   = s
-  _        <> _        = Hover
-instance Monoid FocusState where
-  mempty = Normal
-
-emptyDocument :: Text -> Unique -> Document
-emptyDocument docName unique =
-  Document
-    { displayName     = docName
-    , mbFilePath      = Nothing
-    , viewportCenter  = ℝ2 0 0
-    , zoomFactor      = 1
-    , documentUnique  = unique
-    , documentContent =
-      Content
-      { unsavedChanges = False
-      , latestChange   = "New document"
-      , strokes        = Seq.empty
-      , guides         = Map.empty
-      }
-    }
-
---------------------------------------------------------------------------------
-
-data HoverContext
-  = MouseHover     !( ℝ 2 )
-  | RectangleHover !AABB
-  deriving stock    ( Show, Generic )
-  deriving anyclass NFData
-
-instance Act ( T ( ℝ 2 ) ) HoverContext where
-  v • MouseHover p = MouseHover ( v • p )
-  v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
-
-instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
-  (•) v = fmap ( v • )
-
-class Hoverable a where
-  hovered :: Maybe HoverContext -> Double -> a -> FocusState
-
-instance Hoverable ( ℝ 2 ) where
-  hovered Nothing _ _ = Normal
-  hovered ( Just ( MouseHover p ) ) zoom q
-    | quadrance @( T ( ℝ 2 ) ) p q * zoom ^ ( 2 :: Int ) < 16
-    = Hover
-    | otherwise
-    = Normal
-  hovered ( Just ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) ) _ ( ℝ2 x y )
-    | x >= x1 && x <= x2 && y >= y1 && y <= y2
-    = Hover
-    | otherwise
-    = Normal
-
-instance Hoverable ( Segment ( ℝ 2 ) ) where
-  hovered Nothing _ _ = Normal
-  hovered ( Just ( MouseHover p ) ) zoom seg
-    = hovered ( Just ( MouseHover p ) ) zoom p'
-    where
-      ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
-  hovered hov@( Just ( RectangleHover {} ) ) zoom ( Segment p0 p1 )
-    -- Only consider a segment to be "hovered" if it lies entirely within the
-    -- hover rectangle, not just if the hover rectangle intersects it.
-    = hovered hov zoom p0 <> hovered hov zoom p1
-
-class HasSelection pt where
-  _selection :: Lens' pt FocusState
-instance HasSelection ( PointData brushParams ) where
-  _selection = field' @"pointState"
-instance HasSelection BrushPointData where
-  _selection = field' @"brushPointState"
-
-_coords :: Lens' ( PointData brushParams ) ( ℝ 2 )
-_coords = field' @"pointCoords"
-
-coords :: PointData brushParams -> ℝ 2
-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 :: !( T ( ℝ 2 ) )
-  , 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.
-
 data Guide
   = Guide
   { guidePoint  :: !( ℝ 2 )       -- ^ point on the guide line
   , guideNormal :: !( T ( ℝ 2 ) ) -- ^ /normalised/ normal vector of the guide
-  , guideFocus  :: !FocusState
-  , guideUnique :: Unique
   }
   deriving stock    ( Show, Generic )
   deriving anyclass NFData
 
-data Ruler
+emptyDocument :: Text -> Document
-  = RulerCorner
+emptyDocument docName =
-  | LeftRuler
+  Document
-  | TopRuler
+    { documentContent  = emptyDocumentContent
-  deriving stock Show
+    , documentMetadata = emptyDocumentMetadata docName
+    }
 
--- | Try to select a guide at the given document coordinates.
+emptyDocumentContent :: DocumentContent
-selectedGuide :: ℝ 2 -> Document -> Maybe Guide
+emptyDocumentContent =
-selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
+  Content
-  \case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
+    { strokeHierarchy = emptyHierarchy
+    , unsavedChanges  = False
+    }
 
-selectGuide_maybe :: ℝ 2 -> Double -> Guide -> Maybe ( ArgMin Double Guide )
+emptyDocumentMetadata :: Text -> DocumentMetadata
-selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
+emptyDocumentMetadata docName =
-  | sqDist * zoom ^ ( 2 :: Int ) < 4
+  Metadata
-  = Just ( Min ( Arg sqDist guide ) )
+    { documentName     = docName
-  | otherwise
+    , documentFilePath = Nothing
-  = Nothing
+    , viewportCenter   = ℝ2 0 0
-  where
+    , documentZoom     = Zoom { zoomFactor = 1 }
-    t :: Double
+    , documentGuides   = Map.empty
-    t = ( c --> p ) ^.^ n
+    , layerMetadata    = mempty
-    sqDist :: Double
+    , selectedPoints   = mempty
-    sqDist = t ^ ( 2 :: Int ) / squaredNorm n
+    }
-
--- | Add new guide after a mouse drag from a ruler area.
-addGuide :: UniqueSupply -> Ruler -> ℝ 2 -> Document -> STM Document
-addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
-  where
-    insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
-    insertNewGuides gs = case ruler of
-      RulerCorner
-        -> do
-          uniq1 <- freshUnique
-          uniq2 <- freshUnique
-          let
-            guide1, guide2 :: Guide
-            guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
-            guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
-          pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
-      TopRuler
-        -> do
-          uniq1 <- freshUnique
-          let
-            guide1 :: Guide
-            guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
-          pure ( Map.insert uniq1 guide1 gs )
-      LeftRuler
-        -> do
-          uniq2 <- freshUnique
-          let
-            guide2 :: Guide
-            guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
-          pure ( Map.insert uniq2 guide2 gs )
-
-instance Hoverable Guide where
-  hovered ( Just ( MouseHover c ) ) zoom guide
-    | Just _ <- selectGuide_maybe c zoom guide
-    = Hover
-    | otherwise
-    = Normal
-  hovered _ _ _ = Normal

src/metabrushes/MetaBrush/Document/Diff.hs

@@ -0,0 +1,176 @@
+module MetaBrush.Document.Diff where
+
+-- base
+import qualified Data.List.NonEmpty as NE
+import GHC.Generics
+  ( Generic )
+
+-- containers
+import Data.Set
+  ( Set )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
+-- brush-strokes
+import Math.Bezier.Spline
+import Math.Linear
+  ( ℝ(..), T(..) )
+
+-- MetaBrush
+import qualified MetaBrush.Brush.Widget as Brush
+  ( WidgetAction(..) )
+import MetaBrush.Document
+  ( StrokePoints )
+import MetaBrush.Layer
+import MetaBrush.Stroke
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+-- | A change to a document.
+data Diff
+  = TrivialDiff
+  | HistoryDiff !HistoryDiff
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | A change to a document that affects history.
+data HistoryDiff
+  = DocumentDiff  !DocumentDiff
+  | HierarchyDiff !HierarchyDiff
+  | ContentDiff   !ContentDiff
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | A change of document (e.g. new document).
+data DocumentDiff
+  = DocumentCreated
+  | DocumentOpened
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | A change in the layer hierarchy of a document.
+data HierarchyDiff
+  = NewLayer
+      { newUnique   :: !Unique
+      , newPosition :: !ChildLayerPosition
+      }
+  | DeleteLayer
+      { delUnique   :: !Unique
+      , delPosition :: !ChildLayerPosition
+      }
+  | MoveLayer
+      { moveUnique :: !Unique
+      , srcPos :: !ChildLayerPosition
+      , dstPos :: !ChildLayerPosition
+      }
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | A subdivision of a single stroke.
+data Subdivision
+  = Subdivision
+  { subdividedStroke :: !Unique
+  , subdivisions :: !( NE.NonEmpty ( Curve Open () (), Double ) )
+  }
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+data SelectionMode
+  = New
+  | Add
+  | Subtract
+  deriving stock ( Show, Eq, Generic )
+  deriving anyclass NFData
+
+instance Semigroup SelectionMode where
+  Subtract <> _ = Subtract
+  _ <> Subtract = Subtract
+  New <> m      = m
+  m <> New      = m
+  Add <> Add    = Add
+
+instance Monoid SelectionMode where
+  mempty = New
+
+-- | A change in the content of strokes in the document.
+data ContentDiff
+  = Translation
+      { translationVector :: !( T ( ℝ 2 ) )
+      , translatedPoints  :: !StrokePoints
+      }
+  | DragMove
+      { dragMoveSelection :: !DragMoveSelect
+      , dragVector        :: !( T ( ℝ 2 ) )
+      , draggedPoints     :: !StrokePoints
+      }
+  | CloseStroke
+      { closedStroke :: !Unique }
+  | ContinueStroke
+      { continuedStroke :: !Unique
+      , newSegment :: !( Spline Open () () )
+      }
+  | DeletePoints
+      { deletedPoints :: !StrokePoints
+      , deletedStrokes :: !( Set Unique)
+      }
+  | UpdateBrushParameters
+      { updateBrushStroke :: !Unique
+      , updateBrushPoint  :: !PointIndex
+      , updateBrushAction :: !Brush.WidgetAction
+      }
+  | SubdivideStroke !Subdivision
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | Type of a drag move selection: point drag or curve drag.
+data DragMoveSelect
+  -- | User initiated drag by clicking on a point.
+  = ClickedOnPoint
+    { dragPoint :: !( Unique, PointIndex )
+    , dragPointWasSelected :: !Bool
+       -- ^ Whether the drag point was already selected
+       -- before beginning the drag.
+    }
+  -- | User initiated drag by clicking on an interior point of a curve;
+  -- start a curve drag, selection is preserved.
+  | ClickedOnCurve
+    { dragStrokeUnique   :: !Unique
+    , dragCurve          :: !Rational
+    , dragCurveIndex     :: !Int
+    , dragCurveParameter :: !Double
+    }
+  deriving stock ( Show, Eq, Generic )
+  deriving anyclass NFData
+
+{-
+changeText :: LayerMetadata -> ChangeDescription -> Text
+changeText metadata = \case
+  TrivialChange -> "(trivial change)"
+  HistoryChange ch -> historyChangeText metadata ch
+
+historyChangeText :: LayerMetadata -> HistoryChangeDescription -> Text
+historyChangeText metadata = \case
+  DocumentCreated -> "Create document"
+  DocumentOpened  -> "Open document"
+  Translation pathPointsAffected controlPointsAffected strokesAffected ->
+    let
+      ppMv, cpMv :: Maybe Text
+      ppMv
+        | pathPointsAffected == 0
+        = Nothing
+        | otherwise
+        = Just ( Text.pack ( show pathPointsAffected ) <> " path points" )
+      cpMv
+        | controlPointsAffected == 0
+        = Nothing
+        | otherwise
+        = Just ( Text.pack ( show controlPointsAffected ) <> " control points" )
+    in "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
+    <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
+  DragCurveSegment strokeUnique ->
+    "Drag curve segment of stroke " <> ( layerNames metadata Map.! strokeUnique )
+-}

src/metabrushes/MetaBrush/Document/Draw.hs

@@ -1,262 +0,0 @@
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module MetaBrush.Document.Draw
-  ( DrawAnchor(..), anchorsAreComplementary
-  , getOrCreateDrawAnchor, addToAnchor
-  , withAnchorBrushData
-  )
-  where
-
--- base
-import Data.Coerce
-  ( coerce )
-import Data.Functor
-  ( ($>) )
-import Data.Semigroup
-  ( First(..) )
-import GHC.TypeLits
-  ( Symbol )
-
--- acts
-import Data.Act
-  ( Torsor((-->)) )
-
--- containers
-import Data.Sequence
-  ( Seq(..) )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field, field' )
-
--- lens
-import Control.Lens
-  ( set, over, mapped )
-
--- stm
-import Control.Concurrent.STM
-  ( STM )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.State.Strict
-  ( State, runState, get, put )
-import Control.Monad.Trans.Reader
-  ( runReaderT )
-
--- MetaBrush
-import Math.Bezier.Spline
-  ( Spline(..), Curves(..)
-  , SplineType(..), SSplineType(..)
-  , SplineTypeI(ssplineType)
-  , reverseSpline, splineEnd
-  , openCurveEnd
-  )
-import Math.Module
-  ( squaredNorm )
-import Math.Linear
-  ( ℝ(..), T(..) )
-import MetaBrush.Assert
-  ( assert )
-import MetaBrush.Brush
-  ( NamedBrush(..), PointFields )
-import MetaBrush.Document
-  ( Document(..), DocumentContent(..)
-  , Stroke(..), StrokeHierarchy(..), StrokeSpline
-  , FocusState(..), PointData(..)
-  , _selection, _strokeSpline
-  , coords, overStrokeSpline
-  )
-import MetaBrush.Records
-import MetaBrush.Unique
-  ( Unique, UniqueSupply, freshUnique, uniqueText )
-
---------------------------------------------------------------------------------
-
-data DrawAnchor
-  = AnchorAtStart { anchorStrokeUnique :: Unique }
-  | AnchorAtEnd   { anchorStrokeUnique :: Unique }
-  deriving stock Show
-
--- | Computes whether two anchors are the two ends of the same stroke.
-anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
-anchorsAreComplementary ( AnchorAtStart uniq1 ) ( AnchorAtEnd uniq2 )
-  | uniq1 == uniq2
-  = True
-anchorsAreComplementary ( AnchorAtEnd uniq1 ) ( AnchorAtStart uniq2 )
-  | uniq1 == uniq2
-  = True
-anchorsAreComplementary _ _ = False
-
-getOrCreateDrawAnchor
-  :: UniqueSupply
-  -> ℝ 2
-  -> Document
-  -> STM ( Document, DrawAnchor, ℝ 2, Maybe Text )
-getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
-  case
-      ( `runState` Nothing )
-    $ ( field' @"documentContent" . field' @"strokes" . traverse )
-        updateStrokeHierarchy
-        doc
-  of
-    -- Anchor found: use it.
-    ( 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 <- runReaderT freshUnique uniqueSupply
-      let
-        newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
-        newSpline =
-          Spline { splineStart  = PointData c Normal ( MkR ℝ0 )
-                 , splineCurves = OpenCurves Empty
-                 }
-        newStroke :: Stroke
-        newStroke =
-          Stroke
-            { strokeName    = "Stroke " <> uniqueText uniq
-            , strokeVisible = True
-            , strokeUnique  = uniq
-            , strokeSpline  = newSpline
-            , strokeBrush   = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
-            }
-        newDoc' :: Document
-        newDoc'
-          = over ( field' @"documentContent" . field' @"strokes" )
-              ( StrokeLeaf 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).
-
-    updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) StrokeHierarchy
-    updateStrokeHierarchy ( StrokeGroup { .. } ) = do
-      newContents <- traverse updateStrokeHierarchy groupContents
-      pure ( StrokeGroup { groupContents = newContents, .. } )
-    updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
-
-    updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) Stroke
-    updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
-
-      where
-        updateStrokeSpline
-          :: forall clo brushParams
-          .  SplineTypeI clo
-          => StrokeSpline clo brushParams
-          -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) ( StrokeSpline clo brushParams )
-        updateStrokeSpline spline = do
-
-          mbAnchor <- get
-          case mbAnchor of
-            -- If we haven't already found an anchor,
-            -- and the current point is a valid candidate,
-            -- then select it as an anchor for the drawing operation.
-            Nothing
-              | strokeVisible
-              , Just anchor <- endpointAnchor strokeUnique spline
-              -> put ( Just ( anchor, strokeName ) )
-                      $> set ( mapped . _selection ) Normal spline
-            -- Otherwise, just deselect.
-            _ -> pure $  set ( mapped . _selection ) Normal spline
-
-          where
-            -- See if we can anchor a drawing operation on a given (visible) stroke.
-            endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, ℝ 2 )
-            endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
-              SOpen
-                | let
-                    p0 :: ℝ 2
-                    p0 = coords splineStart
-                , inPointClickRange p0
-                -> Just ( AnchorAtStart uniq, p0 )
-                | OpenCurves ( _ :|> lastCurve ) <- splineCurves
-                , let
-                    pn :: ℝ 2
-                    pn = coords ( openCurveEnd lastCurve )
-                , inPointClickRange pn
-                -> Just ( AnchorAtEnd uniq, pn )
-              _ -> Nothing
-            inPointClickRange :: ℝ 2 -> Bool
-            inPointClickRange p =
-              squaredNorm ( c --> p :: T ( ℝ 2 ) ) < 16 / ( zoomFactor * zoomFactor )
-
-addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
-addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy
-  where
-
-    updateStrokeHierarchy :: StrokeHierarchy -> StrokeHierarchy
-    updateStrokeHierarchy ( StrokeGroup { .. } ) =
-      let
-        newContents = fmap updateStrokeHierarchy groupContents
-      in
-        StrokeGroup { groupContents = newContents, .. }
-    updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf $ updateStroke strokeLeaf
-
-    updateStroke :: Stroke -> Stroke
-    updateStroke 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 _ ->
-                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
-            = assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
-                prevSpline -- should never add to a closed spline
-      = overStrokeSpline updateSpline stroke
-      | otherwise
-      = stroke
-
-withAnchorBrushData
-  :: forall r
-  .  DrawAnchor
-  -> Document
-  -> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
-     . ( pointParams ~ Record pointFields
-       , PointFields pointFields
-       )
-     => Maybe ( NamedBrush brushFields )
-     -> pointParams
-     -> r
-     )
-  -> r
-withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } ) f =
-  splineAnchor . coerce $ foldMap getFirstRelevantStroke strokes
-  where
-
-    getFirstRelevantStroke :: StrokeHierarchy -> Maybe ( First Stroke )
-    getFirstRelevantStroke ( StrokeGroup { groupContents } ) =
-      foldMap getFirstRelevantStroke groupContents
-    getFirstRelevantStroke ( StrokeLeaf { strokeLeaf } )
-      | strokeUnique strokeLeaf == anchorStrokeUnique anchor
-      = Just ( First strokeLeaf )
-      | otherwise
-      = Nothing
-
-    splineAnchor :: Maybe Stroke -> r
-    splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
-      | SOpen <- ssplineType @clo
-      = case anchor of
-        AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
-        AnchorAtEnd   {} -> f strokeBrush ( brushParams ( splineEnd   strokeSpline ) )
-    splineAnchor _
-      = f @_ @'[] @'[] Nothing ( MkR ℝ0 )

src/metabrushes/MetaBrush/Document/Serialise.hs

@@ -11,10 +11,16 @@ module MetaBrush.Document.Serialise
 -- base
 import Control.Monad
   ( unless )
+import Control.Monad.ST
+  ( stToIO )
 import qualified Data.Bifunctor as Bifunctor
   ( first )
 import Data.Functor.Identity
   ( Identity(..) )
+import Data.Maybe
+  ( fromMaybe )
+import Data.STRef
+  ( newSTRef )
 import Data.Version
   ( Version(versionBranch) )
 import GHC.Exts
@@ -38,6 +44,9 @@ import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Builder as Lazy.ByteString.Builder
   ( toLazyByteString )
 
+-- containers
+import qualified Data.Map.Strict as Map
+
 -- directory
 import System.Directory
   ( canonicalizePath, createDirectoryIfMissing, doesFileExist )
@@ -65,8 +74,7 @@ import Control.Monad.IO.Class
   ( MonadIO(liftIO) )
 import Control.Monad.Trans.Class
   ( MonadTrans(lift) )
-import Control.Monad.Trans.Reader
+import qualified Control.Monad.Trans.Reader as Reader
-  ( runReaderT )
 
 -- waargonaut
 import qualified Waargonaut.Attoparsec as JSON.Decoder
@@ -76,13 +84,9 @@ import qualified Waargonaut.Decode as JSON
 import qualified Waargonaut.Decode.Error as JSON
   ( DecodeError(ParseFailed) )
 import qualified Waargonaut.Decode as JSON.Decoder
-  ( atKey, atKeyOptional, bool, text, list )
 import qualified Waargonaut.Encode as JSON
   ( Encoder )
 import qualified Waargonaut.Encode as JSON.Encoder
-  ( runEncoder
-  , atKey', bool, int, list, mapLikeObj, text
-  )
 import qualified Waargonaut.Encode.Builder as JSON.Builder
   ( waargonautBuilder, bsBuilder )
 import qualified Waargonaut.Encode.Builder.Whitespace as JSON.Builder
@@ -102,32 +106,32 @@ import Waargonaut.Types.Json
 import qualified Waargonaut.Types.Whitespace as JSON
   ( WS )
 
--- metabrushes
+-- brush-strokes
 import Math.Bezier.Spline
-  (  SplineType(..), SSplineType(..), SplineTypeI(..) )
+  ( SplineType(..), SSplineType(..), SplineTypeI(..) )
+import Math.Bezier.Stroke
+  ( CachedStroke(..) )
 import Math.Linear
   ( ℝ(..), T(..) )
+
+-- MetaBrush
 import MetaBrush.Asset.Brushes
   ( lookupBrush )
 import MetaBrush.Brush
   ( NamedBrush(..), SomeBrush(..), provePointFields, duplicates )
 import MetaBrush.Document
-  ( Document(..), DocumentContent(..), Guide(..)
+import MetaBrush.Layer ( LayerMetadata(..) )
-  , Stroke(..), StrokeHierarchy(..), StrokeSpline
-  , PointData(..), FocusState(..)
-  )
 import MetaBrush.Serialisable
   ( Serialisable(..)
-  , encodeSequence, decodeSequence
-  , encodeUniqueMap, decodeUniqueMap
   , encodeSpline, decodeSpline
   )
+import MetaBrush.Stroke
 import MetaBrush.Records
   ( Record, knownSymbols )
 import MetaBrush.Unique
   ( UniqueSupply, freshUnique )
-
+import MetaBrush.Unique
--- MetaBrush
+  ( Unique )
 import qualified Paths_MetaBrush as Cabal
   ( version )
 
@@ -204,12 +208,8 @@ decodePointData
   => JSON.Decoder m ( PointData brushParams )
 decodePointData = do
   pointCoords <- JSON.Decoder.atKey "coords"      ( decoder @( ℝ 2 ) )
-  let
-    pointState :: FocusState
-    pointState = Normal
   brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Record flds ) )
-  pure ( PointData { pointCoords, pointState, brushParams } )
+  pure ( PointData { pointCoords, brushParams } )
-
 
 encodeFields :: Monad f => JSON.Encoder f [ Text ]
 encodeFields = JSON.Encoder.list JSON.Encoder.text
@@ -223,12 +223,12 @@ decodeFields = do
     dups  -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
 
 
-encodeBrush :: Applicative f => JSON.Encoder f (NamedBrush brushFields)
+encodeBrush :: Applicative f => JSON.Encoder f ( NamedBrush brushFields )
 encodeBrush = JSON.Encoder.mapLikeObj
   \ ( NamedBrush { brushName } ) ->
     JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
 
-decodeBrush :: MonadIO m => JSON.Decoder m SomeBrush
+decodeBrush :: Monad m => JSON.Decoder m SomeBrush
 decodeBrush = do
   brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
   case lookupBrush brushName of
@@ -239,9 +239,7 @@ decodeBrush = do
 encodeStroke :: Monad f => JSON.Encoder f Stroke
 encodeStroke = JSON.Encoder.mapLikeObj
   \ ( Stroke
-      { strokeName
+      { strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
-      , strokeVisible
-      , strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
       , strokeBrush
       }
     ) ->
@@ -255,18 +253,22 @@ encodeStroke = JSON.Encoder.mapLikeObj
         Nothing    -> id
         Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush
     in
-      JSON.Encoder.atKey' "name"        JSON.Encoder.text                strokeName
+      JSON.Encoder.atKey' "closed"      JSON.Encoder.bool                closed
-    . JSON.Encoder.atKey' "visible"     JSON.Encoder.bool                strokeVisible
-    . JSON.Encoder.atKey' "closed"      JSON.Encoder.bool                closed
     . JSON.Encoder.atKey' "pointFields" encodeFields                     ( knownSymbols @pointFields )
     . mbEncodeBrush
     . JSON.Encoder.atKey' "spline"      ( encodeSpline encodePointData ) strokeSpline
 
-decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
+newCurveData :: MonadIO m => ( Integer -> m CurveData )
-decodeStroke uniqueSupply = do
+newCurveData i = do
-  strokeUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
+  noCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
-  strokeName    <- JSON.Decoder.atKey         "name"        JSON.Decoder.text
+  return $
-  strokeVisible <- JSON.Decoder.atKey         "visible"     JSON.Decoder.bool
+    CurveData
+      { curveIndex   = fromInteger i
+      , cachedStroke = noCache
+      }
+
+decodeStroke :: MonadIO m => JSON.Decoder m Stroke
+decodeStroke = do
   strokeClosed  <- JSON.Decoder.atKey         "closed"      JSON.Decoder.bool
   mbSomeBrush   <- JSON.Decoder.atKeyOptional "brush"       decodeBrush
   pointFields   <- JSON.Decoder.atKey         "pointFields" decodeFields
@@ -274,97 +276,122 @@ decodeStroke uniqueSupply = do
   provePointFields pointFields \ ( _ :: Proxy# pointFields ) ->
     if strokeClosed
     then do
-      strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData )
+      strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData newCurveData  )
       pure $ case mbSomeBrush of
         Nothing ->
-          Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
+          Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
         Just (SomeBrush brush) ->
-          Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
+          Stroke { strokeSpline, strokeBrush = Just brush }
     else do
-      strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open   @( PointData ( Record pointFields ) ) decodePointData )
+      strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open   @( PointData ( Record pointFields ) ) decodePointData newCurveData  )
       pure $ case mbSomeBrush of
         Nothing ->
-          Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
+          Stroke { strokeSpline, strokeBrush = Nothing :: Maybe ( NamedBrush '[] ) }
         Just (SomeBrush brush) ->
-          Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
+          Stroke { strokeSpline, strokeBrush = Just brush }
-
-
-encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy
-encodeStrokeHierarchy = JSON.Encoder.mapLikeObj \case
-  StrokeGroup { groupName, groupVisible, groupContents } ->
-      JSON.Encoder.atKey' "tag"      JSON.Encoder.text                        "group"
-    . JSON.Encoder.atKey' "name"     JSON.Encoder.text                        groupName
-    . JSON.Encoder.atKey' "visible"  JSON.Encoder.bool                        groupVisible
-    . JSON.Encoder.atKey' "contents" ( encodeSequence encodeStrokeHierarchy ) groupContents
-  StrokeLeaf { strokeLeaf } ->
-      JSON.Encoder.atKey' "tag"      JSON.Encoder.text                        "leaf"
-    . JSON.Encoder.atKey' "stroke"   encodeStroke                             strokeLeaf
-
-decodeStrokeHierarchy :: MonadIO m => UniqueSupply -> JSON.Decoder m StrokeHierarchy
-decodeStrokeHierarchy uniqueSupply = do
-  tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
-  case tag of
-    "group" -> do
-      groupName     <- JSON.Decoder.atKey "name"     JSON.Decoder.text
-      groupVisible  <- JSON.Decoder.atKey "visible"  JSON.Decoder.bool
-      groupContents <- JSON.Decoder.atKey "contents" ( decodeSequence $ decodeStrokeHierarchy uniqueSupply )
-      pure ( StrokeGroup { groupName, groupVisible, groupContents } )
-    "leaf"  -> do
-      strokeLeaf    <- JSON.Decoder.atKey "stroke"   ( decodeStroke uniqueSupply )
-      pure ( StrokeLeaf { strokeLeaf } )
-    _ -> throwError ( JSON.ParseFailed $ "Unsupported stroke hierarchy type with tag " <> tag )
 
+encodeLayer :: Monad f => JSON.Encoder f Layer
+encodeLayer =
+  JSON.Encoder.mapLikeObj \ layer ->
+    let
+      encodeLayerData = case layer of
+        GroupLayer { groupChildren } ->
+          JSON.Encoder.atKey' "contents" ( JSON.Encoder.list encodeLayer ) groupChildren
+        StrokeLayer { layerStroke } ->
+          JSON.Encoder.atKey' "stroke"   encodeStroke                      layerStroke
+    in
+      JSON.Encoder.atKey'    "name"     JSON.Encoder.text ( layerName layer )
+    . JSON.Encoder.atOptKey' "visible"  JSON.Encoder.bool ( if layerVisible layer then Nothing else Just False )
+    . JSON.Encoder.atOptKey' "locked"   JSON.Encoder.bool ( if layerLocked  layer then Just True else Nothing )
+    . encodeLayerData
 
+decodeLayer :: MonadIO m => UniqueSupply -> JSON.Decoder m Layer
+decodeLayer uniqueSupply = do
+  layerUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
+  mbLayerName     <- JSON.Decoder.atKeyOptional "name"    JSON.Decoder.text
+  mbLayerVisible  <- JSON.Decoder.atKeyOptional "visible" JSON.Decoder.bool
+  mbLayerLocked   <- JSON.Decoder.atKeyOptional "locked"  JSON.Decoder.bool
+  let layerVisible = fromMaybe True  mbLayerVisible
+      layerLocked  = fromMaybe False mbLayerLocked
+  mbLayerStroke <- JSON.Decoder.atKeyOptional "stroke" decodeStroke
+  case mbLayerStroke of
+    Nothing -> do
+      let layerName = fromMaybe "Group" mbLayerName
+      groupChildren <- fromMaybe [] <$> JSON.Decoder.atKeyOptional "contents" ( JSON.Decoder.list ( decodeLayer uniqueSupply ) )
+      pure ( GroupLayer { layerUnique, layerName, layerVisible, layerLocked, groupChildren } )
+    Just layerStroke -> do
+      let layerName = fromMaybe "Stroke" mbLayerName
+      pure ( StrokeLayer { layerUnique, layerName, layerVisible, layerLocked, layerStroke } )
 
 encodeGuide :: Applicative f => JSON.Encoder f Guide
 encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
     JSON.Encoder.atKey' "point"  ( encoder @( ℝ 2 ) )       guidePoint
   . JSON.Encoder.atKey' "normal" ( encoder @( T ( ℝ 2 ) ) ) guideNormal
 
-decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
+decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m ( Unique, Guide )
 decodeGuide uniqueSupply = do
+  guideUnique <- lift ( liftIO . STM.atomically $ Reader.runReaderT freshUnique uniqueSupply )
   guidePoint  <- JSON.Decoder.atKey "point"  ( decoder @( ℝ 2 ) )
   guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) )
-  let
+  pure ( guideUnique, Guide { guidePoint, guideNormal } )
-    guideFocus :: FocusState
-    guideFocus = Normal
-  guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
-  pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
 
+encodeDocumentContent :: Applicative f => JSON.Encoder f ( LayerMetadata, DocumentContent )
+encodeDocumentContent  = JSON.Encoder.mapLikeObj \ ( layerMetadata, Content { strokeHierarchy } ) ->
+  JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeLayer ) $
+    strokeHierarchyLayers layerMetadata strokeHierarchy
 
-
+decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m ( LayerMetadata, DocumentContent )
-encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
-encodeDocumentContent  = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
-    JSON.Encoder.atKey' "guides"  ( encodeUniqueMap encodeGuide           ) guides
-  . JSON.Encoder.atKey' "strokes" ( encodeSequence  encodeStrokeHierarchy ) strokes
-
-decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent
 decodeDocumentContent uniqueSupply = do
   let
     unsavedChanges :: Bool
     unsavedChanges = False
-    latestChange :: Text
+  layers <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list $ decodeLayer uniqueSupply )
-    latestChange = "Load document"
+  let ( layerMetadata, strokeHierarchy ) = layersStrokeHierarchy layers
-  strokes <- JSON.Decoder.atKey "strokes" ( decodeSequence  ( decodeStrokeHierarchy uniqueSupply ) )
+  pure ( layerMetadata, Content { unsavedChanges, strokeHierarchy } )
-  guides  <- JSON.Decoder.atKey "guides"  ( decodeUniqueMap ( decodeGuide           uniqueSupply ) )
-  pure ( Content { unsavedChanges, latestChange, strokes, guides } )
 
 
+encodeDocumentMetadata :: Applicative f => JSON.Encoder f DocumentMetadata
+encodeDocumentMetadata =
+  JSON.Encoder.mapLikeObj
+    \ ( Metadata { documentName, viewportCenter, documentZoom, documentGuides } ) ->
+        JSON.Encoder.atKey' "name"    JSON.Encoder.text                 documentName
+      . JSON.Encoder.atKey' "center"  ( encoder @( ℝ 2 ) )              viewportCenter
+      . JSON.Encoder.atKey' "zoom"    ( encoder @Double )               ( zoomFactor documentZoom )
+      . JSON.Encoder.atKey' "guides"  ( JSON.Encoder.list encodeGuide ) ( Map.elems documentGuides )
+
+
+decodeDocumentMetadata
+  :: MonadIO m
+  => UniqueSupply
+  -> Maybe FilePath
+  -> LayerMetadata
+  -> JSON.Decoder m DocumentMetadata
+decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do
+  documentName    <- JSON.Decoder.atKey "name" JSON.Decoder.text
+  viewportCenter  <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
+  zoomFactor      <- JSON.Decoder.atKey "zoom"   ( decoder @Double )
+  guides          <- JSON.Decoder.atKey "guides" ( JSON.Decoder.list $ decodeGuide uniqueSupply )
+  pure $
+    Metadata
+      { documentName
+      , documentFilePath = mbFilePath
+      , viewportCenter
+      , documentZoom = Zoom { zoomFactor }
+      , documentGuides = Map.fromList guides
+      , layerMetadata
+      , selectedPoints = mempty
+      }
 
 encodeDocument :: Applicative f => JSON.Encoder f Document
 encodeDocument = JSON.Encoder.mapLikeObj
-  \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
+  \ ( Document { documentMetadata, documentContent } ) ->
     JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
-  . JSON.Encoder.atKey' "name"    JSON.Encoder.text                      displayName
+  . JSON.Encoder.atKey' "metadata" encodeDocumentMetadata documentMetadata
-  . JSON.Encoder.atKey' "center"  ( encoder @( ℝ 2 ) )        viewportCenter
+  . JSON.Encoder.atKey' "content"  encodeDocumentContent ( layerMetadata documentMetadata, documentContent )
-  . 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
+  ( layerMetadata, documentContent ) <-
-  viewportCenter  <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
+    JSON.Decoder.atKey "content"  ( decodeDocumentContent uniqueSupply )
-  zoomFactor      <- JSON.Decoder.atKey "zoom"   ( decoder @Double )
+  documentMetadata <- JSON.Decoder.atKey "metadata" $ decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata
-  documentUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
+  pure ( Document { documentMetadata, documentContent } )
-  documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
-  pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )

src/metabrushes/MetaBrush/Document/SubdivideStroke.hs

@@ -1,164 +0,0 @@
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module MetaBrush.Document.SubdivideStroke
-  ( subdivide )
-  where
-
--- base
-import Control.Monad.ST
-  ( RealWorld )
-import Data.Semigroup
-  ( Min(..), Arg(..) )
-
--- acts
-import Data.Act
-  ( Act((•)) )
-
--- containers
-import Data.Sequence
-  ( Seq(..) )
-import qualified Data.Sequence as Seq
-  ( singleton )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- groups
-import Data.Group
-  ( invert )
-
--- text
-import Data.Text
-  ( Text )
-
--- transformers
-import Control.Monad.Trans.State.Strict
-  ( State, runState, put )
-
--- MetaBrush
-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
-  ( CachedStroke(..), invalidateCache )
-import Math.Module
-  ( Interpolatable, lerp, quadrance, closestPointOnSegment )
-import Math.Linear
-  ( Segment(..), ℝ(..), T(..) )
-import MetaBrush.Document
-  ( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
-  , PointData(..), DiffPointData(..)
-  , coords, _strokeSpline
-  )
-
---------------------------------------------------------------------------------
-
--- | Subdivide a path at the given center, provided a path indeed lies there.
-subdivide :: ℝ 2 -> Document -> Maybe ( Document, Text )
-subdivide c doc@( Document { zoomFactor } ) =
-  let
-    updatedDoc :: Document
-    mbSubdivLoc :: Maybe Text
-    ( updatedDoc, mbSubdivLoc ) =
-      ( `runState` Nothing )
-        $ ( field' @"documentContent" . field' @"strokes" . traverse )
-            updateStrokeHierarchy
-            doc
-  in ( updatedDoc , ) <$> mbSubdivLoc
-  where
-    updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe Text ) StrokeHierarchy
-    updateStrokeHierarchy ( StrokeGroup { .. } ) = do
-      newContents <- traverse updateStrokeHierarchy groupContents
-      pure ( StrokeGroup { groupContents = newContents, .. } )
-    updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
-
-    updateStroke :: Stroke -> State ( Maybe Text ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
-
-      where
-        updateSpline
-          :: forall clo brushParams
-          .  ( KnownSplineType clo, Interpolatable Double brushParams )
-          => StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
-        updateSpline spline@( Spline { splineStart } )
-          | not strokeVisible
-          = pure spline
-          | otherwise
-          = fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
-          $ bifoldSpline
-              ( updateCurve ( "stroke " <> strokeName ) ( V2 0 0 ) )
-              ( const $ pure Empty )
-              ( adjustSplineType @Open spline )
-
-            where
-              updateCurve
-                :: Text
-                -> T ( ℝ 2 )
-                -> PointData brushParams
-                -> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
-                -> State ( Maybe Text )
-                    ( Seq ( Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) ) )
-              updateCurve txt offset sp0 curve = case curve of
-                line@( LineTo ( NextPoint sp1 ) dat ) ->
-                  let
-                      p0, p1, s :: ℝ 2
-                      t :: Double
-                      p0 = coords sp0
-                      p1 = coords sp1
-                      ( t, s ) = closestPointOnSegment @( T ( ℝ 2 ) ) ( invert offset • c ) ( Segment p0 p1 )
-                      sqDist :: Double
-                      sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s )
-                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-                    then
-                      let
-                        subdiv :: PointData brushParams
-                        subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
-                      in do
-                        put ( Just txt )
-                        pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty )
-                    else pure $ Seq.singleton line
-                bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
-                  let
-                    p0, p1, p2 :: ℝ 2
-                    p0 = coords sp0
-                    p1 = coords sp1
-                    p2 = coords sp2
-                    sqDist :: Double
-                    Min ( Arg sqDist ( t, _ ) )
-                      = Quadratic.closestPoint @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) ( invert offset • c )
-                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-                    then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
-                      ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
-                        let
-                          bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
-                          bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
-                          bez_end   = Bezier2To r1 ( NextPoint sp2    ) ( invalidateCache dat )
-                        put ( Just txt )
-                        pure ( bez_start :<| bez_end :<| Empty )
-                    else pure $ Seq.singleton bez2
-                bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
-                  let
-                      p0, p1, p2, p3 :: ℝ 2
-                      p0 = coords sp0
-                      p1 = coords sp1
-                      p2 = coords sp2
-                      p3 = coords sp3
-                      Min ( Arg sqDist ( t, _ ) )
-                        = Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier {..} ) ( invert offset • c )
-                  in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
-                    then case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
-                      ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
-                        let
-                          bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
-                          bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
-                          bez_end   = Bezier3To r1 r2 ( NextPoint sp3    ) ( invalidateCache dat )
-                        put ( Just txt )
-                        pure ( bez_start :<| bez_end :<| Empty )
-                    else pure $ Seq.singleton bez3

src/metabrushes/MetaBrush/Draw.hs

@@ -0,0 +1,282 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module MetaBrush.Draw
+  ( DrawAnchor(..), anchorsAreComplementary
+  , getOrCreateDrawAnchor, addToAnchor
+  , withAnchorBrushData
+  )
+  where
+
+-- base
+import Control.Monad
+  ( when )
+import Data.Foldable
+  ( for_ )
+import Data.Functor.Identity
+  ( Identity(..) )
+import GHC.Generics
+  ( Generic )
+import GHC.TypeLits
+  ( Symbol )
+
+-- containers
+import Data.Sequence
+  ( Seq(..) )
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field, field' )
+
+-- lens
+import Control.Lens
+  ( set, over )
+
+-- stm
+import Control.Concurrent.STM
+  ( STM )
+
+-- transformers
+import Control.Monad.Trans.Except
+  ( Except )
+import qualified Control.Monad.Trans.Except as Except
+import Control.Monad.Trans.Reader
+  ( runReaderT )
+
+-- MetaBrush
+import Math.Bezier.Spline
+import Math.Linear
+  ( ℝ(..) )
+import MetaBrush.Assert
+  ( assert )
+import MetaBrush.Brush
+  ( NamedBrush(..), PointFields )
+import MetaBrush.Document
+import MetaBrush.Hover
+  ( inPointClickRange )
+import MetaBrush.Layer
+import MetaBrush.Records
+import MetaBrush.Stroke
+import MetaBrush.Unique
+  ( Unique, UniqueSupply, freshUnique )
+
+--------------------------------------------------------------------------------
+
+-- | A draw anchor, to continue drawing from one end of an existing stroke.
+data DrawAnchor
+  = DrawAnchor
+    { anchorIsNew   :: !Bool
+    , anchorStroke  :: !Unique
+    , anchorIsAtEnd :: !Bool
+    , anchorPos     :: !( ℝ 2 )
+    , anchorIndex   :: !PointIndex
+    }
+  deriving stock ( Show, Eq, Generic )
+  deriving anyclass NFData
+
+-- | Computes whether two anchors are the two ends of the same stroke.
+anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
+anchorsAreComplementary
+  ( DrawAnchor { anchorStroke = uniq1, anchorIndex = end1 } )
+  ( DrawAnchor { anchorStroke = uniq2, anchorIndex = end2 } )
+  = uniq1 == uniq2 && end1 /= end2
+
+-- | Compute a draw anchor at the given position, e.g. to continue
+-- drawing a stroke or to start a new one.
+getOrCreateDrawAnchor
+  :: UniqueSupply
+  -> ℝ 2
+  -> Document
+  -> STM ( Document, DrawAnchor )
+getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldContent, documentMetadata } ) =
+
+  -- Deselect all points, and try to find a valid anchor for drawing
+  -- (a path start/end point at mouse click point).
+
+  case
+    Except.runExcept $
+      forStrokeHierarchy
+        ( layerMetadata documentMetadata )
+        ( strokeHierarchy oldContent )
+        findAnchor
+  of
+    -- Anchor found: use it.
+    Left anchor@( DrawAnchor { anchorStroke, anchorIndex }) ->
+      let newSel = StrokePoints $ Map.singleton anchorStroke ( Set.singleton anchorIndex )
+          newMeta :: DocumentMetadata
+          newMeta = documentMetadata { selectedPoints = newSel }
+      in pure ( doc { documentMetadata = newMeta }
+              , anchor )
+    -- No anchor found: start a new stroke (on a new stroke layer).
+    Right {} -> do
+      newStrokeUnique <- runReaderT freshUnique uniqueSupply
+      let
+        newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
+        newSpline =
+          Spline { splineStart  = PointData c ( MkR ℝ0 )
+                 , splineCurves = OpenCurves Empty
+                 }
+        newStroke :: Stroke
+        newStroke =
+          Stroke
+            { strokeSpline  = newSpline
+            , strokeBrush   = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
+            }
+        newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
+        newMeta :: DocumentMetadata
+        newMeta =
+            set ( field' @"selectedPoints" ) newSel
+          . over ( field' @"layerMetadata" . field' @"layerNames" ) ( Map.insert newStrokeUnique "Stroke" )
+          $ documentMetadata
+        newHierarchy :: StrokeHierarchy
+        newHierarchy =
+          ( strokeHierarchy oldContent )
+            { topLevel = newStrokeUnique : topLevel ( strokeHierarchy oldContent )
+            , content = Map.insert newStrokeUnique newStroke ( content ( strokeHierarchy oldContent ) )
+            }
+        newContent :: DocumentContent
+        newContent = oldContent { strokeHierarchy = newHierarchy }
+        newDoc' :: Document
+        newDoc' =
+          doc { documentMetadata = newMeta
+              , documentContent  = newContent
+              }
+        anchor =
+          DrawAnchor
+            { anchorIsNew   = True
+            , anchorStroke  = newStrokeUnique
+            , anchorIsAtEnd = True
+            , anchorPos     = c
+            , anchorIndex   = FirstPoint
+            }
+      pure ( newDoc', anchor )
+  where
+    zoom = documentZoom documentMetadata
+
+    findAnchor :: Unique -> Stroke -> StrokeMetadata -> Except DrawAnchor UpdateStroke
+    findAnchor strokeUnique ( Stroke { strokeSpline }) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
+      when ( strokeVisible && not strokeLocked ) $
+        findAnchorSpline strokeSpline
+      return PreserveStroke
+
+      where
+        findAnchorSpline
+          :: forall clo brushParams
+          .  SplineTypeI clo
+          => StrokeSpline clo brushParams
+          -> Except DrawAnchor ()
+        findAnchorSpline spline =
+          for_ ( endpointAnchor strokeUnique spline ) Except.throwE
+          where
+            -- See if we can anchor a drawing operation on a given (visible) stroke.
+            endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe DrawAnchor
+            endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
+              SOpen
+                | let
+                    p0 = coords splineStart
+                , inPointClickRange zoom c p0
+                , let anchor =
+                       DrawAnchor
+                         { anchorIsNew   = False
+                         , anchorStroke  = uniq
+                         , anchorIsAtEnd = False
+                         , anchorPos     = p0
+                         , anchorIndex   = FirstPoint
+                         }
+                -> Just anchor
+                | OpenCurves ( _ :|> lastCurve ) <- splineCurves
+                , let
+                    pn :: ℝ 2
+                    pn = coords ( openCurveEnd lastCurve )
+                , inPointClickRange zoom c pn
+                , let anchor =
+                       DrawAnchor
+                         { anchorIsNew   = False
+                         , anchorStroke  = uniq
+                         , anchorIsAtEnd = True
+                         , anchorPos     = pn
+                         , anchorIndex   = PointIndex
+                                             ( curveIndex $ curveData lastCurve )
+                                             PathPoint
+                         }
+                -> Just anchor
+              _ -> Nothing
+
+addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
+addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) =
+  let
+    strokes' =
+      runIdentity $
+        forStrokeHierarchy
+          ( layerMetadata documentMetadata )
+          ( strokeHierarchy oldContent )
+          ( \ u s _ -> Identity $ updateStroke u s )
+  in doc { documentContent = oldContent { strokeHierarchy = strokes' } }
+  where
+
+    updateStroke :: Unique -> Stroke -> UpdateStroke
+    updateStroke strokeUnique stroke
+      | strokeUnique == anchorStroke anchor
+      , let
+          updateSpline
+            :: forall clo brushData
+            .  SplineTypeI clo
+            => StrokeSpline clo brushData -> StrokeSpline clo brushData
+          updateSpline prevSpline
+            | SOpen <- ssplineType @clo
+            = if anchorIsAtEnd anchor
+              then
+                let
+                  setBrushData :: PointData () -> PointData brushData
+                  setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
+                in prevSpline <> fmap setBrushData newSpline
+              else
+                let
+                  setBrushData :: PointData () -> PointData brushData
+                  setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
+                in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
+            | otherwise
+            = assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique )
+                prevSpline -- should never add to a closed spline
+      = UpdateStrokeTo $ overStrokeSpline updateSpline stroke
+      | otherwise
+      = PreserveStroke
+
+withAnchorBrushData
+  :: forall r
+  .  DrawAnchor
+  -> Document
+  -> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
+     . ( pointParams ~ Record pointFields
+       , PointFields pointFields
+       )
+     => Maybe ( NamedBrush brushFields )
+     -> pointParams
+     -> r
+     )
+  -> r
+withAnchorBrushData anchor ( Document { documentMetadata = Metadata { layerMetadata }, documentContent = Content { strokeHierarchy } } ) f =
+  splineAnchor $ Except.runExcept $ forStrokeHierarchy layerMetadata strokeHierarchy relevantStroke
+  where
+
+    relevantStroke :: Unique -> Stroke -> StrokeMetadata -> Except Stroke UpdateStroke
+    relevantStroke strokeUnique stroke _
+      | strokeUnique == anchorStroke anchor
+      = Except.throwE stroke
+      | otherwise
+      = return PreserveStroke
+
+    splineAnchor :: Either Stroke other -> r
+    splineAnchor ( Left ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
+      | SOpen <- ssplineType @clo
+      = if anchorIsAtEnd anchor
+        then f strokeBrush ( brushParams ( splineEnd   strokeSpline ) )
+        else f strokeBrush ( brushParams ( splineStart strokeSpline ) )
+    splineAnchor _
+      = f @_ @'[] @'[] Nothing ( MkR ℝ0 )

src/metabrushes/MetaBrush/Guide.hs

@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module MetaBrush.Guide where
+
+-- base
+import Data.Semigroup
+  ( Arg(..), Min(..), ArgMin )
+
+-- acts
+import Data.Act
+  ( Torsor(..) )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- stm
+import Control.Concurrent.STM
+  ( STM )
+
+-- transformers
+import Control.Monad.Trans.Reader
+  ( ReaderT, runReaderT )
+
+-- brush-strokes
+import Math.Module
+  ( Inner((^.^))
+  , squaredNorm
+  )
+import Math.Linear
+  ( ℝ(..), T(..) )
+
+-- MetaBrush
+import MetaBrush.Document
+import MetaBrush.Hover
+import MetaBrush.Unique
+  ( UniqueSupply, Unique, freshUnique )
+
+--------------------------------------------------------------------------------
+-- Guides.
+
+data Ruler
+  = RulerCorner
+  | LeftRuler
+  | TopRuler
+  deriving stock Show
+
+-- | Try to select a guide at the given document coordinates.
+selectedGuide :: ℝ 2 -> Zoom -> Map Unique Guide -> Maybe ( Unique, Guide )
+selectedGuide c zoom guides =
+  \case { Min ( Arg _ g ) -> g } <$> Map.foldMapWithKey ( selectGuide_maybe c zoom ) guides
+
+selectGuide_maybe :: ℝ 2 -> Zoom -> unique -> Guide -> Maybe ( ArgMin Double ( unique, Guide ) )
+selectGuide_maybe c ( Zoom { zoomFactor } ) u guide@( Guide { guidePoint = p, guideNormal = n } )
+  | sqDist * zoomFactor ^ ( 2 :: Int ) < 4
+  = Just ( Min ( Arg sqDist ( u, guide ) ) )
+  | otherwise
+  = Nothing
+  where
+    t :: Double
+    t = ( c --> p ) ^.^ n
+    sqDist :: Double
+    sqDist = t ^ ( 2 :: Int ) / squaredNorm n
+
+-- | Add new guide after a mouse drag from a ruler area.
+addGuide :: UniqueSupply -> Ruler -> ℝ 2 -> Document -> STM Document
+addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentMetadata" . field' @"documentGuides" ) insertNewGuides doc
+  where
+    insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
+    insertNewGuides gs = case ruler of
+      RulerCorner
+        -> do
+          uniq1 <- freshUnique
+          uniq2 <- freshUnique
+          let
+            guide1, guide2 :: Guide
+            guide1 = Guide { guidePoint = p, guideNormal = V2 0 1 }
+            guide2 = Guide { guidePoint = p, guideNormal = V2 1 0 }
+          pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
+      TopRuler
+        -> do
+          uniq1 <- freshUnique
+          let
+            guide1 :: Guide
+            guide1 = Guide { guidePoint = p, guideNormal = V2 0 1 }
+          pure ( Map.insert uniq1 guide1 gs )
+      LeftRuler
+        -> do
+          uniq2 <- freshUnique
+          let
+            guide2 :: Guide
+            guide2 = Guide { guidePoint = p, guideNormal = V2 1 0 }
+          pure ( Map.insert uniq2 guide2 gs )
+
+instance Hoverable Guide where
+  hovered ( MouseHover c ) zoom guide
+    | Just {} <- selectGuide_maybe c zoom () guide
+    = True
+    | otherwise
+    = False
+  hovered ( RectangleHover {} ) _ _
+    = False

src/metabrushes/MetaBrush/Hover.hs

@@ -0,0 +1,82 @@
+module MetaBrush.Hover where
+
+-- base
+import GHC.Generics
+  ( Generic )
+
+-- acts
+import Data.Act
+  ( Act(..) )
+
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
+-- brush-strokes
+import Math.Module
+  ( quadrance
+  , closestPointOnSegment
+  )
+import Math.Linear
+  ( ℝ(..), T(..), Segment(..) )
+
+-- MetaBrush
+import MetaBrush.Document
+
+--------------------------------------------------------------------------------
+
+-- | An axis-aligned bounding box.
+data AABB
+  = AABB
+  { topLeft, botRight :: !( ℝ 2 ) }
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+
+-- | Create an 'AABB'.
+mkAABB :: ℝ 2 -> ℝ 2 -> AABB
+mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
+  where
+    ( xmin, xmax )
+      | x1 > x2   = ( x2, x1 )
+      | otherwise = ( x1, x2 )
+    ( ymin, ymax )
+      | y1 > y2   = ( y2, y1 )
+      | otherwise = ( y1, y2 )
+
+-- | A hover (mouse cursor or entire rectangle).
+data HoverContext
+  = MouseHover     !( ℝ 2 )
+  | RectangleHover !AABB
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+
+instance Act ( T ( ℝ 2 ) ) HoverContext where
+  v • MouseHover p = MouseHover ( v • p )
+  v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
+
+instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
+  (•) v = fmap ( v • )
+
+class Hoverable a where
+  hovered :: HoverContext -> Zoom -> a -> Bool
+
+instance Hoverable ( ℝ 2 ) where
+  hovered ( MouseHover p ) zoom q
+    = inPointClickRange zoom p q
+  hovered ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) _ ( ℝ2 x y )
+    = x >= x1 && x <= x2 && y >= y1 && y <= y2
+
+instance Hoverable ( Segment ( ℝ 2 ) ) where
+  hovered ( MouseHover p ) zoom seg
+    = hovered ( MouseHover p ) zoom p'
+    where
+      ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
+  hovered hov@(RectangleHover {} ) zoom ( Segment p0 p1 )
+    -- Only consider a segment to be "hovered" if it lies entirely within the
+    -- hover rectangle, not just if the hover rectangle intersects it.
+    = hovered hov zoom p0 && hovered hov zoom p1
+
+inPointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool
+inPointClickRange ( Zoom { zoomFactor } ) c p =
+  quadrance @( T ( ℝ 2 ) ) c p < 16 / ( zoomFactor * zoomFactor )

src/metabrushes/MetaBrush/Layer.hs

@@ -0,0 +1,88 @@
+module MetaBrush.Layer where
+
+-- base
+import Data.Word
+  ( Word32 )
+import GHC.Generics
+  ( Generically(..), Generic )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+import Data.Set
+  ( Set )
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..) )
+
+-- text
+import Data.Text
+  ( Text )
+
+-- MetaBrush
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+-- | A layer: either a stroke or a group.
+data Layer
+  = StrokeLayer { layerUnique :: !Unique }
+  | GroupLayer  { layerUnique :: !Unique }
+  deriving stock ( Show, Eq, Generic )
+  deriving anyclass NFData
+
+-- | Metadata about layers, e.g. their names and their visibilities.
+data LayerMetadata =
+  LayerMetadata
+    { layerNames       :: !( Map Unique Text )
+    , invisibleLayers  :: !( Set Unique )
+    , lockedLayers     :: !( Set Unique )
+    }
+  deriving stock    ( Show, Generic )
+  deriving anyclass NFData
+  deriving ( Semigroup, Monoid )
+    via Generically LayerMetadata
+
+-- | A parent of a layer.
+data Parent a
+  -- | The layer is at the top level.
+  = Root
+  -- | The layer has this parent.
+  | Parent !a
+  deriving stock ( Show, Eq, Ord, Functor, Generic )
+  deriving anyclass NFData
+
+-- | An item within a parent.
+data WithinParent a =
+  WithinParent
+    { parent :: !( Parent Unique )
+    , item   :: !a
+    }
+  deriving stock ( Show, Eq, Generic )
+  deriving anyclass NFData
+
+-- | A child layer within a parent.
+type ChildLayer         = WithinParent Unique
+-- | A child layer, with its index among the list of children of its parent.
+type ChildLayerPosition = WithinParent Word32
+
+-- | Content in a hierarchical tree-like structure.
+data Hierarchy a =
+  Hierarchy
+    { topLevel :: ![ Unique ]
+    , groups   :: !( Map Unique [ Unique ] )
+    , content  :: !( Map Unique a )
+    }
+  deriving stock ( Show, Eq, Functor, Generic )
+  deriving anyclass NFData
+
+emptyHierarchy :: Hierarchy a
+emptyHierarchy =
+  Hierarchy
+    { topLevel = []
+    , groups   = Map.empty
+    , content  = Map.empty
+    }

src/metabrushes/MetaBrush/Serialisable.hs

@@ -5,7 +5,6 @@
 module MetaBrush.Serialisable
   ( Serialisable(..)
   , encodeSequence, decodeSequence
-  , encodeUniqueMap, decodeUniqueMap
   , encodeCurve, decodeCurve
   , encodeCurves, decodeCurves
   , encodeSpline, decodeSpline
@@ -13,10 +12,7 @@ module MetaBrush.Serialisable
   where
 
 -- base
-import Control.Arrow
+
-  ( (&&&) )
-import Control.Monad.ST
-  ( RealWorld, stToIO )
 import Data.Foldable
   ( toList )
 import Data.Functor
@@ -25,29 +21,17 @@ import Data.Functor.Contravariant
   ( contramap )
 import Data.Functor.Identity
   ( Identity(..) )
-import Data.STRef
+import Data.IORef
-  ( newSTRef )
+  ( newIORef, atomicModifyIORef' )
 import Data.Traversable
   ( for )
 
 -- containers
-import Data.Map.Strict
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( elems, fromList )
 import Data.Sequence
   ( Seq )
 import qualified Data.Sequence as Seq
   ( fromList )
 
--- generic-lens
-import Data.Generics.Product.Typed
-  ( HasType(typed) )
-
--- lens
-import Control.Lens
-  ( view )
-
 -- scientific
 import qualified Data.Scientific as Scientific
   ( fromFloatDigits, toRealFloat )
@@ -66,26 +50,20 @@ import Control.Monad.Trans.Class
 import qualified Waargonaut.Decode as JSON
   ( Decoder )
 import qualified Waargonaut.Decode as JSON.Decoder
-  ( atKey, atKeyOptional, list, scientific, text )
 import qualified Waargonaut.Encode as JSON
   ( Encoder )
 import qualified Waargonaut.Encode as JSON.Encoder
-  ( atKey', keyValueTupleFoldable, list, mapLikeObj, scientific, text, either )
 
 -- meta-brushes
 import Math.Bezier.Spline
   ( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..)
   , Curves(..), Curve(..), NextPoint(..)
   )
-import Math.Bezier.Stroke
-  ( CachedStroke(..) )
 import Math.Linear
   ( ℝ(..), T(..)
   , Fin(..), Representable(tabulate, index)
   )
 import MetaBrush.Records
-import MetaBrush.Unique
-  ( Unique )
 
 --------------------------------------------------------------------------------
 
@@ -101,13 +79,15 @@ instance Serialisable ( ℝ 2 ) where
   encoder = JSON.Encoder.mapLikeObj \ ( ℝ2 x y ) ->
       JSON.Encoder.atKey' "x" encoder x
     . JSON.Encoder.atKey' "y" encoder y
-  decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
+  decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder
-
+               <*> JSON.Decoder.atKey "y" decoder
 instance Serialisable ( T ( ℝ 2 ) ) where
   encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) ->
       JSON.Encoder.atKey' "x" encoder x
     . JSON.Encoder.atKey' "y" encoder y
-  decoder = V2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
+  decoder = V2 <$> JSON.Decoder.atKey "x" decoder
+               <*> JSON.Decoder.atKey "y" decoder
+
 instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) )
       => Serialisable ( Record ks ) where
   encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
@@ -131,16 +111,6 @@ encodeSequence enc = contramap toList ( JSON.Encoder.list enc )
 decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a )
 decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
 
-
-
-encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
-encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
-
-decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
-decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
-
-
-
 {-
 encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
 encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
@@ -202,36 +172,35 @@ encodeCurve  encodePtData = case ssplineType @clo of
       . JSON.Encoder.atKey' "p2" encodePtData p2
 
 decodeCurve
-  :: forall clo ptData m
+  :: forall clo ptData crvData m
   .  ( SplineTypeI clo, MonadIO m )
   => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Curve clo ( CachedStroke RealWorld ) ptData )
+  -> JSON.Decoder m crvData
-decodeCurve decodePtData = do
+  -> JSON.Decoder m ( Curve clo crvData ptData )
-  noCache <- lift . liftIO . stToIO $ CachedStroke <$> newSTRef Nothing
+decodeCurve decodePtData decodeCrvData = do
+  crv <- decodeCrvData
   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 ) noCache )
+          pure ( LineTo ( NextPoint p1 ) crv)
         Just p2 -> do
           mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
           case mb_p3 of
-            Nothing -> pure ( Bezier2To    p1 ( NextPoint p2 ) noCache )
+            Nothing -> pure ( Bezier2To    p1 ( NextPoint p2 ) crv )
-            Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) noCache )
+            Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) crv )
     SClosed -> do
       mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
       case mb_p1 of
         Nothing ->
-          pure ( LineTo BackToStart noCache )
+          pure ( LineTo BackToStart crv )
         Just p1 -> do
           mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
           case mb_p2 of
-            Nothing -> pure ( Bezier2To    p1 BackToStart noCache )
+            Nothing -> pure ( Bezier2To    p1 BackToStart crv )
-            Just p2 -> pure ( Bezier3To p1 p2 BackToStart noCache )
+            Just p2 -> pure ( Bezier3To p1 p2 BackToStart crv )
-
-
 
 encodeCurves
   :: forall clo crvData ptData f
@@ -250,19 +219,20 @@ encodeCurves encodePtData = case ssplineType @clo of
         . JSON.Encoder.atKey' "lastClosedCurve"                  ( encodeCurve @Closed encodePtData ) closedCurve
 
 decodeCurves
-  :: forall clo ptData m
+  :: forall clo ptData crvData m
   .  ( SplineTypeI clo, MonadIO m )
   => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Curves clo ( CachedStroke RealWorld ) ptData )
+  -> JSON.Decoder m crvData
-decodeCurves decodePtData = case ssplineType @clo of
+  -> JSON.Decoder m ( Curves clo crvData ptData )
-  SOpen   -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
+decodeCurves decodePtData decodeCrvData = case ssplineType @clo of
+  SOpen   -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData decodeCrvData )
   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 )
+        prevCurves <- JSON.Decoder.atKey "prevOpenCurves"  ( decodeSequence $ decodeCurve @Open   decodePtData decodeCrvData )
-        lastCurve  <- JSON.Decoder.atKey "lastClosedCurve"                  ( decodeCurve @Closed decodePtData )
+        lastCurve  <- JSON.Decoder.atKey "lastClosedCurve"                  ( decodeCurve @Closed decodePtData decodeCrvData )
         pure ( ClosedCurves prevCurves lastCurve )
 
 
@@ -277,11 +247,17 @@ encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, sp
   . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
 
 decodeSpline
-  :: forall clo ptData m
+  :: forall clo ptData crvData m
   .  ( SplineTypeI clo, MonadIO m )
   => JSON.Decoder m ptData
-  -> JSON.Decoder m ( Spline clo ( CachedStroke RealWorld ) ptData )
+  -> ( Integer -> m crvData )
-decodeSpline decodePtData = do
+  -> JSON.Decoder m ( Spline clo crvData ptData )
+decodeSpline decodePtData newCurve = do
+  ref <- lift $ liftIO $ newIORef 0
+  let newCrvData :: m crvData
+      newCrvData = do
+        i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) )
+        newCurve i
   splineStart  <- JSON.Decoder.atKey "splineStart"  decodePtData
-  splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
+  splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData ( lift newCrvData ) )
   pure ( Spline { splineStart, splineCurves } )

src/metabrushes/MetaBrush/Stroke.hs

@@ -0,0 +1,366 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module MetaBrush.Stroke where
+
+-- base
+import Control.Monad.ST
+  ( RealWorld )
+import Data.Coerce
+  ( coerce )
+import Data.Foldable
+  ( foldr' )
+import Data.Functor.Identity
+  ( Identity(..) )
+import Data.Typeable
+  ( Typeable )
+import GHC.Generics
+  ( Generic, Generic1 )
+import GHC.Stack
+  ( HasCallStack )
+import GHC.TypeLits
+  ( Symbol )
+
+-- acts
+import Data.Act
+  ( Act(..), Torsor(..) )
+
+-- containers
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-- deepseq
+import Control.DeepSeq
+  ( NFData(..), NFData1 )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- groups
+import Data.Group
+  ( Group(..) )
+
+-- lens
+import Control.Lens
+  ( Lens'
+  , view, over
+  )
+
+-- text
+import Data.Text
+  ( Text )
+
+-- transformers
+import Control.Monad.State.Strict
+  ( State )
+import qualified Control.Monad.State.Strict as State
+
+-- brush-strokes
+import Math.Bezier.Spline
+  ( Spline(..), KnownSplineType
+  , PointType(..)
+  )
+import Math.Bezier.Stroke
+  ( CachedStroke )
+import Math.Module
+  ( Module
+    ( origin, (^+^), (^-^), (*^) )
+  )
+import Math.Linear
+  ( ℝ(..), T(..) )
+
+-- MetaBrush
+import MetaBrush.Brush
+  ( NamedBrush, PointFields )
+import MetaBrush.Layer hiding ( Layer(..) )
+import MetaBrush.Records
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+-- | Data attached to each point on a spline.
+data PointData params
+  = PointData
+  { pointCoords :: !( ℝ 2 )
+  , brushParams :: !params
+  }
+  deriving stock ( Show, Generic )
+  deriving anyclass NFData
+
+-- | Data attached to each curve in a spline.
+data CurveData =
+  CurveData
+    { curveIndex   :: !Rational
+    , cachedStroke :: !( CachedStroke RealWorld )
+    }
+  deriving stock Generic
+  deriving anyclass NFData
+
+instance Show CurveData where
+  show ( CurveData { curveIndex } ) = show curveIndex
+instance Eq CurveData where
+  ( CurveData { curveIndex = i1 } ) == ( CurveData { curveIndex = i2 } )
+    = i1 == i2
+instance Ord CurveData where
+  compare ( CurveData { curveIndex = i1 } ) ( CurveData { curveIndex = i2 } )
+    = compare i1 i2
+
+-- | An index for a point on a spline.
+data PointIndex
+  = FirstPoint
+  | PointIndex
+    -- | Which curve the point belongs to.
+    { pointCurve :: !Rational
+    -- | Index within a curve.
+    , pointType  :: !PointType
+    }
+  deriving stock ( Show, Eq, Ord, Generic )
+  deriving anyclass NFData
+
+_coords :: Lens' ( PointData brushParams ) ( ℝ 2 )
+_coords = field' @"pointCoords"
+
+coords :: PointData brushParams -> ℝ 2
+coords = view _coords
+
+type StrokeSpline clo brushParams =
+  Spline clo CurveData ( PointData brushParams )
+
+data Stroke where
+  Stroke
+    :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
+    .  ( KnownSplineType clo
+       , pointParams ~ Record pointFields
+       , PointFields pointFields, Typeable pointFields
+       )
+    =>
+      { strokeBrush  :: !( Maybe ( NamedBrush brushFields ) )
+      , strokeSpline :: !( StrokeSpline clo pointParams )
+      }
+    -> Stroke
+deriving stock instance Show Stroke
+instance NFData Stroke where
+  rnf ( Stroke { strokeBrush, strokeSpline } )
+    = rnf strokeBrush `seq` rnf strokeSpline
+
+_strokeSpline
+  :: forall f
+  .  Functor f
+  => (  forall clo pointParams ( pointFields :: [ Symbol ] )
+     .  ( KnownSplineType clo
+        , pointParams ~ Record pointFields
+        , PointFields pointFields
+        )
+     => 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 :: [ Symbol ] )
+     .  ( KnownSplineType clo
+        , pointParams ~ Record pointFields
+        , PointFields pointFields
+        )
+     => StrokeSpline clo pointParams
+     -> StrokeSpline clo pointParams
+     )
+  -> Stroke -> Stroke
+overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
+
+instance Act ( T ( ℝ 2 ) ) ( PointData params ) where
+  v • ( dat@( PointData { pointCoords = p } ) ) =
+    dat { pointCoords = v • p }
+
+data DiffPointData diffBrushParams
+  = DiffPointData
+  { diffVector :: !( T ( ℝ 2 ) )
+  , diffParams :: !diffBrushParams
+  }
+  deriving stock    ( Show, Generic, Generic1, Functor, Foldable, Traversable )
+  deriving anyclass ( NFData, NFData1 )
+
+instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
+  DiffPointData v1 p1 <> DiffPointData v2 p2 =
+    DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 )
+instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
+  mempty = DiffPointData mempty origin
+instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
+  invert ( DiffPointData v1 p1 ) =
+    DiffPointData ( invert v1 ) ( -1 *^ p1 )
+
+instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
+      => Act    ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
+  (•) ( DiffPointData { diffVector = dp, diffParams = db } )
+    = over _coords ( dp • )
+    . over ( field' @"brushParams" ) ( db • )
+instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
+      => Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
+  ( PointData
+    { pointCoords = p1
+    , brushParams = b1
+    } ) <--
+    ( PointData
+      { pointCoords = p2
+      , brushParams = b2 } ) =
+    DiffPointData
+      { diffVector = p1 <-- p2
+      , diffParams = b1 <-- b2
+      }
+
+instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
+  origin = mempty
+  (^+^) = (<>)
+  x ^-^ y = x <> invert y
+  d *^ DiffPointData v1 p1 =
+    DiffPointData ( d *^ v1 ) ( d *^ p1 )
+
+--------------------------------------------------------------------------------
+
+-- | Metadata about a stroke, such as its name or its visibility.
+data StrokeMetadata
+  = StrokeMetadata
+  { strokeName    :: !Text
+  , strokeVisible :: !Bool
+  , strokeLocked  :: !Bool
+  }
+
+type StrokeHierarchy = Hierarchy Stroke
+
+data UpdateStroke
+  = PreserveStroke
+  | DeleteStroke
+  | UpdateStrokeTo !Stroke
+  deriving stock Show
+
+-- | Traverse through a stroke hierarchy.
+forStrokeHierarchy
+  :: forall f
+  .  ( HasCallStack, Applicative f )
+  => LayerMetadata
+  -> StrokeHierarchy
+  -> ( Unique -> Stroke -> StrokeMetadata -> f UpdateStroke )
+  -> f StrokeHierarchy
+forStrokeHierarchy
+  ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f =
+    foldr' ( g Nothing ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 )
+  where
+
+    insertMaybe :: Maybe Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy
+    insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case
+      PreserveStroke   -> old
+      UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes )
+      DeleteStroke     ->
+        let newStrokes = Map.delete u oldStrokes
+         in case mbPar of
+              Nothing ->
+                Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes
+              Just par ->
+                Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes
+
+
+    g :: Maybe Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy
+    g par ( vis, lock ) u acc =
+      let vis'  = vis && not ( u `Set.member` invisibleLayers )
+          lock' = lock || u `Set.member` lockedLayers
+      in
+        case Map.lookup u ( groups hierarchy0 ) of
+          Nothing ->
+            let
+              meta =
+                StrokeMetadata
+                  { strokeName    = layerNames Map.! u
+                  , strokeVisible = vis'
+                  , strokeLocked  = lock'
+                  }
+            in
+              insertMaybe par u <$> acc <*> f u ( content hierarchy0 Map.! u ) meta
+          Just ds ->
+            foldr' ( g ( Just u ) ( vis', lock' ) ) acc ds
+
+--------------------------------------------------------------------------------
+
+-- | Recursive representation of a stroke hierarchy.
+--
+-- Used for serialisation/deserialisation only.
+type Layers = [ Layer ]
+
+-- | Layer in a recursive representation of a stroke hierarchy.
+--
+-- Used for serialisation/deserialisation only.
+data Layer
+  = StrokeLayer
+      { layerUnique  :: !Unique
+      , layerName    :: !Text
+      , layerVisible :: !Bool
+      , layerLocked  :: !Bool
+      , layerStroke  :: !Stroke
+      }
+  | GroupLayer
+      { layerUnique   :: !Unique
+      , layerName     :: !Text
+      , layerVisible  :: !Bool
+      , layerLocked   :: !Bool
+      , groupChildren :: !Layers
+      }
+  deriving stock Show
+
+strokeHierarchyLayers :: LayerMetadata -> StrokeHierarchy -> Layers
+strokeHierarchyLayers
+  ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } )
+  ( Hierarchy topLevel hierarchy content ) = map go topLevel
+    where
+      go :: Unique -> Layer
+      go layerUnique =
+        let
+          layerName    = layerNames Map.! layerUnique
+          layerVisible = not $ layerUnique `Set.member` invisibleLayers
+          layerLocked  = layerUnique `Set.member` lockedLayers
+        in
+          case Map.lookup layerUnique hierarchy of
+            Nothing ->
+              StrokeLayer
+                { layerUnique, layerName, layerVisible, layerLocked
+                , layerStroke = content Map.! layerUnique
+                }
+            Just cs ->
+              GroupLayer
+                { layerUnique, layerName, layerVisible, layerLocked
+                , groupChildren = map go cs
+                }
+
+layersStrokeHierarchy :: Layers -> ( LayerMetadata, StrokeHierarchy )
+layersStrokeHierarchy lays = ( `State.execState` ( mempty, emptyHierarchy ) ) $ do
+  us <- traverse go lays
+  State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) )
+  where
+    go :: Layer -> State ( LayerMetadata, StrokeHierarchy ) Unique
+    go l = do
+      ( LayerMetadata { layerNames = nms, invisibleLayers = invis, lockedLayers = locked }
+        , oldHierarchy@( Hierarchy _topLevel oldGroups oldStrokes )
+        ) <- State.get
+      let u = layerUnique l
+          newMeta =
+            LayerMetadata
+              { layerNames      = Map.insert u ( layerName l ) nms
+              , invisibleLayers = if layerVisible l then invis else Set.insert u invis
+              , lockedLayers    = if layerLocked l then Set.insert u locked else locked
+              }
+      newHierarchy <-
+        case l of
+          StrokeLayer { layerStroke } ->
+            return $
+              oldHierarchy
+                { content = Map.insert u layerStroke oldStrokes }
+          GroupLayer { groupChildren } -> do
+            us <- traverse go groupChildren
+            return $
+              oldHierarchy { groups = Map.insert u us oldGroups }
+      State.put ( newMeta, newHierarchy )
+      return u
+
+--------------------------------------------------------------------------------

src/metabrushes/MetaBrush/Util.hs

@@ -1,19 +1,8 @@
 module MetaBrush.Util
-  ( traverseMaybe
+  ( Exists(..)
-  , Exists(..)
   )
   where
 
--- containers
-import Data.Sequence
-  ( Seq(..) )
-
---------------------------------------------------------------------------------
-
-traverseMaybe :: Applicative f => ( a -> f ( Maybe b ) ) -> Seq a -> f ( Seq b )
-traverseMaybe _ Empty        = pure Empty
-traverseMaybe f ( a :<| as ) = ( \ case { Nothing -> id; Just b -> ( b :<| ) } ) <$> f a <*> traverseMaybe f as
-
 --------------------------------------------------------------------------------
 
 data Exists c where