mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
fixes to brush widget UI
This commit is contained in:
sheaf
parent
77a36e1f0b
commit
300fbf92c0
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
Loading…
Reference in a new issue