mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
1213 lines
51 KiB
Haskell
1213 lines
51 KiB
Haskell
{-# 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.Layer
|
||
( Parent, WithinParent (..) )
|
||
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 :: 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 =
|
||
WidgetFwd
|
||
{ mbPastAction :: !( Maybe ABrushWidgetActionState )
|
||
, changeInPrevCurve :: !Bool
|
||
, pastActionPropagates :: !Bool
|
||
}
|
||
|
||
data WidgetBwd =
|
||
WidgetBwd
|
||
{ mbFuturePropagatingAction :: !( Maybe ABrushWidgetActionState ) }
|
||
|
||
|
||
type WidgetM :: Type -> Type
|
||
type WidgetM = Tardis WidgetBwd WidgetFwd
|
||
|
||
-- | 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, ( _bwd, WidgetFwd { mbPastAction = mbNewAction } ) ) =
|
||
( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd mbPrevAction False False ) ) $
|
||
forStrokeHierarchy
|
||
( layerMetadata documentMetadata )
|
||
( strokeHierarchy documentContent )
|
||
updateStroke
|
||
in mbNewAction <&> \ act ->
|
||
( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
|
||
, act
|
||
)
|
||
where
|
||
|
||
zoom = documentZoom $ documentMetadata
|
||
|
||
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> WidgetM 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 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' }
|
||
| 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 ( 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 ( 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 ( 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 $ ABrushWidgetActionState newAction
|
||
, changeInPrevCurve = True
|
||
, pastActionPropagates = True -- currentPointSelected
|
||
}
|
||
Tardis.sendPast $
|
||
WidgetBwd
|
||
{ mbFuturePropagatingAction =
|
||
--if currentPointSelected
|
||
--then
|
||
Just $ ABrushWidgetActionState 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 ABrushWidgetActionState
|
||
propagatingAct
|
||
| Just a <- mbPastAct
|
||
, pastActionPropagates
|
||
= Just a
|
||
| otherwise
|
||
= mbFutureAct
|
||
in
|
||
if
|
||
| Just ( ABrushWidgetActionState @brushFields'' propAct ) <- propagatingAct
|
||
, Just Refl <- eqT @brushFields @brushFields''
|
||
, 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 $ ABrushWidgetActionState 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
|