fixes to brush widget UI

This commit is contained in:
sheaf 2024-05-25 17:04:08 +02:00
parent 77a36e1f0b
commit 300fbf92c0
3 changed files with 191 additions and 156 deletions

View file

@ -8,7 +8,7 @@ import Control.Monad
import Control.Monad.ST
( RealWorld )
import Data.Foldable
( for_, sequenceA_ )
( for_ )
import Data.Int
( Int32 )
import Data.List
@ -106,6 +106,8 @@ import Math.Linear
-- MetaBrush
import MetaBrush.Asset.WindowIcons
( drawClose )
import qualified MetaBrush.Brush.Widget as Brush
( describeWidgetAction )
import MetaBrush.Context
( UIElements(..), Variables(..)
, Modifier(..), modifierKey
@ -128,6 +130,7 @@ import MetaBrush.Document.Selection
, UpdateInfo(..)
, deleteSelected
, dragUpdate, pressingControl
, BrushWidgetActionState(..)
, applyBrushWidgetAction
)
import MetaBrush.Document.Serialise
@ -135,7 +138,7 @@ import MetaBrush.Document.Serialise
import MetaBrush.Document.SubdivideStroke
( subdivide )
import MetaBrush.Document.Update
( activeDocument, withActiveDocument
( activeDocument
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
, modifyingCurrentDocument
, updateUIAction, updateHistoryState
@ -787,27 +790,26 @@ instance HandleAction MouseMove where
mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
case tool of
Pen
| Just pp <- mbPartialPath
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
-> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
pure Don'tModifyDoc
| BrushMode <- mode
-- Pen tool in brush mode: modify brush parameters through brush widget.
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
case mbHoldAction of
Just ( BrushWidgetAction { brushWidgetAction } ) ->
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction) doc of
Nothing ->
pure Don'tModifyDoc
Just ( widgetAction, newDocument ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
let changeText :: Text
changeText = "Update brush parameters"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
_ -> pure Don'tModifyDoc
_ -> pure Don'tModifyDoc
if
| Pen <- tool
, Just pp <- mbPartialPath
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
-> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
pure Don'tModifyDoc
-- In brush mode: modify brush parameters through brush widget.
| BrushMode <- mode
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
case mbHoldAction of
Just ( BrushWidgetAction { brushWidgetAction } ) ->
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
Nothing ->
pure Don'tModifyDoc
Just ( widgetAction, newDocument ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
_ -> pure Don'tModifyDoc
| otherwise
-> pure Don'tModifyDoc
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
for_ mbDoc \doc ->
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
@ -863,38 +865,35 @@ instance HandleAction MouseClick where
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| PathMode <- mode
, Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
ClickedOnSelected ->
case mode of
PathMode ->
case tool of
Selection ->
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
ClickedOnSelected ->
pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
Pen ->
case mode of
-- Pen tool in path mode: start or continue a drawing operation.
PathMode -> do
Pen -> do
-- Pen tool in path mode: start or continue a drawing operation.
mbPartialPath <- STM.readTVar partialPathTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of
@ -922,24 +921,23 @@ instance HandleAction MouseClick where
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
BrushMode -> do
-- Brush mode: modify brush parameters through brush widget.
mbAction <- STM.readTVar mouseHoldTVar
let mbPrevWidgetAction = case mbAction of
Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction
_ -> Nothing
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
Just ( actionState@( BrushWidgetActionState { brushWidgetAction = act } ), newDocument ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
let changeText :: Text
changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
_ ->
pure Don'tModifyDoc
-- Pen tool in brush mode: modify brush parameters through brush widget.
BrushMode -> do
mbAction <- STM.readTVar mouseHoldTVar
let mbPrevWidgetAction = case mbAction of
Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction
_ -> Nothing
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
Nothing ->
pure Don'tModifyDoc
Just ( widgetAction, newDocument ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
let changeText :: Text
changeText = "Update brush parameters"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
MetaMode -> pure Don'tModifyDoc
_ -> pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
@ -1178,6 +1176,20 @@ instance HandleAction MouseRelease where
BrushMode -> do
STM.writeTVar mouseHoldTVar Nothing
pure Don'tModifyDoc
{-
mbHoldAction <- STM.readTVar mouseHoldTVar
case mbHoldAction of
Just ( BrushWidgetAction { brushWidgetAction } ) ->
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
Just ( BrushWidgetActionState { brushWidgetAction = act }, newDocument ) -> do
STM.writeTVar mouseHoldTVar Nothing
let changeText :: Text
changeText = "Update brush parameters (" <> Brush.describeWidgetAction act <> ")"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
_ ->
pure Don'tModifyDoc
_ -> pure Don'tModifyDoc
-}
MetaMode ->
pure Don'tModifyDoc

View file

@ -15,7 +15,7 @@ module MetaBrush.Document.Selection
-- base
import Control.Monad
( guard )
( guard, unless )
import Control.Monad.ST
( RealWorld )
import Data.Functor
@ -23,7 +23,7 @@ import Data.Functor
import Data.Functor.Identity
( runIdentity )
import Data.Maybe
( catMaybes, listToMaybe )
( catMaybes, isNothing, listToMaybe )
import Data.Monoid
( Sum(..) )
import Data.Semigroup
@ -70,7 +70,7 @@ import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Maybe
( MaybeT(..) )
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.State.Strict as State
( StateT(..), State
, evalState, evalStateT, runState
, get, put, modify'
@ -845,6 +845,7 @@ data BrushWidgetActionState
= BrushWidgetActionState
{ brushWidgetAction :: !Brush.WidgetAction
, brushWidgetStrokeUnique :: !Unique
, brushWidgetCurveIndex :: !Int
, brushWidgetPointIndex :: !Int
, brushWidgetPointBeingMoved :: !( T ( 2 ) )
}
@ -860,24 +861,21 @@ instance Semigroup BrushWidgetActionState where
applyBrushWidgetAction :: Bool -> 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document )
applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
let
res :: Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Document
res = do
newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
Tardis.getPast >>= Tardis.sendPast
pure newDoc
in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) $ res of
( newDoc, ( _, Just brushWidgetAction ) )
res :: State ( Maybe BrushWidgetActionState ) Document
res = ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
in case ( `runState` Nothing ) res of
( newDoc, Just brushWidgetAction )
-> Just ( brushWidgetAction, newDoc )
_ -> Nothing
where
updateStrokeHierarchy :: StrokeHierarchy -> ( Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) ) StrokeHierarchy
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe BrushWidgetActionState ) StrokeHierarchy
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
newContents <- traverse updateStrokeHierarchy groupContents
pure ( StrokeGroup { groupContents = newContents, .. } )
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
updateStroke :: Stroke -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Stroke
updateStroke :: Stroke -> State ( Maybe BrushWidgetActionState ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) =
case strokeBrush of
-- Don't touch strokes without brushes.
@ -906,12 +904,11 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
-> ( Record brushFields -> pointParams -> pointParams )
-> Unique
-> StrokeSpline clo pointParams
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
( StrokeSpline clo pointParams )
-> State ( Maybe BrushWidgetActionState ) ( StrokeSpline clo pointParams )
updateSpline brush toBrushParams updatePointParams uniq oldSpline =
ibitraverseSpline
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
( updateSplinePoint brush toBrushParams updatePointParams uniq 0 )
( updateSplinePoint brush toBrushParams updatePointParams uniq 0 0 )
oldSpline
updateSplineCurve
@ -923,91 +920,106 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
-> ( Record brushFields -> pointParams -> pointParams )
-> Unique -> Int
-> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
-> State ( Maybe BrushWidgetActionState )
( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) )
updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve
-- If we have already started a widget action, only continue an action
-- at the point with the correct index in the stroke.
| case mbPrevAction of { Just act -> brushWidgetPointIndex act /= i ; Nothing -> False }
= pure curve
| case mbPrevAction of
Just act ->
case ssplineType @clo' of
SClosed -> brushWidgetCurveIndex act /= i && brushWidgetCurveIndex act /= 0
SOpen -> brushWidgetCurveIndex act /= i
Nothing -> False
= case mbPrevAction of
Just act
| abs ( i - brushWidgetCurveIndex act ) <= 1
-> pure $ curve { curveData = invalidateCache $ curveData curve }
_ -> pure curve
| otherwise
, let i' :: Int
j' :: Int -> Int
( i', j' ) = case ssplineType @clo' of { SClosed -> ( 0, const 0 ) ; SOpen -> ( i, id ) }
= case curve of
line@( LineTo sp1 _ ) -> do
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp1
pure ( line { curveEnd = sp1' } )
bez2@( Bezier2To sp1 sp2 _ ) -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp2
pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp2
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp3
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
line@( LineTo sp1 dat ) -> do
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i' ( j' 1 ) ) sp1
pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
bez2@( Bezier2To sp1 sp2 dat ) -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 2 ) ) sp2
pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 2 sp2
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 3 ) ) sp3
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
inSelectionRange :: 2 -> T ( 2 ) -> Bool
inSelectionRange p cp =
squaredNorm ( c --> ( cp p ) :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
lineInSelectionRange :: 2 -> Segment ( T ( 2 ) ) -> Bool
lineInSelectionRange p seg
= case closestPointOnSegment @( T ( 2 ) ) c ( ( \ q -> ( q p ) ) <$> seg ) of
( _, q ) -> squaredNorm ( c --> q :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
lineInSelectionRange p seg =
case closestPointOnSegment @( T ( 2 ) ) c ( ( \ q -> ( q p ) ) <$> seg ) of
( _, q ) -> squaredNorm ( c --> q :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
updateSplinePoint
:: forall pointParams brushFields
. NamedBrush brushFields
-> ( pointParams -> Record brushFields )
-> ( Record brushFields -> pointParams -> pointParams )
-> Unique -> Int
-> Unique -> Int -> Int
-> PointData pointParams
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
-> State ( Maybe BrushWidgetActionState )
( PointData pointParams )
updateSplinePoint brush toBrushParams updatePointParams uniq i pt = do
mbPreviousBrushWidgetAction <- Tardis.getPast
case mbPreviousBrushWidgetAction of
-- Already started a brush widget update: don't do anything else.
Just {}
-> pure pt
-- Otherwise, check whether we are updating the brush parameters at this stroke point.
Nothing -> 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, brushWidgetAction = act }) ->
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 = i
, 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
updateSplinePoint brush toBrushParams updatePointParams uniq i 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 ( Just prevAction, 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
, brushWidgetCurveIndex = i
, 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
Tardis.sendFuture newBrushWidgetAction
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
unless ( isNothing newBrushWidgetAction ) $
State.put newBrushWidgetAction
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )

View file

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Brush.Widget
( Widget(..)
, WidgetElements(..)
@ -5,6 +7,7 @@ module MetaBrush.Brush.Widget
, widgetUpdate
, WhatScale(..)
, WidgetAction(..)
, describeWidgetAction
)
where
@ -26,6 +29,10 @@ import Math.Module
, norm
)
-- text
import Data.Text
( Text )
-- metabrushes
import MetaBrush.Records
( Record(..) )
@ -94,6 +101,10 @@ data WidgetAction
--{ windingNumber :: Int }
deriving stock ( Eq, Ord, Show )
describeWidgetAction :: WidgetAction -> Text
describeWidgetAction ( ScaleAction {} ) = "scaling"
describeWidgetAction RotateAction = "rotation"
-- | Given an UI action (moving a widget control element),
-- how should we update the brush parameters?
widgetUpdate :: Widget flds
@ -121,9 +132,9 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
-> MkR oldFlds
| otherwise
->
let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt )
θ' = nearestAngle θ θ1
in MkR $ 3 w h θ'
let θ1 = atan2 ( oldPt × newPt ) ( oldPt ^.^ newPt )
θ' = θ + nearestAngle 0 θ1
in MkR ( 3 w h θ' )
nearestAngle :: Double -> Double -> Double
nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )