subdivide paths by double-clicking on them

* still WIP:
    - path mode: does not correctly interpolate brushes
    - brush mode: does not propagate subdivision to other brushes
This commit is contained in:
sheaf 2020-09-06 04:43:28 +02:00
parent 9a2f123895
commit 3660cb8dce
4 changed files with 246 additions and 54 deletions

View file

@ -112,6 +112,7 @@ executable MetaBrush
, MetaBrush.Document.Guide
, MetaBrush.Document.Selection
, MetaBrush.Document.Serialise
, MetaBrush.Document.SubdivideStroke
, MetaBrush.Event
, MetaBrush.Render.Document
, MetaBrush.Time

View file

@ -107,6 +107,8 @@ import MetaBrush.Document.Selection
)
import MetaBrush.Document.Serialise
( saveDocument, loadDocument )
import MetaBrush.Document.SubdivideStroke
( subdivide )
import MetaBrush.UI.Coordinates
( toViewportCoordinates )
import MetaBrush.UI.InfoBar
@ -564,14 +566,19 @@ data ActionOrigin
| RulerOrigin Ruler
deriving stock Show
data MouseClick = MouseClick ActionOrigin Word32 ( Point2D Double )
data MouseClickType
= SingleClick
| DoubleClick
deriving stock Show
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
deriving stock Show
instance HandleAction MouseClick where
handleAction
uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} )
( MouseClick actionOrigin button mouseClickCoords )
( MouseClick actionOrigin ty button mouseClickCoords )
= case button of
-- Left mouse button.
@ -587,51 +594,69 @@ instance HandleAction MouseClick where
STM.writeTVar mousePosTVar ( Just pos )
case actionOrigin of
ViewportOrigin -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect mode pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
pure ( UpdateDocTo $ Just newDoc )
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
ViewportOrigin -> case ty of
-- Pen tool: start or continue a drawing operation.
Pen -> 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
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
pure ( UpdateDocTo $ Just newDoc )
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just newDoc <- dragMoveSelect mode pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
pure ( UpdateDocTo $ Just newDoc )
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
-- Pen tool: start or continue a drawing operation.
Pen -> 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
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
pure ( UpdateDocTo $ Just newDoc )
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
Selection -> do
STM.writeTVar mouseHoldTVar Nothing
let
mbSubdivide :: Maybe Document
mbSubdivide = subdivide mode pos doc
case mbSubdivide of
Nothing -> pure Don'tModifyDoc
Just newDoc -> pure ( UpdateDocTo $ Just newDoc )
-- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc
RulerOrigin ruler -> do
let
@ -717,11 +742,10 @@ instance HandleAction MouseRelease where
&& x <= viewportWidth
&& y <= viewportHeight
pure ( UpdateDocTo ( Just newDoc ) )
_ -> do
_ -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
Selection -> do

View file

@ -0,0 +1,156 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.SubdivideStroke
( subdivide )
where
-- base
import Data.Semigroup
( Min(..), Arg(..) )
-- acts
import Data.Act
( Act(()) )
-- containers
import Data.Sequence
( Seq(..) )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- groups
import Data.Group
( invert )
-- transformers
import Control.Monad.Trans.State.Strict
( State, runState, put )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint, subdivide )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint, subdivide )
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Module
( quadrance, closestPointToSegment )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..) )
import MetaBrush.UI.ToolBar
( Mode(..) )
--------------------------------------------------------------------------------
-- | Subdivide a path at the given center, provided a path indeed lies there.
subdivide :: Mode -> Point2D Double -> Document -> Maybe Document
subdivide mode c doc@( Document { zoomFactor } )
| subdivOccurred
= Just updatedDoc
| otherwise
= Nothing
where
updatedDoc :: Document
subdivOccurred :: Bool
( updatedDoc, subdivOccurred ) = ( `runState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } )
| Brush <- mode
= ( field' @"strokePoints" . traverse )
( \ spt ->
( field' @"pointData" . field' @"brushShape" )
( subdivideStroke strokeVisible ( MkVector2D $ coords spt ) )
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( subdivideStroke strokeVisible ( Vector2D 0 0 ) )
stroke
subdivideStroke
:: forall pt
. Show pt
=> Bool
-> Vector2D Double
-> Seq ( StrokePoint pt )
-> State Bool ( Seq ( StrokePoint pt ) )
subdivideStroke False _ pts = pure pts
subdivideStroke True _ Empty = pure Empty
subdivideStroke True offset ( spt :<| spts ) = go spt spts
where
go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State Bool ( Seq ( StrokePoint pt ) )
go sp0 Empty = pure ( sp0 :<| Empty )
-- Line.
go sp0 ( sp1 :<| sps )
| PathPoint {} <- sp1
, let
p0, p1, s :: Point2D Double
p0 = coords sp0
p1 = coords sp1
s = closestPointToSegment @( Vector2D Double ) ( invert offset c ) p0 p1
sqDist :: Double
sqDist = quadrance @( Vector2D Double ) c ( offset s )
= if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then do
put True
-- TODO: interpolate brush instead of using these arbitrary intermediate points
pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
else ( sp0 :<| ) <$> go sp1 sps
-- Quadratic Bézier curve.
go sp0 ( sp1 :<| sp2 :<| sps )
| ControlPoint {} <- sp1
, PathPoint {} <- sp2
, let
p0, p1, p2, s :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier {..}
sqDist :: Double
Min ( Arg sqDist ( t, s ) )
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset c )
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then case Quadratic.subdivide @( Vector2D Double ) bez t of
( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do
put True
-- TODO: interpolate brush instead of using these arbitrary intermediate points
pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
-- Cubic Bézier curve.
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
| ControlPoint {} <- sp1
, ControlPoint {} <- sp2
, PathPoint {} <- sp3
, let
p0, p1, p2, p3, s :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier {..}
Min ( Arg sqDist ( t, s ) )
= Cubic.closestPoint @( Vector2D Double ) bez ( invert offset c )
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then case Cubic.subdivide @( Vector2D Double ) bez t of
( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
put True
-- TODO: interpolate brush instead of using these arbitrary intermediate points
pure
( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
:<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
)
else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )

View file

@ -1,3 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
@ -9,6 +10,8 @@ module MetaBrush.Event
-- base
import Control.Monad
( void )
import Data.Foldable
( for_ )
-- gi-gdk
import qualified GI.Gdk as GDK
@ -22,7 +25,7 @@ import Math.Vector2D
import MetaBrush.Action
( HandleAction(..)
, ActionOrigin(..)
, MouseMove(..), MouseClick(..), MouseRelease(..)
, MouseMove(..), MouseClick(..), MouseClickType(..), MouseRelease(..)
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
, quitEverything
)
@ -80,11 +83,19 @@ handleScrollEvent elts vars eventOrigin scrollEvent = do
handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
button <- GDK.getEventButtonButton mouseClickEvent
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( MouseClick eventOrigin button mousePos )
ty <- GDK.getEventButtonType mouseClickEvent
let
mbClick :: Maybe MouseClickType
mbClick = case ty of
GDK.EventTypeButtonPress -> Just SingleClick
GDK.EventType2buttonPress -> Just DoubleClick
_ -> Nothing
for_ mbClick \ click -> do
button <- GDK.getEventButtonButton mouseClickEvent
x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( MouseClick eventOrigin click button mousePos )
pure False
handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool