hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +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
-- base
import Control.Monad
( guard )
import Data.Bifoldable
( Bifoldable(..) )
import Data.Bifunctor
@ -290,11 +292,19 @@ splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case cu
Empty -> splineStart
_ :|> lastCurve -> openCurveEnd lastCurve
catMaybesSpline :: 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 dat p0 ( Just p1 ) Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) }
catMaybesSpline dat p0 Nothing ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) }
catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) }
catMaybesSpline :: ( ptData -> ptData -> Bool ) -> crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData
catMaybesSpline eq dat p0 mbCp1 mbCp2 p3 =
let
mbCp1' = do { cp1 <- mbCp1; guard ( not $ eq cp1 p0 ); return cp1 }
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.
--

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

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

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

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

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

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