module Graphics.Rasterific.QuadraticBezier
(
straightLine
, bezierFromPath
, decomposeBeziers
, clipBezier
, sanitizeBezier
, offsetBezier
, flattenBezier
, bezierBreakAt
, bezierLengthApproximation
) where
import Control.Applicative( (<$>), (<*>), pure )
import Graphics.Rasterific.Linear
( V2( .. )
, V1( .. )
, (^-^)
, (^+^)
, (^*)
, dot
, norm
, lerp
)
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 -> Container EdgeSample
decomposeBeziers (Bezier aRoot bRoot cRoot) = go aRoot bRoot cRoot where
go !a@(V2 ax ay) !_ !c@(V2 cx cy)
| insideX && insideY = pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h
where
!floorA = vfloor a
!floorC = vfloor c
!(V2 insideX insideY) =
floorA ^==^ floorC ^||^ vceil a ^==^ vceil c
!(V2 px py) = fromIntegral <$> vmin floorA floorC
!(V1 w) = (px + 1 ) <$> (V1 cx `midPoint` V1 ax)
!h = cy ay
go a b c = go a ab m <> go m bc c
where
!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 = lerp t a b
bc = lerp t b c
abbc = lerp t ab 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 = (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)