diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 41752a3..a4fde28 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -171,6 +171,7 @@ library metabrushes MetaBrush.Assert , MetaBrush.Asset.Brushes , MetaBrush.Brush + , MetaBrush.Brush.Widget , MetaBrush.Document , MetaBrush.Document.Draw , MetaBrush.Document.History diff --git a/assets/colours.css b/assets/colours.css index 26d9249..4461370 100644 --- a/assets/colours.css +++ b/assets/colours.css @@ -32,6 +32,9 @@ @define-color glass rgba( 156, 231, 255, 0.5); @define-color selected rgba( 161, 201, 236, 0.5); @define-color selectedOutline rgb( 74, 150, 218); +@define-color brushWidget rgba( 0, 0, 0, 0.9); +@define-color brushWidgetHover rgb( 231, 172, 83); + @define-color shortcutKey rgb( 112, 109, 96 ); @define-color windowButtonHover rgb( 34, 131, 186); diff --git a/assets/theme.css b/assets/theme.css index beb248f..08b5be0 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -113,7 +113,12 @@ .selectedOutline { color: @selectedOutline; } - +.brushWidget { + color: @brushWidget; +} +.brushWidgetHover { + color: @brushWidgetHover; +} /* Proper CSS styling */ diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 3b114db..bdbf577 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -127,7 +127,8 @@ import MetaBrush.Document.Selection , DragMoveSelect(..), dragMoveSelect , UpdateInfo(..) , deleteSelected - , dragUpdate + , dragUpdate, pressingControl + , applyBrushWidgetAction ) import MetaBrush.Document.Serialise ( saveDocument, loadDocument ) @@ -765,13 +766,13 @@ data MouseMove = MouseMove !( ℝ 2 ) instance HandleAction MouseMove where handleAction - ( UIElements { viewport = Viewport {..}, .. } ) + uiElts@( UIElements { viewport = Viewport {..}, infoBar } ) vars@( Variables {..} ) ( MouseMove ( ℝ2 x y ) ) = do viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do + modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do modifiers <- STM.readTVar modifiersTVar let toViewport :: ℝ 2 -> ℝ 2 @@ -784,18 +785,34 @@ instance HandleAction MouseMove where -- moves the partial control point (if one exists). tool <- STM.readTVar toolTVar 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 - -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } ) - _ -> pure () - STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates - pure do - updateInfoBar viewportDrawingArea infoBar vars ( Just doc ) - for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do - GTK.widgetQueueDraw drawingArea - sequenceA_ uiUpdateAction + -> 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 + mbDoc <- fmap present <$> STM.atomically ( activeDocument vars ) + for_ mbDoc \doc -> + updateInfoBar viewportDrawingArea infoBar vars ( Just doc ) + for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do + GTK.widgetQueueDraw drawingArea ----------------- -- Mouse click -- @@ -874,37 +891,55 @@ instance HandleAction MouseClick where STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) pure Don'tModifyDoc - -- Pen tool: start or continue a drawing operation. - Pen | PathMode <- mode -> do - mbPartialPath <- STM.readTVar partialPathTVar - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - case mbPartialPath of - -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). - Nothing -> do - ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- - getOrCreateDrawAnchor uniqueSupply pos doc - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialStartPos = anchorPt - , partialControlPoint = Nothing - , partialPathAnchor = drawAnchor - , firstPoint = True - } - ) - case mbExistingAnchorName of - Nothing -> - let - changeText :: Text - changeText = "Begin new stroke" - in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - Just _ -> + Pen -> + case mode of + -- Pen tool in path mode: start or continue a drawing operation. + PathMode -> do + mbPartialPath <- STM.readTVar partialPathTVar + STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) + case mbPartialPath of + -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). + Nothing -> do + ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- + getOrCreateDrawAnchor uniqueSupply pos doc + STM.writeTVar partialPathTVar + ( Just $ PartialPath + { partialStartPos = anchorPt + , partialControlPoint = Nothing + , partialPathAnchor = drawAnchor + , firstPoint = True + } + ) + case mbExistingAnchorName of + Nothing -> + let + changeText :: Text + changeText = "Begin new stroke" + in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + Just _ -> + pure Don'tModifyDoc + -- Path already started: indicate that we are continuing a path. + Just pp -> do + STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) pure Don'tModifyDoc - -- Path already started: indicate that we are continuing a path. - Just pp -> do - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) - pure Don'tModifyDoc - _ -> 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 DoubleClick -> do tool <- STM.readTVar toolTVar @@ -959,7 +994,7 @@ data MouseRelease = MouseRelease !Word32 !( ℝ 2 ) deriving stock Show instance HandleAction MouseRelease where - handleAction + handleAction uiElts@( UIElements { viewport = Viewport {..} } ) vars@( Variables {..} ) ( MouseRelease button ( ℝ2 x y ) ) @@ -1057,9 +1092,8 @@ instance HandleAction MouseRelease where -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc ) _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) - Pen - | PathMode <- mode - -> do + Pen -> case mode of + PathMode -> do mbPartialPath <- STM.readTVar partialPathTVar case mbPartialPath of -- Normal pen mode mouse click should have created an anchor. @@ -1141,8 +1175,12 @@ instance HandleAction MouseRelease where changeText :: Text changeText = "Continue stroke" pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + BrushMode -> do + STM.writeTVar mouseHoldTVar Nothing + pure Don'tModifyDoc - _ -> pure Don'tModifyDoc + MetaMode -> + pure Don'tModifyDoc -- Other mouse buttons: ignored (for the moment at least). _ -> pure () diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 8a5004e..ad9cb65 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -206,8 +206,8 @@ runApplication application = do maxHistorySizeTVar <- STM.newTVarIO @Int 1000 fitParametersTVar <- STM.newTVarIO @FitParameters $ FitParameters - { maxSubdiv = 0 --5 --2 --3 -- 6 - , nbSegments = 1 --5 + { maxSubdiv = 2 --5 --2 --3 -- 6 + , nbSegments = 3 , dist_tol = 5e-3 , t_tol = 1e-4 , maxIters = 20 @@ -217,7 +217,7 @@ runApplication application = do NewtonRaphson { maxIters = 20, precision = 8 } cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $ - Nothing --Just defaultRootIsolationOptions + Just defaultRootIsolationOptions -- Put all these stateful variables in a record for conciseness. let diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index b2e8c13..22d6d3a 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -35,8 +35,13 @@ data ColourRecord a , pointHover, pointSelected , viewport, viewportScrollbar, tabScrollbar , guide, rulerBg, rulerTick, magnifier, glass - , selected, selectedOutline :: !a + , selected, selectedOutline + , brushWidget, brushWidgetHover :: !a } + -- NB: when adding a new colour to this record, don't forget to update: + -- + -- - colours.css, to define a value for the colour, + -- - theme.css, which is where GTK parses the colours in 'getColours'. deriving stock ( Show, Functor, Foldable, Traversable ) newtype ColourName @@ -76,6 +81,8 @@ colourNames = Colours , glass = ColourName "glass" , selected = ColourName "selected" , selectedOutline = ColourName "selectedOutline" + , brushWidget = ColourName "brushWidget" + , brushWidgetHover = ColourName "brushWidgetHover" } type Colours = ColourRecord GDK.RGBA diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index ff6963b..c506676 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -54,7 +54,7 @@ import MetaBrush.Document.Draw import MetaBrush.Document.History ( DocumentHistory(..) ) import MetaBrush.Document.Selection - ( DragMoveSelect ) + ( DragMoveSelect, BrushWidgetActionState ) import {-# SOURCE #-} MetaBrush.UI.FileBar ( FileBar, FileBarTab ) import {-# SOURCE #-} MetaBrush.UI.InfoBar @@ -135,16 +135,25 @@ data GuideAction -- - start a rectangular selection, -- - move objects by dragging, -- - draw a control point, --- - create/modify a guide. +-- - create/modify a guide, +-- - modify brush parameters through a brush widget. data HoldAction - = SelectionHold { holdStartPos :: !( ℝ 2 ) } - | DragMoveHold { holdStartPos :: !( ℝ 2 ) - , dragAction :: !DragMoveSelect - } - | DrawHold { holdStartPos :: !( ℝ 2 ) } - | GuideAction { holdStartPos :: !( ℝ 2 ) - , guideAction :: !GuideAction - } + = SelectionHold + { holdStartPos :: !( ℝ 2 ) } + | DragMoveHold + { holdStartPos :: !( ℝ 2 ) + , dragAction :: !DragMoveSelect + } + | DrawHold + { holdStartPos :: !( ℝ 2 ) } + | GuideAction + { holdStartPos :: !( ℝ 2 ) + , guideAction :: !GuideAction + } + | BrushWidgetAction + { holdStartPos :: !( ℝ 2 ) + , brushWidgetAction :: !BrushWidgetActionState + } deriving stock Show -- | Keep track of a path that is in the middle of being drawn. diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 3d28889..4e8c05a 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -2,12 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module MetaBrush.Document.Selection - ( SelectionMode(..), selectionMode + ( SelectionMode(..), selectionMode, pressingControl , selectAt, selectRectangle , DragMoveSelect(.., PointDrag), dragMoveSelect , UpdateInfo(..) , translateSelection, deleteSelected , dragUpdate + , BrushWidgetActionState(..) + , applyBrushWidgetAction ) where @@ -21,7 +23,7 @@ import Data.Functor import Data.Functor.Identity ( runIdentity ) import Data.Maybe - ( catMaybes ) + ( catMaybes, listToMaybe ) import Data.Monoid ( Sum(..) ) import Data.Semigroup @@ -97,6 +99,15 @@ import Math.Module ( Module, lerp, squaredNorm, closestPointOnSegment ) import Math.Linear ( Segment(..), ℝ(..), T(..) ) + +-- metabrush +import MetaBrush.Brush + ( NamedBrush(..), WithParams(defaultParams) ) +import qualified MetaBrush.Brush.Widget as Brush + ( Widget(..), WidgetAction(..), WidgetElements(..) + , WhatScale(..) + , widgetElements, widgetUpdate + ) import {-# SOURCE #-} MetaBrush.Context ( Modifier(..) ) import MetaBrush.Document @@ -108,6 +119,10 @@ import MetaBrush.Document ) import {-# SOURCE #-} MetaBrush.Document.Update ( DocChange(..) ) +import MetaBrush.Records + ( Record + , Intersection(..), intersect + ) import MetaBrush.Unique ( Unique ) import MetaBrush.Util @@ -137,6 +152,11 @@ selectionMode = foldMap \case Shift _ -> Add _ -> New +pressingControl :: Foldable f => f Modifier -> Bool +pressingControl = any \case + Control {} -> True + _ -> False + -- | Updates the selected objects on a single click selection event. selectAt :: SelectionMode -> ℝ 2 -> Document -> Document selectAt selMode c doc@( Document { zoomFactor } ) = @@ -439,7 +459,7 @@ translateSelection t doc = | not strokeVisible = pure oldSpline | otherwise - = bitraverseSpline + = bitraverseSpline ( const $ updateSplineCurve ( splineStart oldSpline ) ) ( updatePoint PathPoint ) oldSpline @@ -533,7 +553,7 @@ deleteSelected doc = updateSpline :: forall clo brushParams . KnownSplineType clo - => StrokeSpline clo brushParams + => StrokeSpline clo brushParams -> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams ) updateSpline oldSpline | not strokeVisible @@ -816,3 +836,178 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen dragSegmentParameter p in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat ) + + +-------------------------------------------------------------------------------- +-- Brush widget + +data BrushWidgetActionState + = BrushWidgetActionState + { brushWidgetAction :: !Brush.WidgetAction + , brushWidgetStrokeUnique :: !Unique + , brushWidgetPointIndex :: !Int + , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) ) + } + deriving stock ( Eq, Show ) +instance Semigroup BrushWidgetActionState where + a <> b + | a == b + = a + | otherwise + = error "internal error: trying to combine incompatible brush widget action states" + +-- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point. +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 ) ) + -> Just ( brushWidgetAction, newDoc ) + _ -> Nothing + + where + updateStrokeHierarchy :: StrokeHierarchy -> ( Tardis ( Maybe BrushWidgetActionState ) ( 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@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) = + case strokeBrush of + -- Don't touch strokes without brushes. + Nothing -> pure stroke + Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) + | -- Don't touch invisible strokes + not strokeVisible + -- If we have already started a widget action, only continue an action + -- for the stroke with the correct unique. + || case mbPrevAction of { Just act -> brushWidgetStrokeUnique act /= strokeUnique ; Nothing -> False } + -> pure stroke + | otherwise + -> case intersect @pointFields @brushFields of + Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do + let embedUsedParams = updateBrushParams ( defaultParams $ brushFunction brush ) + toBrushParams = embedUsedParams . ptParamsToUsedParams + updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' ) + spline' <- updateSpline brush toBrushParams updatePointParams strokeUnique spline0 + pure $ stroke { strokeSpline = spline' } + where + updateSpline + :: forall clo pointParams brushFields + . ( KnownSplineType clo ) + => NamedBrush brushFields + -> ( pointParams -> Record brushFields ) + -> ( Record brushFields -> pointParams -> pointParams ) + -> Unique + -> StrokeSpline clo pointParams + -> Tardis ( Maybe BrushWidgetActionState ) ( 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 ) + oldSpline + + updateSplineCurve + :: forall clo' pointParams brushFields + . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) + => PointData pointParams + -> NamedBrush brushFields + -> ( pointParams -> Record brushFields ) + -> ( Record brushFields -> pointParams -> pointParams ) + -> Unique -> Int + -> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) + -> Tardis ( Maybe BrushWidgetActionState ) ( 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 + | otherwise + = 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' } ) + + 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 + + updateSplinePoint + :: forall pointParams brushFields + . NamedBrush brushFields + -> ( pointParams -> Record brushFields ) + -> ( Record brushFields -> pointParams -> pointParams ) + -> Unique -> Int + -> PointData pointParams + -> Tardis ( Maybe BrushWidgetActionState ) ( 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 + + Tardis.sendFuture newBrushWidgetAction + pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index c73a632..991b5b5 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -77,7 +77,7 @@ import Math.Bezier.Stroke , RootSolvingAlgorithm ) import Math.Linear - ( ℝ(..), T(..) + ( ℝ(..), T(..), Segment(..) , rotate ) import Math.Module @@ -88,6 +88,8 @@ import MetaBrush.Asset.Colours ( Colours, ColourRecord(..) ) import MetaBrush.Brush ( NamedBrush(..), WithParams(..) ) +import qualified MetaBrush.Brush.Widget as Brush + ( Widget(..), WidgetElements(..), widgetElements ) import MetaBrush.Context ( Modifier(..) , HoldAction(..), PartialPath(..) @@ -125,7 +127,8 @@ import MetaBrush.GTK.Util data Renders a = Renders - { renderStrokes, renderPath, renderDebug, renderBrushes + { renderStrokes, renderPath, renderDebug + , renderBrushes, renderBrushWidgets , renderCLines, renderCPts, renderPPts :: a } deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 ) @@ -261,7 +264,7 @@ data StrokeRenderData where => { strokeDataSpline :: !( StrokeSpline clo pointParams ) } -> StrokeRenderData StrokeWithOutlineRenderData - :: forall pointParams clo + :: forall pointParams clo brushFields . ( KnownSplineType clo, Show pointParams, NFData pointParams ) => { strokeDataSpline :: !( StrokeSpline clo pointParams ) , strokeOutlineData :: !( Either @@ -271,6 +274,7 @@ data StrokeRenderData where , [ Cusp ] ) , strokeBrushFunction :: pointParams -> SplinePts Closed + , strokeWidgetData :: ( Brush.Widget brushFields, pointParams -> Record brushFields ) } -> StrokeRenderData @@ -285,7 +289,8 @@ instance NFData StrokeRenderData where -- - If the stroke has an associated brush, this consists of: -- - the path that the brush follows, -- - the computed outline (using fitting algorithm), --- - the brush shape function. +-- - the brush shape function, +-- - the brush widget (UI for modifying brush parameters). -- - Otherwise, this consists of the underlying spline path only. strokeRenderData :: RootSolvingAlgorithm @@ -301,7 +306,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams } ) | strokeVisible = Just $ case strokeBrush of - Just ( NamedBrush { brushFunction = fn } ) + Just ( NamedBrush { brushFunction = fn, brushWidget = widget } ) | WithParams { defaultParams = brush_defaults , withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } ) @@ -311,10 +316,10 @@ strokeRenderData rootAlgo mbCuspOptions fitParams -- the collection of parameters expected by the brush. case intersect @pointFields @brushFields of Intersection - { inject - , project = toUsedParams :: Record pointFields -> Record usedFields } + { inject2 + , project1 = toUsedParams :: Record pointFields -> Record usedFields } -> do - let embedUsedParams = inject brush_defaults + let embedUsedParams = inject2 brush_defaults -- Compute the outline using the brush function. ( outline, fitPts, cusps ) <- @@ -339,6 +344,8 @@ strokeRenderData rootAlgo mbCuspOptions fitParams cosθ = cos θ sinθ = sin θ in fmap ( unT . rotate cosθ sinθ . T ) shape + , strokeWidgetData = + ( widget, \ params -> embedUsedParams $ toUsedParams params ) } _ -> pure $ StrokeRenderData @@ -353,10 +360,19 @@ renderStroke renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case StrokeRenderData { strokeDataSpline } -> renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline - StrokeWithOutlineRenderData strokeDataSpline ( strokeOutlineData, fitPts, cusps ) strokeBrushFunction -> + StrokeWithOutlineRenderData + { strokeDataSpline + , strokeOutlineData = ( strokeOutlineData, fitPts, cusps ) + , strokeBrushFunction + , strokeWidgetData = ( widget, widgetParams ) + } -> renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( when ( mode == BrushMode ) - . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction + . ( \ pt -> + renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) + strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) ) + pt + ) ) strokeDataSpline *> Compose blank @@ -445,10 +461,11 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline = renderBrushShape :: Colours -> Maybe HoverContext -> Double - -> ( brushParams -> SplinePts Closed ) - -> PointData brushParams + -> ( pointParams -> SplinePts Closed ) + -> Brush.WidgetElements + -> PointData pointParams -> Compose Renders Cairo.Render () -renderBrushShape cols mbHoverContext zoom brushFn pt = +renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt = let x, y :: Double ℝ2 x y = coords pt @@ -462,6 +479,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt = Cairo.translate x y *> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () ) ( fmap ( \ p -> PointData p Normal () ) brushPts ) + *> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts *> toAll Cairo.restore drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render () @@ -742,6 +760,49 @@ drawCross ( Colours {..} ) zoom = do Cairo.restore -} +renderBrushWidgetElements :: Colours -> Double -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render () +renderBrushWidgetElements ( Colours { .. } ) zoom mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) = + Compose blank + { renderBrushWidgets = do + for_ lns $ \ seg@( Segment ( T p0@( ℝ2 x1 y1 ) ) ( T p1@( ℝ2 x2 y2 ) ) ) -> do + let lineFocus + -- Don't do rectangle hover highlighting; doesn't make sense here. + | Just ( MouseHover {} ) <- mbHover + -- Only focus the line if we aren't focusing a point, + -- as line focus corresponds to horizontal/vertical scaling + -- as opposed to 2D scaling. + , Normal <- hovered mbHover zoom p0 + , Normal <- hovered mbHover zoom p1 + = hovered mbHover zoom ( fmap unT seg ) + | otherwise + = Normal + Cairo.save + Cairo.moveTo x1 y1 + Cairo.lineTo x2 y2 + Cairo.setLineWidth ( 2 / zoom ) + case lineFocus of + Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA + _ -> withRGBA brushWidget Cairo.setSourceRGBA + Cairo.stroke + Cairo.restore + for_ pts $ \ ( T p@( ℝ2 x y ) ) -> do + let ptFocus + -- Don't do rectangle hover highlighting; doesn't make sense here. + | Just ( MouseHover {} ) <- mbHover + = hovered mbHover zoom p + | otherwise + = Normal + Cairo.save + Cairo.translate x y + Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi ) + Cairo.setLineWidth ( 2 / zoom ) + case ptFocus of + Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA + _ -> withRGBA brushWidget Cairo.setSourceRGBA + Cairo.fill + Cairo.restore + } + hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double ) hsl2rgb h s l = case hc2rgb h c of ( r, g, b ) -> ( r + m, g + m, b + m ) diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 45139af..013da58 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/src/metabrushes/MetaBrush/Asset/Brushes.hs @@ -39,6 +39,8 @@ import Math.Ring -- MetaBrush import MetaBrush.Brush ( NamedBrush(..), SomeBrush(..), WithParams(..) ) +import qualified MetaBrush.Brush.Widget as Brush + ( Widget(..) ) import MetaBrush.Records ( Record(MkR) ) @@ -60,7 +62,12 @@ brushes = HashMap.fromList type CircleBrushFields = '[ "r" ] -- | A circular brush with the given radius. circle :: NamedBrush CircleBrushFields -circle = NamedBrush "circle" ( WithParams deflts $ coerce circleBrush ) +circle = + NamedBrush + { brushName = "circle" + , brushFunction = WithParams deflts $ coerce circleBrush + , brushWidget = Brush.SquareWidget + } where deflts :: Record CircleBrushFields deflts = MkR ( ℝ1 1 ) @@ -70,7 +77,12 @@ type EllipseBrushFields = '[ "a", "b", "phi" ] -- | An elliptical brush with the given semi-major and semi-minor axes and -- angle of rotation. ellipse :: NamedBrush EllipseBrushFields -ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush ) +ellipse = + NamedBrush + { brushName = "ellipse" + , brushFunction = WithParams deflts $ coerce ellipseBrush + , brushWidget = Brush.RotatableRectangleWidget + } where deflts :: Record EllipseBrushFields deflts = MkR ( ℝ3 1 1 0 ) @@ -79,7 +91,12 @@ ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush ) type TearDropBrushFields = '[ "w", "h", "phi" ] -- | A tear-drop shape with the given width, height and angle of rotation. tearDrop :: NamedBrush TearDropBrushFields -tearDrop = NamedBrush "tear-drop" ( WithParams deflts $ coerce tearDropBrush ) +tearDrop = + NamedBrush + { brushName = "tear-drop" + , brushFunction = WithParams deflts $ coerce tearDropBrush + , brushWidget = Brush.RotatableRectangleWidget + } where deflts :: Record TearDropBrushFields deflts = MkR ( ℝ3 1 2.25 0 ) diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 2cffed5..912201d 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -42,8 +42,6 @@ import qualified Data.Text as Text -- brush-strokes import Calligraphy.Brushes ( Brush(..) ) -import Math.Bezier.Spline - ( SplineType(Closed), Spline ) import Math.Differentiable ( DiffInterp ) import Math.Interval @@ -51,6 +49,8 @@ import Math.Interval import Math.Linear -- MetaBrush +import qualified MetaBrush.Brush.Widget as Brush + ( Widget ) import MetaBrush.Records ( KnownSymbols, Length, Record ) import MetaBrush.Serialisable @@ -77,19 +77,22 @@ type NamedBrush :: [ Symbol ] -> Type data NamedBrush brushFields where NamedBrush :: forall brushFields - . ( KnownSymbols brushFields, Typeable brushFields + . ( KnownSymbols brushFields , Representable Double ( ℝ ( Length brushFields ) ) , DiffInterp 2 () ( ℝ ( Length brushFields ) ) , DiffInterp 3 𝕀 ( ℝ ( Length brushFields ) ) ) => { brushName :: !Text - , brushFunction :: BrushFunction brushFields + , brushFunction :: !( BrushFunction brushFields ) + , brushWidget :: !( Brush.Widget brushFields ) } -> NamedBrush brushFields data SomeBrush where SomeBrush - :: { someBrush :: !( NamedBrush brushFields ) } + :: forall brushFields + . KnownSymbols brushFields + => { someBrush :: !( NamedBrush brushFields ) } -> SomeBrush instance Show ( NamedBrush brushFields ) where @@ -102,9 +105,11 @@ instance NFData ( NamedBrush brushFields ) where rnf ( NamedBrush { brushName } ) = rnf brushName instance Eq ( NamedBrush brushFields ) where - NamedBrush name1 _ == NamedBrush name2 _ = name1 == name2 + NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 } + = name1 == name2 instance Ord ( NamedBrush brushFields ) where - compare ( NamedBrush name1 _ ) ( NamedBrush name2 _ ) = compare name1 name2 + compare ( NamedBrush { brushName = name1 } ) ( NamedBrush { brushName = name2 } ) + = compare name1 name2 instance Hashable ( NamedBrush brushFields ) where hashWithSalt salt ( NamedBrush { brushName } ) = hashWithSalt salt brushName diff --git a/src/metabrushes/MetaBrush/Brush/Widget.hs b/src/metabrushes/MetaBrush/Brush/Widget.hs new file mode 100644 index 0000000..e4ee672 --- /dev/null +++ b/src/metabrushes/MetaBrush/Brush/Widget.hs @@ -0,0 +1,129 @@ +module MetaBrush.Brush.Widget + ( Widget(..) + , WidgetElements(..) + , widgetElements + , widgetUpdate + , WhatScale(..) + , WidgetAction(..) + ) + where + +-- base +import Data.Fixed + ( mod' ) +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol ) + +-- brush-strokes +import Math.Linear + ( ℝ(..), T(..), Segment(..) + , rotate + ) +import Math.Module + ( (^.^), (×) + , norm + ) + +-- metabrushes +import MetaBrush.Records + ( Record(..) ) + +-------------------------------------------------------------------------------- + +-- | A description of a widget to control brush parameters interactively. +-- +-- For example, a rotatable rectangle widget to control the size of an +-- elliptical brush. +type Widget :: [ Symbol ] -> Type +data Widget flds where + SquareWidget + :: Widget '[ r ] + RotatableRectangleWidget + :: Widget '[ w, h, phi ] +deriving stock instance Eq ( Widget flds ) +deriving stock instance Ord ( Widget flds ) +deriving stock instance Show ( Widget flds ) + +-- | Components of a widget that can be displayed visually. +data WidgetElements + = WidgetElements + { widgetPoints :: ![ T ( ℝ 2 ) ] + , widgetLines :: ![ Segment ( T ( ℝ 2 ) ) ] + } + +-- | All UI elements associated to a 'Widget'. +widgetElements :: Widget flds -> Record flds -> WidgetElements +widgetElements widget ( MkR flds ) = + case widget of + SquareWidget + | ℝ1 r <- flds + -> rectElements r r 0 + RotatableRectangleWidget + | ℝ3 w h θ <- flds + -> rectElements w h θ + where + rectElements w h θ = + WidgetElements + { widgetPoints = [ p1, p2, p3, p4 ] + , widgetLines = [ Segment p1 p2 + , Segment p2 p3 + , Segment p3 p4 + , Segment p4 p1 + ] + } + where + p1 = rot $ T $ ℝ2 -w -h + p2 = rot $ T $ ℝ2 w -h + p3 = rot $ T $ ℝ2 w h + p4 = rot $ T $ ℝ2 -w h + rot = rotate ( cos θ ) ( sin θ ) + +data WhatScale + = ScaleXY + | ScaleX + | ScaleY + deriving stock ( Eq, Ord, Show ) + +-- | Keep track of state in a brush widget action, e.g. +-- scaling or rotating a brush. +data WidgetAction + = ScaleAction WhatScale + | RotateAction + --{ windingNumber :: Int } + deriving stock ( Eq, Ord, Show ) + +-- | Given an UI action (moving a widget control element), +-- how should we update the brush parameters? +widgetUpdate :: Widget flds + -> WidgetAction + -> ( T ( ℝ 2 ), T ( ℝ 2 ) ) + -- ^ ( oldPt, newPt ) + -> Record flds + -> Record flds +widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) = + case widget of + SquareWidget + | T ( ℝ2 x y ) <- newPt + -> MkR $ ℝ1 ( max ( abs x ) ( abs y ) ) + RotatableRectangleWidget + | ℝ3 w h θ <- oldFlds + -> case mode of + ScaleAction whatScale -> + let T ( ℝ2 w' h' ) = rotate ( cos -θ ) ( sin -θ ) newPt + in case whatScale of + ScaleXY -> MkR $ ℝ3 ( abs w' ) ( abs h' ) θ + ScaleX -> MkR $ ℝ3 ( abs w' ) h θ + ScaleY -> MkR $ ℝ3 w ( abs h' ) θ + RotateAction {} + | norm newPt < 1e-5 + -> MkR oldFlds + | otherwise + -> + let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt ) + θ' = nearestAngle θ θ1 + in MkR $ ℝ3 w h θ' + +nearestAngle :: Double -> Double -> Double +nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi ) diff --git a/src/metabrushes/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs index a33b4c1..7301608 100644 --- a/src/metabrushes/MetaBrush/Document.hs +++ b/src/metabrushes/MetaBrush/Document.hs @@ -85,9 +85,10 @@ import Math.Module ( origin, (^+^), (^-^), (*^) ) , Inner((^.^)) , squaredNorm, quadrance + , closestPointOnSegment ) import Math.Linear - ( ℝ(..), T(..) ) + ( ℝ(..), T(..), Segment(..) ) import MetaBrush.Brush ( NamedBrush, PointFields ) import MetaBrush.Records @@ -298,6 +299,17 @@ instance Hoverable ( ℝ 2 ) where | otherwise = Normal +instance Hoverable ( Segment ( ℝ 2 ) ) where + hovered Nothing _ _ = Normal + hovered ( Just ( MouseHover p ) ) zoom seg + = hovered ( Just ( MouseHover p ) ) zoom p' + where + ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg + hovered hov@( Just ( RectangleHover {} ) ) zoom ( Segment p0 p1 ) + -- Only consider a segment to be "hovered" if it lies entirely within the + -- hover rectangle, not just if the hover rectangle intersects it. + = hovered hov zoom p0 <> hovered hov zoom p1 + class HasSelection pt where _selection :: Lens' pt FocusState instance HasSelection ( PointData brushParams ) where diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 07fe0a6..86220aa 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -162,7 +162,7 @@ type family Length xs where Length ( _ : xs ) = 1 + Length xs type KnownSymbols :: [ Symbol ] -> Constraint -class KnownSymbols ks where +class Typeable ks => KnownSymbols ks where knownSymbols :: [ Text ] instance KnownSymbols '[] where knownSymbols = [] @@ -176,8 +176,7 @@ instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where {-# INLINE intersect #-} intersect :: forall r1 r2 l1 l2 - . ( Typeable r1, Typeable r2 - , KnownSymbols r1, KnownSymbols r2 + . ( KnownSymbols r1, KnownSymbols r2 , l1 ~ Length r1, l2 ~ Length r2 , Representable Double ( ℝ l1 ) , Representable Double ( ℝ l2 ) @@ -189,16 +188,22 @@ intersect -- Shortcut when the two rows are equal. | Just Refl <- eqT @r1 @r2 , Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 ) - = Intersection { project = id, inject = \ _ -> id } + = Intersection { project1 = id, project2 = id, inject1 = \ _ -> id, inject2 = \ _ -> id } | otherwise = doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs -> let - project :: Record r1 -> Record r1r2 - project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1 + project1 :: Record r1 -> Record r1r2 + project1 = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1 - inject :: Record r2 -> Record r1r2 -> Record r2 - inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2 - in Intersection { project, inject } + project2 :: Record r2 -> Record r1r2 + project2 = \ ( MkR r2 ) -> MkR $ projection ( (!) r2_idxs ) r2 + + inject1 :: Record r1 -> Record r1r2 -> Record r1 + inject1 = \ ( MkR r1 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r1_idxs ) r1r2 r1 + + inject2 :: Record r2 -> Record r1r2 -> Record r2 + inject2 = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2 + in Intersection { project1, project2, inject1, inject2 } data Intersection r1 r2 where Intersection @@ -209,10 +214,16 @@ data Intersection r1 r2 where , Differentiable 2 () ( ℝ l12 ) , Differentiable 3 𝕀 ( ℝ l12 ) ) - => { project :: Record r1 -> Record r1r2 + => { project1 :: Record r1 -> Record r1r2 -- ^ project out fields present in both rows -- (linear non-decreasing mapping) - , inject :: Record r2 -> Record r1r2 -> Record r2 + , project2 :: Record r2 -> Record r1r2 + -- ^ project out fields present in both rows + -- (linear non-decreasing mapping) + , inject1 :: Record r1 -> Record r1r2 -> Record r1 + -- ^ overrides the components of the first record with the second + -- (linear non-decreasing mapping in its second argument) + , inject2 :: Record r2 -> Record r1r2 -> Record r2 -- ^ overrides the components of the first record with the second -- (linear non-decreasing mapping in its second argument) } -> Intersection r1 r2