{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Geom2D.CubicBezier.Stroke (penCircle, pathToPen, penStrokeOpen, penStrokeClosed, Pen, bezierOffset) where import Geom2D import Geom2D.CubicBezier import Data.Monoid data Pen a = PenEllipse (Transform a) (Transform a) (Transform a) | PenPath [PenSegment a] data PenSegment a = PenCorner !(Point a) !(Point a) | PenCurve !(Point a) !(CubicBezier a) -- | A circular pen with unit radius. penCircle :: (Floating a) => Pen a penCircle = PenEllipse idTrans rotate90L rotate90R {-# SPECIALIZE penCircle :: Pen Double #-} -- | Create a pen from a path. For predictable results the path -- should be convex. pathToPen :: (Floating a) => ClosedPath a -> Pen a pathToPen (ClosedPath []) = PenPath [] pathToPen (ClosedPath nodes) = PenPath \$ pathToPen' \$ nodes ++ take 2 nodes pathToPen' :: Num a => [(Point a, PathJoin a)] -> [PenSegment a] pathToPen' [] = [] pathToPen' [_] = [] pathToPen' [_, _] = [] pathToPen' ((p, JoinLine):tl@((q, JoinLine):_)) = PenCorner (q ^-^ p) q : pathToPen' tl pathToPen' ((_, JoinCurve _ _):tl@((_, JoinLine):_)) = pathToPen' tl pathToPen' ((p, JoinLine):tl@((q1, JoinCurve q2 q3):(q4, _):_)) = PenCurve (q1 ^-^ p) (CubicBezier q1 q2 q3 q4) : pathToPen' tl pathToPen' ((_, JoinCurve _ p3):tl@((q1, JoinCurve q2 q3):(q4, _):_)) = PenCurve (q1 ^-^ p3) (CubicBezier q1 q2 q3 q4) : pathToPen' tl noTranslate :: Num a => Transform a -> Transform a noTranslate (Transform a b _ c d _) = Transform a b 0 c d 0 instance (Floating a, Eq a) => AffineTransform (Pen a) a where {-# SPECIALIZE transform :: Transform Double -> Pen Double -> Pen Double #-} transform t (PenEllipse trans _ _) = let t2@(Transform a b c d e f) = transform t trans in case inverse \$ noTranslate t2 of Nothing -> pathToPen \$ ClosedPath [ (Point c f ^+^ p, JoinLine), (Point c f ^-^ p, JoinLine)] where p | a /= 0 && b /= 0 = sqrt(1 + a*a/(b*b)) *^ Point a d | d /= 0 && e /= 0 = sqrt(1 + d*d/(e*e)) *^ Point a d | a /= 0 = Point (a+d) 0 | b /= 0 = Point 0 (b+e) -- singular point: create tiny pen instead of an error | otherwise = Point 1e-5 1e-5 Just inv -> PenEllipse t2 (transform rotate90L inv) (transform rotate90R inv) transform t (PenPath segments) = PenPath \$ map (transformSegment t) segments transformSegment :: Num b => Transform b -> PenSegment b -> PenSegment b transformSegment t (PenCorner p q) = PenCorner (transform t (q^+^p) ^-^ q') q' where q' = transform t q transformSegment t (PenCurve p c) = PenCurve (transform t (cubicC0 c^+^p) ^-^ cubicC0 c') c' where c' = transform t c offsetPoint :: (Floating a) => a -> Point a -> Point a -> Point a offsetPoint dist start tangent = start ^+^ (rotate90L \$* dist *^ normVector tangent) bezierOffsetPoint :: CubicBezier Double -> Double -> Double -> (DPoint, DPoint) bezierOffsetPoint cb dist t = (offsetPoint dist p p', p') where (p, p') = evalBezierDeriv cb t -- | Calculate an offset path from the bezier curve to within -- tolerance. If the distance is positive offset to the left, -- otherwise to the right. A smaller tolerance may require more bezier -- curves in the path to approximate the offset curve bezierOffset :: CubicBezier Double -- ^ The curve -> Double -- ^ Offset distance. -> Maybe Int -- ^ maximum subcurves -> Double -- ^ Tolerance. -> Bool -- ^ Calculate the curve faster but with -- more subcurves -> [CubicBezier Double] -- ^ The offset curve bezierOffset cb dist (Just m) tol faster = approximatePathMax m (bezierOffsetPoint cb dist) 15 tol 0 1 faster bezierOffset cb dist Nothing tol faster = approximatePath (bezierOffsetPoint cb dist) 15 tol 0 1 faster penOffset :: Pen Double -> Point Double -> Point Double penOffset (PenEllipse trans leftInv _) dir = transform trans \$ normVector \$ leftInv \$* dir penOffset (PenPath segments) dir = pathOffsetPoint (cycle segments) dir penOffsetFun :: Pen Double -> (Double -> (DPoint, DPoint)) -> Double -> (Point Double, Point Double) penOffsetFun pen f t = (px ^+^ penOffset pen px', px') where (px, px') = f t firstPoint :: PenSegment a -> Point a firstPoint (PenCorner _ p) = p firstPoint (PenCurve _ c) = cubicC0 c pathOffsetPoint :: [PenSegment Double] -> Point Double -> Point Double pathOffsetPoint (PenCorner c p:b:rest) dir | vectorCross dir c > 0 = pathOffsetPoint (b:rest) dir | vectorCross dir (firstPoint b ^-^ p) > 0 = p | otherwise = pathOffsetPoint (b:rest) dir pathOffsetPoint (PenCurve c curve@(CubicBezier p1 p2 p3 p4):b:rest) dir | vectorCross dir c > 0 = pathOffsetPoint (b:rest) dir | vectorCross dir (p2 ^-^ p1) > 0 = p1 | vectorCross dir (p3 ^-^ p4) > 0 = case findBezierTangent dir curve of (t:_) -> evalBezier curve t [] -> p4 | vectorCross dir (firstPoint b ^-^ p4) > 0 = p4 | otherwise = pathOffsetPoint (b:rest) dir pathOffsetPoint _ _ = error "unexpected end of list" segDirs :: [(DPoint, PathJoin Double)] -> Point Double -> [(DPoint, DPoint)] segDirs [] _ = [] segDirs [(p, JoinLine)] q = [(dp, dp)] where dp = q ^-^ p segDirs [(p1, JoinCurve p2 p3 )] p4 = [(p2 ^-^ p1, p4 ^-^ p3)] segDirs ((p, JoinLine):r@((q, _):_)) s = (dp, dp): segDirs r s where dp = q ^-^ p segDirs ((p1, JoinCurve p2 p3 ):r@((p4,_):_)) q = (p2 ^-^ p1, p4 ^-^ p3):segDirs r q penStrokeOpen :: Int -> Double -> Bool -> Pen Double -> OpenPath Double -> [ClosedPath Double] penStrokeOpen samples tol fast pen (OpenPath segments p) = union [closeOpenPath path] NonZero tol where dirs = segDirs segments (fst \$ head segments) fdirs = map fst (tail dirs) fd = fst \$ head dirs ld = snd \$ last dirs ldirs = map snd dirs pts = map fst (tail segments) ++ [p] leftJoins = zipWith (penJoinLeft pen) ldirs fdirs leftStrokes = zipWith (strokeLeft samples tol fast pen) segments pts rightJoins = zipWith (penJoinRight pen) ldirs fdirs rightStrokes = zipWith (strokeRight samples tol fast pen) segments pts path = mconcat \$ penJoinLeft pen (turnAround fd) fd : interleave leftStrokes leftJoins ++ penJoinLeft pen ld (turnAround ld) : reverse (interleave rightStrokes rightJoins) interleave :: [a] -> [a] -> [a] interleave [] xs = xs interleave xs [] = xs interleave (x:xs) (y:ys) = x:y:interleave xs ys --penStrokeClosed :: ClosedPath Double -> Pen Double -> Double -> [ClosedPath Double] penStrokeClosed :: Int -> Double -> Bool -> Pen Double -> ClosedPath Double -> [ClosedPath Double] penStrokeClosed _ _ _ _ (ClosedPath []) = [ClosedPath []] penStrokeClosed samples tol fast pen (ClosedPath segments) = union [closeOpenPath leftPath, closeOpenPath rightPath] NonZero tol where dirs = segDirs segments (fst \$ head segments) fdirs = map fst (tail dirs) ++ [fst (head dirs)] ldirs = map snd dirs pts = map fst (tail segments) ++ [fst (head segments)] leftJoins = zipWith (penJoinLeft pen) ldirs fdirs leftStrokes = zipWith (strokeLeft samples tol fast pen) segments pts rightJoins = zipWith (penJoinRight pen) ldirs fdirs rightStrokes = zipWith (strokeRight samples tol fast pen) segments pts leftPath = mconcat \$ interleave leftStrokes leftJoins rightPath = mconcat \$ reverse \$ interleave rightStrokes rightJoins strokeLeft :: Int -> Double -> Bool -> Pen Double -> (DPoint, PathJoin Double) -> DPoint -> OpenPath Double strokeLeft _ _ _ pen (p, JoinLine) q = OpenPath [(p ^+^ offset, JoinLine)] (q ^+^ offset) where offset = penOffset pen (q ^-^ p) strokeLeft samples tol fast pen (p1, JoinCurve p2 p3) p4 = curvesToOpen \$ approximatePath (penOffsetFun pen (evalBezierDeriv (CubicBezier p1 p2 p3 p4))) samples tol 0 1 fast strokeRight :: Int -> Double -> Bool -> Pen Double -> (DPoint, PathJoin Double) -> DPoint -> OpenPath Double strokeRight _ _ _ pen (p, JoinLine) q = OpenPath [(q ^+^ offset, JoinLine)] (p ^+^ offset) where offset = penOffset pen (p ^-^ q) strokeRight samples tol fast pen (p1, JoinCurve p2 p3) p4 = curvesToOpen \$ approximatePath (penOffsetFun pen (evalBezierDeriv (CubicBezier p4 p3 p2 p1))) samples tol 0 1 fast penJoinLeft :: Pen Double -> DPoint -> DPoint -> OpenPath Double penJoinLeft = penJoin penJoinRight :: Pen Double -> DPoint -> DPoint -> OpenPath Double penJoinRight pen from to = penJoin pen (turnAround to) (turnAround from) ellipticArc :: Transform Double -> Transform Double -> Point Double -> Point Double -> CubicBezier Double ellipticArc trans leftInv from to = trans \$* bezierArc (vectorAngle \$ leftInv \$* from) (vectorAngle \$ leftInv \$* to) segmentsToPath :: (Eq a) => [PenSegment a] -> OpenPath a segmentsToPath [PenCorner _ q] = OpenPath [] q segmentsToPath [PenCurve _ (CubicBezier p1 p2 p3 p4)] = OpenPath [(p1, JoinCurve p2 p3)] p4 segmentsToPath (PenCorner _ p:r) = consOpenPath p JoinLine (segmentsToPath r) segmentsToPath (PenCurve _ (CubicBezier p1 p2 p3 p4):r) = consOpenPath p1 (JoinCurve p2 p3) \$ case r of (PenCurve _ (CubicBezier q1 _ _ _):_) | p4 /= q1 -> consOpenPath p4 JoinLine \$ segmentsToPath r _ -> segmentsToPath r segmentsToPath [] = emptyOpenPath emptyOpenPath :: OpenPath a emptyOpenPath = OpenPath [] (error "empty path") penJoin :: Pen Double -> Point Double -> Point Double -> OpenPath Double penJoin pen@(PenEllipse trans leftInv _) from to | dir == 0 = emptyOpenPath | dir > 0 && sameQuadrant from to = curvesToOpen [ellipticArc trans leftInv from to] | otherwise = curvesToOpen [ellipticArc trans leftInv from next] <> penJoin pen next to where next = nextVector from dir = vectorCross from to penJoin (PenPath segments) from to = segmentsToPath \$ nextSegments (firstSegment (cycle segments) from) to firstSegment :: [PenSegment Double] -> Point Double -> [PenSegment Double] firstSegment segments@(PenCorner c _:q:rest) from | vectorCross from c > 0 = firstSegment (q:rest) from | otherwise = segments firstSegment segments@(PenCurve c curve@(CubicBezier p1 p2 p3 p4):q:rest) from | vectorCross from c > 0 = firstSegment (q:rest) from | vectorCross from (p2 ^-^ p1) > 0 = segments | vectorCross from (p4 ^-^ p3) > 0 = case findBezierTangent from curve of (t:_) -> PenCurve from (snd (splitBezier curve t)):q:rest _ -> q:rest | vectorCross from (firstPoint q ^-^ p4) > 0 = PenCorner (firstPoint q ^-^ p4) p4:q:rest | otherwise = firstSegment (q:rest) from firstSegment _ _ = error "firstsegment: finite list" nextSegments :: [PenSegment Double] -> Point Double -> [PenSegment Double] nextSegments (PenCorner c p:q:rest) to | vectorCross to c > 0 = PenCorner c p: nextSegments (q:rest) to | otherwise = [] nextSegments (pc@(PenCurve c curve@(CubicBezier p1 p2 p3 p4)):q:rest) to | vectorCross to c > 0 = pc: nextSegments (q:rest) to | vectorCross to (p2 ^-^ p1) > 0 = [] | vectorCross to (p4 ^-^ p3) > 0 = case findBezierTangent to curve of (t:_) -> [PenCurve c (fst (splitBezier curve t))] _ -> [] | vectorCross to (firstPoint q ^-^ p4) > 0 = [PenCorner (firstPoint q ^-^ p4) p4] | otherwise = pc:firstSegment (q:rest) to nextSegments _ _ = error "nextSegments: finite list" sameQuadrant :: (Num a, Eq a) => Point a -> Point a -> Bool sameQuadrant v w = signum (pointX v) /= -signum (pointX w) && signum (pointY v) /= -signum (pointY w) nextVector :: (Ord a1, Num a1, Num a) => Point a1 -> Point a nextVector v | pointX v >= 0 && pointY v > 0 = Point 1 0 | pointX v > 0 && pointY v <= 0 = Point 0 (-1) | pointX v <= 0 && pointY v < 0 = Point (-1) 0 | otherwise = Point 0 1