mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
start reworking brush stroking
This commit is contained in:
sheaf
parent
f8b0ec2ab1
commit
b46dc2a140
|
|
@ -61,6 +61,8 @@ common common
|
|||
-fspecialise-aggressively
|
||||
-optc-O3
|
||||
-optc-ffast-math
|
||||
-- work around a laziness bug involving runRW# in GHC 9.0.1
|
||||
-fno-full-laziness
|
||||
-Wall
|
||||
-Wcompat
|
||||
-fwarn-missing-local-signatures
|
||||
|
|
|
|||
|
|
@ -181,7 +181,7 @@ instance HandleAction () where
|
|||
-- New file --
|
||||
--------------
|
||||
|
||||
data NewFile = NewFile TabLocation
|
||||
data NewFile = NewFile !TabLocation
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction NewFile where
|
||||
|
|
@ -192,7 +192,7 @@ instance HandleAction NewFile where
|
|||
-- Open file --
|
||||
---------------
|
||||
|
||||
data OpenFile = OpenFile TabLocation
|
||||
data OpenFile = OpenFile !TabLocation
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction OpenFile where
|
||||
|
|
@ -252,7 +252,7 @@ warningDialog window filePath errMess = do
|
|||
-- Open folder --
|
||||
-----------------
|
||||
|
||||
data OpenFolder = OpenFolder TabLocation
|
||||
data OpenFolder = OpenFolder !TabLocation
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction OpenFolder where
|
||||
|
|
@ -671,7 +671,7 @@ instance HandleAction About where
|
|||
-- Mouse movement --
|
||||
--------------------
|
||||
|
||||
data MouseMove = MouseMove ( Point2D Double )
|
||||
data MouseMove = MouseMove !( Point2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseMove where
|
||||
|
|
@ -714,7 +714,7 @@ instance HandleAction MouseMove where
|
|||
|
||||
data ActionOrigin
|
||||
= ViewportOrigin
|
||||
| RulerOrigin Ruler
|
||||
| RulerOrigin !Ruler
|
||||
deriving stock Show
|
||||
|
||||
data MouseClickType
|
||||
|
|
@ -722,7 +722,7 @@ data MouseClickType
|
|||
| DoubleClick
|
||||
deriving stock Show
|
||||
|
||||
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
|
||||
data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseClick where
|
||||
|
|
@ -860,7 +860,7 @@ instance HandleAction MouseClick where
|
|||
-- Mouse release --
|
||||
-------------------
|
||||
|
||||
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
||||
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseRelease where
|
||||
|
|
@ -1053,7 +1053,7 @@ instance HandleAction MouseRelease where
|
|||
-- Scrolling --
|
||||
---------------
|
||||
|
||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
||||
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction Scroll where
|
||||
|
|
@ -1108,7 +1108,7 @@ instance HandleAction Scroll where
|
|||
-- Keyboard press --
|
||||
--------------------
|
||||
|
||||
data KeyboardPress = KeyboardPress Word32
|
||||
data KeyboardPress = KeyboardPress !Word32
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction KeyboardPress where
|
||||
|
|
@ -1153,7 +1153,7 @@ instance HandleAction KeyboardPress where
|
|||
-- Keyboard release --
|
||||
----------------------
|
||||
|
||||
data KeyboardRelease = KeyboardRelease Word32
|
||||
data KeyboardRelease = KeyboardRelease !Word32
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction KeyboardRelease where
|
||||
|
|
|
|||
|
|
@ -45,13 +45,13 @@ class HandleAction action where
|
|||
|
||||
instance HandleAction ()
|
||||
|
||||
data NewFile = NewFile TabLocation
|
||||
data NewFile = NewFile !TabLocation
|
||||
instance HandleAction NewFile
|
||||
|
||||
data OpenFile = OpenFile TabLocation
|
||||
data OpenFile = OpenFile !TabLocation
|
||||
instance HandleAction OpenFile
|
||||
|
||||
data OpenFolder = OpenFolder TabLocation
|
||||
data OpenFolder = OpenFolder !TabLocation
|
||||
instance HandleAction OpenFolder
|
||||
|
||||
data Save = Save
|
||||
|
|
@ -107,26 +107,26 @@ instance HandleAction Confirm
|
|||
data About = About
|
||||
instance HandleAction About
|
||||
|
||||
data MouseMove = MouseMove ( Point2D Double )
|
||||
data MouseMove = MouseMove !( Point2D Double )
|
||||
instance HandleAction MouseMove
|
||||
|
||||
data ActionOrigin
|
||||
= ViewportOrigin
|
||||
| RulerOrigin Ruler
|
||||
| RulerOrigin !Ruler
|
||||
data MouseClickType
|
||||
= SingleClick
|
||||
| DoubleClick
|
||||
data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
|
||||
data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double )
|
||||
instance HandleAction MouseClick
|
||||
|
||||
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
||||
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||
instance HandleAction MouseRelease
|
||||
|
||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
||||
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||
instance HandleAction Scroll
|
||||
|
||||
data KeyboardPress = KeyboardPress Word32
|
||||
data KeyboardPress = KeyboardPress !Word32
|
||||
instance HandleAction KeyboardPress
|
||||
|
||||
data KeyboardRelease = KeyboardRelease Word32
|
||||
data KeyboardRelease = KeyboardRelease !Word32
|
||||
instance HandleAction KeyboardRelease
|
||||
|
|
|
|||
|
|
@ -184,9 +184,9 @@ runApplication application = do
|
|||
Spline
|
||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ 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 10 ) 10 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 15 ), curveData = invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ import Math.Module
|
|||
import Math.Vector2D
|
||||
( Point2D )
|
||||
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
||||
( Serialisable, Workaround(..) )
|
||||
( Serialisable, Workaround(..), workaround )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( SType(..), STypeI(..), SomeSType(..), STypes(..), STypesI(..), someSTypes
|
||||
, Adapted, BrushFunction
|
||||
|
|
@ -93,7 +93,7 @@ import MetaBrush.MetaParameter.Interpolation
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
whatever :: Int
|
||||
whatever = case Workaround of
|
||||
whatever = case workaround Workaround of
|
||||
Workaround -> 0
|
||||
|
||||
data Brush brushFields where
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Document.Serialise
|
||||
( Workaround(..), Serialisable(..)
|
||||
( Workaround(..), workaround
|
||||
, Serialisable(..)
|
||||
, documentToJSON, documentFromJSON
|
||||
, 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.
|
||||
data Workaround = Workaround
|
||||
workaround :: Workaround -> Workaround
|
||||
workaround Workaround = Workaround
|
||||
|
||||
-- | Serialise a document to JSON (in the form of a lazy bytestring).
|
||||
documentToJSON :: Document -> Lazy.ByteString
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.Document.Serialise
|
||||
( Workaround(..), Serialisable(..) )
|
||||
( Workaround(..), workaround, Serialisable(..) )
|
||||
where
|
||||
|
||||
-- base
|
||||
|
|
@ -31,6 +31,8 @@ import Math.Vector2D
|
|||
|
||||
data Workaround = Workaround
|
||||
|
||||
workaround :: Workaround -> Workaround
|
||||
|
||||
class Serialisable a where
|
||||
encoder :: Monad f => JSON.Encoder f a
|
||||
decoder :: Monad m => JSON.Decoder m a
|
||||
|
|
|
|||
|
|
@ -516,7 +516,10 @@ type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Close
|
|||
newtype AdaptableFunction brushFields a
|
||||
= AdaptableFunction
|
||||
( forall givenFields usedFields
|
||||
. Adapted brushFields givenFields usedFields
|
||||
. ( Adapted brushFields givenFields usedFields
|
||||
-- Debugging.
|
||||
, Show ( Super.Rec givenFields )
|
||||
)
|
||||
=> ( Super.Rec givenFields -> Super.Rec usedFields
|
||||
, Super.Rec usedFields -> a
|
||||
)
|
||||
|
|
|
|||
|
|
@ -303,12 +303,12 @@ strokeRenderData fitParams
|
|||
= Just $ case strokeBrush of
|
||||
Just ( AdaptedBrush ( brush :: Brush brushFields ) )
|
||||
| ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) )
|
||||
-- Get the adaptable brush shape (function),
|
||||
-- specialising it to the type we are using.
|
||||
, let
|
||||
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
|
||||
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
|
||||
AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush
|
||||
-- Get the adaptable brush shape (function),
|
||||
-- specialising it to the type we are using.
|
||||
-> do
|
||||
-- Compute the outline using the brush function.
|
||||
( outline, fitPts ) <-
|
||||
|
|
|
|||
|
|
@ -101,10 +101,9 @@ import Math.Bezier.Spline
|
|||
, ssplineType, adjustSplineType
|
||||
, NextPoint(..), fromNextPoint
|
||||
, KnownSplineType
|
||||
( bifoldSpline, ibifoldSpline, bimapSpline )
|
||||
( bifoldSpline, ibifoldSpline )
|
||||
, Spline(..), SplinePts, Curves(..), Curve(..)
|
||||
, openCurveStart, openCurveEnd
|
||||
, splitSplineAt, dropCurves
|
||||
, openCurveEnd, splitSplineAt, dropCurves
|
||||
)
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
import Math.Epsilon
|
||||
|
|
@ -180,6 +179,8 @@ computeStrokeOutline ::
|
|||
, HasType ( Point2D Double ) ptData
|
||||
, HasType ( CachedStroke s ) crvData
|
||||
, NFData ptData, NFData crvData
|
||||
-- Debugging.
|
||||
, Show ptData
|
||||
)
|
||||
=> FitParameters
|
||||
-> ( ptData -> brushParams )
|
||||
|
|
@ -189,53 +190,54 @@ computeStrokeOutline ::
|
|||
( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
|
||||
, 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.
|
||||
-- Need to add caps at both ends of the path.
|
||||
SOpen
|
||||
| OpenCurves curves <- splineCurves
|
||||
, firstCurve :<| _ <- curves
|
||||
, prevCurves :|> lastCurve <- curves
|
||||
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
|
||||
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
|
||||
, _ :|> lastCurve <- openCurves $ splineCurves spline
|
||||
, let
|
||||
endPt :: ptData
|
||||
endPt = openCurveEnd lastCurve
|
||||
startTgt, endTgt :: Vector2D Double
|
||||
startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
|
||||
endTgt = case prevCurves of
|
||||
Empty -> endTangent spt0 spt0 lastCurve
|
||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
||||
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||
startTgtFwd = snd $ firstOutlineFwd 0
|
||||
startTgtBwd = snd $ firstOutlineBwd 1
|
||||
endTgtFwd = snd $ lastOutlineFwd 1
|
||||
endTgtBwd = snd $ lastOutlineBwd 0
|
||||
startBrush, endBrush :: SplinePts Closed
|
||||
startBrush = brushShape spt0
|
||||
endBrush = brushShape endPt
|
||||
startCap, endCap :: SplinePts Open
|
||||
startCap
|
||||
= fmap ( MkVector2D ( coords spt0 ) • )
|
||||
$ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush
|
||||
$ joinWithBrush ( withTangent ( (-1) *^ startTgtBwd ) startBrush ) ( withTangent startTgtFwd startBrush ) startBrush
|
||||
endCap
|
||||
= fmap ( MkVector2D ( coords endPt ) • )
|
||||
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
|
||||
$ joinWithBrush ( withTangent endTgtFwd endBrush ) ( withTangent ( (-1) *^ endTgtBwd ) endBrush ) endBrush
|
||||
-> do
|
||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline startTgt
|
||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( startTgtFwd, startTgtBwd )
|
||||
pure
|
||||
( Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
|
||||
, fwdFits <> bwdFits
|
||||
)
|
||||
-- Closed brush path with at least one segment.
|
||||
-- Add forward and backward caps at the start.
|
||||
SClosed
|
||||
| ClosedCurves prevCurves lastCurve <- splineCurves
|
||||
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
|
||||
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
|
||||
, let
|
||||
startTgt, endTgt :: Vector2D Double
|
||||
startTgt = case prevCurves of
|
||||
Empty -> startTangent spt0 spt0 lastCurve
|
||||
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
|
||||
endTgt = case prevCurves of
|
||||
Empty -> endTangent spt0 spt0 lastCurve
|
||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
||||
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||
startTgtFwd = snd $ firstOutlineFwd 0
|
||||
startTgtBwd = snd $ firstOutlineBwd 1
|
||||
endTgtFwd = snd $ lastOutlineFwd 1
|
||||
endTgtBwd = snd $ lastOutlineBwd 0
|
||||
fwdStartCap, bwdStartCap :: SplinePts Open
|
||||
TwoSided fwdStartCap bwdStartCap
|
||||
= fmap fst . snd . runWriter
|
||||
$ tellBrushJoin endTgt spt0 startTgt
|
||||
$ tellBrushJoin ( endTgtFwd, endTgtBwd ) spt0 ( startTgtFwd, startTgtBwd )
|
||||
-> do
|
||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline endTgt
|
||||
TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) <- updateSpline ( endTgtFwd, endTgtBwd )
|
||||
pure
|
||||
( Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
|
||||
, fwdFits <> bwdFits
|
||||
|
|
@ -243,160 +245,54 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
-- Single point.
|
||||
_ ->
|
||||
pure
|
||||
( Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
||||
( Left $ fmap ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
||||
, Empty
|
||||
)
|
||||
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 pt = brushFn ( ptParams pt )
|
||||
|
||||
updateSpline :: Vector2D Double -> ST s OutlineData
|
||||
updateSpline lastTgt
|
||||
updateSpline :: ( Vector2D Double, Vector2D Double ) -> ST s OutlineData
|
||||
updateSpline ( lastTgtFwd, lastTgtBwd )
|
||||
= execWriterT
|
||||
. ( `evalStateT` lastTgt )
|
||||
. ( `evalStateT` ( lastTgtFwd, lastTgtBwd ) )
|
||||
$ bifoldSpline
|
||||
( \ ptData curve -> do
|
||||
prev_tgt <- get
|
||||
( prev_tgtFwd, prev_tgtBwd ) <- get
|
||||
let
|
||||
tgt :: Vector2D Double
|
||||
tgt = startTangent spt0 ptData curve
|
||||
lift $ tellBrushJoin prev_tgt ptData tgt
|
||||
lift $ strokeOutline ptData curve
|
||||
put ( endTangent spt0 ptData curve )
|
||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||
( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve
|
||||
tgtFwd, tgtBwd, next_tgtFwd, next_tgtBwd :: Vector2D Double
|
||||
tgtFwd = snd ( fwd 0 )
|
||||
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 () ) )
|
||||
( 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
|
||||
:: crvData
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||
|
|
@ -426,29 +322,122 @@ 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).
|
||||
tellBrushJoin
|
||||
:: Monad m
|
||||
=> Vector2D Double
|
||||
=> ( Vector2D Double, Vector2D Double )
|
||||
-> ptData
|
||||
-> Vector2D Double
|
||||
-> ( Vector2D Double, Vector2D Double )
|
||||
-> WriterT OutlineData m ()
|
||||
tellBrushJoin prevTgt sp0 tgt
|
||||
| tgt `parallel` prevTgt
|
||||
= pure ()
|
||||
| otherwise
|
||||
= tell brushJoin
|
||||
where
|
||||
ptOffset :: Vector2D Double
|
||||
ptOffset = Point2D 0 0 --> coords sp0
|
||||
brush0 :: SplinePts Closed
|
||||
brush0 = brushShape sp0
|
||||
fwdJoin, bwdJoin :: SplinePts Open
|
||||
fwdJoin
|
||||
= fmap ( ptOffset • )
|
||||
$ joinWithBrush ( withTangent prevTgt brush0 ) ( withTangent tgt brush0 ) brush0
|
||||
bwdJoin
|
||||
= fmap ( ptOffset • )
|
||||
$ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0
|
||||
brushJoin :: OutlineData
|
||||
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
|
||||
tellBrushJoin ( prevTgtFwd, prevTgtBwd ) sp0 ( tgtFwd, tgtBwd ) = tell brushJoin
|
||||
where
|
||||
ptOffset :: Vector2D Double
|
||||
ptOffset = Point2D 0 0 --> coords sp0
|
||||
brush0 :: SplinePts Closed
|
||||
brush0 = brushShape sp0
|
||||
fwdJoin, bwdJoin :: SplinePts Open
|
||||
fwdJoin
|
||||
| tgtFwd `parallel` prevTgtFwd
|
||||
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
|
||||
| otherwise
|
||||
= fmap ( ptOffset • )
|
||||
$ joinWithBrush ( withTangent prevTgtFwd brush0 ) ( withTangent tgtFwd brush0 ) brush0
|
||||
bwdJoin
|
||||
| tgtBwd `parallel` prevTgtBwd
|
||||
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
|
||||
| otherwise
|
||||
= fmap ( ptOffset • )
|
||||
$ joinWithBrush ( withTangent ( (-1) *^ tgtBwd ) brush0 ) ( withTangent ( (-1) *^ prevTgtBwd ) brush0 ) brush0
|
||||
brushJoin :: OutlineData
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue