hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +00:00
Code Issues Actions Projects Releases Wiki Activity
metabrush/src/metabrushes/MetaBrush/Action.hs

1055 lines
45 KiB
Haskell
Raw Normal View History

Refactors in preparation for stroke hierarchy
2024-09-27 15:21:24 +00:00
{-# 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 Data.Foldable
( for_, traverse_ )
import Data.Functor
( (<&>) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
( fromMaybe, isNothing, listToMaybe )
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 )
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
-- 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 $
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 ( PointData brushParams )
-> Writer [ ( Curve Open () (), Double ) ]
( Seq ( Curve Open CurveData ( PointData brushParams ) ) )
subdivideCurve offset sp0 crv =
case crv of
LineTo ( NextPoint sp1 ) 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
Writer.tell [ ( stripData crv, t ) ]
let
subdiv :: PointData brushParams
subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
return $
LineTo ( NextPoint subdiv ) ( invalidateCache dat )
Seq.:<| LineTo ( NextPoint sp1 ) ( invalidateCache dat )
Seq.:<| Seq.Empty
else return $ Seq.singleton crv
Bezier2To sp1 ( NextPoint sp2 ) 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
Writer.tell [ ( stripData crv, t ) ]
let
bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else return $ Seq.singleton crv
Bezier3To sp1 sp2 ( NextPoint sp3 ) 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
Writer.tell [ ( stripData crv, t ) ]
let
bez_start, bez_end :: Curve Open CurveData ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else
return $ Seq.singleton crv
--------------------------------------------------------------------------------
-- 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 ( 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 ( 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 ( 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 @( 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 ( PointData brushParams )
-> State ( Set PointIndex, Bool )
( Curve clo' CurveData ( 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
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
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
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 ( PointData brushParams )
-> Writer ( Set PointIndex )
( WitherResult hasStart clo' CurveData ( 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 ( PointData pointParams )
-> Writer ( Set PointIndex )
( Curve Open CurveData ( 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
-> Quadratic.Bezier ( PointData pointParams )
-> Curve Open CurveData ( 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
-> Cubic.Bezier ( PointData pointParams )
-> Curve Open CurveData ( 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 ( PointData pointParams )
-> State ( Maybe BrushWidgetActionState, Bool )
( Curve clo' CurveData ( 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 )
Reference in a new issue Copy permalink