mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
improvements to draw anchor
This commit is contained in:
sheaf
parent
3d36b39541
commit
3886dca483
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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,37 +1210,35 @@ 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 )
|
||||
pure Don'tModifyDoc
|
||||
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 )
|
||||
let
|
||||
newSegment :: Spline Open () ( PointData () )
|
||||
newSegment = catMaybesSpline ()
|
||||
( PointData p1 () )
|
||||
( do
|
||||
cp <- mbCp2
|
||||
guard ( cp /= p1 )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( do
|
||||
cp <- mbControlPoint
|
||||
guard ( cp /= pathPoint )
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( PointData pathPoint () )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
diff = HistoryDiff $ ContentDiff
|
||||
$ ContinueStroke
|
||||
{ continuedStroke = anchorStroke anchor
|
||||
, newSegment
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
Nothing -> do
|
||||
STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint Nothing )
|
||||
let
|
||||
newSegment :: Spline Open () ( PointData () )
|
||||
newSegment = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
|
||||
( PointData p1 () )
|
||||
( do
|
||||
cp <- mbCp2
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( do
|
||||
cp <- mbControlPoint
|
||||
pure ( PointData cp () )
|
||||
)
|
||||
( PointData pathPoint () )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
diff = HistoryDiff $ ContentDiff
|
||||
$ ContinueStroke
|
||||
{ continuedStroke = anchorStroke anchor
|
||||
, newSegment
|
||||
}
|
||||
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
|
||||
BrushMode -> do
|
||||
STM.writeTVar mouseHoldTVar Nothing
|
||||
pure Don'tModifyDoc
|
||||
|
|
|
|||
|
|
@ -185,7 +185,7 @@ data PartialPath
|
|||
= PartialPath
|
||||
{ partialPathAnchor :: !DrawAnchor
|
||||
, partialControlPoint :: !( Maybe ( ℝ 2 ) )
|
||||
, firstPoint :: !Bool
|
||||
, firstPoint :: !( Maybe ( ℝ 2 ) )
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
|
|
|
|||
|
|
@ -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 () )
|
||||
|
|
|
|||
Loading…
Reference in a new issue