metabrush/src/metabrushes/MetaBrush/Action.hs

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

module MetaBrush.Action
  ( -- * Subdividing a stroke
    subdivide
    -- * Selection
  , selectAt, selectRectangle
    -- * Drag
  , dragMoveSelect, dragUpdate
    -- * Translation
  , translateSelection
    -- * Deletion
  , deleteSelected
    -- * Brush widget actions
  , BrushWidgetActionState(..)
  , 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 qualified Data.List.NonEmpty as NE
import Data.Maybe
  ( fromMaybe, isNothing, listToMaybe )
import Data.Ratio
import Data.Semigroup
  ( Arg(..), Min(..) )
import Data.Traversable
  ( for )

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

-- containers
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' )

-- groups
import Data.Group
  ( invert )

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

-- 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 )

--------------------------------------------------------------------------------
-- 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 :: Unique -> Stroke -> StrokeMetadata
                    -> State
                          ( Maybe Subdivision )
                          UpdateStroke
    subdivideStroke 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 :: Unique -> Stroke -> StrokeMetadata -> Except ( Unique, PointIndex ) UpdateStroke
    computeSelected 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 :: Unique -> Stroke -> StrokeMetadata -> Except DragMoveSelect UpdateStroke
    dragSelect 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 :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    selectRect 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 :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    updateStroke 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, Set 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 :: Unique -> Stroke -> StrokeMetadata -> Writer ( StrokePoints, Set Unique ) UpdateStroke
    updateStroke 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, Set.singleton u )
                return DeleteStroke
              Just spline' -> do
                Writer.tell ( StrokePoints $ Map.singleton u delPts, Set.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 :: Unique -> Stroke -> StrokeMetadata -> Writer StrokePoints UpdateStroke
    updateStroke 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 BrushWidgetActionState
  = BrushWidgetActionState
  { brushWidgetAction       :: !Brush.WidgetAction
  , brushWidgetStrokeUnique :: !Unique
  , brushWidgetPointIndex   :: !PointIndex
  , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
  }
  deriving stock ( Eq, Show )

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

    zoom = documentZoom $ documentMetadata

    updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
    updateStroke u stroke@( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline _clo ( Record pointFields ) } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
      | strokeVisible
      , not strokeLocked
        -- If we have already started a widget action, only continue an action
        -- for the stroke with the correct unique.
      , case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
        -- Don't touch strokes without brushes.
      , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
      = case intersect @pointFields @brushFields of
          Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do
            let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush )
                toBrushParams = embedUsedParams . ptParamsToUsedParams
                updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' )
            spline' <-
              bitraverseSpline
                ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u )
                ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
                oldSpline
            ( mbAct, _ ) <- State.get
            case mbAct of
              Nothing -> return PreserveStroke
              Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
      | otherwise
      = return PreserveStroke

    updateSplineCurve
      :: forall clo' pointParams brushFields
      .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
      => PointData pointParams
      -> NamedBrush brushFields
      -> ( pointParams -> Record brushFields )
      -> ( Record brushFields -> pointParams -> pointParams )
      -> Unique
      -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
      -> State ( Maybe BrushWidgetActionState, Bool )
            ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) )
    updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do
      ( mbAct, prevCurveAct ) <- State.get
      -- We can only perform a brush widget update if:
      --   - we aren't already updating another point,
      --   - either:
      --      - we are starting a new operation, or
      --      - we are continuing an operation, and we have the right curve index
      let canAct
            | isNothing mbAct
            = case mbPrevAction of
                Just prevAct -> case ssplineType @clo' of
                  SClosed -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
                  SOpen   -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
                Nothing -> True
            | otherwise
            = False
      if canAct
      then do
        case curve of
          line@( LineTo sp1 dat ) -> do
            sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
            pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
          bez2@( Bezier2To sp1 sp2 dat ) -> do
            sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
            sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
            pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
          bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
            sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
            sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
            sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
            pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
      else do
        State.put ( mbAct, False )
        let curve' = if prevCurveAct
                     then curve { curveData = invalidateCache $ curveData curve }
                     else curve
        return curve'
      where
        crvIx = curveIndex ( curveData curve )

    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
      .  NamedBrush brushFields
      -> ( pointParams -> Record brushFields )
      -> ( Record brushFields -> pointParams -> pointParams )
      -> Unique -> PointIndex
      -> PointData pointParams
      -> State ( Maybe BrushWidgetActionState, Bool )
          ( PointData pointParams )
    updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
      let
        currentBrushParams :: Record brushFields
        currentBrushParams = toBrushParams ( brushParams pt )
        brushWidgetElts :: Brush.WidgetElements
        brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
        newBrushWidgetAction :: Maybe BrushWidgetActionState
        ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
          -- Continue the current brush widget action.
          Just prevAction@( BrushWidgetActionState
                            { brushWidgetPointBeingMoved = oldPt
                            , brushWidgetPointIndex = j'
                            , brushWidgetAction = act }) ->
            if j /= j'
              -- If we have already started a widget action, only continue an action
              -- at the point with the correct index in the stroke.
            then ( Nothing, currentBrushParams )
            else
              let newPt = pointCoords pt --> c
                  newParams =
                    Brush.widgetUpdate ( brushWidget brush ) act
                      ( oldPt, newPt )
                      currentBrushParams
              in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
          Nothing ->
            -- See if we can start a new brush widget action.
            case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
              Just cp ->
                let newAction =
                      BrushWidgetActionState
                        { brushWidgetPointBeingMoved = cp
                        , brushWidgetStrokeUnique = uniq
                        , brushWidgetPointIndex = j
                        , brushWidgetAction = case brushWidget brush of
                            Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
                            Brush.RotatableRectangleWidget ->
                              if pressingCtrl
                              then Brush.RotateAction
                              else Brush.ScaleAction Brush.ScaleXY
                        }
                in ( Just newAction, currentBrushParams )
              Nothing -> ( Nothing, currentBrushParams )
                -- TODO: handle clicking on an edge.
                -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
                --   Just ln -> error "todo"
                --   Nothing -> Nothing

      case newBrushWidgetAction of
        Just a -> State.put ( Just a, True )
        _      -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
      pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )