start reworking brush stroking

This commit is contained in:
sheaf 2021-05-10 17:46:31 +02:00
parent f8b0ec2ab1
commit b46dc2a140
10 changed files with 214 additions and 215 deletions

View file

@ -61,6 +61,8 @@ common common
-fspecialise-aggressively -fspecialise-aggressively
-optc-O3 -optc-O3
-optc-ffast-math -optc-ffast-math
-- work around a laziness bug involving runRW# in GHC 9.0.1
-fno-full-laziness
-Wall -Wall
-Wcompat -Wcompat
-fwarn-missing-local-signatures -fwarn-missing-local-signatures

View file

@ -181,7 +181,7 @@ instance HandleAction () where
-- New file -- -- New file --
-------------- --------------
data NewFile = NewFile TabLocation data NewFile = NewFile !TabLocation
deriving stock Show deriving stock Show
instance HandleAction NewFile where instance HandleAction NewFile where
@ -192,7 +192,7 @@ instance HandleAction NewFile where
-- Open file -- -- Open file --
--------------- ---------------
data OpenFile = OpenFile TabLocation data OpenFile = OpenFile !TabLocation
deriving stock Show deriving stock Show
instance HandleAction OpenFile where instance HandleAction OpenFile where
@ -252,7 +252,7 @@ warningDialog window filePath errMess = do
-- Open folder -- -- Open folder --
----------------- -----------------
data OpenFolder = OpenFolder TabLocation data OpenFolder = OpenFolder !TabLocation
deriving stock Show deriving stock Show
instance HandleAction OpenFolder where instance HandleAction OpenFolder where
@ -671,7 +671,7 @@ instance HandleAction About where
-- Mouse movement -- -- Mouse movement --
-------------------- --------------------
data MouseMove = MouseMove ( Point2D Double ) data MouseMove = MouseMove !( Point2D Double )
deriving stock Show deriving stock Show
instance HandleAction MouseMove where instance HandleAction MouseMove where
@ -714,7 +714,7 @@ instance HandleAction MouseMove where
data ActionOrigin data ActionOrigin
= ViewportOrigin = ViewportOrigin
| RulerOrigin Ruler | RulerOrigin !Ruler
deriving stock Show deriving stock Show
data MouseClickType data MouseClickType
@ -722,7 +722,7 @@ data MouseClickType
| DoubleClick | DoubleClick
deriving stock Show deriving stock Show
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double ) data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
deriving stock Show deriving stock Show
instance HandleAction MouseClick where instance HandleAction MouseClick where
@ -860,7 +860,7 @@ instance HandleAction MouseClick where
-- Mouse release -- -- Mouse release --
------------------- -------------------
data MouseRelease = MouseRelease Word32 ( Point2D Double ) data MouseRelease = MouseRelease !Word32 !( Point2D Double )
deriving stock Show deriving stock Show
instance HandleAction MouseRelease where instance HandleAction MouseRelease where
@ -1053,7 +1053,7 @@ instance HandleAction MouseRelease where
-- Scrolling -- -- Scrolling --
--------------- ---------------
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double ) data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
deriving stock Show deriving stock Show
instance HandleAction Scroll where instance HandleAction Scroll where
@ -1108,7 +1108,7 @@ instance HandleAction Scroll where
-- Keyboard press -- -- Keyboard press --
-------------------- --------------------
data KeyboardPress = KeyboardPress Word32 data KeyboardPress = KeyboardPress !Word32
deriving stock Show deriving stock Show
instance HandleAction KeyboardPress where instance HandleAction KeyboardPress where
@ -1153,7 +1153,7 @@ instance HandleAction KeyboardPress where
-- Keyboard release -- -- Keyboard release --
---------------------- ----------------------
data KeyboardRelease = KeyboardRelease Word32 data KeyboardRelease = KeyboardRelease !Word32
deriving stock Show deriving stock Show
instance HandleAction KeyboardRelease where instance HandleAction KeyboardRelease where

View file

