From eb8e7012aabbf1bb180a08ad6e79083053b0d2b3 Mon Sep 17 00:00:00 2001 From: sheaf Date: Fri, 18 Sep 2020 11:40:14 +0200 Subject: [PATCH] curve dragging support --- .gitignore | 2 + app/Main.hs | 3 +- src/app/MetaBrush/Action.hs | 56 +-- src/app/MetaBrush/Context.hs | 8 +- src/app/MetaBrush/Context.hs-boot | 10 +- src/app/MetaBrush/Document/Selection.hs | 424 +++++++++++++++--- src/app/MetaBrush/Document/SubdivideStroke.hs | 5 +- src/app/MetaBrush/Document/Update.hs-boot | 36 ++ src/app/MetaBrush/Render/Document.hs | 23 +- src/app/MetaBrush/UI/Coordinates.hs | 2 +- src/app/MetaBrush/UI/ToolBar.hs-boot | 4 + src/lib/Math/Module.hs | 8 +- 12 files changed, 474 insertions(+), 107 deletions(-) create mode 100644 src/app/MetaBrush/Document/Update.hs-boot diff --git a/.gitignore b/.gitignore index a6d1196..8b33153 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,5 @@ files/ *.html hie.yaml *.mb +*.prof +*.eventlog diff --git a/app/Main.hs b/app/Main.hs index a802985..23e806e 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -333,6 +333,7 @@ main = do viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do + modifiers <- STM.readTVar modifiersTVar mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar mbPartialPath <- STM.readTVar partialPathTVar @@ -343,7 +344,7 @@ main = do pure do renderDocument colours fitParameters mode debug ( viewportWidth, viewportHeight ) - mbMousePos mbHoldAction mbPartialPath + modifiers mbMousePos mbHoldAction mbPartialPath doc renderRuler colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight ) diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index a52f525..a1755ca 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -108,9 +108,10 @@ import MetaBrush.Document.History import MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle - , dragMoveSelect + , DragMoveSelect(..), dragMoveSelect , UpdateInfo(..) - , translateSelection, deleteSelected + , deleteSelected + , dragUpdate ) import MetaBrush.Document.Serialise ( saveDocument, loadDocument ) @@ -695,10 +696,16 @@ instance HandleAction MouseClick where case selectionMode modifiers of -- Drag move: not holding shift or alt, click has selected something. New - | Just newDoc <- dragMoveSelect mode pos doc + | Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc -> do - STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) - pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) + STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) + case dragMove of + ClickedOnSelected -> + pure Don'tModifyDoc + ClickedOnUnselected -> + pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) + ClickedOnCurve {} -> + pure Don'tModifyDoc -- Rectangular selection. _ -> do STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) @@ -860,8 +867,8 @@ instance HandleAction MouseRelease where && y <= viewportHeight _ -> do - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar + tool <- STM.readTVar toolTVar + mode <- STM.readTVar modeTVar case tool of Selection -> do @@ -870,35 +877,14 @@ instance HandleAction MouseRelease where selMode = selectionMode modifiers case mbHoldPos of Just hold - | DragMoveHold pos0 <- hold + | DragMoveHold { holdStartPos = pos0, dragAction } <- hold , pos0 /= pos - -> do - let - vec :: Vector2D Double - vec = pos0 --> pos - newDocument :: Document - updateInfo :: UpdateInfo - ( newDocument, updateInfo ) = translateSelection mode vec doc - case updateInfo of - UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } - | null strokesAffected - -> pure Don'tModifyDoc - | let - ppMv, cpMv, changeText :: Text - ppMv - | pathPointsAffected == 0 - = "" - | otherwise - = Text.pack ( show pathPointsAffected ) <> " path points" - cpMv - | controlPointsAffected == 0 - = "" - | otherwise - = Text.pack ( show controlPointsAffected ) <> " control points" - changeText = - "Translate " <> Text.intercalate " and" [ ppMv, cpMv ] - <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes" - -> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} ) + -> let + alternateMode :: Bool + alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers + in case dragUpdate mode pos0 pos dragAction alternateMode doc of + Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) + Nothing -> pure Don'tModifyDoc | SelectionHold pos0 <- hold , pos0 /= pos -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc ) diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 2e39796..3eb0d60 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -39,6 +39,8 @@ import MetaBrush.Document.Draw ( DrawAnchor ) import MetaBrush.Document.History ( DocumentHistory(..) ) +import MetaBrush.Document.Selection + ( DragMoveSelect ) import {-# SOURCE #-} MetaBrush.UI.FileBar ( FileBar ) import {-# SOURCE #-} MetaBrush.UI.InfoBar @@ -119,11 +121,13 @@ data GuideAction -- -- - start a rectangular selection, -- - move objects by dragging, --- - drawing a control point, +-- - draw a control point, -- - create/modify a guide. data HoldAction = SelectionHold { holdStartPos :: !( Point2D Double ) } - | DragMoveHold { holdStartPos :: !( Point2D Double ) } + | DragMoveHold { holdStartPos :: !( Point2D Double ) + , dragAction :: !DragMoveSelect + } | DrawHold { holdStartPos :: !( Point2D Double ) } | GuideAction { holdStartPos :: !( Point2D Double ) , guideAction :: !GuideAction diff --git a/src/app/MetaBrush/Context.hs-boot b/src/app/MetaBrush/Context.hs-boot index 2f4046a..c3a2481 100644 --- a/src/app/MetaBrush/Context.hs-boot +++ b/src/app/MetaBrush/Context.hs-boot @@ -1,5 +1,6 @@ module MetaBrush.Context - ( UIElements, Variables ) + ( UIElements, Variables + , Modifier(..), LR(..) ) where -------------------------------------------------------------------------------- @@ -7,3 +8,10 @@ module MetaBrush.Context data UIElements data Variables + +data LR = L | R + +data Modifier + = Control LR + | Alt LR + | Shift LR diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 0b3d0b5..0704b71 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -5,28 +5,42 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module MetaBrush.Document.Selection ( SelectionMode(..), selectionMode , selectAt, selectRectangle - , DragMoveSelect(..), dragMoveSelect + , DragMoveSelect(.., PointDrag), dragMoveSelect , UpdateInfo(..) , translateSelection, deleteSelected + , dragUpdate ) where -- base import Control.Category ( (>>>) ) +import Control.Monad + ( guard ) import Data.Functor ( ($>) ) import Data.Functor.Identity ( runIdentity ) +import Data.Maybe + ( catMaybes ) import Data.Monoid ( Sum(..) ) +import Data.Semigroup + ( Arg(..), Min(..) ) +import GHC.Exts + ( dataToTag#, (>#), (<#), isTrue# ) import GHC.Generics ( Generic ) @@ -52,6 +66,10 @@ import Data.Generics.Product.Fields import Data.Generics.Product.Typed ( HasType ) +-- groups +import Data.Group + ( invert ) + -- lens import Control.Lens ( view, set, over, mapped ) @@ -64,6 +82,12 @@ import qualified Control.Monad.Trans.Tardis as Tardis , getPast, getFuture, sendPast, sendFuture ) +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( intercalate, pack ) + -- transformers import Control.Monad.Trans.Class ( lift ) @@ -71,21 +95,29 @@ import Control.Monad.Trans.State.Strict ( StateT(..), State, runState, evalState , get, put, modify ) +import Control.Monad.Trans.Writer.CPS + ( WriterT, runWriterT, tell ) -- MetaBrush +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..), closestPoint, fromQuadratic, drag ) +import qualified Math.Bezier.Quadratic as Quadratic + ( Bezier(..), closestPoint, interpolate ) import Math.Bezier.Stroke ( StrokePoint(..) ) import Math.Module - ( squaredNorm ) + ( squaredNorm, closestPointToSegment ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) -import MetaBrush.Context +import {-# SOURCE #-} MetaBrush.Context ( Modifier(..) ) import MetaBrush.Document ( Document(..), Stroke(..) , FocusState(..), _selection ) -import MetaBrush.UI.ToolBar +import {-# SOURCE #-} MetaBrush.Document.Update + ( DocChange(..) ) +import {-# SOURCE #-} MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Unique ( Unique ) @@ -161,35 +193,54 @@ selectAt mode selMode c doc@( Document { zoomFactor } ) = -- | Type of a drag move selection: -- --- - user initiated drag by clicking on an already selected item: selection is preserved; --- - user initiated drag by clicking on an unselected item: select this item and deselect the previous selection. +-- - user initiated drag by clicking on an unselected point: select this point and deselect the previous selection, +-- - user initiated drag by clicking on an already selected point: selection is preserved; +-- - user initiated drag by clicking on an interior point of a curve: start a curve drag, selection is preserved. data DragMoveSelect = ClickedOnSelected | ClickedOnUnselected + | ClickedOnCurve + { dragStrokeUnique :: !Unique + , dragSegmentIndex :: !Int + , dragSegmentParameter :: !Double + , dragBrushCenter :: !( Maybe ( Point2D Double ) ) + } deriving stock Show +{-# COMPLETE PointDrag, ClickedOnCurve #-} +pattern PointDrag :: DragMoveSelect +pattern PointDrag <- ( ( \x -> isTrue# ( dataToTag# x <# 2# ) ) -> True ) + +instance Semigroup DragMoveSelect where + x <> y + | isTrue# ( dataToTag# x ># dataToTag# y ) + = y + | otherwise + = x + -- | Checks whether a mouse click can initiate a drag move event, -- and if so returns an updated document with the selection modified from the start of the drag move. -dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe Document +dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe ( DragMoveSelect, Document ) dragMoveSelect mode c doc@( Document { zoomFactor } ) = let - res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document + res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document res = do newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc - Tardis.getPast >>= Tardis.sendPast + lift $ Tardis.getPast >>= Tardis.sendPast pure newDoc - in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of - ( newDoc, ( _, Just _ ) ) -> Just newDoc - ( _ , ( _, Nothing ) ) -> Nothing + in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) . runWriterT $ res of + ( ( newDoc, Just dragMove ), _ ) + -> Just ( dragMove, newDoc ) + _ -> Nothing where - updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke - updateStroke stroke@( Stroke { strokeVisible } ) + updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) | Brush <- mode = ( field' @"strokePoints" . traverse ) ( \ spt -> ( field' @"pointData" . field' @"brushShape" ) - ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) ) + ( updateStrokePoints strokeVisible strokeUnique ( coords spt ) >>> fmap matchEndpoints ) spt @@ -197,49 +248,11 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) = stroke | otherwise = ( field' @"strokePoints" ) - ( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) ) + ( updateStrokePoints strokeVisible strokeUnique ( Point2D 0 0 ) >>> fmap matchEndpoints ) stroke - updatePoint - :: HasType FocusState pt - => Bool - -> Vector2D Double - -> StrokePoint pt - -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint pt ) - updatePoint isVisible offset pt - | selected - = do - mbPreviousSelect <- Tardis.getPast - case mbPreviousSelect of - -- Already clicked on a point: don't select further points. - Just _ -> pure pt - -- First click on a point: record this. - Nothing -> do - case view _selection pt of - Selected -> Tardis.sendFuture ( Just ClickedOnSelected ) - _ -> Tardis.sendFuture ( Just ClickedOnUnselected ) - -- Select this point (whether it was previously selected or not). - pure $ set _selection Selected pt - | otherwise - = do - mbDragClick <- Tardis.getFuture - let - -- needs to be lazy - newPointState :: FocusState - newPointState - -- User clicked on a selected point: preserve _selection. - | Just ClickedOnSelected <- mbDragClick - = view _selection pt - -- User clicked on an unselected point, or not on a point at all: discard selection. - | otherwise - = Normal - pure ( set _selection newPointState pt ) - where - selected :: Bool - selected - | not isVisible = False - | otherwise = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 + -- Ensure consistency of selection at endpoints for closed loops. matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt ) matchEndpoints ( p0 :<| ( ps :|> pn ) ) @@ -247,6 +260,146 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) = = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn ) matchEndpoints ps = ps + updateStrokePoints + :: forall pt + . ( Show pt, HasType FocusState pt ) + => Bool + -> Unique + -> Point2D Double + -> Seq ( StrokePoint pt ) + -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) ) + updateStrokePoints _ _ _ Empty = pure Empty + updateStrokePoints isVisible uniq offset ( spt :<| spts ) = go 0 spt spts + where + inSelectionRange :: Point2D Double -> Bool + inSelectionRange p + | not isVisible = False + | otherwise = squaredNorm ( c --> ( MkVector2D offset • p ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 + go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) + -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) ) + go _ sp0 Empty = ( :<| Empty ) <$> updatePoint sp0 + -- Line. + go i sp0 ( sp1 :<| sps ) + | PathPoint {} <- sp1 + = do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + t :: Double + p :: Point2D Double + ( t, p ) + = closestPointToSegment @( Vector2D Double ) ( invert ( MkVector2D offset ) • c ) ( coords sp0 ) ( coords sp1 ) + guard ( inSelectionRange p ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } + } + tell mbCurveDrag + sp0' <- updatePoint sp0 + ( sp0' :<| ) <$> go ( i + 1 ) sp1 sps + -- Quadratic Bézier curve. + go i sp0 ( sp1 :<| sp2 :<| sps ) + | ControlPoint {} <- sp1 + , PathPoint {} <- sp2 + = do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + bez :: Quadratic.Bezier ( Point2D Double ) + bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) + = Quadratic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c ) + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } + } + tell mbCurveDrag + sp0' <- updatePoint sp0 + sp1' <- updatePoint sp1 + ( ( sp0' :<| ) . ( sp1' :<| ) ) <$> go ( i + 2 ) sp2 sps + -- Cubic Bézier curve. + go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) + | ControlPoint {} <- sp1 + , ControlPoint {} <- sp2 + , PathPoint {} <- sp3 + = do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do + let + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) + = Cubic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c ) + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } + } + tell mbCurveDrag + sp0' <- updatePoint sp0 + sp1' <- updatePoint sp1 + sp2' <- updatePoint sp2 + ( ( sp0' :<| ) . ( sp1' :<| ) . ( sp2' :<| ) ) <$> go ( i + 3 ) sp3 sps + go _ sp0 sps = error ( "dragMoveSelect: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) + updatePoint + :: StrokePoint pt + -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( StrokePoint pt ) + updatePoint pt + | inSelectionRange ( coords pt ) + = do + mbPreviousSelect <- lift $ Tardis.getPast + case mbPreviousSelect of + -- Already clicked on a point: don't select further points. + Just dragSelect + | ClickedOnSelected <- dragSelect + -> pure pt + | ClickedOnUnselected <- dragSelect + -> pure pt + -- First click on a point: record this. + _ -> do + let + mbDrag :: Maybe DragMoveSelect + mbDrag = case view _selection pt of + Selected -> Just ClickedOnSelected + _ -> Just ClickedOnUnselected + lift $ Tardis.sendFuture mbDrag + tell mbDrag + -- Select this point (whether it was previously selected or not). + pure ( set _selection Selected pt ) + | otherwise + = do + mbDragClick <- lift $ Tardis.getFuture + let + -- needs to be lazy + newPointState :: FocusState + newPointState = case mbDragClick of + -- User clicked on a selected point or a curve segment: preserve selection. + Just dragMove + | ClickedOnSelected <- dragMove + -> view _selection pt + | ClickedOnCurve {} <- dragMove + -> view _selection pt + -- User clicked on an unselected point, or not on a point at all: discard selection. + _ -> Normal + pure ( set _selection newPointState pt ) + -- | Updates the selected objects on a rectangular selection event. selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) @@ -409,3 +562,164 @@ deleteSelected mode doc = deletionResult where selectionState :: FocusState selectionState = view _selection p + +-- | Perform a drag move action on a document. +dragUpdate :: Mode -> Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange +dragUpdate mode p0 p PointDrag _ doc = case updateInfo of + UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } + | null strokesAffected + -> Nothing + | let + ppMv, cpMv :: Maybe Text + ppMv + | pathPointsAffected == 0 + = Nothing + | otherwise + = Just ( Text.pack ( show pathPointsAffected ) <> " path points" ) + cpMv + | controlPointsAffected == 0 + = Nothing + | otherwise + = Just ( Text.pack ( show controlPointsAffected ) <> " control points" ) + changeText :: Text + changeText = + "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] ) + <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes" + -> Just ( HistoryChange { newDocument, changeText } ) + where + newDocument :: Document + updateInfo :: UpdateInfo + ( newDocument, updateInfo ) = translateSelection mode ( p0 --> p ) doc +dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc + | Just name <- mbStrokeName + , let + changeText :: Text + changeText = "Drag curve segment of " <> name + = Just ( HistoryChange { newDocument, changeText } ) + | otherwise + = Nothing + where + newDocument :: Document + mbStrokeName :: Maybe Text + ( newDocument, mbStrokeName ) + = ( `runState` Nothing ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + updateStroke :: Stroke -> State ( Maybe Text ) Stroke + updateStroke stroke@( Stroke { strokeUnique, strokeName } ) + | strokeUnique /= dragStrokeUnique + = pure stroke + | Brush <- mode + = ( field' @"strokePoints" . traverse ) + ( \ spt -> + if dragBrushCenter /= Just ( coords spt ) + then -- only update the correct brush path + pure spt + else + ( field' @"pointData" . field' @"brushShape" ) + ( updateStrokePoints strokeName ( MkVector2D $ coords spt ) ) + spt + ) + stroke + | otherwise + = ( field' @"strokePoints" ) + ( updateStrokePoints strokeName ( Vector2D 0 0 ) ) + stroke + updateStrokePoints + :: forall pt. Show pt + => Text -> Vector2D Double + -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) + updateStrokePoints _ _ Empty = pure Empty + updateStrokePoints name offset ( spt :<| spts ) = go 0 spt spts + where + p_eff :: Point2D Double + p_eff = invert offset • p + go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) + go _ sp0 Empty = pure ( sp0 :<| Empty ) + -- Line. + go i sp0 ( sp1 :<| sps ) + | PathPoint {} <- sp1 + = case compare i dragSegmentIndex of + GT -> pure ( sp0 :<| sp1 :<| sps ) + LT -> ( sp0 :<| ) <$> go ( i + 1 ) sp1 sps + EQ -> do + put ( Just name ) + if alternateMode + then + let + p1 :: Point2D Double + Quadratic.Bezier { p1 } = + Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp1 ) dragSegmentParameter p_eff + cp :: StrokePoint pt + cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate + in pure ( sp0 :<| cp :<| sp1 :<| sps ) + else + let + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier ( coords sp0 ) ( coords sp0 ) ( coords sp1 ) ( coords sp1 ) + p1, p2 :: Point2D Double + Cubic.Bezier { p1, p2 } = + Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff + cp1, cp2 :: StrokePoint pt + cp1 = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate + cp2 = ControlPoint { coords = p2, pointData = pointData sp1 } -- TODO: interpolate + in pure ( sp0 :<| cp1 :<| cp2 :<| sp1 :<| sps ) + -- Quadratic Bézier curve. + go i sp0 ( sp1 :<| sp2 :<| sps ) + | ControlPoint {} <- sp1 + , PathPoint {} <- sp2 + = case compare i dragSegmentIndex of + GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sps ) + LT -> ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go ( i + 2 ) sp2 sps + EQ -> do + put ( Just name ) + if not alternateMode -- switch alternate mode for quadratic Bézier case... + then + let + p1 :: Point2D Double + Quadratic.Bezier { p1 } = + Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p_eff + cp :: StrokePoint pt + cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate + in pure ( sp0 :<| cp :<| sp2 :<| sps ) + else + let + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.fromQuadratic @( Vector2D Double ) ( Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ) + p1, p2 :: Point2D Double + Cubic.Bezier { p1, p2 } = + Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff + cp1, cp2 :: StrokePoint pt + cp1 = sp1 { coords = p1 } -- TODO: interpolate + cp2 = sp1 { coords = p2 } -- TODO: interpolate + in pure ( sp0 :<| cp1 :<| cp2 :<| sp2 :<| sps ) + -- Cubic Bézier curve. + go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) + | ControlPoint {} <- sp1 + , ControlPoint {} <- sp2 + , PathPoint {} <- sp3 + = case compare i dragSegmentIndex of + GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| sps ) + LT -> ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go ( i + 3 ) sp3 sps + EQ -> do + put ( Just name ) + if alternateMode + then + let + p1 :: Point2D Double + Quadratic.Bezier { p1 } = + Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp3 ) dragSegmentParameter p_eff + cp :: StrokePoint pt + cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate + in pure ( sp0 :<| cp :<| sp3 :<| sps ) + else + let + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) + p1, p2 :: Point2D Double + Cubic.Bezier { p1, p2 } = + Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff + cp1, cp2 :: StrokePoint pt + cp1 = sp1 { coords = p1 } -- TODO: interpolate + cp2 = sp2 { coords = p2 } -- TODO: interpolate + in pure ( sp0 :<| cp1 :<| cp2 :<| sp3 :<| sps ) + go _ sp0 sps = error ( "dragUpdate: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index 8e16e69..557c684 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -102,12 +102,13 @@ subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdiv | PathPoint {} <- sp1 , let p0, p1, s :: Point2D Double + t :: Double p0 = coords sp0 p1 = coords sp1 - s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 + ( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 sqDist :: Double sqDist = quadrance @( Vector2D Double ) c ( offset • s ) - = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 then do put ( Just txt ) -- TODO: interpolate brush instead of using these arbitrary intermediate points diff --git a/src/app/MetaBrush/Document/Update.hs-boot b/src/app/MetaBrush/Document/Update.hs-boot new file mode 100644 index 0000000..affc419 --- /dev/null +++ b/src/app/MetaBrush/Document/Update.hs-boot @@ -0,0 +1,36 @@ +module MetaBrush.Document.Update + ( DocChange(..), DocumentUpdate(..) + , PureDocModification(..), DocModification(..) + ) +where + +-- text +import Data.Text + ( Text ) + +-- MetaBrush +import MetaBrush.Document + ( Document(..) ) + +-------------------------------------------------------------------------------- + +data DocChange + = TrivialChange { newDocument :: !Document } + | HistoryChange { newDocument :: !Document, changeText :: !Text } + +data DocumentUpdate + = CloseDocument + | SaveDocument !( Maybe FilePath ) + | UpdateDocumentTo !DocChange + +data PureDocModification + = Don'tModifyDoc + | UpdateDoc !DocumentUpdate + +data DocModification + = Don'tModifyDocAndThen + { postModifAction :: IO () } + | UpdateDocAndThen + { modifDocument :: !DocumentUpdate + , postModifAction :: IO () + } diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 2e8c1b0..2f9f306 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} @@ -45,6 +46,8 @@ import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq ( fromList ) +import Data.Set + ( Set ) -- generic-data import Generic.Data @@ -81,7 +84,9 @@ import Math.Vector2D import MetaBrush.Asset.Colours ( Colours, ColourRecord(..) ) import MetaBrush.Context - ( HoldAction(..), PartialPath(..) ) + ( Modifier(..) + , HoldAction(..), PartialPath(..) + ) import MetaBrush.Document ( Document(..), DocumentContent(..) , mkAABB @@ -91,7 +96,9 @@ import MetaBrush.Document , _selection ) import MetaBrush.Document.Selection - ( translateSelection ) + ( dragUpdate ) +import MetaBrush.Document.Update + ( DocChange(..) ) import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Util @@ -124,12 +131,12 @@ blankRender ( Colours {..} ) = pure () renderDocument :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 ) - -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath + -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Document -> Cairo.Render () renderDocument cols params mode debug ( viewportWidth, viewportHeight ) - mbMousePos mbHoldEvent mbPartialPath + modifiers mbMousePos mbHoldEvent mbPartialPath doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) = do @@ -150,10 +157,14 @@ renderDocument modifiedStrokes :: [ Stroke ] modifiedStrokes - | Just ( DragMoveHold p0 ) <- mbHoldEvent + | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent , Just p1 <- mbMousePos , p0 /= p1 - = strokes . documentContent . fst $ translateSelection mode ( p0 --> p1 ) doc + , let + alternateMode :: Bool + alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers + , Just docUpdate <- dragUpdate mode p0 p1 dragAction alternateMode doc + = strokes . documentContent $ newDocument docUpdate | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath , let mbFinalPoint :: Maybe ( Point2D Double ) diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 648b3c6..8a42d8a 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -55,7 +55,7 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = -- Line. go ( PathPoint { coords = p0 } ) ( sp1@( PathPoint { coords = p1 } ) :<| ps ) - = res ( closestPointToSegment @( Vector2D Double ) c p0 p1 ) + = res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 ) <> go sp1 ps -- Quadratic Bézier curve. go ( PathPoint { coords = p0 } ) diff --git a/src/app/MetaBrush/UI/ToolBar.hs-boot b/src/app/MetaBrush/UI/ToolBar.hs-boot index c5618cd..b29f6cb 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs-boot +++ b/src/app/MetaBrush/UI/ToolBar.hs-boot @@ -13,11 +13,15 @@ data Tool = Selection | Pen +instance Show Tool + data Mode = Path | Brush | Meta +instance Show Mode + data ToolBar = ToolBar { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index e1fc8ad..71255cf 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -82,14 +82,14 @@ projC x y = x ^.^ y / squaredNorm y closestPointToSegment :: forall v r p . ( Inner r v, Torsor v p, Fractional r, Ord r ) - => p -> p -> p -> p + => p -> p -> p -> ( r, p ) closestPointToSegment c p0 p1 | t <= 0 - = p0 + = ( 0, p0 ) | t >= 1 - = p1 + = ( 1, p1 ) | otherwise - = ( t *^ v01 ) • p0 + = ( t, ( t *^ v01 ) • p0 ) where v01 :: v v01 = p0 --> p1