diff --git a/MetaBrush.cabal b/MetaBrush.cabal index dc1acc6..20f019b 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 1ee0f40..7e87165 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs new file mode 100644 index 0000000..ac4bac7 --- /dev/null +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -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 ) ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index f17a1a3..dfc5bb6 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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