@ -45,13 +45,13 @@ class HandleAction action where
instance HandleAction () instance HandleAction ()
data NewFile = NewFile TabLocation data NewFile = NewFile !TabLocation
instance HandleAction NewFile instance HandleAction NewFile
data OpenFile = OpenFile TabLocation data OpenFile = OpenFile !TabLocation
instance HandleAction OpenFile instance HandleAction OpenFile
data OpenFolder = OpenFolder TabLocation data OpenFolder = OpenFolder !TabLocation
instance HandleAction OpenFolder instance HandleAction OpenFolder
data Save = Save data Save = Save
@ -107,26 +107,26 @@ instance HandleAction Confirm
data About = About data About = About
instance HandleAction About instance HandleAction About
data MouseMove = MouseMove ( Point2D Double ) data MouseMove = MouseMove !( Point2D Double )
instance HandleAction MouseMove instance HandleAction MouseMove
data ActionOrigin data ActionOrigin
= ViewportOrigin = ViewportOrigin
| RulerOrigin Ruler | RulerOrigin !Ruler
data MouseClickType data MouseClickType
= SingleClick = SingleClick
| DoubleClick | DoubleClick
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double ) data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
instance HandleAction MouseClick instance HandleAction MouseClick
data MouseRelease = MouseRelease Word32 ( Point2D Double ) data MouseRelease = MouseRelease !Word32 !( Point2D Double )
instance HandleAction MouseRelease instance HandleAction MouseRelease
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double ) data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
instance HandleAction Scroll instance HandleAction Scroll
data KeyboardPress = KeyboardPress Word32 data KeyboardPress = KeyboardPress !Word32
instance HandleAction KeyboardPress instance HandleAction KeyboardPress
data KeyboardRelease = KeyboardRelease Word32 data KeyboardRelease = KeyboardRelease !Word32
instance HandleAction KeyboardRelease instance HandleAction KeyboardRelease

View file

@ -184,9 +184,9 @@ runApplication application = do
Spline Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2 { splineStart = mkPoint ( Point2D 10 -20 ) 2
, splineCurves = OpenCurves $ Seq.fromList , splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined } [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined } , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined } , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 15 ), curveData = invalidateCache undefined }
] ]
} }
} }

View file

@ -81,7 +81,7 @@ import Math.Module
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D )
import {-# SOURCE #-} MetaBrush.Document.Serialise import {-# SOURCE #-} MetaBrush.Document.Serialise
( Serialisable, Workaround(..) ) ( Serialisable, Workaround(..), workaround )
import MetaBrush.MetaParameter.AST import MetaBrush.MetaParameter.AST
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes ( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
, Adapted, BrushFunction , Adapted, BrushFunction
@ -93,7 +93,7 @@ import MetaBrush.MetaParameter.Interpolation
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
whatever :: Int whatever :: Int
whatever = case Workaround of whatever = case workaround Workaround of
Workaround -> 0 Workaround -> 0
data Brush brushFields where data Brush brushFields where

View file

@ -14,7 +14,8 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( Workaround(..), Serialisable(..) ( Workaround(..), workaround
, Serialisable(..)
, documentToJSON, documentFromJSON , documentToJSON, documentFromJSON
, saveDocument, loadDocument , saveDocument, loadDocument
) )
@ -201,6 +202,8 @@ import qualified Paths_MetaBrush as Cabal
-- | Dummy data-type that helps workaround a GHC bug with hs-boot files. -- | Dummy data-type that helps workaround a GHC bug with hs-boot files.
data Workaround = Workaround data Workaround = Workaround
workaround :: Workaround -> Workaround
workaround Workaround = Workaround
-- | Serialise a document to JSON (in the form of a lazy bytestring). -- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString documentToJSON :: Document -> Lazy.ByteString

View file

@ -2,7 +2,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( Workaround(..), Serialisable(..) ) ( Workaround(..), workaround, Serialisable(..) )
where where
-- base -- base
@ -31,6 +31,8 @@ import Math.Vector2D
data Workaround = Workaround data Workaround = Workaround
workaround :: Workaround -> Workaround
class Serialisable a where class Serialisable a where
encoder :: Monad f => JSON.Encoder f a encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a decoder :: Monad m => JSON.Decoder m a

View file

@ -516,7 +516,10 @@ type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Close
newtype AdaptableFunction brushFields a newtype AdaptableFunction brushFields a
= AdaptableFunction = AdaptableFunction
( forall givenFields usedFields ( forall givenFields usedFields
. Adapted brushFields givenFields usedFields . ( Adapted brushFields givenFields usedFields
-- Debugging.
, Show ( Super.Rec givenFields )
)
=> ( Super.Rec givenFields -> Super.Rec usedFields => ( Super.Rec givenFields -> Super.Rec usedFields
, Super.Rec usedFields -> a , Super.Rec usedFields -> a
) )

View file

@ -303,12 +303,12 @@ strokeRenderData fitParams
= Just $ case strokeBrush of = Just $ case strokeBrush of
Just ( AdaptedBrush ( brush :: Brush brushFields ) ) Just ( AdaptedBrush ( brush :: Brush brushFields ) )
| ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) | ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
, let , let
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
-> do -> do
-- Compute the outline using the brush function. -- Compute the outline using the brush function.
( outline, fitPts ) <- ( outline, fitPts ) <-

View file

@ -101,10 +101,9 @@ import Math.Bezier.Spline
, ssplineType, adjustSplineType , ssplineType, adjustSplineType
, NextPoint(..), fromNextPoint , NextPoint(..), fromNextPoint
, KnownSplineType , KnownSplineType
( bifoldSpline, ibifoldSpline, bimapSpline ) ( bifoldSpline, ibifoldSpline )
, Spline(..), SplinePts, Curves(..), Curve(..) , Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd , openCurveEnd, splitSplineAt, dropCurves
, splitSplineAt, dropCurves
) )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon import Math.Epsilon
@ -180,6 +179,8 @@ computeStrokeOutline ::
, HasType ( Point2D Double ) ptData , HasType ( Point2D Double ) ptData
, HasType ( CachedStroke s ) crvData , HasType ( CachedStroke s ) crvData
, NFData ptData, NFData crvData , NFData ptData, NFData crvData
-- Debugging.
, Show ptData
) )
=> FitParameters => FitParameters
-> ( ptData -> brushParams ) -> ( ptData -> brushParams )
@ -189,53 +190,54 @@ computeStrokeOutline ::
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ) ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
, Seq FitPoint , Seq FitPoint
) )
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
-- Open brush path with at least one segment. -- Open brush path with at least one segment.
-- Need to add caps at both ends of the path.
SOpen SOpen
| OpenCurves curves <- splineCurves | ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, firstCurve :<| _ <- curves , _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, prevCurves :|> lastCurve <- curves , _ :|> lastCurve <- openCurves $ splineCurves spline
, let , let
endPt :: ptData endPt :: ptData
endPt = openCurveEnd lastCurve endPt = openCurveEnd lastCurve
startTgt, endTgt :: Vector2D Double startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
startTgt = coords spt0 --> coords ( openCurveStart firstCurve ) startTgtFwd = snd $ firstOutlineFwd 0
endTgt = case prevCurves of startTgtBwd = snd $ firstOutlineBwd 1
Empty -> endTangent spt0 spt0 lastCurve endTgtFwd = snd $ lastOutlineFwd 1
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve endTgtBwd = snd $ lastOutlineBwd 0
startBrush, endBrush :: SplinePts Closed startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0 startBrush = brushShape spt0
endBrush = brushShape endPt endBrush = brushShape endPt
startCap, endCap :: SplinePts Open startCap, endCap :: SplinePts Open
startCap startCap
= fmap ( MkVector2D ( coords spt0 ) ) = fmap ( MkVector2D ( coords spt0 ) )
$ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush $ joinWithBrush ( withTangent ( (-1) *^ startTgtBwd ) startBrush ) ( withTangent startTgtFwd startBrush ) startBrush
endCap endCap
= fmap ( MkVector2D ( coords endPt ) ) = fmap ( MkVector2D ( coords endPt ) )
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush $ joinWithBrush ( withTangent endTgtFwd endBrush ) ( withTangent ( (-1) *^ endTgtBwd ) endBrush ) endBrush
-> do -> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline startTgt TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgtFwd, startTgtBwd )
pure pure
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts ) ( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits , fwdFits <> bwdFits
) )
-- Closed brush path with at least one segment. -- Closed brush path with at least one segment.
-- Add forward and backward caps at the start.
SClosed SClosed
| ClosedCurves prevCurves lastCurve <- splineCurves | ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, let , let
startTgt, endTgt :: Vector2D Double startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
startTgt = case prevCurves of startTgtFwd = snd $ firstOutlineFwd 0
Empty -> startTangent spt0 spt0 lastCurve startTgtBwd = snd $ firstOutlineBwd 1
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv endTgtFwd = snd $ lastOutlineFwd 1
endTgt = case prevCurves of endTgtBwd = snd $ lastOutlineBwd 0
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
fwdStartCap, bwdStartCap :: SplinePts Open fwdStartCap, bwdStartCap :: SplinePts Open
TwoSided fwdStartCap bwdStartCap TwoSided fwdStartCap bwdStartCap
= fmap fst . snd . runWriter = fmap fst . snd . runWriter
$ tellBrushJoin endTgt spt0 startTgt $ tellBrushJoin ( endTgtFwd, endTgtBwd ) spt0 ( startTgtFwd, startTgtBwd )
-> do -> do
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline endTgt TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgtFwd, endTgtBwd )
pure pure
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) ) ( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
, fwdFits <> bwdFits , fwdFits <> bwdFits
@ -243,160 +245,54 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- Single point. -- Single point.
_ -> _ ->
pure pure
( Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) ) ( brushShape spt0 ) ( Left $ fmap ( MkVector2D ( coords spt0 ) ) ( brushShape spt0 )
, Empty , Empty
) )
where where
outlineFns
:: Seq
( Double -> ( Point2D Double, Vector2D Double )
, Double -> ( Point2D Double, Vector2D Double )
)
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
where
go
:: ptData
-> Seq ( Curve Open crvData ptData )
-> Seq
( Double -> ( Point2D Double, Vector2D Double )
, Double -> ( Point2D Double, Vector2D Double )
)
go _ Empty = Empty
go p0 ( crv :<| crvs ) =
outlineFunctions @diffParams ptParams brushFn p0 crv :<| go ( openCurveEnd crv ) crvs
brushShape :: ptData -> SplinePts Closed brushShape :: ptData -> SplinePts Closed
brushShape pt = brushFn ( ptParams pt ) brushShape pt = brushFn ( ptParams pt )
updateSpline :: Vector2D Double -> ST s OutlineData updateSpline :: ( Vector2D Double, Vector2D Double ) -> ST s OutlineData
updateSpline lastTgt updateSpline ( lastTgtFwd, lastTgtBwd )
= execWriterT = execWriterT
. ( `evalStateT` lastTgt ) . ( `evalStateT` ( lastTgtFwd, lastTgtBwd ) )
$ bifoldSpline $ bifoldSpline
( \ ptData curve -> do ( \ ptData curve -> do
prev_tgt <- get ( prev_tgtFwd, prev_tgtBwd ) <- get
let let
tgt :: Vector2D Double fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
tgt = startTangent spt0 ptData curve ( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve
lift $ tellBrushJoin prev_tgt ptData tgt tgtFwd, tgtBwd, next_tgtFwd, next_tgtBwd :: Vector2D Double
lift $ strokeOutline ptData curve tgtFwd = snd ( fwd 0 )
put ( endTangent spt0 ptData curve ) tgtBwd = snd ( bwd 1 )
next_tgtFwd = snd ( fwd 1 )
next_tgtBwd = snd ( bwd 0 )
lift $ tellBrushJoin ( prev_tgtFwd, prev_tgtBwd ) ptData ( tgtFwd, tgtBwd )
lift $ updateCurveData ( curveData curve ) fwd bwd
put ( next_tgtFwd, next_tgtBwd )
) )
( const ( pure () ) ) ( const ( pure () ) )
( adjustSplineType @Open spline ) ( adjustSplineType @Open spline )
strokeOutline
:: ptData -> Curve Open crvData ptData
-> WriterT OutlineData ( ST s ) ()
strokeOutline sp0 ( LineTo { curveEnd = NextPoint sp1, curveData } ) =
let
p0, p1 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
tgt :: Vector2D Double
tgt = p0 --> p1
brush :: Double -> SplinePts Closed
brush t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
, if squaredNorm offTgt < epsilon then tgt else offTgt
)
where
off :: Double -> Point2D Double
off x = offset ( withTangent tgt ( brush x ) ) lerp @( Vector2D Double ) x p0 p1
offTgt :: Vector2D Double
offTgt
| t < 0.5
= 1e9 *^ ( off t --> off (t + 1e-9) )
| otherwise
= 1e9 *^ ( off (t - 1e-9) --> off t )
bwd t
= ( off s
, if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt
)
where
s :: Double
s = 1 - t
off :: Double -> Point2D Double
off x = offset ( withTangent ( (-1) *^ tgt ) ( brush x ) ) lerp @( Vector2D Double ) x p0 p1
offTgt :: Vector2D Double
offTgt
| s < 0.5
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in
updateCurveData curveData fwd bwd
strokeOutline sp0 ( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
let
p0, p1, p2 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier {..}
brush :: Double -> SplinePts Closed
brush t = brushFn
$ Quadratic.bezier @diffParams
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
, if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt
)
where
off :: Double -> Point2D Double
off x = offset ( withTangent ( Quadratic.bezier' bez x ) ( brush x ) ) Quadratic.bezier @( Vector2D Double ) bez x
offTgt :: Vector2D Double
offTgt
| t < 0.5
= 1e9 *^ ( off t --> off (t + 1e-9) )
| otherwise
= 1e9 *^ ( off (t - 1e-9) --> off t )
bwd t
= ( off s
, if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt
)
where
s :: Double
s = 1 - t
off :: Double -> Point2D Double
off x = offset ( withTangent ( (-1) *^ Quadratic.bezier' bez x ) ( brush x ) ) Quadratic.bezier @( Vector2D Double ) bez x
offTgt :: Vector2D Double
offTgt
| s < 0.5
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in updateCurveData curveData fwd bwd
strokeOutline sp0 ( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
let
p0, p1, p2, p3 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier {..}
brush :: Double -> SplinePts Closed
brush t = brushFn
$ Cubic.bezier @diffParams
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
, if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt
)
where
off :: Double -> Point2D Double
off x = offset ( withTangent ( Cubic.bezier' bez x ) ( brush x ) ) Cubic.bezier @( Vector2D Double ) bez x
offTgt :: Vector2D Double
offTgt
| t < 0.5
= 1e9 *^ ( off t --> off (t + 1e-9) )
| otherwise
= 1e9 *^ ( off (t - 1e-9) --> off t )
bwd t
= ( off s
, if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt
)
where
s :: Double
s = 1 - t
off :: Double -> Point2D Double
off x = offset ( withTangent ( (-1) *^ Cubic.bezier' bez x ) ( brush x ) ) Cubic.bezier @( Vector2D Double ) bez x
offTgt :: Vector2D Double
offTgt
| s < 0.5
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in updateCurveData curveData fwd bwd
updateCurveData updateCurveData
:: crvData :: crvData
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( Point2D Double, Vector2D Double ) )
@ -426,15 +322,11 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction). -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
tellBrushJoin tellBrushJoin
:: Monad m :: Monad m
=> Vector2D Double => ( Vector2D Double, Vector2D Double )
-> ptData -> ptData
-> Vector2D Double -> ( Vector2D Double, Vector2D Double )
-> WriterT OutlineData m () -> WriterT OutlineData m ()
tellBrushJoin prevTgt sp0 tgt tellBrushJoin ( prevTgtFwd, prevTgtBwd ) sp0 ( tgtFwd, tgtBwd ) = tell brushJoin
| tgt `parallel` prevTgt
= pure ()
| otherwise
= tell brushJoin
where where
ptOffset :: Vector2D Double ptOffset :: Vector2D Double
ptOffset = Point2D 0 0 --> coords sp0 ptOffset = Point2D 0 0 --> coords sp0
@ -442,14 +334,111 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
brush0 = brushShape sp0 brush0 = brushShape sp0
fwdJoin, bwdJoin :: SplinePts Open fwdJoin, bwdJoin :: SplinePts Open
fwdJoin fwdJoin
| tgtFwd `parallel` prevTgtFwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| otherwise
= fmap ( ptOffset ) = fmap ( ptOffset )
$ joinWithBrush ( withTangent prevTgt brush0 ) ( withTangent tgt brush0 ) brush0 $ joinWithBrush ( withTangent prevTgtFwd brush0 ) ( withTangent tgtFwd brush0 ) brush0
bwdJoin bwdJoin
| tgtBwd `parallel` prevTgtBwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| otherwise
= fmap ( ptOffset ) = fmap ( ptOffset )
$ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0 $ joinWithBrush ( withTangent ( (-1) *^ tgtBwd ) brush0 ) ( withTangent ( (-1) *^ prevTgtBwd ) brush0 ) brush0
brushJoin :: OutlineData brushJoin :: OutlineData
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
-- | Computes the forward and backward stroke outline functions for a single curve.
outlineFunctions
:: forall diffParams brushParams crvData ptData
. ( Group diffParams, Module Double diffParams
, Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData
-- Debugging.
, Show ptData
)
=> ( ptData -> brushParams )
-> ( brushParams -> SplinePts Closed )
-> ptData
-> Curve Open crvData ptData
-> ( Double -> ( Point2D Double, Vector2D Double )
, Double -> ( Point2D Double, Vector2D Double )
)
outlineFunctions ptParams brushFn sp0 crv =
let
p0 :: Point2D Double
p0 = coords sp0
brush :: Double -> SplinePts Closed
f :: Double -> Point2D Double
f' :: Double -> Vector2D Double
( brush, f, f' ) = case crv of
LineTo { curveEnd = NextPoint sp1 }
| let
p1 :: Point2D Double
p1 = coords sp1
tgt :: Vector2D Double
tgt = p0 --> p1
brush1 :: Double -> SplinePts Closed
brush1 t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
-> ( brush1, \ t -> lerp @( Vector2D Double ) t p0 p1, const tgt )
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
| let
p1, p2 :: Point2D Double
p1 = coords sp1
p2 = coords sp2
bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier {..}
brush2 :: Double -> SplinePts Closed
brush2 t =
brushFn $
Quadratic.bezier @diffParams
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
-> ( brush2, Quadratic.bezier @( Vector2D Double ) bez, Quadratic.bezier' bez )
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
| let
p1, p2, p3 :: Point2D Double
p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier {..}
brush3 :: Double -> SplinePts Closed
brush3 t =
brushFn $
Cubic.bezier @diffParams
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
-> ( brush3, Cubic.bezier @( Vector2D Double ) bez, Cubic.bezier' bez )
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
, if squaredNorm offTgt < epsilon then f' t else offTgt
)
where
off :: Double -> Point2D Double
off u = offset ( withTangent ( f' u ) ( brush u ) ) f u
offTgt :: Vector2D Double
offTgt
| t < 0.5
= 1e9 *^ ( off t --> off (t + 1e-9) )
| otherwise
= 1e9 *^ ( off (t - 1e-9) --> off t )
bwd t
= ( off s
, if squaredNorm offTgt < epsilon then (-1) *^ f' s else offTgt
)
where
s :: Double
s = 1 - t
off :: Double -> Point2D Double
off u = offset ( withTangent ( (-1) *^ f' u ) ( brush u ) ) f u
offTgt :: Vector2D Double
offTgt
| s < 0.5
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
in ( fwd, bwd )
----------------------------------- -----------------------------------
-- Various utility functions -- Various utility functions
-- used in the "stroke" function. -- used in the "stroke" function.