mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
curve dragging support
This commit is contained in:
sheaf
parent
40d10b6a8e
commit
eb8e7012aa
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -12,3 +12,5 @@ files/
|
|||
*.html
|
||||
hie.yaml
|
||||
*.mb
|
||||
*.prof
|
||||
*.eventlog
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ) )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
36
src/app/MetaBrush/Document/Update.hs-boot
Normal file
36
src/app/MetaBrush/Document/Update.hs-boot
Normal file
|
|
@ -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 ()
|
||||
}
|
||||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 } )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue