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.Assert
, MetaBrush.Asset.Brushes , MetaBrush.Asset.Brushes
, MetaBrush.Brush , MetaBrush.Brush
, MetaBrush.Brush.Widget
, MetaBrush.Document , MetaBrush.Document
, MetaBrush.Document.Draw , MetaBrush.Document.Draw
, MetaBrush.Document.History , MetaBrush.Document.History

View file

@ -32,6 +32,9 @@
@define-color glass rgba( 156, 231, 255, 0.5); @define-color glass rgba( 156, 231, 255, 0.5);
@define-color selected rgba( 161, 201, 236, 0.5); @define-color selected rgba( 161, 201, 236, 0.5);
@define-color selectedOutline rgb( 74, 150, 218); @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 shortcutKey rgb( 112, 109, 96 );
@define-color windowButtonHover rgb( 34, 131, 186); @define-color windowButtonHover rgb( 34, 131, 186);

View file

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

View file

@ -127,7 +127,8 @@ import MetaBrush.Document.Selection
, DragMoveSelect(..), dragMoveSelect , DragMoveSelect(..), dragMoveSelect
, UpdateInfo(..) , UpdateInfo(..)
, deleteSelected , deleteSelected
, dragUpdate , dragUpdate, pressingControl
, applyBrushWidgetAction
) )
import MetaBrush.Document.Serialise import MetaBrush.Document.Serialise
( saveDocument, loadDocument ) ( saveDocument, loadDocument )
@ -765,13 +766,13 @@ data MouseMove = MouseMove !( 2 )
instance HandleAction MouseMove where instance HandleAction MouseMove where
handleAction handleAction
( UIElements { viewport = Viewport {..}, .. } ) uiElts@( UIElements { viewport = Viewport {..}, infoBar } )
vars@( Variables {..} ) vars@( Variables {..} )
( MouseMove ( 2 x y ) ) ( MouseMove ( 2 x y ) )
= do = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 modifiers <- STM.readTVar modifiersTVar
let let
toViewport :: 2 -> 2 toViewport :: 2 -> 2
@ -784,18 +785,34 @@ instance HandleAction MouseMove where
-- moves the partial control point (if one exists). -- moves the partial control point (if one exists).
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
case tool of case tool of
Pen Pen
| Just pp <- mbPartialPath | Just pp <- mbPartialPath
, any ( \ case { Control _ -> True; _ -> False } ) modifiers , any ( \ case { Control _ -> True; _ -> False } ) modifiers
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } ) -> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure () pure Don'tModifyDoc
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates | BrushMode <- mode
pure do -- Pen tool in brush mode: modify brush parameters through brush widget.
updateInfoBar viewportDrawingArea infoBar vars ( Just doc ) -> do mbHoldAction <- STM.readTVar mouseHoldTVar
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do case mbHoldAction of
GTK.widgetQueueDraw drawingArea Just ( BrushWidgetAction { brushWidgetAction } ) ->
sequenceA_ uiUpdateAction 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 -- -- Mouse click --
@ -874,37 +891,55 @@ instance HandleAction MouseClick where
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc pure Don'tModifyDoc
-- Pen tool: start or continue a drawing operation. Pen ->
Pen | PathMode <- mode -> do case mode of
mbPartialPath <- STM.readTVar partialPathTVar -- Pen tool in path mode: start or continue a drawing operation.
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) PathMode -> do
case mbPartialPath of mbPartialPath <- STM.readTVar partialPathTVar
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
Nothing -> do case mbPartialPath of
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
getOrCreateDrawAnchor uniqueSupply pos doc Nothing -> do
STM.writeTVar partialPathTVar ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
( Just $ PartialPath getOrCreateDrawAnchor uniqueSupply pos doc
{ partialStartPos = anchorPt STM.writeTVar partialPathTVar
, partialControlPoint = Nothing ( Just $ PartialPath
, partialPathAnchor = drawAnchor { partialStartPos = anchorPt
, firstPoint = True , partialControlPoint = Nothing
} , partialPathAnchor = drawAnchor
) , firstPoint = True
case mbExistingAnchorName of }
Nothing -> )
let case mbExistingAnchorName of
changeText :: Text Nothing ->
changeText = "Begin new stroke" let
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) changeText :: Text
Just _ -> 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 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 DoubleClick -> do
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
@ -959,7 +994,7 @@ data MouseRelease = MouseRelease !Word32 !( 2 )
deriving stock Show deriving stock Show
instance HandleAction MouseRelease where instance HandleAction MouseRelease where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..} } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} ) vars@( Variables {..} )
( MouseRelease button ( 2 x y ) ) ( 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 $ selectRectangle selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
Pen Pen -> case mode of
| PathMode <- mode PathMode -> do
-> do
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor. -- Normal pen mode mouse click should have created an anchor.
@ -1141,8 +1175,12 @@ instance HandleAction MouseRelease where
changeText :: Text changeText :: Text
changeText = "Continue stroke" changeText = "Continue stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) 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). -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()

View file

@ -206,8 +206,8 @@ runApplication application = do
maxHistorySizeTVar <- STM.newTVarIO @Int 1000 maxHistorySizeTVar <- STM.newTVarIO @Int 1000
fitParametersTVar <- STM.newTVarIO @FitParameters $ fitParametersTVar <- STM.newTVarIO @FitParameters $
FitParameters FitParameters
{ maxSubdiv = 0 --5 --2 --3 -- 6 { maxSubdiv = 2 --5 --2 --3 -- 6
, nbSegments = 1 --5 , nbSegments = 3
, dist_tol = 5e-3 , dist_tol = 5e-3
, t_tol = 1e-4 , t_tol = 1e-4
, maxIters = 20 , maxIters = 20
@ -217,7 +217,7 @@ runApplication application = do
NewtonRaphson NewtonRaphson
{ maxIters = 20, precision = 8 } { maxIters = 20, precision = 8 }
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $ cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
Nothing --Just defaultRootIsolationOptions Just defaultRootIsolationOptions
-- Put all these stateful variables in a record for conciseness. -- Put all these stateful variables in a record for conciseness.
let let

View file

@ -35,8 +35,13 @@ data ColourRecord a
, pointHover, pointSelected , pointHover, pointSelected
, viewport, viewportScrollbar, tabScrollbar , viewport, viewportScrollbar, tabScrollbar
, guide, rulerBg, rulerTick, magnifier, glass , 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 ) deriving stock ( Show, Functor, Foldable, Traversable )
newtype ColourName newtype ColourName
@ -76,6 +81,8 @@ colourNames = Colours
, glass = ColourName "glass" , glass = ColourName "glass"
, selected = ColourName "selected" , selected = ColourName "selected"
, selectedOutline = ColourName "selectedOutline" , selectedOutline = ColourName "selectedOutline"
, brushWidget = ColourName "brushWidget"
, brushWidgetHover = ColourName "brushWidgetHover"
} }
type Colours = ColourRecord GDK.RGBA type Colours = ColourRecord GDK.RGBA

View file

@ -54,7 +54,7 @@ import MetaBrush.Document.Draw
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..) ) ( DocumentHistory(..) )
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( DragMoveSelect ) ( DragMoveSelect, BrushWidgetActionState )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBar, FileBarTab ) ( FileBar, FileBarTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
@ -135,16 +135,25 @@ data GuideAction
-- - start a rectangular selection, -- - start a rectangular selection,
-- - move objects by dragging, -- - move objects by dragging,
-- - draw a control point, -- - draw a control point,
-- - create/modify a guide. -- - create/modify a guide,
-- - modify brush parameters through a brush widget.
data HoldAction data HoldAction
= SelectionHold { holdStartPos :: !( 2 ) } = SelectionHold
| DragMoveHold { holdStartPos :: !( 2 ) { holdStartPos :: !( 2 ) }
, dragAction :: !DragMoveSelect | DragMoveHold
} { holdStartPos :: !( 2 )
| DrawHold { holdStartPos :: !( 2 ) } , dragAction :: !DragMoveSelect
| GuideAction { holdStartPos :: !( 2 ) }
, guideAction :: !GuideAction | DrawHold
} { holdStartPos :: !( 2 ) }
| GuideAction
{ holdStartPos :: !( 2 )
, guideAction :: !GuideAction
}
| BrushWidgetAction
{ holdStartPos :: !( 2 )
, brushWidgetAction :: !BrushWidgetActionState
}
deriving stock Show deriving stock Show
-- | Keep track of a path that is in the middle of being drawn. -- | Keep track of a path that is in the middle of being drawn.

View file

@ -2,12 +2,14 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Document.Selection module MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode, pressingControl
, selectAt, selectRectangle , selectAt, selectRectangle
, DragMoveSelect(.., PointDrag), dragMoveSelect , DragMoveSelect(.., PointDrag), dragMoveSelect
, UpdateInfo(..) , UpdateInfo(..)
, translateSelection, deleteSelected , translateSelection, deleteSelected
, dragUpdate , dragUpdate
, BrushWidgetActionState(..)
, applyBrushWidgetAction
) )
where where
@ -21,7 +23,7 @@ import Data.Functor
import Data.Functor.Identity import Data.Functor.Identity
( runIdentity ) ( runIdentity )
import Data.Maybe import Data.Maybe
( catMaybes ) ( catMaybes, listToMaybe )
import Data.Monoid import Data.Monoid
( Sum(..) ) ( Sum(..) )
import Data.Semigroup import Data.Semigroup
@ -97,6 +99,15 @@ import Math.Module
( Module, lerp, squaredNorm, closestPointOnSegment ) ( Module, lerp, squaredNorm, closestPointOnSegment )
import Math.Linear import Math.Linear
( Segment(..), (..), T(..) ) ( 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 import {-# SOURCE #-} MetaBrush.Context
( Modifier(..) ) ( Modifier(..) )
import MetaBrush.Document import MetaBrush.Document
@ -108,6 +119,10 @@ import MetaBrush.Document
) )
import {-# SOURCE #-} MetaBrush.Document.Update import {-# SOURCE #-} MetaBrush.Document.Update
( DocChange(..) ) ( DocChange(..) )
import MetaBrush.Records
( Record
, Intersection(..), intersect
)
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
import MetaBrush.Util import MetaBrush.Util
@ -137,6 +152,11 @@ selectionMode = foldMap \case
Shift _ -> Add Shift _ -> Add
_ -> New _ -> New
pressingControl :: Foldable f => f Modifier -> Bool
pressingControl = any \case
Control {} -> True
_ -> False
-- | Updates the selected objects on a single click selection event. -- | Updates the selected objects on a single click selection event.
selectAt :: SelectionMode -> 2 -> Document -> Document selectAt :: SelectionMode -> 2 -> Document -> Document
selectAt selMode c doc@( Document { zoomFactor } ) = selectAt selMode c doc@( Document { zoomFactor } ) =
@ -439,7 +459,7 @@ translateSelection t doc =
| not strokeVisible | not strokeVisible
= pure oldSpline = pure oldSpline
| otherwise | otherwise
= bitraverseSpline = bitraverseSpline
( const $ updateSplineCurve ( splineStart oldSpline ) ) ( const $ updateSplineCurve ( splineStart oldSpline ) )
( updatePoint PathPoint ) ( updatePoint PathPoint )
oldSpline oldSpline
@ -533,7 +553,7 @@ deleteSelected doc =
updateSpline updateSpline
:: forall clo brushParams :: forall clo brushParams
. KnownSplineType clo . KnownSplineType clo
=> StrokeSpline clo brushParams => StrokeSpline clo brushParams
-> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams ) -> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams )
updateSpline oldSpline updateSpline oldSpline
| not strokeVisible | not strokeVisible
@ -816,3 +836,178 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
dragSegmentParameter dragSegmentParameter
p p
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat ) 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 , RootSolvingAlgorithm
) )
import Math.Linear import Math.Linear
( (..), T(..) ( (..), T(..), Segment(..)
, rotate , rotate
) )
import Math.Module import Math.Module
@ -88,6 +88,8 @@ import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) ) ( Colours, ColourRecord(..) )
import MetaBrush.Brush import MetaBrush.Brush
( NamedBrush(..), WithParams(..) ) ( NamedBrush(..), WithParams(..) )
import qualified MetaBrush.Brush.Widget as Brush
( Widget(..), WidgetElements(..), widgetElements )
import MetaBrush.Context import MetaBrush.Context
( Modifier(..) ( Modifier(..)
, HoldAction(..), PartialPath(..) , HoldAction(..), PartialPath(..)
@ -125,7 +127,8 @@ import MetaBrush.GTK.Util
data Renders a data Renders a
= Renders = Renders
{ renderStrokes, renderPath, renderDebug, renderBrushes { renderStrokes, renderPath, renderDebug
, renderBrushes, renderBrushWidgets
, renderCLines, renderCPts, renderPPts :: a , renderCLines, renderCPts, renderPPts :: a
} }
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 ) deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
@ -261,7 +264,7 @@ data StrokeRenderData where
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) } => { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
-> StrokeRenderData -> StrokeRenderData
StrokeWithOutlineRenderData StrokeWithOutlineRenderData
:: forall pointParams clo :: forall pointParams clo brushFields
. ( KnownSplineType clo, Show pointParams, NFData pointParams ) . ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) => { strokeDataSpline :: !( StrokeSpline clo pointParams )
, strokeOutlineData :: !( Either , strokeOutlineData :: !( Either
@ -271,6 +274,7 @@ data StrokeRenderData where
, [ Cusp ] , [ Cusp ]
) )
, strokeBrushFunction :: pointParams -> SplinePts Closed , strokeBrushFunction :: pointParams -> SplinePts Closed
, strokeWidgetData :: ( Brush.Widget brushFields, pointParams -> Record brushFields )
} }
-> StrokeRenderData -> StrokeRenderData
@ -285,7 +289,8 @@ instance NFData StrokeRenderData where
-- - If the stroke has an associated brush, this consists of: -- - If the stroke has an associated brush, this consists of:
-- - the path that the brush follows, -- - the path that the brush follows,
-- - the computed outline (using fitting algorithm), -- - 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. -- - Otherwise, this consists of the underlying spline path only.
strokeRenderData strokeRenderData
:: RootSolvingAlgorithm :: RootSolvingAlgorithm
@ -301,7 +306,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
} }
) | strokeVisible ) | strokeVisible
= Just $ case strokeBrush of = Just $ case strokeBrush of
Just ( NamedBrush { brushFunction = fn } ) Just ( NamedBrush { brushFunction = fn, brushWidget = widget } )
| WithParams | WithParams
{ defaultParams = brush_defaults { defaultParams = brush_defaults
, withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } ) , withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } )
@ -311,10 +316,10 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
-- the collection of parameters expected by the brush. -- the collection of parameters expected by the brush.
case intersect @pointFields @brushFields of case intersect @pointFields @brushFields of
Intersection Intersection
{ inject { inject2
, project = toUsedParams :: Record pointFields -> Record usedFields } , project1 = toUsedParams :: Record pointFields -> Record usedFields }
-> do -> do
let embedUsedParams = inject brush_defaults let embedUsedParams = inject2 brush_defaults
-- Compute the outline using the brush function. -- Compute the outline using the brush function.
( outline, fitPts, cusps ) <- ( outline, fitPts, cusps ) <-
@ -339,6 +344,8 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
cosθ = cos θ cosθ = cos θ
sinθ = sin θ sinθ = sin θ
in fmap ( unT . rotate cosθ sinθ . T ) shape in fmap ( unT . rotate cosθ sinθ . T ) shape
, strokeWidgetData =
( widget, \ params -> embedUsedParams $ toUsedParams params )
} }
_ -> pure $ _ -> pure $
StrokeRenderData StrokeRenderData
@ -353,10 +360,19 @@ renderStroke
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
StrokeRenderData { strokeDataSpline } -> StrokeRenderData { strokeDataSpline } ->
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) 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 renderStrokeSpline cols mode rdrMode mbHoverContext zoom
( when ( mode == BrushMode ) ( 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 strokeDataSpline
*> Compose blank *> Compose blank
@ -445,10 +461,11 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
renderBrushShape renderBrushShape
:: Colours -> Maybe HoverContext -> Double :: Colours -> Maybe HoverContext -> Double
-> ( brushParams -> SplinePts Closed ) -> ( pointParams -> SplinePts Closed )
-> PointData brushParams -> Brush.WidgetElements
-> PointData pointParams
-> Compose Renders Cairo.Render () -> Compose Renders Cairo.Render ()
renderBrushShape cols mbHoverContext zoom brushFn pt = renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
let let
x, y :: Double x, y :: Double
2 x y = coords pt 2 x y = coords pt
@ -462,6 +479,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt =
Cairo.translate x y Cairo.translate x y
*> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () ) *> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
( fmap ( \ p -> PointData p Normal () ) brushPts ) ( fmap ( \ p -> PointData p Normal () ) brushPts )
*> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
*> toAll Cairo.restore *> toAll Cairo.restore
drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render () drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
@ -742,6 +760,49 @@ drawCross ( Colours {..} ) zoom = do
Cairo.restore 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 :: Double -> Double -> Double -> ( Double, Double, Double )
hsl2rgb h s l = case hc2rgb h c of hsl2rgb h s l = case hc2rgb h c of
( r, g, b ) -> ( r + m, g + m, b + m ) ( r, g, b ) -> ( r + m, g + m, b + m )

View file

@ -39,6 +39,8 @@ import Math.Ring
-- MetaBrush -- MetaBrush
import MetaBrush.Brush import MetaBrush.Brush
( NamedBrush(..), SomeBrush(..), WithParams(..) ) ( NamedBrush(..), SomeBrush(..), WithParams(..) )
import qualified MetaBrush.Brush.Widget as Brush
( Widget(..) )
import MetaBrush.Records import MetaBrush.Records
( Record(MkR) ) ( Record(MkR) )
@ -60,7 +62,12 @@ brushes = HashMap.fromList
type CircleBrushFields = '[ "r" ] type CircleBrushFields = '[ "r" ]
-- | A circular brush with the given radius. -- | A circular brush with the given radius.
circle :: NamedBrush CircleBrushFields circle :: NamedBrush CircleBrushFields
circle = NamedBrush "circle" ( WithParams deflts $ coerce circleBrush ) circle =
NamedBrush
{ brushName = "circle"
, brushFunction = WithParams deflts $ coerce circleBrush
, brushWidget = Brush.SquareWidget
}
where where
deflts :: Record CircleBrushFields deflts :: Record CircleBrushFields
deflts = MkR ( 1 1 ) 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 -- | An elliptical brush with the given semi-major and semi-minor axes and
-- angle of rotation. -- angle of rotation.
ellipse :: NamedBrush EllipseBrushFields ellipse :: NamedBrush EllipseBrushFields
ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush ) ellipse =
NamedBrush
{ brushName = "ellipse"
, brushFunction = WithParams deflts $ coerce ellipseBrush
, brushWidget = Brush.RotatableRectangleWidget
}
where where
deflts :: Record EllipseBrushFields deflts :: Record EllipseBrushFields
deflts = MkR ( 3 1 1 0 ) deflts = MkR ( 3 1 1 0 )
@ -79,7 +91,12 @@ ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
type TearDropBrushFields = '[ "w", "h", "phi" ] type TearDropBrushFields = '[ "w", "h", "phi" ]
-- | A tear-drop shape with the given width, height and angle of rotation. -- | A tear-drop shape with the given width, height and angle of rotation.
tearDrop :: NamedBrush TearDropBrushFields 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 where
deflts :: Record TearDropBrushFields deflts :: Record TearDropBrushFields
deflts = MkR ( 3 1 2.25 0 ) deflts = MkR ( 3 1 2.25 0 )

View file

@ -42,8 +42,6 @@ import qualified Data.Text as Text
-- brush-strokes -- brush-strokes
import Calligraphy.Brushes import Calligraphy.Brushes
( Brush(..) ) ( Brush(..) )
import Math.Bezier.Spline
( SplineType(Closed), Spline )
import Math.Differentiable import Math.Differentiable
( DiffInterp ) ( DiffInterp )
import Math.Interval import Math.Interval
@ -51,6 +49,8 @@ import Math.Interval
import Math.Linear import Math.Linear
-- MetaBrush -- MetaBrush
import qualified MetaBrush.Brush.Widget as Brush
( Widget )
import MetaBrush.Records import MetaBrush.Records
( KnownSymbols, Length, Record ) ( KnownSymbols, Length, Record )
import MetaBrush.Serialisable import MetaBrush.Serialisable
@ -77,19 +77,22 @@ type NamedBrush :: [ Symbol ] -> Type
data NamedBrush brushFields where data NamedBrush brushFields where
NamedBrush NamedBrush
:: forall brushFields :: forall brushFields
. ( KnownSymbols brushFields, Typeable brushFields . ( KnownSymbols brushFields
, Representable Double ( ( Length brushFields ) ) , Representable Double ( ( Length brushFields ) )
, DiffInterp 2 () ( ( Length brushFields ) ) , DiffInterp 2 () ( ( Length brushFields ) )
, DiffInterp 3 𝕀 ( ( Length brushFields ) ) , DiffInterp 3 𝕀 ( ( Length brushFields ) )
) )
=> { brushName :: !Text => { brushName :: !Text
, brushFunction :: BrushFunction brushFields , brushFunction :: !( BrushFunction brushFields )
, brushWidget :: !( Brush.Widget brushFields )
} }
-> NamedBrush brushFields -> NamedBrush brushFields
data SomeBrush where data SomeBrush where
SomeBrush SomeBrush
:: { someBrush :: !( NamedBrush brushFields ) } :: forall brushFields
. KnownSymbols brushFields
=> { someBrush :: !( NamedBrush brushFields ) }
-> SomeBrush -> SomeBrush
instance Show ( NamedBrush brushFields ) where instance Show ( NamedBrush brushFields ) where
@ -102,9 +105,11 @@ instance NFData ( NamedBrush brushFields ) where
rnf ( NamedBrush { brushName } ) rnf ( NamedBrush { brushName } )
= rnf brushName = rnf brushName
instance Eq ( NamedBrush brushFields ) where instance Eq ( NamedBrush brushFields ) where
NamedBrush name1 _ == NamedBrush name2 _ = name1 == name2 NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 }
= name1 == name2
instance Ord ( NamedBrush brushFields ) where 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 instance Hashable ( NamedBrush brushFields ) where
hashWithSalt salt ( NamedBrush { brushName } ) = hashWithSalt salt ( NamedBrush { brushName } ) =
hashWithSalt salt 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, (^+^), (^-^), (*^) ) ( origin, (^+^), (^-^), (*^) )
, Inner((^.^)) , Inner((^.^))
, squaredNorm, quadrance , squaredNorm, quadrance
, closestPointOnSegment
) )
import Math.Linear import Math.Linear
( (..), T(..) ) ( (..), T(..), Segment(..) )
import MetaBrush.Brush import MetaBrush.Brush
( NamedBrush, PointFields ) ( NamedBrush, PointFields )
import MetaBrush.Records import MetaBrush.Records
@ -298,6 +299,17 @@ instance Hoverable ( 2 ) where
| otherwise | otherwise
= Normal = 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 class HasSelection pt where
_selection :: Lens' pt FocusState _selection :: Lens' pt FocusState
instance HasSelection ( PointData brushParams ) where instance HasSelection ( PointData brushParams ) where

View file

@ -162,7 +162,7 @@ type family Length xs where
Length ( _ : xs ) = 1 + Length xs Length ( _ : xs ) = 1 + Length xs
type KnownSymbols :: [ Symbol ] -> Constraint type KnownSymbols :: [ Symbol ] -> Constraint
class KnownSymbols ks where class Typeable ks => KnownSymbols ks where
knownSymbols :: [ Text ] knownSymbols :: [ Text ]
instance KnownSymbols '[] where instance KnownSymbols '[] where
knownSymbols = [] knownSymbols = []
@ -176,8 +176,7 @@ instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where
{-# INLINE intersect #-} {-# INLINE intersect #-}
intersect :: forall r1 r2 l1 l2 intersect :: forall r1 r2 l1 l2
. ( Typeable r1, Typeable r2 . ( KnownSymbols r1, KnownSymbols r2
, KnownSymbols r1, KnownSymbols r2
, l1 ~ Length r1, l2 ~ Length r2 , l1 ~ Length r1, l2 ~ Length r2
, Representable Double ( l1 ) , Representable Double ( l1 )
, Representable Double ( l2 ) , Representable Double ( l2 )
@ -189,16 +188,22 @@ intersect
-- Shortcut when the two rows are equal. -- Shortcut when the two rows are equal.
| Just Refl <- eqT @r1 @r2 | Just Refl <- eqT @r1 @r2
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 ) , Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
= Intersection { project = id, inject = \ _ -> id } = Intersection { project1 = id, project2 = id, inject1 = \ _ -> id, inject2 = \ _ -> id }
| otherwise | otherwise
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs -> = doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
let let
project :: Record r1 -> Record r1r2 project1 :: Record r1 -> Record r1r2
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1 project1 = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
inject :: Record r2 -> Record r1r2 -> Record r2 project2 :: Record r2 -> Record r1r2
inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2 project2 = \ ( MkR r2 ) -> MkR $ projection ( (!) r2_idxs ) r2
in Intersection { project, inject }
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 data Intersection r1 r2 where
Intersection Intersection
@ -209,10 +214,16 @@ data Intersection r1 r2 where
, Differentiable 2 () ( l12 ) , Differentiable 2 () ( l12 )
, Differentiable 3 𝕀 ( l12 ) , Differentiable 3 𝕀 ( l12 )
) )
=> { project :: Record r1 -> Record r1r2 => { project1 :: Record r1 -> Record r1r2
-- ^ project out fields present in both rows -- ^ project out fields present in both rows
-- (linear non-decreasing mapping) -- (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 -- ^ overrides the components of the first record with the second
-- (linear non-decreasing mapping in its second argument) -- (linear non-decreasing mapping in its second argument)
} -> Intersection r1 r2 } -> Intersection r1 r2