From 300fbf92c018dc51b53e499333758bbace4dad3d Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 25 May 2024 17:04:08 +0200 Subject: [PATCH] fixes to brush widget UI --- src/app/MetaBrush/Action.hs | 154 ++++++++++--------- src/app/MetaBrush/Document/Selection.hs | 176 ++++++++++++---------- src/metabrushes/MetaBrush/Brush/Widget.hs | 17 ++- 3 files changed, 191 insertions(+), 156 deletions(-) diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index bdbf577..9afb413 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 4e8c05a..1d8b9ff 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Brush/Widget.hs b/src/metabrushes/MetaBrush/Brush/Widget.hs index e4ee672..f31b966 100644 --- a/src/metabrushes/MetaBrush/Brush/Widget.hs +++ b/src/metabrushes/MetaBrush/Brush/Widget.hs @@ -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 )