hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

improvements to draw anchor

Browse source
This commit is contained in:
sheaf 2024-09-28 12:10:36 +02:00
parent 3d36b39541
commit 3886dca483
4 changed files with 74 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
brush-strokes/src/lib/Math/Bezier/Spline.hs
View file

@ -5,6 +5,8 @@
module Math.Bezier.Spline where module Math.Bezier.Spline where
-- base -- base
import Control.Monad
( guard )
import Data.Bifoldable import Data.Bifoldable
( Bifoldable(..) ) ( Bifoldable(..) )
import Data.Bifunctor import Data.Bifunctor
@ -290,11 +292,19 @@ splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case cu
Empty -> splineStart Empty -> splineStart
_ :|> lastCurve -> openCurveEnd lastCurve _ :|> lastCurve -> openCurveEnd lastCurve
catMaybesSpline :: crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData catMaybesSpline :: ( ptData -> ptData -> Bool ) -> crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData
catMaybesSpline dat p0 Nothing Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) } catMaybesSpline eq dat p0 mbCp1 mbCp2 p3 =
catMaybesSpline dat p0 ( Just p1 ) Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) } let
catMaybesSpline dat p0 Nothing ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) } mbCp1' = do { cp1 <- mbCp1; guard ( not $ eq cp1 p0 ); return cp1 }
catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) } mbCp2' = do { cp2 <- mbCp2; guard ( not $ eq cp2 p3 ); return cp2 }
mbCp1'' = do { cp1 <- mbCp1'; guard ( case mbCp2' of { Just {} -> True ; Nothing -> not ( eq cp1 p3 ) } ); return cp1 }
mbCp2'' = do { cp2 <- mbCp2'; guard ( case mbCp1' of { Just {} -> True ; Nothing -> not ( eq cp2 p0 ) } ); return cp2 }
in go mbCp1'' mbCp2''
where
go Nothing Nothing = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) }
go ( Just p1 ) Nothing = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) }
go Nothing ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) }
go ( Just p1 ) ( Just p2 ) = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) }
-- | Connect two open curves. -- | Connect two open curves.
-- --

82
src/app/MetaBrush/Application/Action.hs
View file

@ -7,13 +7,15 @@ module MetaBrush.Application.Action where
import Control.Arrow import Control.Arrow
( second ) ( second )
import Control.Monad import Control.Monad
( guard, when, unless, void ) ( when, unless, void )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Function
( on )
import Data.List import Data.List
( uncons ) ( uncons )
import Data.Maybe import Data.Maybe
( catMaybes, fromMaybe ) ( catMaybes, fromMaybe, isNothing )
import Data.String import Data.String
( IsString ) ( IsString )
import Data.Traversable import Data.Traversable
@ -943,11 +945,12 @@ instance HandleAction MouseClick where
Nothing -> do Nothing -> do
( newDocument, drawAnchor ) <- ( newDocument, drawAnchor ) <-
getOrCreateDrawAnchor uniqueSupply pos doc getOrCreateDrawAnchor uniqueSupply pos doc
let firstPos = anchorPos drawAnchor doc
STM.writeTVar partialPathTVar STM.writeTVar partialPathTVar
( Just $ PartialPath ( Just $ PartialPath
{ partialPathAnchor = drawAnchor { partialPathAnchor = drawAnchor
, partialControlPoint = Nothing , partialControlPoint = Nothing
, firstPoint = True , firstPoint = Just firstPos
} }
) )
if anchorIsNew drawAnchor if anchorIsNew drawAnchor
@ -966,8 +969,15 @@ instance HandleAction MouseClick where
else else
pure Don'tModifyDoc pure Don'tModifyDoc
-- Path already started: indicate that we are continuing a path. -- Path already started: indicate that we are continuing a path.
Just pp -> do Just pp@( PartialPath { firstPoint = mbFirst } ) -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) let stillAtFirstPoint = case mbFirst of
Nothing -> Nothing
Just p ->
if inPointClickRange zoom p pos
then Just p
else Nothing
STM.writeTVar partialPathTVar
( Just $ pp { firstPoint = stillAtFirstPoint } )
pure Don'tModifyDoc pure Don'tModifyDoc
BrushMode -> do BrushMode -> do
-- Brush mode: modify brush parameters through brush widget. -- Brush mode: modify brush parameters through brush widget.
@ -1177,22 +1187,20 @@ instance HandleAction MouseRelease where
| otherwise | otherwise
= ( pos, Nothing, Nothing ) = ( pos, Nothing, Nothing )
( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path. -- Close path.
then do then do
STM.writeTVar partialPathTVar Nothing STM.writeTVar partialPathTVar Nothing
let let
newSegment :: Spline Open () ( PointData () ) newSegment :: Spline Open () ( PointData () )
newSegment = catMaybesSpline () newSegment = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
( PointData p1 () ) ( PointData p1 () )
( do ( do
cp <- mbCp2 cp <- mbCp2
guard ( cp /= p1 )
pure ( PointData cp () ) pure ( PointData cp () )
) )
( do ( do
cp <- mbControlPoint cp <- mbControlPoint
guard ( cp /= anchorPos otherAnchor doc )
pure ( PointData cp () ) pure ( PointData cp () )
) )
( PointData ( anchorPos otherAnchor doc ) () ) ( PointData ( anchorPos otherAnchor doc ) () )
@ -1202,37 +1210,35 @@ instance HandleAction MouseRelease where
$ CloseStroke { closedStroke = anchorStroke anchor } $ CloseStroke { closedStroke = anchorStroke anchor }
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff ) pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
else else
if firstPoint case firstPoint of
-- Continue current partial path. -- Continue current partial path.
then do Just {} -> do
STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False ) STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint firstPoint )
pure Don'tModifyDoc pure Don'tModifyDoc
-- Finish current partial path. -- Finish current partial path.
else do Nothing -> do
STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False ) STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint Nothing )
let let
newSegment :: Spline Open () ( PointData () ) newSegment :: Spline Open () ( PointData () )
newSegment = catMaybesSpline () newSegment = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
( PointData p1 () ) ( PointData p1 () )
( do ( do
cp <- mbCp2 cp <- mbCp2
guard ( cp /= p1 ) pure ( PointData cp () )
pure ( PointData cp () ) )
) ( do
( do cp <- mbControlPoint
cp <- mbControlPoint pure ( PointData cp () )
guard ( cp /= pathPoint ) )
pure ( PointData cp () ) ( PointData pathPoint () )
) newDocument :: Document
( PointData pathPoint () ) newDocument = addToAnchor anchor newSegment doc
newDocument :: Document diff = HistoryDiff $ ContentDiff
newDocument = addToAnchor anchor newSegment doc $ ContinueStroke
diff = HistoryDiff $ ContentDiff { continuedStroke = anchorStroke anchor
$ ContinueStroke , newSegment
{ continuedStroke = anchorStroke anchor }
, newSegment pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
}
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
BrushMode -> do BrushMode -> do
STM.writeTVar mouseHoldTVar Nothing STM.writeTVar mouseHoldTVar Nothing
pure Don'tModifyDoc pure Don'tModifyDoc

