metabrush/src/metabrushes/MetaBrush/Action.hs

{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}

module MetaBrush.Action
  ( -- * Subdividing a stroke
    subdivide
    -- * Selection
  , selectAt, selectRectangle
    -- * Drag
  , dragMoveSelect, dragUpdate
    -- * Translation
  , translateSelection
    -- * Deletion
  , deleteSelected
    -- * Brush widget actions
  , BrushWidgetActionState(..)
  , ABrushWidgetActionState(..)
  , applyBrushWidgetAction
  ) where

-- base
import Control.Arrow
  ( second )
import Control.Monad
  ( guard, when )
import Control.Monad.ST
  ( RealWorld )
import Data.Foldable
  ( for_, traverse_ )
import Data.Functor
  ( (<&>) )
import Data.Kind
  ( Type )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
  ( fromMaybe, isNothing, listToMaybe )
import Data.Ratio
import Data.Semigroup
  ( Arg(..), Min(..) )
import Data.Traversable
  ( for )
import Data.Type.Equality
  ( (:~:)(..) )
import Data.Typeable
  ( Typeable, eqT )
import GHC.TypeLits
  ( Symbol )

-- acts
import Data.Act
  ( Act((•)), Torsor((-->)) )

-- containers
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
import Data.Sequence
  ( Seq )
import qualified Data.Sequence as Seq
import Data.Set
  ( Set )
import qualified Data.Set as Set

-- generic-lens
import Data.Generics.Product.Fields
  ( field, field' )

-- groups
import Data.Group
  ( invert )

-- lens
import Control.Lens
  ( set, over )

-- tardis
import Control.Monad.Tardis
  ( Tardis )
import qualified Control.Monad.Tardis as Tardis

-- transformers
import Control.Monad.Trans.Except
  ( Except )
import qualified Control.Monad.Trans.Except as Except
import Control.Monad.Trans.State.Strict
  ( State, StateT )
import qualified Control.Monad.Trans.State.Strict as State
import Control.Monad.Trans.Writer.CPS
  ( Writer )
import qualified Control.Monad.Trans.Writer.CPS as Writer
import Control.Monad.Trans.Class
  ( lift )

-- brush-strokes
import qualified Math.Bezier.Cubic as Cubic
import qualified Math.Bezier.Quadratic as Quadratic
import Math.Bezier.Spline
import Math.Bezier.Stroke
  ( invalidateCache )
import Math.Module
  ( lerp, quadrance, closestPointOnSegment
  , squaredNorm
  )
import Math.Linear
  ( Segment(..), ℝ(..), T(..) )

-- MetaBrush
import MetaBrush.Brush
import qualified MetaBrush.Brush.Widget as Brush
import MetaBrush.Document
import MetaBrush.Document.Diff
import MetaBrush.Hover
  ( inPointClickRange )
import MetaBrush.Records
import MetaBrush.Stroke
import MetaBrush.Unique
  ( Unique )
import MetaBrush.Layer (Parent, WithinParent (..))

--------------------------------------------------------------------------------
-- Subdivision.

-- | Subdivide a path at the given center, provided a path indeed lies there.
subdivide :: ℝ 2 -> Document -> Maybe ( Document, Subdivision )
subdivide c doc@( Document { documentMetadata, documentContent }) =
  let
    updatedStrokes :: StrokeHierarchy
    mbSubdivStroke :: Maybe Subdivision
    ( updatedStrokes, mbSubdivStroke )
      = ( `State.runState` Nothing )
      $ forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          subdivideStroke
  in mbSubdivStroke <&> \ subdiv ->
       ( set ( field' @"documentContent"  . field' @"strokeHierarchy" ) updatedStrokes
       . set ( field' @"documentMetadata" . field' @"selectedPoints"  ) mempty
       $ doc
       , subdiv )
  where

    Zoom { zoomFactor } = documentZoom documentMetadata

    stripData :: Curve Open crvData ( PointData ptData ) -> Curve Open () ()
    stripData = bimapCurve ( \ _ ->  () ) ( \ _ _ -> () )

    subdivideStroke :: WithinParent Unique -> Stroke -> StrokeMetadata
                    -> State
                          ( Maybe Subdivision )
                          UpdateStroke
    subdivideStroke ( WithinParent _ u ) stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
      mbPrevSubdivision <- State.get
      let ( curves', subdivs ) =
              Writer.runWriter $
                ( `State.evalStateT` Nothing ) $
                bifoldSpline @Open
                  ( subdivideCurve ( V2 0 0 ) )
                  ( const $ pure Seq.Empty )
                  ( adjustSplineType @Open strokeSpline )
      if | strokeVisible
         , not strokeLocked
         , Nothing <- mbPrevSubdivision
         , Just nonEmptySubdivs <- NE.nonEmpty subdivs
         -> do State.put $ Just $ Subdivision u nonEmptySubdivs
               let spline' = adjustSplineType @clo
                           $ strokeSpline { splineStart = splineStart strokeSpline
                                          , splineCurves = OpenCurves curves' }
               return $ UpdateStrokeTo stroke0 { strokeSpline = spline' }
         | otherwise
         -> return PreserveStroke

      where
        -- Note that if the user clicks on a point of self-intersection,
        -- the code below will subdivide the curve on both branches.
        -- This seems desirable.
        subdivideCurve
          :: T ( ℝ 2 )
          -> PointData brushParams
          -> Curve Open ( CurveData RealWorld ) ( PointData brushParams )
          -> StateT ( Maybe Rational )
              ( Writer [ ( Curve Open () (), Double ) ] )
              ( Seq ( Curve Open ( CurveData RealWorld ) ( PointData brushParams ) ) )
        subdivideCurve offset sp0 crv = do
          mbPrevCrvIx <- State.get
          let i = curveIndex ( curveData crv )
              i' = case mbPrevCrvIx of { Nothing -> i - 1
                                       ; Just i0 -> fareySum i0 i }
          State.put ( Just i )
          case crv of
            LineTo ( NextPoint sp1 ) ( CurveData _ dat ) -> do
              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 )
              if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
              then do
                lift $ Writer.tell [ ( stripData crv, t ) ]
                let
                  subdiv :: PointData brushParams
                  subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
                return $
                          LineTo ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
                  Seq.:<| LineTo ( NextPoint sp1    ) ( CurveData i  $ invalidateCache dat )
                  Seq.:<| Seq.Empty
              else return $ Seq.singleton crv
            Bezier2To sp1 ( NextPoint sp2 ) ( CurveData _ dat ) -> do
              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 )
              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
                    lift $ Writer.tell [ ( stripData crv, t ) ]
                    let
                      bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
                      bez_start = Bezier2To q1 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
                      bez_end   = Bezier2To r1 ( NextPoint sp2    ) ( CurveData i  $ invalidateCache dat )
                    return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
              else return $ Seq.singleton crv
            Bezier3To sp1 sp2 ( NextPoint sp3 ) ( CurveData _ dat ) -> do
              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 )
              if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
              then do
                case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
                  ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
                    lift $ Writer.tell [ ( stripData crv, t ) ]
                    let
                      bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
                      bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
                      bez_end   = Bezier3To r1 r2 ( NextPoint sp3    ) ( CurveData i  $ invalidateCache dat )
                    return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
              else
                return $ Seq.singleton crv

-- | Stroke subdivision is the key reason why we index curves with 'Rational'
-- rather than 'Integer'.
fareySum :: Rational -> Rational -> Rational
fareySum a b = ( numerator a + numerator b )
             % ( denominator a + denominator b )

--------------------------------------------------------------------------------
-- Selection.

-- | Updates the selection on a single-click selection or deselection event.
selectAt :: SelectionMode -> ℝ 2 -> Document -> Maybe ( Document, StrokePoints )
selectAt selMode c doc@( Document { documentContent, documentMetadata } ) =
  let mbSel =
        Except.runExcept $
          forStrokeHierarchy
            ( layerMetadata documentMetadata )
            ( strokeHierarchy documentContent )
            computeSelected
      selPts = case mbSel of
        Left ( u, i ) -> StrokePoints $ Map.singleton u ( Set.singleton i )
        Right {}      -> mempty
  in if noStrokePoints selPts && selMode /= New
     then Nothing
     else
      let doc' =
            over ( field' @"documentMetadata" . field' @"selectedPoints" )
              ( addOrRemove selMode selPts )
              doc
      in Just ( doc', selPts )
  where
    Zoom { zoomFactor } = documentZoom documentMetadata

    computeSelected :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
    computeSelected ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
      when ( strokeVisible ) $
        Except.withExcept ( strokeUnique , ) $
          bifoldSpline
            ( \ _ -> selectSplineCurve )
            ( selectSplinePoint FirstPoint )
            strokeSpline
      return PreserveStroke

    selectSplineCurve :: SplineTypeI clo
                      => Curve clo ( CurveData RealWorld ) ( PointData ptData )
                      -> Except PointIndex ()
    selectSplineCurve = \case
      LineTo p1 ( CurveData { curveIndex } ) ->
        traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p1
      Bezier2To cp1 p2 ( CurveData { curveIndex } ) -> do
        selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) cp1
        traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p2
      Bezier3To cp1 cp2 p3 ( CurveData { curveIndex } ) -> do
        selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) cp1
        selectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) cp2
        traverse_ ( selectSplinePoint ( PointIndex curveIndex PathPoint ) ) p3

    selectSplinePoint :: PointIndex -> PointData brushParams -> Except PointIndex ()
    selectSplinePoint ptIx pt = do
      let
        selected :: Bool
        selected =
          squaredNorm ( c --> coords pt :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
      when selected $
        Except.throwE ptIx

-- | Checks whether a mouse click can initiate a drag move event.
dragMoveSelect :: ℝ 2 -> Document -> Maybe DragMoveSelect
dragMoveSelect c ( Document { documentContent, documentMetadata } ) =
  ( \case { Left drag -> Just drag; Right {} -> Nothing } ) $
  Except.runExcept $
    forStrokeHierarchy
      ( layerMetadata documentMetadata )
      ( strokeHierarchy documentContent )
      dragSelect

  where
    Zoom { zoomFactor } = documentZoom documentMetadata

    inSelectionRange :: ℝ 2 -> Bool
    inSelectionRange p =
      squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16

    dragSelect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
    dragSelect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
      when ( strokeVisible && not strokeLocked ) $
        ibifoldSpline
          ( dragSelectSplineCurve strokeUnique ( splineStart strokeSpline ) )
          ( dragSelectSplinePoint strokeUnique FirstPoint )
          strokeSpline
      return PreserveStroke

    dragSelectSplineCurve
      :: forall clo' brushParams
      .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
      => Unique
      -> PointData brushParams
      -> Int
      -> PointData brushParams -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
      -> Except DragMoveSelect ()
    dragSelectSplineCurve uniq start i sp0 = \case
      LineTo sp1 ( CurveData { curveIndex } ) -> do
        -- Check endpoints first.
        traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp1
        let
          mbCurveDrag :: Maybe DragMoveSelect
          mbCurveDrag = do
            let
              t :: Double
              p :: ℝ 2
              ( t, p ) =
                closestPointOnSegment @( T ( ℝ 2 ) )
                  c
                  ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
            guard ( inSelectionRange p )
            pure $
              ClickedOnCurve
                { dragStrokeUnique   = uniq
                , dragCurve          = curveIndex
                , dragCurveIndex     = i
                , dragCurveParameter = t
                }
        for_ mbCurveDrag Except.throwE
      Bezier2To sp1 sp2 ( CurveData { curveIndex } ) -> do
        -- Check endpoints first.
        dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) sp1
        traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp2
        let
          mbCurveDrag :: Maybe DragMoveSelect
          mbCurveDrag = do
            let
              bez :: Quadratic.Bezier ( ℝ 2 )
              bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
              sq_d :: Double
              t :: Double
              Min ( Arg sq_d (t, _) ) =
                Quadratic.closestPoint @( T ( ℝ 2 ) ) bez c
            guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
            pure $
              ClickedOnCurve
                { dragStrokeUnique   = uniq
                , dragCurve          = curveIndex
                , dragCurveIndex     = i
                , dragCurveParameter = t
                }
        for_ mbCurveDrag Except.throwE
      Bezier3To sp1 sp2 sp3 ( CurveData { curveIndex } ) -> do
        -- Check endpoints first.
        dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) sp1
        dragSelectSplinePoint uniq ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) sp2
        traverse_ ( dragSelectSplinePoint uniq ( PointIndex curveIndex PathPoint ) ) sp3
        let
          mbCurveDrag :: Maybe DragMoveSelect
          mbCurveDrag = do
            let
              bez :: Cubic.Bezier ( ℝ 2 )
              bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
              sq_d :: Double
              t :: Double
              Min ( Arg sq_d (t, _) ) =
                Cubic.closestPoint @( T ( ℝ 2 ) ) bez c
            guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
            pure $
              ClickedOnCurve
                { dragStrokeUnique   = uniq
                , dragCurve          = curveIndex
                , dragCurveIndex     = i
                , dragCurveParameter = t
                }
        for_ mbCurveDrag Except.throwE

    dragSelectSplinePoint :: Unique -> PointIndex -> PointData brushParams -> Except DragMoveSelect ()
    dragSelectSplinePoint u ptIx pt =
      when ( inSelectionRange ( coords pt ) ) do
      let
        drag :: DragMoveSelect
        drag = ClickedOnPoint
          { dragPoint = ( u, ptIx )
          , dragPointWasSelected =
              elemStrokePoint u ptIx ( selectedPoints documentMetadata )
          }
      Except.throwE drag


addOrRemove :: SelectionMode
            -> StrokePoints -- ^ items to add or remove
            -> StrokePoints -- ^ base collection
            -> StrokePoints
addOrRemove selMode new old =
  case selMode of
    New      -> new
    Add      -> old <> new
    Subtract -> old `differenceStrokePoints` new

-- | Updates the selected objects on a rectangular selection event.
selectRectangle :: SelectionMode -> ℝ 2 -> ℝ 2 -> Document -> Maybe ( Document, StrokePoints )
selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) doc@( Document { documentContent, documentMetadata } ) =
  let
    selPts =
      Writer.execWriter $
        forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          selectRect
  in if noStrokePoints selPts && selMode /= New
     then Nothing
     else
      let doc' = over ( field' @"documentMetadata" . field' @"selectedPoints" )
                      ( addOrRemove selMode selPts )
                      doc
      in Just ( doc', selPts )

  where

    xMin, xMax, yMin, yMax :: Double
    ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
    ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )

    selectRect :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    selectRect ( WithinParent _ strokeUnique ) ( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible } ) = do
      when strokeVisible $
        Writer.mapWriter ( second $ \ is -> StrokePoints ( Map.singleton strokeUnique is ) ) $
          bifoldSpline
            ( \ _ -> selectRectSplineCurve )
            ( selectRectSplinePoint FirstPoint )
            strokeSpline
      return PreserveStroke

    selectRectSplineCurve :: SplineTypeI clo
                          => Curve clo ( CurveData RealWorld ) ( PointData ptData )
                          -> Writer ( Set PointIndex ) ()
    selectRectSplineCurve = \case
      LineTo p1 ( CurveData { curveIndex } ) ->
        traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p1
      Bezier2To cp1 p2 ( CurveData { curveIndex } ) -> do
        selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez2Cp ) ) cp1
        traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p2
      Bezier3To cp1 cp2 p3 ( CurveData { curveIndex } ) -> do
        selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp1 ) ) cp1
        selectRectSplinePoint ( PointIndex curveIndex ( ControlPoint Bez3Cp2 ) ) cp2
        traverse_ ( selectRectSplinePoint ( PointIndex curveIndex PathPoint ) ) p3

    selectRectSplinePoint :: PointIndex -> PointData brushParams -> Writer ( Set PointIndex ) ()
    selectRectSplinePoint ptIx pt = do
      let
        x, y :: Double
        ℝ2 x y = coords pt
        selected :: Bool
        selected =
          x >= xMin && x <= xMax && y >= yMin && y <= yMax
      when selected $
        Writer.tell $ Set.singleton ptIx

-- | Translate all selected points by the given vector.
--
-- Returns the updated document, together with info about how many points were translated.
translateSelection :: T ( ℝ 2 ) -> Document -> Maybe ( Document, StrokePoints )
translateSelection t doc@( Document { documentContent, documentMetadata } ) =
  let
    ( newStrokes, movedPts ) =
      Writer.runWriter $
        forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          updateStroke
  in
    if noStrokePoints movedPts
    then Nothing
    else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
              , movedPts
              )
  where

    selPts :: StrokePoints
    selPts = selectedPoints documentMetadata

    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
      let strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
          firstPointSel = FirstPoint `Set.member` strokeSelPts
          ( spline', ( modPts, _ ) ) =
             ( `State.runState` ( mempty, False ) ) $
               bitraverseSpline @_ @_ @( CurveData RealWorld ) @( PointData _ )
                ( \ _ -> updateSplineCurve firstPointSel strokeSelPts )
                ( \ pt -> do { ( NextPoint pt', _ ) <- updatePoint firstPointSel strokeSelPts FirstPoint ( NextPoint pt ) ; return pt' } )
                strokeSpline
      if strokeVisible && not strokeLocked && not ( null modPts )
      then do
        Writer.tell ( StrokePoints $ Map.singleton u modPts )
        return $ UpdateStrokeTo ( stroke { strokeSpline = spline' } )
      else
        return PreserveStroke

    updateSplineCurve
      :: forall clo' brushParams
      .  SplineTypeI clo'
      => Bool
      -> Set PointIndex
      -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
      -> State ( Set PointIndex, Bool )
          ( Curve clo' ( CurveData RealWorld ) ( PointData brushParams ) )
    updateSplineCurve startPtSel strokeSelPts = \case
      LineTo p1 dat@( CurveData { curveIndex } ) -> do
        ( _, sel0 ) <- State.get
        ( p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint ) p1
        let
          dat' :: ( CurveData RealWorld )
          dat'
            | sel0 || sel1
            = invalidateCache dat
            | otherwise
            = dat
        State.modify' ( \ ( pts, _ ) -> ( pts, sel1 ) )
        pure $ LineTo p1' dat'
      Bezier2To p1 p2 dat@( CurveData { curveIndex } ) -> do
        ( _, sel0 ) <- State.get
        ( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez2Cp )) ( NextPoint p1 )
        (           p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint )                          p2
        let
          dat' :: ( CurveData RealWorld )
          dat'
            | sel0 || sel1 || sel2
            = invalidateCache dat
            | otherwise
            = dat
        State.modify' ( \ ( pts, _ ) -> ( pts, sel2 ) )
        pure $ Bezier2To p1' p2' dat'
      Bezier3To p1 p2 p3 dat@( CurveData { curveIndex } ) -> do
        ( _, sel0 ) <- State.get
        ( NextPoint p1', sel1 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp1 )) ( NextPoint p1 )
        ( NextPoint p2', sel2 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex ( ControlPoint Bez3Cp2 )) ( NextPoint p2 )
        (           p3', sel3 ) <- updatePoint startPtSel strokeSelPts ( PointIndex curveIndex PathPoint )                           p3
        let
          dat' :: ( CurveData RealWorld )
          dat'
            | sel0 || sel1 || sel2 || sel3
            = invalidateCache dat
            | otherwise
            = dat
        State.modify' ( \ ( pts, _ ) -> ( pts, sel3 ) )
        pure $ Bezier3To p1' p2' p3' dat'

    updatePoint :: forall clo brushParams
                .  SplineTypeI clo
                => Bool
                -> Set PointIndex
                -> PointIndex
                -> NextPoint clo ( PointData brushParams )
                -> State ( Set PointIndex, Bool ) ( NextPoint clo ( PointData brushParams ), Bool )
    updatePoint startPtSel strokeSelPts i nextPt = do
      if i `Set.member` strokeSelPts
      then do
        nextPt' <- for nextPt $ \ pt -> do
          State.modify' ( \ ( pts, _ ) -> ( Set.insert i pts, True ) )
          return $ over _coords ( t • ) pt
        return ( nextPt', True )
      else do
        let endPtSel :: Bool
            endPtSel = case ssplineType @clo of
              SOpen -> False
              SClosed -> case nextPt of
                BackToStart -> startPtSel
        State.modify' ( \ ( pts, _ ) -> ( pts, endPtSel ) )
        return ( nextPt, endPtSel )

-- | Delete the selected points.
--
-- Returns the updated document, together with info about how many points
-- and strokes were deleted.
deleteSelected :: Document -> Maybe ( Document, StrokePoints, Map Unique ( Parent Unique ) )
deleteSelected doc@( Document { documentContent, documentMetadata } ) =
  let
    ( newStrokes, ( delPts, delStrokes ) ) =
      Writer.runWriter $
        forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          updateStroke
  in
    if noStrokePoints delPts
    then Nothing
    else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes $ doc
                  -- NB: not removing metadata about the layer from the LayerMetadata,
                  -- as it might be useful to keep it around if we undo the action.
              , delPts
              , delStrokes
              )
  where

    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Map Unique ( Parent Unique ) ) UpdateStroke
    updateStroke ( WithinParent par u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
      | not strokeVisible || strokeLocked
      = return PreserveStroke
      | otherwise
      = let
          ( mbSpline, delPts ) =
            Writer.runWriter $
              biwitherSpline
               updateSplineCurve
               ( updateSplinePoint FirstPoint )
               oldSpline
        in if null delPts
           then
            return PreserveStroke
           else case mbSpline of
              Nothing -> do
                Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.singleton u par )
                return DeleteStroke
              Just spline' -> do
                Writer.tell ( StrokePoints $ Map.singleton u delPts, Map.empty )
                return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }

      where
        strokeSelPts = fromMaybe Set.empty $ Map.lookup u ( strokePoints $ selectedPoints documentMetadata )

        updateSplinePoint
          :: PointIndex
          -> PointData brushParams
          -> Writer ( Set PointIndex )
                ( Maybe ( PointData brushParams ) )
        updateSplinePoint i pt =
          if i `Set.member` strokeSelPts
          then
            do Writer.tell ( Set.singleton i )
               return Nothing
          else
            return ( Just pt )

        updateSplineCurve
          :: forall clo' hasStart. SplineTypeI clo'
          => CurrentStart hasStart ( PointData brushParams )
          -> Curve clo' ( CurveData RealWorld ) ( PointData brushParams )
          -> Writer ( Set PointIndex )
              ( WitherResult hasStart clo' ( CurveData RealWorld ) ( PointData brushParams ) )
        updateSplineCurve mbPrevPt crv = case crv of

          LineTo p1 ( CurveData { curveIndex } ) ->
            let i = PointIndex curveIndex PathPoint
            in
            case ssplineType @clo' of
              SOpen
                | i `Set.member` strokeSelPts
                -> do
                  Writer.tell ( Set.singleton i )
                  pure Dismiss
                | NextPoint pt <- p1
                , NoStartFound <- mbPrevPt
                -> pure ( UseStartPoint pt Nothing )
              SClosed
                | NoStartFound <- mbPrevPt
                -> pure Dismiss
              _ | CurrentStart wasOrigPt _ <- mbPrevPt
                -> let crv' = if wasOrigPt
                              then crv
                              else crv { curveData = invalidateCache $ curveData crv }
                   in pure $ UseCurve crv'

          Bezier2To _cp1 p2 dat@( CurveData { curveIndex } ) ->
            let i = PointIndex curveIndex PathPoint
                j = PointIndex curveIndex ( ControlPoint Bez2Cp )
            in
            case ssplineType @clo' of
              SOpen
                | i `Set.member` strokeSelPts
                -> do
                  Writer.tell ( Set.fromList [ i, j ] )
                  pure Dismiss
                | NextPoint pt <- p2
                , NoStartFound <- mbPrevPt
                -> do Writer.tell ( Set.singleton j )
                      pure ( UseStartPoint pt Nothing )
              SClosed
                | NoStartFound <- mbPrevPt
                -> do Writer.tell ( Set.singleton j )
                      pure Dismiss
              _ | CurrentStart wasOrigPt _ <- mbPrevPt
                -> if j `Set.member` strokeSelPts
                   then do
                      Writer.tell ( Set.singleton j )
                      pure ( UseCurve ( LineTo p2 ( invalidateCache dat ) ) )
                   else
                      let crv' = if wasOrigPt
                                 then crv
                                 else crv { curveData = invalidateCache $ curveData crv }
                      in pure $ UseCurve crv'

          Bezier3To cp1 cp2 p3 dat@( CurveData { curveIndex } ) ->
            let i  = PointIndex curveIndex PathPoint
                j1 = PointIndex curveIndex ( ControlPoint Bez3Cp1 )
                j2 = PointIndex curveIndex ( ControlPoint Bez3Cp2 )
            in
            case ssplineType @clo' of
              SOpen
                | i `Set.member` strokeSelPts
                -> do
                  Writer.tell ( Set.fromList [ i, j1, j2 ] )
                  pure Dismiss
                | NextPoint pt <- p3
                , NoStartFound <- mbPrevPt
                -> do
                  Writer.tell ( Set.fromList [ j1, j2 ] )
                  pure ( UseStartPoint pt Nothing )
              SClosed
                | NoStartFound <- mbPrevPt
                -> do
                  Writer.tell ( Set.fromList [ j1, j2 ] )
                  pure Dismiss
              _ | CurrentStart wasOrigPt _ <- mbPrevPt
                -> case ( j1 `Set.member` strokeSelPts
                        , j2 `Set.member` strokeSelPts ) of
                  ( False, False ) ->
                    let crv' = if wasOrigPt
                              then crv
                              else crv { curveData = invalidateCache $ curveData crv }
                    in pure $ UseCurve crv'
                  ( False, _ ) -> do
                    Writer.tell ( Set.singleton j2 )
                    pure ( UseCurve $ Bezier2To cp1 p3 ( invalidateCache dat ) )
                  ( _, False ) -> do
                    Writer.tell ( Set.singleton j1 )
                    pure ( UseCurve $ Bezier2To cp2 p3 ( invalidateCache dat ) )
                  _ -> do
                    Writer.tell ( Set.fromList [ j1, j2 ] )
                    pure ( UseCurve $ LineTo p3 ( invalidateCache dat ) )

-- | Perform a drag move action on a document.
dragUpdate :: ℝ 2 -> ℝ 2 -> DragMoveSelect -> Bool -> Document -> Maybe ( Document, StrokePoints )
dragUpdate p0 p ( ClickedOnPoint {} ) _ doc = translateSelection ( p0 --> p ) doc
dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurveParameter } ) alternateMode
  doc@( Document { documentContent, documentMetadata } ) =
  let
    ( newStrokes, movedPts ) =
      Writer.runWriter $
        forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          updateStroke
  in
    if noStrokePoints movedPts
    then Nothing
    else Just ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
              , movedPts
              )
  where

    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    updateStroke ( WithinParent _ u ) stroke@( Stroke { strokeSpline = oldSpline :: StrokeSpline clo pointParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
      | not strokeVisible || strokeLocked || u /= dragStrokeUnique
      = return PreserveStroke
      | otherwise
      = let
          ( spline', movedPts ) =
            Writer.runWriter
              $ fmap ( adjustSplineType @clo )
              $ updateSplineCurves
              $ adjustSplineType @Open oldSpline
        in if null movedPts
           then return PreserveStroke
           else do
              Writer.tell ( StrokePoints $ Map.singleton u movedPts )
              return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }

      where

        updateSplineCurves
          :: StrokeSpline Open pointParams
          -> Writer ( Set PointIndex ) ( StrokeSpline Open pointParams )
        updateSplineCurves spline =
          case splitSplineAt dragCurveIndex spline of
            ( _  , Spline { splineCurves = OpenCurves Seq.Empty } ) -> pure spline
            ( bef, Spline { splineStart, splineCurves = OpenCurves ( curve Seq.:<| next ) } ) -> do
              curve' <- updateCurve ( lastPoint bef ) curve
              pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ curve' Seq.:<| next } )

        updateCurve
          :: PointData pointParams
          -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
          -> Writer ( Set PointIndex )
           ( Curve Open ( CurveData RealWorld ) ( PointData pointParams ) )
        updateCurve sp0 curve = case curve of
          LineTo ( NextPoint sp1 ) dat@( CurveData { curveIndex } ) -> do
            let
              bez2 :: Quadratic.Bezier ( PointData pointParams )
              bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( T pointParams ) ) dragCurveParameter sp0 sp1 ) sp1
            Writer.tell ( Set.singleton ( PointIndex curveIndex PathPoint ) )
            pure $
              if alternateMode
              then quadraticDragCurve dat bez2
              else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 )
          Bezier2To sp1 ( NextPoint sp2 ) dat@( CurveData { curveIndex } )  -> do
            let
              bez2 :: Quadratic.Bezier ( PointData pointParams )
              bez2 = Quadratic.Bezier sp0 sp1 sp2
            if alternateMode
            then do
              Writer.tell $
                Set.fromList
                  [ PointIndex curveIndex PathPoint
                  , PointIndex curveIndex ( ControlPoint Bez2Cp )
                  , PointIndex curveIndex ( ControlPoint Bez3Cp1 )
                  , PointIndex curveIndex ( ControlPoint Bez3Cp2 )
                  ]
              pure $ cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2
            else do
              Writer.tell $
                Set.fromList
                  [ PointIndex curveIndex PathPoint
                  , PointIndex curveIndex ( ControlPoint Bez2Cp )
                  ]
              pure $ quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 )
          Bezier3To sp1 sp2 ( NextPoint sp3 ) dat@( CurveData { curveIndex } ) -> do
            let
              bez3 :: Cubic.Bezier ( PointData pointParams )
              bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
            if alternateMode
            then do
              Writer.tell $
                Set.fromList
                  [ PointIndex curveIndex PathPoint
                  , PointIndex curveIndex ( ControlPoint Bez2Cp )
                  , PointIndex curveIndex ( ControlPoint Bez3Cp1 )
                  , PointIndex curveIndex ( ControlPoint Bez3Cp2 )
                  ]
              pure $ quadraticDragCurve dat
                  ( Quadratic.Bezier
                    sp0
                    ( Cubic.bezier @( DiffPointData ( T pointParams ) ) bez3 dragCurveParameter )
                    sp3
                  )
            else do
              Writer.tell $
                Set.fromList
                  [ PointIndex curveIndex PathPoint
                  , PointIndex curveIndex ( ControlPoint Bez3Cp1 )
                  , PointIndex curveIndex ( ControlPoint Bez3Cp2 )
                  ]
              pure $ cubicDragCurve dat bez3
          where
            quadraticDragCurve
              :: ( CurveData RealWorld )
              -> Quadratic.Bezier ( PointData pointParams )
              -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
            quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
              let
                cp :: ℝ 2
                Quadratic.Bezier { Quadratic.p1 = cp } =
                  Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragCurveParameter p
              in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
            cubicDragCurve
              :: ( CurveData RealWorld )
              -> Cubic.Bezier ( PointData pointParams )
              -> Curve Open ( CurveData RealWorld ) ( PointData pointParams )
            cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
              let
                cp1, cp2 :: ℝ 2
                Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } =
                  Cubic.drag @( T ( ℝ 2 ) )
                    ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
                    dragCurveParameter
                    p
              in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )

--------------------------------------------------------------------------------
-- Brush widget


data ABrushWidgetActionState where
  ABrushWidgetActionState ::
    forall brushFields
    .  ( Show ( Record brushFields ), Typeable brushFields )
    => BrushWidgetActionState brushFields -> ABrushWidgetActionState
deriving stock instance Show ABrushWidgetActionState

type BrushWidgetActionState :: [ Symbol ] -> Type
data BrushWidgetActionState brushFields
  = BrushWidgetActionState
  { brushWidgetAction          :: !Brush.WidgetAction
  , brushWidgetStrokeUnique    :: !Unique
  , brushWidgetPointIndex      :: !PointIndex
  , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
  , brushWidgetPrevParams      :: !( Record brushFields )
  , brushWidgetNewParams       :: !( Maybe ( Record brushFields ) )
  }
deriving stock instance Show ( Record brushFields ) => Show ( BrushWidgetActionState brushFields )
deriving stock instance   Eq ( Record brushFields ) => Eq   ( BrushWidgetActionState brushFields )

data WidgetFwd act =
  WidgetFwd
    { mbPastAction         :: !( Maybe act )
    , changeInPrevCurve    :: !Bool
    , pastActionPropagates :: !Bool
    }

data WidgetBwd act =
  WidgetBwd
    { mbFuturePropagatingAction :: !( Maybe act ) }


type WidgetM :: Type -> Type -> Type
type WidgetM act = Tardis ( WidgetBwd act ) ( WidgetFwd act )

-- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point.
applyBrushWidgetAction :: Bool -> Bool -> ℝ 2 -> Maybe ABrushWidgetActionState -> Document -> Maybe ( Document, ABrushWidgetActionState )
applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
  let
    ( newStrokes, mbAct ) =
      ( `State.runState` Nothing ) $
        forStrokeHierarchy
          ( layerMetadata documentMetadata )
          ( strokeHierarchy documentContent )
          updateStroke
  in mbAct <&> \ act ->
      ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
      , act
      )
  where

    zoom = documentZoom $ documentMetadata

    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe ABrushWidgetActionState ) UpdateStroke
    updateStroke ( WithinParent _ u )
      ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
      ( StrokeMetadata { strokeVisible, strokeLocked } )
      | strokeVisible
      , not strokeLocked
        -- Don't touch strokes without brushes.
      , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
      , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
          <- intersect @pointFields @brushFields
      , Union @pointFields' unionWith
          <- union @pointFields @brushFields
      = do
          let ( res, ( _bwd, WidgetFwd { mbPastAction = mbAction } ) ) =
                ( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd Nothing False False ) ) $ do
                  let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
                      embedUsedParams = updateBrushParams defaultBrushParams
                      toBrushParams = embedUsedParams . ptParamsToUsedParams
                      noUpdatePointParams :: Record pointFields -> Record pointFields'
                      noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
                      updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
                      updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
                  spline' <-
                      bitraverseSpline
                        ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
                        ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
                        oldSpline
                  WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast
                  case mbAct of
                    Nothing -> return PreserveStroke
                    Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
          State.put $ ABrushWidgetActionState <$> mbAction
          return res
      | otherwise
      = return PreserveStroke

    updateSplineCurve
      :: forall clo' pointParams brushFields pointParams'
      .  ( SplineTypeI clo', Traversable ( NextPoint clo' )
         , Typeable brushFields
         , Show ( Record brushFields )
         , Torsor ( T ( Record brushFields ) ) ( Record brushFields )
         )
      => PointData pointParams
      -> NamedBrush brushFields
      -> ( pointParams -> Record brushFields )
      -> ( pointParams -> pointParams' )
      -> ( Record brushFields -> pointParams -> pointParams' )
      -> Unique
      -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
      -> WidgetM ( BrushWidgetActionState brushFields ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
    updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
      WidgetFwd { changeInPrevCurve } <- Tardis.getPast
      -- There are two kinds of brush widget updates:
      --
      --   - Updating the current widget. This can only happen if:
      --     - we aren't already starting a widget operation at another point,
      --     - either:
      --        - we are starting a new operation, or
      --        - we are continuing an operation, and we have the right curve index
      --   - Synchronising an update on other selected points.
      let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq
          updDat :: CurveData RealWorld -> WidgetM ( BrushWidgetActionState brushFields )( CurveData RealWorld )
          updDat dat = do
            WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast
            if newChange
            then return ( invalidateCache dat )
            else do
              let dat' = if changeInPrevCurve then invalidateCache dat else dat
              Tardis.modifyForwards ( \ fwd -> fwd { changeInPrevCurve = False } )
              return dat'
      case curve of
        LineTo sp1 dat -> do
          sp1' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp1
          dat' <- updDat dat
          pure ( LineTo { curveEnd = sp1', curveData = dat' } )
        Bezier2To sp1 sp2 dat -> do
          sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
          sp2' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp2
          dat' <- updDat dat
          pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = dat' } )
        Bezier3To sp1 sp2 sp3 dat -> do
          sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
          sp2' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
          sp3' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp3
          dat' <- updDat dat
          pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = dat' } )
      where
        crvIx = curveIndex ( curveData curve )

    pointIsSelected :: Unique -> PointIndex -> Bool
    pointIsSelected strokeUnique j =
      let strokeSelPts = fromMaybe Set.empty $ Map.lookup strokeUnique ( strokePoints $ selectedPoints documentMetadata )
      in j `Set.member` strokeSelPts

    inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
    inSelectionRange p cp =
      inPointClickRange zoom c ( cp • p )

    lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool
    lineInSelectionRange p seg =
      case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
        ( _, q ) ->
          inPointClickRange zoom c q

    updateSplinePoint
      :: forall pointParams brushFields pointParams'
      .  ( Show ( Record brushFields )
         , Typeable brushFields
         , Torsor ( T ( Record brushFields ) ) ( Record brushFields )
         )
      => NamedBrush brushFields
      -> ( pointParams -> Record brushFields )
      -> ( pointParams -> pointParams' )
      -> ( Record brushFields -> pointParams -> pointParams' )
      -> Unique -> PointIndex
      -> PointData pointParams
      -> WidgetM ( BrushWidgetActionState brushFields ) ( PointData pointParams' )
    updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq j pt = do
      WidgetFwd
        { mbPastAction = mbPastAct
        , pastActionPropagates
        } <- Tardis.getPast
      let
        currentPointSelected = pointIsSelected uniq j
        currentBrushParams :: Record brushFields
        currentBrushParams = toBrushParams ( brushParams pt )

        upd newParams = set ( field @"brushParams" ) ( updatePointParams newParams ( brushParams pt ) ) pt
        noUpd         = set ( field @"brushParams" ) ( noUpdatePointParams $ brushParams pt ) pt

        brushWidgetElts :: Brush.WidgetElements
        brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
      case mbPrevAction of
        Just ( ABrushWidgetActionState @brushFields'
               prevAction@( BrushWidgetActionState
                          { brushWidgetPointBeingMoved = oldPt
                          , brushWidgetStrokeUnique = actionUniq
                          , brushWidgetPointIndex = j'
                          , brushWidgetAction = act } ) ) ->
          if
            | Just Refl <- eqT @brushFields @brushFields'
            , uniq == actionUniq
            , j == j'
            -- Continue the current brush widget action,
            -- but only for the right stroke and only at the point with
            -- the correct index within the stroke.
            -> do
              let
                newPt = pointCoords pt --> c
                newParams =
                  Brush.widgetUpdate ( brushWidget brush ) act
                    ( oldPt, newPt )
                    currentBrushParams
                newAction =
                  prevAction
                    { brushWidgetPointBeingMoved = newPt
                    , brushWidgetPrevParams = currentBrushParams
                    , brushWidgetNewParams = Just newParams
                    }
              Tardis.sendFuture $
                WidgetFwd
                  { mbPastAction         = Just newAction
                  , changeInPrevCurve    = True
                  , pastActionPropagates = True -- currentPointSelected
                  }
              Tardis.sendPast $
                WidgetBwd
                  { mbFuturePropagatingAction =
                    --if currentPointSelected
                    --then
                      Just newAction
                    --else Nothing
                  }
              return $ upd newParams
            | currentPointSelected
            -- Propagate the current brush widget action to other selected points.
            -> do
              ~( WidgetBwd { mbFuturePropagatingAction = mbFutureAct } )
                  <- Tardis.getFuture
              return $
                let
                  propagatingAct :: Maybe ( BrushWidgetActionState brushFields )
                  propagatingAct
                    | Just a <- mbPastAct
                    , pastActionPropagates
                    = Just a
                    | otherwise
                    = mbFutureAct
                in
                  if
                    | Just propAct <- propagatingAct
                    , BrushWidgetActionState
                        { brushWidgetAction = action
                        , brushWidgetPrevParams = params0
                        , brushWidgetNewParams = Just params1 }
                          <- propAct
                    , pointIsSelected uniq j
                    ->
                      let newParams =
                            Brush.widgetUpdateSync
                              pressingAlt
                              ( brushWidget brush ) action
                              ( params0, params1 ) currentBrushParams
                      in upd newParams
                    | otherwise
                    -> noUpd
            | otherwise
            -> return noUpd
        Nothing
          | isNothing mbPastAct ->
          -- See if we can start a new brush widget action.
          case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
            Just cp -> do
              let newAction =
                    BrushWidgetActionState
                      { brushWidgetPointBeingMoved = cp
                      , brushWidgetStrokeUnique = uniq
                      , brushWidgetPointIndex = j
                      , brushWidgetAction = case brushWidget brush of
                          Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
                          Brush.RotatableRectangleWidget ->
                            if pressingCtrl
                            then Brush.RotateAction
                            else Brush.ScaleAction Brush.ScaleXY
                      , brushWidgetPrevParams =
                          currentBrushParams
                      , brushWidgetNewParams =
                          Nothing
                      }
              Tardis.sendFuture $
                WidgetFwd
                  { mbPastAction         = Just newAction
                  , changeInPrevCurve    = False
                  , pastActionPropagates = False
                  }
              return noUpd
            Nothing ->
              return noUpd
              -- TODO: handle clicking on an edge.
              -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
              --   Just ln -> error "todo"
              --   Nothing -> Nothing
        _ -> return noUpd