module Graphics.Rasterific.StrokeInternal ( flatten , dashize , strokize , dashedStrokize , splitPrimitiveUntil , approximatePathLength , isPrimitivePoint , sanitize , sanitizeFilling ) where import Graphics.Rasterific.Linear ( V2( .. ) , (^-^) , (^+^) , (^*) , dot , nearZero ) 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) isPrimitivePoint :: Primitive -> Bool isPrimitivePoint p = case p of LinePrim l -> isLinePoint l BezierPrim b -> isBezierPoint b CubicBezierPrim c -> isCubicBezierPoint c 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) -- | Create a "rounded" join or cap roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive roundJoin offset p = go where go u v -- If we're already on a nice curvature, -- don't bother doing anything | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c | otherwise = go u w <> go w v where -- ^ -- |w -- a X---X c -- \ / -- Xp -- ^ / \ ^ -- u\/ \/v -- / \ . a = p ^+^ u ^* offset c = p ^+^ v ^* offset w = (a `normal` c) `ifZero` u -- Same as offseting n = p ^+^ w ^* offset b = n ^* 2 ^-^ (a `midPoint` c) -- | Put a cap at the end of a bezier curve, depending -- on the kind of cap wanted. cap :: Float -> Cap -> Primitive -> Container Primitive cap offset CapRound prim | nearZero u = cap offset (CapStraight 0) prim | otherwise = 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 -- The usual "normal" (p, u@(V2 ux uy)) = lastPointAndNormal prim -- Vector pointing in the direction of the curve -- of norm 1 v = V2 uy $ negate ux -- Finishing points around the edge -- -u*offset u*offset -- <-><-> -- d/ / /g -- / / / -- / / / -- / -- / curve -- d = p ^+^ u ^* offset g = p ^-^ u ^* offset -- Create the "far" points -- -- e f -- / / ^ -- / / / v * offset * cVal -- d/ / /g -- / / / -- / / / -- / -- / curve -- 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 (a `lineFromTo` m) <> pure (m `lineFromTo` c) -- A simple straight junction | otherwise = pure $ a `lineFromTo` c where -- X m -- /\ -- /|w\ -- a X---X c -- \ / -- Xp -- ^ / \ ^ -- u\/ \/v -- / \ . a = point ^+^ u ^* offset c = point ^+^ v ^* offset w = (a `normal` c) `ifZero` u uDotW = u `dot` w -- Calculate the maximum distance on the -- u axis p = offset / uDotW -- middle point for "straight joining" m = point + w ^* p joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive -> Container Primitive joinPrimitives offset join prim1 prim2 = case join of JoinRound | nearZero u || nearZero v -> miterJoin offset 0 p u v 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 = offseter prev <> joiner prev firstShape | otherwise = offseter prev <> cap offset caping prev go prev (x:xs) = offseter prev <> joiner prev x <> 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 -- | Sanitizing that don't cull really small elements, only -- Degenerate case, to allow them to participate to the correct -- coverage, even if really small. sanitizeFilling :: Primitive -> Container Primitive sanitizeFilling (LinePrim l) = sanitizeLineFilling l sanitizeFilling (BezierPrim b) = sanitizeBezierFilling b sanitizeFilling (CubicBezierPrim c) = sanitizeCubicBezierFilling c strokize :: Geometry geom => StrokeWidth -> Join -> (Cap, Cap) -> geom -> Container Primitive strokize width join (capStart, capEnd) geom = foldMap pathOffseter sanitized where sanitized = foldMap (listOfContainer . sanitize) <$> resplit (toPrimitives geom) offseter = offsetAndJoin (width / 2) join pathOffseter v = offseter capEnd v <> offseter capStart (reverse $ reversePrimitive <$> v) 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 -- sanitizing | offset < x = x - offset : xs | otherwise {- offset >= x -} = go (offset - x) xs -- | Don't make them completly flat, but suficiently -- to assume they are. linearizePrimitives :: [Primitive] -> [Primitive] linearizePrimitives = listOfContainer . foldMap flattenPrimitive . foldMap sanitize -- | Return an approximation of the length of a given path. -- It's results is not precise but should be enough for -- rough calculations 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 [] _ = [] -- Impossible by construction, pattern is infinite taker (atValue:atRest) stream = toKeep : droper atRest next where (toKeep, next) = splitPrimitiveUntil atValue stream droper _ [] = [] droper [] _ = [] -- Impossible by construction, pattern is infinite droper (atValue:atRest) stream = taker atRest next where (_toKeep, next) = splitPrimitiveUntil atValue stream -- | Create a list of outlines corresponding to all the -- dashed elements. They can be then stroked -- -- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ -- > dashedStrokize 0 [10, 5] -- > 40 JoinRound (CapStraight 0, CapStraight 0) $ -- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160) -- -- <> -- dashedStrokize :: Geometry geom => Float -- ^ Starting offset -> DashPattern -- ^ Dashing pattern to use for stroking -> StrokeWidth -- ^ Stroke width -> Join -- ^ Which kind of join will be used -> (Cap, Cap) -- ^ Start and end capping. -> geom -- ^ Elements to transform -> [[Primitive]] dashedStrokize offset dashPattern width join capping geom = listOfContainer . strokize width join capping <$> dashize offset dashPattern (toPrimitives geom)