module Graphics.Rasterific.StrokeInternal
( flatten
, dashize
, strokize
, dashedStrokize
, splitPrimitiveUntil
, approximatePathLength
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure )
import Data.Monoid( mempty )
import Data.Foldable( foldMap )
#endif
import Control.Applicative( (<$>) )
import Data.Monoid( (<>) )
import Graphics.Rasterific.Linear
( V2( .. )
, (^-^)
, (^+^)
, (^*)
, dot
)
import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Line
lastPoint :: Primitive -> Point
lastPoint (LinePrim (Line _ x1)) = x1
lastPoint (BezierPrim (Bezier _ _ x2)) = x2
lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3
lastPointAndNormal :: Primitive -> (Point, Vector)
lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b)
lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c)
lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d)
firstPointAndNormal :: Primitive -> (Point, Vector)
firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b)
firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b)
firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b)
reversePrimitive :: Primitive -> Primitive
reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a)
reversePrimitive (BezierPrim (Bezier a b c)) =
BezierPrim (Bezier c b a)
reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) =
CubicBezierPrim (CubicBezier d c b a)
roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive
roundJoin offset p = go
where go u v
| u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c
| otherwise = go u w <> go w v
where
a = p ^+^ u ^* offset
c = p ^+^ v ^* offset
w = (a `normal` c) `ifZero` u
n = p ^+^ w ^* offset
b = n ^* 2 ^-^ (a `midPoint` c)
cap :: Float -> Cap -> Primitive -> Container Primitive
cap offset CapRound prim = roundJoin offset p u ( u)
where (p, u) = lastPointAndNormal prim
cap offset (CapStraight cVal) prim =
pure (d `lineFromTo` e) <> pure (e `lineFromTo` f)
<> pure (f `lineFromTo` g)
where
(p, u@(V2 ux uy)) = lastPointAndNormal prim
v = V2 uy $ negate ux
d = p ^+^ u ^* offset
g = p ^-^ u ^* offset
e = d ^+^ v ^* (offset * cVal)
f = g ^+^ v ^* (offset * cVal)
lineFromTo :: Point -> Point -> Primitive
lineFromTo a b = LinePrim (Line a b)
miterJoin :: Float -> Float -> Point -> Vector -> Vector
-> Container Primitive
miterJoin offset l point u v
| uDotW > l / max 1 l && uDotW > 0.01 =
pure (m `lineFromTo` c) <> pure (a `lineFromTo` m)
| otherwise = pure $ a `lineFromTo` c
where
a = point ^+^ u ^* offset
c = point ^+^ v ^* offset
w = (a `normal` c) `ifZero` u
uDotW = u `dot` w
p = offset / uDotW
m = point + w ^* p
joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive
-> Container Primitive
joinPrimitives offset join prim1 prim2 =
case join of
JoinRound -> roundJoin offset p u v
JoinMiter l -> miterJoin offset l p u v
where (p, u) = lastPointAndNormal prim1
(_, v) = firstPointAndNormal prim2
offsetPrimitives :: Float -> Primitive -> Container Primitive
offsetPrimitives offset (LinePrim l) = offsetLine offset l
offsetPrimitives offset (BezierPrim b) = offsetBezier offset b
offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c
offsetAndJoin :: Float -> Join -> Cap -> [Primitive]
-> Container Primitive
offsetAndJoin _ _ _ [] = mempty
offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest
where joiner = joinPrimitives offset join
offseter = offsetPrimitives offset
(firstPoint, _) = firstPointAndNormal firstShape
go prev []
| firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev
| otherwise = offseter prev <> cap offset caping prev
go prev (x:xs) =
joiner prev x <> offseter prev <> go x xs
approximateLength :: Primitive -> Float
approximateLength (LinePrim l) = lineLength l
approximateLength (BezierPrim b) = bezierLengthApproximation b
approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c
sanitize :: Primitive -> Container Primitive
sanitize (LinePrim l) = sanitizeLine l
sanitize (BezierPrim b) = sanitizeBezier b
sanitize (CubicBezierPrim c) = sanitizeCubicBezier c
strokize :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive]
-> Container Primitive
strokize width join (capStart, capEnd) beziers =
offseter capEnd sanitized <>
offseter capStart (reverse $ reversePrimitive <$> sanitized)
where
sanitized = foldMap (listOfContainer . sanitize) beziers
offseter = offsetAndJoin (width / 2) join
flattenPrimitive :: Primitive -> Container Primitive
flattenPrimitive (BezierPrim bezier) = flattenBezier bezier
flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier
flattenPrimitive (LinePrim line) = flattenLine line
breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive)
breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b)
where (a, b) = bezierBreakAt bezier at
breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b)
where (a, b) = cubicBezierBreakAt bezier at
breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b)
where (a, b) = lineBreakAt line at
flatten :: Container Primitive -> Container Primitive
flatten = foldMap flattenPrimitive
splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil = go
where
go _ [] = ([], [])
go left lst
| left <= 0 = ([], lst)
go left (x : xs)
| left > primLength = (x : inInterval, afterInterval)
| otherwise = ([beforeStop], afterStop : xs)
where
primLength = approximateLength x
(inInterval, afterInterval) = go (left primLength) xs
(beforeStop, afterStop) =
breakPrimitiveAt x $ left / primLength
dropPattern :: Float -> DashPattern -> DashPattern
dropPattern = go
where
go _ [] = []
go offset (x:xs)
| x < 0 = x:xs
| offset < x = x offset : xs
| otherwise = go (offset x) xs
linearizePrimitives :: [Primitive] -> [Primitive]
linearizePrimitives =
listOfContainer . foldMap flattenPrimitive . foldMap sanitize
approximatePathLength :: Path -> Float
approximatePathLength = approximatePrimitivesLength . pathToPrimitives
approximatePrimitivesLength :: [Primitive] -> Float
approximatePrimitivesLength prims =
sum $ approximateLength <$> linearizePrimitives prims
dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]
dashize offset pattern = taker infinitePattern . linearizePrimitives
where
realOffset | offset >= 0 = offset
| otherwise = offset + sum pattern
infinitePattern =
dropPattern realOffset . cycle $ filter (> 0) pattern
taker _ [] = []
taker [] _ = []
taker (atValue:atRest) stream = toKeep : droper atRest next
where (toKeep, next) = splitPrimitiveUntil atValue stream
droper _ [] = []
droper [] _ = []
droper (atValue:atRest) stream = taker atRest next
where (_toKeep, next) = splitPrimitiveUntil atValue stream
dashedStrokize :: Float
-> DashPattern
-> StrokeWidth
-> Join
-> (Cap, Cap)
-> [Primitive]
-> [[Primitive]]
dashedStrokize offset dashPattern width join capping beziers =
listOfContainer . strokize width join capping
<$> dashize offset dashPattern beziers