2
src/app/MetaBrush/Application/Context.hs
View file

@ -185,7 +185,7 @@ data PartialPath
= PartialPath = PartialPath
{ partialPathAnchor :: !DrawAnchor { partialPathAnchor :: !DrawAnchor
, partialControlPoint :: !( Maybe ( ℝ 2 ) ) , partialControlPoint :: !( Maybe ( ℝ 2 ) )
, firstPoint :: !Bool , firstPoint :: !( Maybe ( ℝ 2 ) )
} }
deriving stock Show deriving stock Show

22
src/app/MetaBrush/Render/Document.hs
View file

@ -8,7 +8,7 @@ module MetaBrush.Render.Document
-- base -- base
import Control.Monad import Control.Monad
( guard, when, unless ) ( when, unless )
import Control.Monad.ST import Control.Monad.ST
( RealWorld, ST ) ( RealWorld, ST )
import Data.Coerce import Data.Coerce
@ -17,6 +17,8 @@ import Data.Fixed
( mod' ) ( mod' )
import Data.Foldable import Data.Foldable
( for_, sequenceA_, traverse_ ) ( for_, sequenceA_, traverse_ )
import Data.Function
( on )
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
@ -100,7 +102,9 @@ import MetaBrush.Document.Serialise
( ) -- 'Serialisable' instances ( ) -- 'Serialisable' instances
import MetaBrush.Draw import MetaBrush.Draw
import MetaBrush.Hover import MetaBrush.Hover
( mkAABB, HoverContext(..), Hoverable(..) ) ( HoverContext(..), Hoverable(..)
, inPointClickRange, mkAABB
)
import MetaBrush.Records import MetaBrush.Records
import MetaBrush.Stroke import MetaBrush.Stroke
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
@ -183,24 +187,26 @@ getDocumentRender
mbControlPoint :: Maybe ( ℝ 2 ) mbControlPoint :: Maybe ( ℝ 2 )
( mbFinalPoint, mbControlPoint ) ( mbFinalPoint, mbControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldEvent | Just ( DrawHold holdPos ) <- mbHoldEvent
= if firstPoint = case firstPoint of
then ( mbMousePos , Just holdPos ) Just {} -> ( mbMousePos , Nothing )
else ( Just holdPos, ( \ cp -> ( cp --> holdPos :: T ( ℝ 2 ) ) • holdPos ) <$> mbMousePos ) Nothing -> ( Just holdPos
, do { cp <- mbMousePos
; return $ ( cp --> holdPos :: T ( ℝ 2 ) ) • holdPos
}
)
| otherwise | otherwise
= ( mbMousePos, Nothing ) = ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint , Just finalPoint <- mbFinalPoint
, let , let
previewSpline :: Spline Open () ( PointData () ) previewSpline :: Spline Open () ( PointData () )
previewSpline = catMaybesSpline () previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
( PointData p0 () ) ( PointData p0 () )
( do ( do
cp <- cp0 cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp () ) pure ( PointData cp () )
) )
( do ( do
cp <- mbControlPoint cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp () ) pure ( PointData cp () )
) )
( PointData finalPoint () ) ( PointData finalPoint () )