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

compute correct open stroke caps

Browse source
This commit is contained in:
sheaf 2021-05-12 13:58:30 +02:00
parent c64a4140c4
commit 2983943363
3 changed files with 196 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

136
src/lib/Math/Bezier/Stroke.hs
View file

@ -22,7 +22,6 @@ module Math.Bezier.Stroke
, CachedStroke(..), discardCache, invalidateCache
, computeStrokeOutline, joinWithBrush
, withTangent
, between, parallel
)
where
@ -32,7 +31,7 @@ import Prelude
import Control.Arrow
( first, (***) )
import Control.Monad
( guard, unless )
( unless )
import Control.Monad.ST
( RealWorld, ST )
import Data.Bifunctor
@ -42,7 +41,7 @@ import Data.Foldable
import Data.List.NonEmpty
( unzip )
import Data.Maybe
( fromMaybe, mapMaybe )
( fromMaybe, isJust, mapMaybe )
import GHC.Exts
( newMutVar#, runRW# )
import GHC.STRef
@ -103,17 +102,20 @@ import Math.Bezier.Spline
, KnownSplineType
( bifoldSpline, ibifoldSpline )
, Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveEnd, splitSplineAt, dropCurves
, openCurveStart, openCurveEnd, splitSplineAt, dropCurves
)
import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon
( epsilon )
import Math.Module
( Module((^-^), (*^)), Inner((^.^))
( Module((*^)), Inner((^.^))
, lerp, squaredNorm, cross
, convexCombination, strictlyParallel
)
import Math.Orientation
( Orientation(..), convexOrientation, splineOrientation )
( Orientation(..), convexOrientation, splineOrientation
, between
)
import Math.Roots
( solveQuadratic )
import Math.Vector2D
@ -152,7 +154,7 @@ instance Monoid OutlineData where
newtype CachedStroke s = CachedStroke { cachedStrokeRef :: STRef s ( Maybe OutlineData ) }
instance Show ( CachedStroke s ) where
show _ = "CachedStroke..."
show _ = "<<CachedStroke>>"
instance NFData ( CachedStroke s ) where
rnf _ = ()
@ -198,7 +200,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
SOpen
| ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, _ :|> lastCurve <- openCurves $ splineCurves spline
, firstCurve :<| _ <- openCurves $ splineCurves spline
, prevCurves :|> lastCurve <- openCurves $ splineCurves spline
, let
endPt :: ptData
endPt = openCurveEnd lastCurve
@ -210,9 +213,26 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0
endBrush = brushShape endPt
-- Computation of which brush segment to use for the end caps.
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
startTestTgt, endTestTgt :: Vector2D Double
( startTestTgt, endTestTgt ) =
case brushOrientation of
CCW -> ( Vector2D sty (-stx), Vector2D ety (-etx) )
CW -> ( Vector2D (-sty) stx , Vector2D (-ety) etx )
where
stx, sty, etx, ety :: Double
Vector2D stx sty = startTgt
Vector2D etx ety = endTgt
startCap, endCap :: SplinePts Open
startCap
| brushOrientation == convexOrientation [ startTgtBwd, startTgtFwd ]
| isJust $ between brushOrientation startTgtBwd startTgtFwd startTestTgt
= fmap ( MkVector2D ( coords spt0 ) • )
$ joinWithBrush ( withTangent startTgtBwd startBrush ) ( withTangent startTgtFwd startBrush ) startBrush
| otherwise
@ -220,7 +240,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
. reverseSpline
$ joinWithBrush ( withTangent startTgtFwd startBrush ) ( withTangent startTgtBwd startBrush )startBrush
endCap
| brushOrientation == convexOrientation [ endTgtFwd, endTgtBwd ]
| not . isJust $ between brushOrientation endTgtBwd endTgtFwd endTestTgt
= fmap ( MkVector2D ( coords endPt ) • )
. reverseSpline
$ joinWithBrush ( withTangent endTgtBwd endBrush ) ( withTangent endTgtFwd endBrush ) endBrush
@ -263,7 +283,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
where
brushOrientation :: Orientation
brushOrientation = splineOrientation ( brushShape spt0 )
brushOrientation = splineOrientation @Double ( brushShape spt0 )
outlineFns
:: Seq
@ -349,7 +369,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
brush0 = brushShape sp0
fwdJoin, bwdJoin :: SplinePts Open
fwdJoin
| tgtFwd `parallel` prevTgtFwd
| tgtFwd `strictlyParallel` prevTgtFwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| brushOrientation == convexOrientation [ prevTgtFwd, tgtFwd ]
= fmap ( ptOffset • )
@ -359,7 +379,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
. reverseSpline
$ joinWithBrush ( withTangent tgtFwd brush0 ) ( withTangent prevTgtFwd brush0 ) brush0
bwdJoin
| tgtBwd `parallel` prevTgtBwd
| tgtBwd `strictlyParallel` prevTgtBwd
= Spline { splineStart = coords sp0, splineCurves = OpenCurves Empty }
| brushOrientation == convexOrientation [ tgtBwd, prevTgtBwd ]
= fmap ( ptOffset • )
@ -433,33 +453,45 @@ outlineFunctions ptParams brushFn sp0 crv =
-> ( 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
= ( offset ( withTangent ( fwd' t ) ( brush t ) ) • f t
, fwd' t
)
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) )
offTgt :: Double -> Vector2D Double
offTgt u
| u < 0.5
= 1e9 *^ ( off u --> off (u + 1e-9) )
| otherwise
= 1e9 *^ ( off (t - 1e-9) --> off t )
= 1e9 *^ ( off (u - 1e-9) --> off u )
fwd' :: Double -> Vector2D Double
fwd' u
| squaredNorm ( offTgt u ) < epsilon
= f' u
| otherwise
= offTgt u
bwd t
= ( off s
, if squaredNorm offTgt < epsilon then (-1) *^ f' s else offTgt
= ( offset ( withTangent ( (-1) *^ bwd' s ) ( brush s ) ) • f s
, bwd' s
)
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) )
offTgt :: Double -> Vector2D Double
offTgt u
| u < 0.5
= 1e9 *^ ( off u --> off (u + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
= 1e9 *^ ( off (u - 1e-9) --> off u )
bwd' :: Double -> Vector2D Double
bwd' u
| squaredNorm ( offTgt u ) < epsilon
= (-1) *^ f' u
| otherwise
= offTgt u
in ( fwd, bwd )
-----------------------------------
@ -647,6 +679,8 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
\tangent vector: " <> show tgt_wanted <> "\n\
\spline: " <> show spline <> "\n"
where
ori :: Orientation
ori = splineOrientation @Double spline
go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) ()
go i cp cseg = do
tgt_prev <- get
@ -659,8 +693,8 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
tgt_start = startTangent splineStart cp cseg
tgt_end = endTangent splineStart cp cseg
-- Handle corner.
unless ( parallel tgt_prev tgt_start ) do
for_ ( between tgt_wanted tgt_prev tgt_start ) \ _ ->
unless ( tgt_prev `strictlyParallel` tgt_start ) do
for_ ( between ori tgt_prev tgt_start tgt_wanted ) \ _ ->
lift . throwE $
Offset
{ offsetIndex = i
@ -673,7 +707,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
handleSegment :: Int -> Point2D Double -> Curve Open crvData ( Point2D Double ) -> Vector2D Double -> Except Offset ()
handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0
| parallel tgt_wanted tgt0
| tgt_wanted `strictlyParallel` tgt0
, let
offset :: Vector2D Double
offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1
@ -684,7 +718,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
let
tgt1 :: Vector2D Double
tgt1 = p1 --> p2
in for_ ( between tgt_wanted tgt0 tgt1 ) \ t ->
in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ t ->
throwE $
Offset
{ offsetIndex = i
@ -715,7 +749,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
mbParam =
case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of
( t : _ ) -> Just t
_ -> between tgt_wanted tgt0 tgt2 -- fallback in case we couldn't solve the quadratic for some reason
_ -> between ori tgt0 tgt2 tgt_wanted -- fallback in case we couldn't solve the quadratic for some reason
in for_ mbParam \ t ->
throwE $
Offset
@ -723,41 +757,3 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spli
, offsetParameter = Just t
, offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t
}
-- | Finds whether the query vector @ u @ lies between the two provided vectors @ v0 @, @ v1 @.
--
-- If so, returns @ t @ in @ [ 0, 1 ] @ such that @ ( 1 - t ) v0 + t v1 @ is a positive multiple of @ u @.
between
:: Vector2D Double -- ^ query vector
-> Vector2D Double -- ^ first vector
-> Vector2D Double -- ^ second vector
-> Maybe Double
between u v0 v1
| abs c10 < epsilon
= if parallel u v0
then Just 0
else if parallel u v1
then Just 1
else Nothing
| otherwise
= do
let
t :: Double
t = c0 / c10
guard ( t > - epsilon && t < 1 + epsilon )
guard ( epsilon < u ^.^ ( lerp @( Vector2D Double ) t v0 v1 ) )
Just $ min 1 ( max 0 t )
where
c0, c10 :: Double
c0 = v0 `cross` u
c10 = ( v0 ^-^ v1 ) `cross` u
-- | Compute whether two vectors point in the same direction,
-- that is, whether each vector is a (strictly) positive multiple of the other.
--
-- Returns @False@ if either of the vectors is zero.
parallel :: Vector2D Double -> Vector2D Double -> Bool
parallel u v
= abs ( u `cross` v ) < epsilon -- vectors are collinear
&& u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel)

49
src/lib/Math/Module.hs
View file

@ -12,12 +12,15 @@ module Math.Module
, squaredNorm, quadrance, distance
, proj, projC, closestPointOnSegment
, cross
, strictlyParallel, convexCombination
)
where
-- base
import Control.Applicative
( liftA2 )
import Control.Monad
( guard )
import Data.Monoid
( Ap(..), Sum(..) )
@ -34,6 +37,8 @@ import Data.Group
( invert )
-- MetaBrush
import Math.Epsilon
( epsilon )
import Math.Vector2D
( Vector2D(..), Segment(..) )
@ -107,6 +112,7 @@ closestPointOnSegment c ( Segment p0 p1 )
t :: r
t = projC ( p0 --> c ) v01
--------------------------------------------------------------------------------
instance Num a => Module a ( Sum a ) where
@ -136,6 +142,47 @@ instance Num a => Inner a ( Vector2D a ) where
( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
= x1 * x2 + y1 * y2
-- | Cross-product of two 2D vectors.
cross :: Num a => Vector2D a -> Vector2D a -> a
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
= x1 * y2 - x2 * y1
= x1 * y2 - x2 * y1
-- | Compute whether two vectors point in the same direction,
-- that is, whether each vector is a (strictly) positive multiple of the other.
--
-- Returns @False@ if either of the vectors is zero.
strictlyParallel :: RealFloat r => Vector2D r -> Vector2D r -> Bool
strictlyParallel u v
= abs ( u `cross` v ) < epsilon -- vectors are collinear
&& u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel)
-- | Finds whether the query vector @ u @ is a convex combination of the two provided vectors @ v0 @, @ v1 @.
--
-- If so, returns @ t @ in @ [ 0, 1 ] @ such that @ ( 1 - t ) v0 + t v1 @ is a positive multiple of @ u @.
convexCombination
:: forall r
. RealFloat r
=> Vector2D r -- ^ first vector
-> Vector2D r -- ^ second vector
-> Vector2D r -- ^ query vector
-> Maybe r
convexCombination v0 v1 u
| abs c10 < epsilon
= if strictlyParallel u v0
then Just 0
else if strictlyParallel u v1
then Just 1
else Nothing
| otherwise
= do
let
t :: r
t = c0 / c10
guard ( t > - epsilon && t < 1 + epsilon )
guard ( epsilon < u ^.^ ( lerp @( Vector2D r ) t v0 v1 ) )
Just $ min 1 ( max 0 t )
where
c0, c10 :: r
c0 = v0 `cross` u
c10 = ( v0 ^-^ v1 ) `cross` u

105
src/lib/Math/Orientation.hs
View file

@ -1,5 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -7,9 +9,16 @@
module Math.Orientation
( Orientation(..), reverseOrientation
, convexOrientation, splineOrientation, splineTangents
, between
)
where
-- base
import Control.Monad
( guard )
import Data.Fixed
( mod' )
-- acts
import Data.Act
( Torsor((-->)) )
@ -18,6 +27,12 @@ import Data.Act
import Data.Sequence
( Seq(..) )
-- generic-lens
import Data.Generics.Product.Typed
( HasType(typed) )
import Data.GenericLens.Internal
( view )
-- MetaBrush
import Math.Epsilon
( nearZero )
@ -29,7 +44,7 @@ import Math.Bezier.Spline
, ssplineType
)
import Math.Vector2D
( Point2D, Vector2D )
( Point2D, Vector2D(..) )
--------------------------------------------------------------------------------
@ -58,34 +73,78 @@ convexOrientation _ = CCW -- default
-- | Compute the orientation of a spline, assuming tangent vectors have a monotone angle.
splineOrientation
:: ( KnownSplineType clo, RealFloat r )
=> Spline clo crvData ( Point2D r )
:: forall r clo crvData ptData
. ( KnownSplineType clo, RealFloat r, HasType ( Point2D r ) ptData )
=> Spline clo crvData ptData
-> Orientation
splineOrientation = convexOrientation . splineTangents
splineOrientation = convexOrientation . splineTangents @r
-- | Compute the sequence of tangent vectors given by the control points of a Bézier spline.
splineTangents
:: forall clo crvData r
. ( Num r, KnownSplineType clo )
=> Spline clo crvData ( Point2D r )
:: forall r clo crvData ptData
. ( Num r, KnownSplineType clo, HasType ( Point2D r ) ptData )
=> Spline clo crvData ptData
-> [ Vector2D r ]
splineTangents spline@( Spline { splineStart = p0, splineCurves = curves } ) =
case ssplineType @clo of
SOpen
| OpenCurves { openCurves = cs } <- curves
-> go p0 cs
SClosed
| OpenCurves cs@( c :<| _ ) <- splineCurves $ adjustSplineType @Open spline
-> go p0 ( cs :|> c )
_ -> []
splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
| let
p0 :: Point2D r
p0 = view typed sp0
= case ssplineType @clo of
SOpen
| OpenCurves { openCurves = cs } <- curves
-> go p0 cs
SClosed
| OpenCurves cs@( c :<| _ ) <- splineCurves $ adjustSplineType @Open spline
-> go p0 ( cs :|> c )
_ -> []
where
go :: Point2D r -> Seq ( Curve Open crvData ( Point2D r ) ) -> [ Vector2D r ]
go :: Point2D r -> Seq ( Curve Open crvData ptData ) -> [ Vector2D r ]
go _ Empty = []
go p ( crv :<| crvs ) =
case crv of
LineTo { curveEnd = NextPoint q } ->
( p --> q ) : go q crvs
Bezier2To { controlPoint = cp, curveEnd = NextPoint q } ->
( p --> cp ) : ( cp --> q ) : go q crvs
Bezier3To { controlPoint1 = cp1, controlPoint2 = cp2, curveEnd = NextPoint q } ->
( p --> cp1 ) : ( cp2 --> q ) : go q crvs
LineTo { curveEnd = NextPoint sq }
| let
q :: Point2D r
q = view typed sq
-> ( p --> q ) : go q crvs
Bezier2To { controlPoint = scp, curveEnd = NextPoint sq }
| let
cp, q :: Point2D r
cp = view typed scp
q = view typed sq
-> ( p --> cp ) : ( cp --> q ) : go q crvs
Bezier3To { controlPoint1 = scp1, controlPoint2 = scp2, curveEnd = NextPoint sq }
| let
cp1, cp2, q :: Point2D r
cp1 = view typed scp1
cp2 = view typed scp2
q = view typed sq
-> ( p --> cp1 ) : ( cp2 --> q ) : go q crvs
-- | Checks whether a 2D vector lies "in between" two other vectors according to a given orientation,
-- i.e. whether the angle of the query vector lies in between the angles of the start and end vectors.
--
-- Returns the proportion of the angle the vector is in between, or @Nothing@ if the query vector
-- is not in between.
--
-- >>> between CCW ( Vector2D 1 0 ) ( Vector2D (-1) 1 ) ( Vector2D 1 1 )
-- Just 0.3333333333333333
between
:: forall r
. RealFloat r
=> Orientation
-> Vector2D r -- ^ start vector
-> Vector2D r -- ^ end vector
-> Vector2D r -- ^ query vector: is in between the start and end vectors w.r.t. the provided orientation?
-> Maybe r
between CCW ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) ( Vector2D a b ) =
let
τ, η, φ, θ :: r
τ = 2 * pi
η = atan2 y1 x1
φ = ( atan2 y2 x2 - η ) `mod'` τ
θ = ( atan2 b a - η ) `mod'` τ
in do
guard ( θ < φ )
pure ( θ / φ )
between CW v1 v2 u = ( 1 - ) <$> between CCW v2 v1 u