diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 10fb42d..313cdbf 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 8224af6..4fbcc79 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index ed32f47..ec8d260 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Action.hs-boot @@ -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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index fef49f3..6d7dae7 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 } ] } } diff --git a/src/app/MetaBrush/Brush.hs b/src/app/MetaBrush/Brush.hs index 25df014..7497978 100644 --- a/src/app/MetaBrush/Brush.hs +++ b/src/app/MetaBrush/Brush.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index d400cbe..4a6f70b 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 diff --git a/src/app/MetaBrush/Document/Serialise.hs-boot b/src/app/MetaBrush/Document/Serialise.hs-boot index 9bd7431..99a46b1 100644 --- a/src/app/MetaBrush/Document/Serialise.hs-boot +++ b/src/app/MetaBrush/Document/Serialise.hs-boot @@ -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 diff --git a/src/app/MetaBrush/MetaParameter/AST.hs b/src/app/MetaBrush/MetaParameter/AST.hs index 4fa5b83..b32a59d 100644 --- a/src/app/MetaBrush/MetaParameter/AST.hs +++ b/src/app/MetaBrush/MetaParameter/AST.hs @@ -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 ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index f53bfad..ee8adc3 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 ) <- diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index b7c6a29..55012fe 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -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