mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
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
parent
9a2f123895
commit
3660cb8dce
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
156
src/app/MetaBrush/Document/SubdivideStroke.hs
Normal file
156
src/app/MetaBrush/Document/SubdivideStroke.hs
Normal 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 ) )
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue