module Graphics.Rasterific.QuadraticBezier
(
straightLine
, bezierFromPath
, decomposeBeziers
, clipBezier
, sanitizeBezier
, offsetBezier
, flattenBezier
, bezierBreakAt
, bezierLengthApproximation
) where
import Control.Applicative( (<$>)
, (<*>)
, Applicative
, pure )
import Linear( V2( .. )
, V1( .. )
, (^-^)
, (^+^)
, (^*)
, dot
, norm
)
import Data.Monoid( Monoid( mempty ), (<>) )
import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types
bezierFromPath :: [Point] -> [Bezier]
bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest
bezierFromPath _ = []
bezierLengthApproximation :: Bezier -> Float
bezierLengthApproximation (Bezier a _ c) =
norm $ c ^-^ a
decomposeBeziers :: Bezier -> [EdgeSample]
decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy))
| insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h]
| otherwise = recurse (Bezier a ab m) <>
recurse (Bezier m bc c)
where floorA = vfloor a
floorC = vfloor c
V2 px py = fromIntegral <$> vmin floorA floorC
V1 w = (px + 1 ) <$> (V1 cx `midPoint` V1 ax)
h = cy ay
recurse = decomposeBeziers
V2 insideX insideY =
floorA ^==^ floorC ^||^ vceil a ^==^ vceil c
ab = a `midPoint` b
bc = b `midPoint` c
abbc = ab `midPoint` bc
mini = fromIntegral <$> vfloor abbc
maxi = fromIntegral <$> vceil abbc
nearmin = vabs (abbc ^-^ mini) ^< 0.1
nearmax = vabs (abbc ^-^ maxi) ^< 0.1
minMaxing mi nearmi ma nearma p
| nearmi = mi
| nearma = ma
| otherwise = p
m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc
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 = a `midPoint` b
bc = b `midPoint` c
abbc = ab `midPoint` bc
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 = lerpPoint a b t
bc = lerpPoint b c t
abbc = lerpPoint ab bc t
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 = (a `midPoint` b)
bc = (b `midPoint` c)
abbc = ab `midPoint` bc
offsetBezier :: Float -> Bezier -> Container Primitive
offsetBezier offset (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 = (a `midPoint` b)
bc = (b `midPoint` c)
abbc = ab `midPoint` bc
shiftedA = a ^+^ (u ^* offset)
shiftedC = c ^+^ (v ^* offset)
shiftedABBC = abbc ^+^ (w ^* offset)
mergedB =
(shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC)