module Graphics.Rasterific.QuadraticBezier
(
straightLine
, bezierFromPath
, decomposeBeziers
, clipBezier
, sanitizeBezier
, offsetBezier
, flattenBezier
, bezierBreakAt
, bezierLengthApproximation
, isBezierPoint
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure )
import Data.Monoid( Monoid( mempty ) )
#endif
import Graphics.Rasterific.Linear
( V2( .. )
, (^-^)
, (^+^)
, (^*)
, dot
, norm
, lerp
)
import Data.Monoid( (<>) )
import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types
bezierFromPath :: [Point] -> [Bezier]
bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest
bezierFromPath _ = []
isBezierPoint :: Bezier -> Bool
isBezierPoint (Bezier a b c) =
not $ a `isDistingableFrom` b ||
b `isDistingableFrom` c
bezierLengthApproximation :: Bezier -> Float
bezierLengthApproximation (Bezier a _ c) =
norm $ c ^-^ a
decomposeBeziers :: Bezier -> Producer EdgeSample
decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) =
go aRx aRy bRx bRy cRx cRy where
go ax ay _bx _by cx cy cont
| insideX && insideY =
let !px = fromIntegral $ min floorAx floorCx
!py = fromIntegral $ min floorAy floorCy
!w = px + 1 cx `middle` ax
!h = cy ay
in
EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont
where
floorAx, floorAy :: Int
!floorAx = floor ax
!floorAy = floor ay
!floorCx = floor cx
!floorCy = floor cy
!insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int)
!insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int)
go !ax !ay !bx !by !cx !cy cont =
go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont
where
!abx = ax `middle` bx
!aby = ay `middle` by
!bcx = bx `middle` cx
!bcy = by `middle` cy
!abbcx = abx `middle` bcx
!abbcy = aby `middle` bcy
!mx | abs (abbcx mini) < 0.1 = mini
| abs (abbcx maxi) < 0.1 = maxi
| otherwise = abbcx
where !mini = fromIntegral (floor abbcx :: Int)
!maxi = fromIntegral (ceiling abbcx :: Int)
!my | abs (abbcy mini) < 0.1 = mini
| abs (abbcy maxi) < 0.1 = maxi
| otherwise = abbcy
where !mini = fromIntegral (floor abbcy :: Int)
!maxi = fromIntegral (ceiling abbcy :: Int)
straightLine :: Point -> Point -> Bezier
straightLine a c = Bezier a (a `midPoint` c) c
clipBezier :: Point
-> Point
-> Bezier
-> Container Primitive
clipBezier mini maxi bezier@(Bezier a b c)
| insideX && insideY = pure $ BezierPrim bezier
| outsideX || outsideY =
pure . BezierPrim $ clampedA `straightLine` clampedC
| otherwise =
recurse (Bezier a ab m) <>
recurse (Bezier m bc c)
where
bmin = vmin a $ vmin b c
bmax = vmax a $ vmax b c
recurse = clipBezier mini maxi
clamper = clampPoint mini maxi
clampedA = clamper a
clampedC = clamper c
V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi
V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin
(ab, bc, abbc) = splitBezier bezier
edgeSeparator =
vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi)
edge = vpartition edgeSeparator mini maxi
m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc
sanitizeBezier :: Bezier -> Container Primitive
sanitizeBezier bezier@(Bezier a b c)
| u `dot` v < 0.9999 =
sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <>
sanitizeBezier (Bezier abbc (abbc `midPoint` c) c)
| a `isDistingableFrom` b && b `isDistingableFrom` c =
pure . BezierPrim $ bezier
| ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c)
| otherwise = mempty
where u = a `normal` b
v = b `normal` c
ac = a `midPoint` c
abbc = (a `midPoint` b) `midPoint` (b `midPoint` c)
bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier)
bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c)
where
ab = lerp t b a
bc = lerp t c b
abbc = lerp t bc ab
splitBezier :: Bezier -> (Point, Point, Point)
splitBezier (Bezier a b c) = (ab, bc, abbc)
where
ab = a `midPoint` b
bc = b `midPoint` c
abbc = ab `midPoint` bc
flattenBezier :: Bezier -> Container Primitive
flattenBezier bezier@(Bezier a b c)
| u `dot` v >= 0.9 = pure $ BezierPrim bezier
| a /= b && b /= c =
flattenBezier (Bezier a ab abbc) <>
flattenBezier (Bezier abbc bc c)
| otherwise = mempty
where
u = a `normal` b
v = b `normal` c
(ab, bc, abbc) = splitBezier bezier
offsetBezier :: Float -> Bezier -> Container Primitive
offsetBezier offset bezier@(Bezier a b c)
| u `dot` v >= 0.9 =
pure . BezierPrim $ Bezier shiftedA mergedB shiftedC
| a /= b && b /= c =
offsetBezier offset (Bezier a ab abbc) <>
offsetBezier offset (Bezier abbc bc c)
| otherwise = mempty
where
u = a `normal` b
v = b `normal` c
w = ab `normal` bc
(ab, bc, abbc) = splitBezier bezier
shiftedA = a ^+^ (u ^* offset)
shiftedC = c ^+^ (v ^* offset)
shiftedABBC = abbc ^+^ (w ^* offset)
mergedB =
(shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC)