WIP: add brush widget UI

This commit is contained in:
sheaf 2024-05-21 19:40:22 +02:00
parent 2a21980ffc
commit 1ec2af6dcc
14 changed files with 592 additions and 99 deletions

View file

@ -171,6 +171,7 @@ library metabrushes
MetaBrush.Assert
, MetaBrush.Asset.Brushes
, MetaBrush.Brush
, MetaBrush.Brush.Widget
, MetaBrush.Document
, MetaBrush.Document.Draw
, MetaBrush.Document.History

View file

@ -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);

View file

@ -113,7 +113,12 @@
.selectedOutline {
color: @selectedOutline;
}
.brushWidget {
color: @brushWidget;
}
.brushWidgetHover {
color: @brushWidgetHover;
}
/* Proper CSS styling */

View file

@ -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
-> 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
sequenceA_ uiUpdateAction
-----------------
-- Mouse click --
@ -874,8 +891,10 @@ 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
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
@ -904,7 +923,23 @@ instance HandleAction MouseClick where
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
@ -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 ()

View file

@ -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

View file

@ -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

View file

@ -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 )
= SelectionHold
{ holdStartPos :: !( 2 ) }
| DragMoveHold
{ holdStartPos :: !( 2 )
, dragAction :: !DragMoveSelect
}
| DrawHold { holdStartPos :: !( 2 ) }
| GuideAction { holdStartPos :: !( 2 )
| 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.

View file

@ -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 } ) =
@ -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 )

View file

@ -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 )

View file

@ -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 )

View file

@ -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

View file

@ -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 )

View file

@ -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

View file

@ -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