module Graphics.Rasterific.CubicBezier
( cubicBezierCircle
, cubicBezierFromPath
, cubicBezierBreakAt
, clipCubicBezier
, decomposeCubicBeziers
, sanitizeCubicBezier
, offsetCubicBezier
, flattenCubicBezier
, cubicBezierLengthApproximation
, cubicBezierBounds
) where
import Prelude hiding( or )
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure )
import Data.Monoid( mempty )
#endif
import Data.Monoid( (<>) )
import Control.Applicative( liftA2, (<$>))
import Graphics.Rasterific.Linear
( V2( .. )
, (^-^)
, (^+^)
, (^*)
, norm
, lerp
)
import Data.List( nub )
import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types
import Graphics.Rasterific.QuadraticFormula
cubicBezierFromPath :: [Point] -> [CubicBezier]
cubicBezierFromPath (a:b:c:rest@(d:_)) =
CubicBezier a b c d : cubicBezierFromPath rest
cubicBezierFromPath _ = []
cubicBezierLengthApproximation :: CubicBezier -> Float
cubicBezierLengthApproximation (CubicBezier a _ _ d) =
norm $ d ^-^ a
cubicBezierCircle :: [CubicBezier]
cubicBezierCircle =
[ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0)
, CubicBezier (V2 1 0) (V2 1 (c)) (V2 c (1)) (V2 0 (1))
, CubicBezier (V2 0 (1)) (V2 (c) (1)) (V2 (1) (c)) (V2 (1) 0)
, CubicBezier (V2 (1) 0) (V2 (1) c) (V2 (c) 1) (V2 0 1)
]
where c = 0.551915024494
straightLine :: Point -> Point -> CubicBezier
straightLine a b = CubicBezier a p p b
where p = a `midPoint` b
isSufficientlyFlat :: Float
-> CubicBezier
-> Bool
isSufficientlyFlat tol (CubicBezier a b c d) =
x + y <= tolerance
where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d
v = (c ^* 3) ^-^ (d ^* 2) ^-^ a
(^*^) = liftA2 (*)
V2 x y = vmax (u ^*^ u) (v ^*^ v)
tolerance = 16 * tol * tol
splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point)
splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd)
where
ab = a `midPoint` b
bc = b `midPoint` c
cd = c `midPoint` d
abbc = ab `midPoint` bc
bccd = bc `midPoint` cd
abbcbccd = abbc `midPoint` bccd
flattenCubicBezier :: CubicBezier -> Container Primitive
flattenCubicBezier bezier@(CubicBezier a _ _ d)
| isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier
| otherwise =
flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <>
flattenCubicBezier (CubicBezier abbcbccd bccd cd d)
where
(ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier
data CachedBezier = CachedBezier
{ _cachedA :: !Float
, _cachedB :: !Float
, _cachedC :: !Float
, _cachedD :: !Float
}
cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier)
cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) =
(CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY)
where
V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3
V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3
V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0
cachedBezierAt :: CachedBezier -> Float -> Float
cachedBezierAt (CachedBezier a b c d) t =
a + b * t + c * tSquare + tCube * d
where
tSquare = t * t
tCube = tSquare * t
cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float
cachedBezierDerivative (CachedBezier _ b c d) =
QuadraticFormula (3 * d) (2 * c) b
extremums :: CachedBezier -> [Float]
extremums cached =
[ root | root <- formulaRoots $ cachedBezierDerivative cached
, 0 <= root && root <= 1.0 ]
extremumPoints :: (CachedBezier, CachedBezier) -> [Point]
extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY)
where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at)
cubicBezierBounds :: CubicBezier -> [Point]
cubicBezierBounds bez@(CubicBezier p0 _ _ p3) =
p0 : p3 : extremumPoints (cacheBezier bez)
offsetCubicBezier :: Float -> CubicBezier -> Container Primitive
offsetCubicBezier offset bezier@(CubicBezier a b c d)
| isSufficientlyFlat 1 bezier =
pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD
| otherwise =
recurse (CubicBezier a ab abbc abbcbccd) <>
recurse (CubicBezier abbcbccd bccd cd d)
where
recurse = offsetCubicBezier offset
u = a `normal` b
v = c `normal` d
(ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier
w = ab `normal` bc
x = bc `normal` cd
shiftedA = a ^+^ (u ^* offset)
shiftedD = d ^+^ (v ^* offset)
shiftedB = b ^+^ (w ^* offset)
shiftedC = c ^+^ (x ^* offset)
clipCubicBezier
:: Point
-> Point
-> CubicBezier
-> Container Primitive
clipCubicBezier mini maxi bezier@(CubicBezier a b c d)
| insideX && insideY = pure $ CubicBezierPrim bezier
| outsideX || outsideY =
pure . CubicBezierPrim $ clampedA `straightLine` clampedD
| otherwise =
recurse (CubicBezier a ab abbc m) <>
recurse (CubicBezier m bccd cd d)
where
bmin = vmin a . vmin b $ vmin c d
bmax = vmax a . vmax b $ vmax c d
recurse = clipCubicBezier mini maxi
clamper = clampPoint mini maxi
clampedA = clamper a
clampedD = clamper d
V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi
V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin
(ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier
edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi)
edge = vpartition edgeSeparator mini maxi
m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd
cubicBezierBreakAt :: CubicBezier -> Float
-> (CubicBezier, CubicBezier)
cubicBezierBreakAt (CubicBezier a b c d) val =
(CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d)
where
ab = lerp val a b
bc = lerp val b c
cd = lerp val c d
abbc = lerp val ab bc
bccd = lerp val bc cd
abbcbccd = lerp val abbc bccd
decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample
decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) =
go aRx aRy bRx bRy cRx cRy dRx dRy where
go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY =
let !px = fromIntegral $ min floorAx floorDx
!py = fromIntegral $ min floorAy floorDy
!w = px + 1 (dx `middle` ax)
!h = dy ay
in
EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont
where
floorAx, floorAy :: Int
!floorAx = floor ax
!floorAy = floor ay
!floorDx = floor dx
!floorDy = floor dy
!insideX =
floorAx == floorDx || ceiling ax == (ceiling dx :: Int)
!insideY =
floorAy == floorDy || ceiling ay == (ceiling dy :: Int)
go !ax !ay !bx !by !cx !cy !dx !dy cont =
go ax ay abx aby abbcx abbcy mx my $
go mx my bccdx bccdy cdx cdy dx dy cont
where
!abx = ax `middle` bx
!aby = ay `middle` by
!bcx = bx `middle` cx
!bcy = by `middle` cy
!cdx = cx `middle` dx
!cdy = cy `middle` dy
!abbcx = abx `middle` bcx
!abbcy = aby `middle` bcy
!bccdx = bcx `middle` cdx
!bccdy = bcy `middle` cdy
!abbcbccdx = abbcx `middle` bccdx
!abbcbccdy = abbcy `middle` bccdy
!mx | abs (abbcbccdx mini) < 0.1 = mini
| abs (abbcbccdx maxi) < 0.1 = maxi
| otherwise = abbcbccdx
where !mini = fromIntegral (floor abbcbccdx :: Int)
!maxi = fromIntegral (ceiling abbcbccdx :: Int)
!my | abs (abbcbccdy mini) < 0.1 = mini
| abs (abbcbccdy maxi) < 0.1 = maxi
| otherwise = abbcbccdy
where !mini = fromIntegral (floor abbcbccdy :: Int)
!maxi = fromIntegral (ceiling abbcbccdy :: Int)
sanitizeCubicBezier :: CubicBezier -> Container Primitive
sanitizeCubicBezier bezier@(CubicBezier a b c d)
| a `isDistingableFrom` b &&
c `isDistingableFrom` d =
pure . CubicBezierPrim $ bezier
| ac `isDistingableFrom` b &&
bd `isDistingableFrom` c =
pure . CubicBezierPrim $ bezier
| ac `isDistingableFrom` b =
pure . CubicBezierPrim $ CubicBezier a ac c d
| bd `isDistingableFrom` c =
pure . CubicBezierPrim $ CubicBezier a b bd d
| otherwise = mempty
where ac = a `midPoint` c
bd = a `midPoint` d