mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
fixes to brush widget UI
This commit is contained in:
parent
77a36e1f0b
commit
300fbf92c0
|
@ -8,7 +8,7 @@ import Control.Monad
|
||||||
import Control.Monad.ST
|
import Control.Monad.ST
|
||||||
( RealWorld )
|
( RealWorld )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_, sequenceA_ )
|
( for_ )
|
||||||
import Data.Int
|
import Data.Int
|
||||||
( Int32 )
|
( Int32 )
|
||||||
import Data.List
|
import Data.List
|
||||||
|
@ -106,6 +106,8 @@ import Math.Linear
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Asset.WindowIcons
|
import MetaBrush.Asset.WindowIcons
|
||||||
( drawClose )
|
( drawClose )
|
||||||
|
import qualified MetaBrush.Brush.Widget as Brush
|
||||||
|
( describeWidgetAction )
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( UIElements(..), Variables(..)
|
( UIElements(..), Variables(..)
|
||||||
, Modifier(..), modifierKey
|
, Modifier(..), modifierKey
|
||||||
|
@ -128,6 +130,7 @@ import MetaBrush.Document.Selection
|
||||||
, UpdateInfo(..)
|
, UpdateInfo(..)
|
||||||
, deleteSelected
|
, deleteSelected
|
||||||
, dragUpdate, pressingControl
|
, dragUpdate, pressingControl
|
||||||
|
, BrushWidgetActionState(..)
|
||||||
, applyBrushWidgetAction
|
, applyBrushWidgetAction
|
||||||
)
|
)
|
||||||
import MetaBrush.Document.Serialise
|
import MetaBrush.Document.Serialise
|
||||||
|
@ -135,7 +138,7 @@ import MetaBrush.Document.Serialise
|
||||||
import MetaBrush.Document.SubdivideStroke
|
import MetaBrush.Document.SubdivideStroke
|
||||||
( subdivide )
|
( subdivide )
|
||||||
import MetaBrush.Document.Update
|
import MetaBrush.Document.Update
|
||||||
( activeDocument, withActiveDocument
|
( activeDocument
|
||||||
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
|
, DocChange(..), DocumentUpdate(..), PureDocModification(..), DocModification(..)
|
||||||
, modifyingCurrentDocument
|
, modifyingCurrentDocument
|
||||||
, updateUIAction, updateHistoryState
|
, updateUIAction, updateHistoryState
|
||||||
|
@ -787,27 +790,26 @@ instance HandleAction MouseMove where
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
mode <- STM.readTVar modeTVar
|
mode <- STM.readTVar modeTVar
|
||||||
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
|
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
|
||||||
case tool of
|
if
|
||||||
Pen
|
| Pen <- tool
|
||||||
| Just pp <- mbPartialPath
|
, Just pp <- mbPartialPath
|
||||||
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||||||
-> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
-> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
||||||
pure Don'tModifyDoc
|
pure Don'tModifyDoc
|
||||||
| BrushMode <- mode
|
-- In brush mode: modify brush parameters through brush widget.
|
||||||
-- Pen tool in brush mode: modify brush parameters through brush widget.
|
| BrushMode <- mode
|
||||||
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
|
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||||
case mbHoldAction of
|
case mbHoldAction of
|
||||||
Just ( BrushWidgetAction { brushWidgetAction } ) ->
|
Just ( BrushWidgetAction { brushWidgetAction } ) ->
|
||||||
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction) doc of
|
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction ) doc of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
pure Don'tModifyDoc
|
pure Don'tModifyDoc
|
||||||
Just ( widgetAction, newDocument ) -> do
|
Just ( widgetAction, newDocument ) -> do
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
|
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
|
||||||
let changeText :: Text
|
pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange {..} )
|
||||||
changeText = "Update brush parameters"
|
_ -> pure Don'tModifyDoc
|
||||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
| otherwise
|
||||||
_ -> pure Don'tModifyDoc
|
-> pure Don'tModifyDoc
|
||||||
_ -> pure Don'tModifyDoc
|
|
||||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||||
for_ mbDoc \doc ->
|
for_ mbDoc \doc ->
|
||||||
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
||||||
|
@ -863,38 +865,35 @@ instance HandleAction MouseClick where
|
||||||
SingleClick -> do
|
SingleClick -> do
|
||||||
modifiers <- STM.readTVar modifiersTVar
|
modifiers <- STM.readTVar modifiersTVar
|
||||||
tool <- STM.readTVar toolTVar
|
tool <- STM.readTVar toolTVar
|
||||||
|
case mode of
|
||||||
case tool of
|
PathMode ->
|
||||||
-- Selection mode mouse hold:
|
case tool of
|
||||||
--
|
Selection ->
|
||||||
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
|
-- Selection mode mouse hold:
|
||||||
-- - If not holding shift or alt:
|
--
|
||||||
-- - if mouse click selected an object, initiate a drag move,
|
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
|
||||||
-- - otherwise, initiate a rectangular selection.
|
-- - If not holding shift or alt:
|
||||||
Selection ->
|
-- - if mouse click selected an object, initiate a drag move,
|
||||||
case selectionMode modifiers of
|
-- - otherwise, initiate a rectangular selection.
|
||||||
-- Drag move: not holding shift or alt, click has selected something.
|
case selectionMode modifiers of
|
||||||
New
|
-- Drag move: not holding shift or alt, click has selected something.
|
||||||
| PathMode <- mode
|
New
|
||||||
, Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
|
| Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
|
||||||
-> do
|
-> do
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
|
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
|
||||||
case dragMove of
|
case dragMove of
|
||||||
ClickedOnSelected ->
|
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
|
pure Don'tModifyDoc
|
||||||
ClickedOnUnselected ->
|
Pen -> do
|
||||||
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
-- Pen tool in path mode: start or continue a drawing operation.
|
||||||
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
|
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
||||||
case mbPartialPath of
|
case mbPartialPath of
|
||||||
|
@ -922,24 +921,23 @@ instance HandleAction MouseClick where
|
||||||
Just pp -> do
|
Just pp -> do
|
||||||
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||||||
pure Don'tModifyDoc
|
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.
|
_ -> pure Don'tModifyDoc
|
||||||
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
|
|
||||||
|
|
||||||
DoubleClick -> do
|
DoubleClick -> do
|
||||||
tool <- STM.readTVar toolTVar
|
tool <- STM.readTVar toolTVar
|
||||||
|
@ -1178,6 +1176,20 @@ instance HandleAction MouseRelease where
|
||||||
BrushMode -> do
|
BrushMode -> do
|
||||||
STM.writeTVar mouseHoldTVar Nothing
|
STM.writeTVar mouseHoldTVar Nothing
|
||||||
pure Don'tModifyDoc
|
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 ->
|
MetaMode ->
|
||||||
pure Don'tModifyDoc
|
pure Don'tModifyDoc
|
||||||
|
|
|
@ -15,7 +15,7 @@ module MetaBrush.Document.Selection
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard )
|
( guard, unless )
|
||||||
import Control.Monad.ST
|
import Control.Monad.ST
|
||||||
( RealWorld )
|
( RealWorld )
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
|
@ -23,7 +23,7 @@ import Data.Functor
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( runIdentity )
|
( runIdentity )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( catMaybes, listToMaybe )
|
( catMaybes, isNothing, listToMaybe )
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
( Sum(..) )
|
( Sum(..) )
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
|
@ -70,7 +70,7 @@ import Control.Monad.Trans.Class
|
||||||
( lift )
|
( lift )
|
||||||
import Control.Monad.Trans.Maybe
|
import Control.Monad.Trans.Maybe
|
||||||
( MaybeT(..) )
|
( MaybeT(..) )
|
||||||
import Control.Monad.Trans.State.Strict
|
import Control.Monad.Trans.State.Strict as State
|
||||||
( StateT(..), State
|
( StateT(..), State
|
||||||
, evalState, evalStateT, runState
|
, evalState, evalStateT, runState
|
||||||
, get, put, modify'
|
, get, put, modify'
|
||||||
|
@ -845,6 +845,7 @@ data BrushWidgetActionState
|
||||||
= BrushWidgetActionState
|
= BrushWidgetActionState
|
||||||
{ brushWidgetAction :: !Brush.WidgetAction
|
{ brushWidgetAction :: !Brush.WidgetAction
|
||||||
, brushWidgetStrokeUnique :: !Unique
|
, brushWidgetStrokeUnique :: !Unique
|
||||||
|
, brushWidgetCurveIndex :: !Int
|
||||||
, brushWidgetPointIndex :: !Int
|
, brushWidgetPointIndex :: !Int
|
||||||
, brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
|
, brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
|
||||||
}
|
}
|
||||||
|
@ -860,24 +861,21 @@ instance Semigroup BrushWidgetActionState where
|
||||||
applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document )
|
applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document )
|
||||||
applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
|
applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
|
||||||
let
|
let
|
||||||
res :: Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Document
|
res :: State ( Maybe BrushWidgetActionState ) Document
|
||||||
res = do
|
res = ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
|
||||||
newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
|
in case ( `runState` Nothing ) res of
|
||||||
Tardis.getPast >>= Tardis.sendPast
|
( newDoc, Just brushWidgetAction )
|
||||||
pure newDoc
|
|
||||||
in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) $ res of
|
|
||||||
( newDoc, ( _, Just brushWidgetAction ) )
|
|
||||||
-> Just ( brushWidgetAction, newDoc )
|
-> Just ( brushWidgetAction, newDoc )
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
where
|
where
|
||||||
updateStrokeHierarchy :: StrokeHierarchy -> ( Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) ) StrokeHierarchy
|
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe BrushWidgetActionState ) StrokeHierarchy
|
||||||
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
||||||
newContents <- traverse updateStrokeHierarchy groupContents
|
newContents <- traverse updateStrokeHierarchy groupContents
|
||||||
pure ( StrokeGroup { groupContents = newContents, .. } )
|
pure ( StrokeGroup { groupContents = newContents, .. } )
|
||||||
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
|
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 ) ) } ) =
|
updateStroke stroke@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) =
|
||||||
case strokeBrush of
|
case strokeBrush of
|
||||||
-- Don't touch strokes without brushes.
|
-- Don't touch strokes without brushes.
|
||||||
|
@ -906,12 +904,11 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
|
||||||
-> ( Record brushFields -> pointParams -> pointParams )
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
-> Unique
|
-> Unique
|
||||||
-> StrokeSpline clo pointParams
|
-> StrokeSpline clo pointParams
|
||||||
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
-> State ( Maybe BrushWidgetActionState ) ( StrokeSpline clo pointParams )
|
||||||
( StrokeSpline clo pointParams )
|
|
||||||
updateSpline brush toBrushParams updatePointParams uniq oldSpline =
|
updateSpline brush toBrushParams updatePointParams uniq oldSpline =
|
||||||
ibitraverseSpline
|
ibitraverseSpline
|
||||||
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
|
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
|
||||||
( updateSplinePoint brush toBrushParams updatePointParams uniq 0 )
|
( updateSplinePoint brush toBrushParams updatePointParams uniq 0 0 )
|
||||||
oldSpline
|
oldSpline
|
||||||
|
|
||||||
updateSplineCurve
|
updateSplineCurve
|
||||||
|
@ -923,91 +920,106 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor }
|
||||||
-> ( Record brushFields -> pointParams -> pointParams )
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
-> Unique -> Int
|
-> Unique -> Int
|
||||||
-> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
|
-> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||||
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
-> State ( Maybe BrushWidgetActionState )
|
||||||
( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) )
|
( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) )
|
||||||
updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve
|
updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve
|
||||||
-- If we have already started a widget action, only continue an action
|
-- If we have already started a widget action, only continue an action
|
||||||
-- at the point with the correct index in the stroke.
|
-- at the point with the correct index in the stroke.
|
||||||
| case mbPrevAction of { Just act -> brushWidgetPointIndex act /= i ; Nothing -> False }
|
| case mbPrevAction of
|
||||||
= pure curve
|
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
|
| otherwise
|
||||||
|
, let i' :: Int
|
||||||
|
j' :: Int -> Int
|
||||||
|
( i', j' ) = case ssplineType @clo' of { SClosed -> ( 0, const 0 ) ; SOpen -> ( i, id ) }
|
||||||
= case curve of
|
= case curve of
|
||||||
line@( LineTo sp1 _ ) -> do
|
line@( LineTo sp1 dat ) -> do
|
||||||
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp1
|
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i' ( j' 1 ) ) sp1
|
||||||
pure ( line { curveEnd = sp1' } )
|
pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
|
||||||
bez2@( Bezier2To sp1 sp2 _ ) -> do
|
bez2@( Bezier2To sp1 sp2 dat ) -> do
|
||||||
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
|
||||||
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp2
|
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 2 ) ) sp2
|
||||||
pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
|
pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
|
||||||
bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
|
bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
|
||||||
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 1 sp1
|
||||||
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp2
|
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i 2 sp2
|
||||||
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp3
|
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ( j' 3 ) ) sp3
|
||||||
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
|
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
|
||||||
|
|
||||||
inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
|
inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
|
||||||
inSelectionRange p cp =
|
inSelectionRange p cp =
|
||||||
squaredNorm ( c --> ( cp • p ) :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
squaredNorm ( c --> ( cp • p ) :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||||
|
|
||||||
lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool
|
lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool
|
||||||
lineInSelectionRange p seg
|
lineInSelectionRange p seg =
|
||||||
= case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
|
case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
|
||||||
( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||||
|
|
||||||
updateSplinePoint
|
updateSplinePoint
|
||||||
:: forall pointParams brushFields
|
:: forall pointParams brushFields
|
||||||
. NamedBrush brushFields
|
. NamedBrush brushFields
|
||||||
-> ( pointParams -> Record brushFields )
|
-> ( pointParams -> Record brushFields )
|
||||||
-> ( Record brushFields -> pointParams -> pointParams )
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
-> Unique -> Int
|
-> Unique -> Int -> Int
|
||||||
-> PointData pointParams
|
-> PointData pointParams
|
||||||
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
-> State ( Maybe BrushWidgetActionState )
|
||||||
( PointData pointParams )
|
( PointData pointParams )
|
||||||
updateSplinePoint brush toBrushParams updatePointParams uniq i pt = do
|
updateSplinePoint brush toBrushParams updatePointParams uniq i j pt = do
|
||||||
mbPreviousBrushWidgetAction <- Tardis.getPast
|
let
|
||||||
case mbPreviousBrushWidgetAction of
|
currentBrushParams :: Record brushFields
|
||||||
-- Already started a brush widget update: don't do anything else.
|
currentBrushParams = toBrushParams ( brushParams pt )
|
||||||
Just {}
|
brushWidgetElts :: Brush.WidgetElements
|
||||||
-> pure pt
|
brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
|
||||||
-- Otherwise, check whether we are updating the brush parameters at this stroke point.
|
newBrushWidgetAction :: Maybe BrushWidgetActionState
|
||||||
Nothing -> do
|
( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
|
||||||
let
|
-- Continue the current brush widget action.
|
||||||
currentBrushParams :: Record brushFields
|
Just prevAction@( BrushWidgetActionState
|
||||||
currentBrushParams = toBrushParams ( brushParams pt )
|
{ brushWidgetPointBeingMoved = oldPt
|
||||||
brushWidgetElts :: Brush.WidgetElements
|
, brushWidgetPointIndex = j'
|
||||||
brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
|
, brushWidgetAction = act }) ->
|
||||||
newBrushWidgetAction :: Maybe BrushWidgetActionState
|
if j /= j'
|
||||||
( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
|
-- If we have already started a widget action, only continue an action
|
||||||
-- Continue the current brush widget action.
|
-- at the point with the correct index in the stroke.
|
||||||
Just prevAction@( BrushWidgetActionState { brushWidgetPointBeingMoved = oldPt, brushWidgetAction = act }) ->
|
then ( Just prevAction, currentBrushParams )
|
||||||
let newPt = pointCoords pt --> c
|
else
|
||||||
newParams =
|
let newPt = pointCoords pt --> c
|
||||||
Brush.widgetUpdate ( brushWidget brush ) act
|
newParams =
|
||||||
( oldPt, newPt )
|
Brush.widgetUpdate ( brushWidget brush ) act
|
||||||
currentBrushParams
|
( oldPt, newPt )
|
||||||
in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
|
currentBrushParams
|
||||||
Nothing ->
|
in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
|
||||||
-- See if we can start a new brush widget action.
|
Nothing ->
|
||||||
case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
|
-- See if we can start a new brush widget action.
|
||||||
Just cp ->
|
case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
|
||||||
let newAction =
|
Just cp ->
|
||||||
BrushWidgetActionState
|
let newAction =
|
||||||
{ brushWidgetPointBeingMoved = cp
|
BrushWidgetActionState
|
||||||
, brushWidgetStrokeUnique = uniq
|
{ brushWidgetPointBeingMoved = cp
|
||||||
, brushWidgetPointIndex = i
|
, brushWidgetStrokeUnique = uniq
|
||||||
, brushWidgetAction = case brushWidget brush of
|
, brushWidgetCurveIndex = i
|
||||||
Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
|
, brushWidgetPointIndex = j
|
||||||
Brush.RotatableRectangleWidget ->
|
, brushWidgetAction = case brushWidget brush of
|
||||||
if pressingCtrl
|
Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
|
||||||
then Brush.RotateAction
|
Brush.RotatableRectangleWidget ->
|
||||||
else Brush.ScaleAction Brush.ScaleXY
|
if pressingCtrl
|
||||||
}
|
then Brush.RotateAction
|
||||||
in ( Just newAction, currentBrushParams )
|
else Brush.ScaleAction Brush.ScaleXY
|
||||||
Nothing -> ( Nothing, currentBrushParams )
|
}
|
||||||
-- TODO: handle clicking on an edge.
|
in ( Just newAction, currentBrushParams )
|
||||||
-- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
|
Nothing -> ( Nothing, currentBrushParams )
|
||||||
-- Just ln -> error "todo"
|
-- TODO: handle clicking on an edge.
|
||||||
-- Nothing -> Nothing
|
-- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
|
||||||
|
-- Just ln -> error "todo"
|
||||||
|
-- Nothing -> Nothing
|
||||||
|
|
||||||
Tardis.sendFuture newBrushWidgetAction
|
unless ( isNothing newBrushWidgetAction ) $
|
||||||
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
|
State.put newBrushWidgetAction
|
||||||
|
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module MetaBrush.Brush.Widget
|
module MetaBrush.Brush.Widget
|
||||||
( Widget(..)
|
( Widget(..)
|
||||||
, WidgetElements(..)
|
, WidgetElements(..)
|
||||||
|
@ -5,6 +7,7 @@ module MetaBrush.Brush.Widget
|
||||||
, widgetUpdate
|
, widgetUpdate
|
||||||
, WhatScale(..)
|
, WhatScale(..)
|
||||||
, WidgetAction(..)
|
, WidgetAction(..)
|
||||||
|
, describeWidgetAction
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -26,6 +29,10 @@ import Math.Module
|
||||||
, norm
|
, norm
|
||||||
)
|
)
|
||||||
|
|
||||||
|
-- text
|
||||||
|
import Data.Text
|
||||||
|
( Text )
|
||||||
|
|
||||||
-- metabrushes
|
-- metabrushes
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
( Record(..) )
|
( Record(..) )
|
||||||
|
@ -94,6 +101,10 @@ data WidgetAction
|
||||||
--{ windingNumber :: Int }
|
--{ windingNumber :: Int }
|
||||||
deriving stock ( Eq, Ord, Show )
|
deriving stock ( Eq, Ord, Show )
|
||||||
|
|
||||||
|
describeWidgetAction :: WidgetAction -> Text
|
||||||
|
describeWidgetAction ( ScaleAction {} ) = "scaling"
|
||||||
|
describeWidgetAction RotateAction = "rotation"
|
||||||
|
|
||||||
-- | Given an UI action (moving a widget control element),
|
-- | Given an UI action (moving a widget control element),
|
||||||
-- how should we update the brush parameters?
|
-- how should we update the brush parameters?
|
||||||
widgetUpdate :: Widget flds
|
widgetUpdate :: Widget flds
|
||||||
|
@ -121,9 +132,9 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
|
||||||
-> MkR oldFlds
|
-> MkR oldFlds
|
||||||
| otherwise
|
| otherwise
|
||||||
->
|
->
|
||||||
let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt )
|
let θ1 = atan2 ( oldPt × newPt ) ( oldPt ^.^ newPt )
|
||||||
θ' = nearestAngle θ θ1
|
θ' = θ + nearestAngle 0 θ1
|
||||||
in MkR $ ℝ3 w h θ'
|
in MkR ( ℝ3 w h θ' )
|
||||||
|
|
||||||
nearestAngle :: Double -> Double -> Double
|
nearestAngle :: Double -> Double -> Double
|
||||||
nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )
|
nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )
|
||||||
|
|
Loading…
Reference in a new issue