Instantly share code, notes, and snippets.

# fryguybob/RoundedPaths.hs Last active Oct 12, 2015

What would you like to do?
Start of rounded paths.
 {-# LANGUAGE TypeFamilies , MultiParamTypeClasses , FlexibleInstances #-} module RoundedPaths ( offsetPath , fromFixed -- , roundedCornerPath ) where import Diagrams.Prelude hiding (arc',start,end) import Diagrams.TwoD.Offset offsetPath :: Double -> Path R2 -> Path R2 offsetPath r = Path . map (fromFixed . expandFixedSegments r) . fixPath expandFixedSegments :: Double -> [FixedSegment R2] -> [FixedSegment R2] expandFixedSegments _ [] = [] expandFixedSegments r fs = caps r s e (f r) (f \$ -r) where f r = joinSegments r ends . map (offsetFixedSegment r) \$ fs ends = tail . map start \$ fs s = start fs e = end fs -- Here we do not have a good option for `FCubic`. At the least -- We would want to result in several segments if we attempt a -- real approximation. For example, for a given `f@(FCubic ...)` -- if first subdividing `f` into `n` segments and applying the -- transformation here we approach the correct solution as `n` -- approaches infinity. offsetFixedSegment :: Double -> FixedSegment R2 -> [FixedSegment R2] offsetFixedSegment r f@(FCubic a b c d) = concat \$ fixPath (Path [(p .+^ (a .-. origin),t)]) where (p,t) = offsetSegment (0.1) r (Cubic (b .-. a) (c .-. a) (d .-. a)) offsetFixedSegment r (FLinear a b) = [FLinear (a .+^ v) (b .+^ v)] where v = r *^ vperp (b .-. a) -- Perpendicular to the right. We want to be on the outside of a -- counter-clockwise closed simple path. vperp :: R2 -> R2 vperp v = rotateBy (-1/4) (normalized v) caps :: Double -> P2 -> P2 -> [FixedSegment R2] -> [FixedSegment R2] -> [FixedSegment R2] caps r _ _ _ [] = [] caps r s e fs bs = concat [cap r s sa sb, fs, cap r e ea eb, reverse . map rev \$ bs] where sa = start bs sb = start fs ea = end fs eb = end bs rev (FLinear a b) = FLinear b a rev (FCubic a b c d) = FCubic d c b a -- Caps go on the end of an expanded path and should represent the -- style of stroke being applied. cap, capCut, capRound :: Double -> P2 -> P2 -> P2 -> [FixedSegment R2] capCut r c a b = [FLinear a b] capRound r c a b = fixedArc r c a b cap = capRound -- intersect -- arc joinSegments :: Double -> [Point R2] -> [[FixedSegment R2]] -> [FixedSegment R2] joinSegments r es [] = [] joinSegments r es fs@(f:_) = f ++ concat [joinSegment r e as bs ++ bs | (e,(as,bs)) <- zip es . (zip <*> tail) \$ fs] -- Ways to join two segments: joinSegment, joinSegmentCut, joinSegmentClip, joinSegmentArc :: Double -> P2 -> [FixedSegment R2] -> [FixedSegment R2] -> [FixedSegment R2] -- Join with segments going back to the original corner. joinSegmentCut r e a b = [FLinear (end a) e, FLinear e (start b)] -- This option works for any corner, just connecting the -- offset segments. On an inside corner this creates negative -- space for even-odd fill. Here is where we would want to -- use an arc or something else in the future. joinSegmentClip _ _ a b = [FLinear (end a) (start b)] -- Since we have expanded with a consistent radius we can fit a radius arc -- here. We don't really want to do this on an inside corner, but no harm -- is done given winding fill. joinSegmentArc r e a b = fixedArc r e (end a) (start b) -- joinSegmentIntersect joinSegment = joinSegmentArc arc' a b | a < 0 = arc' (a + convertAngle (1 :: CircleFrac)) (b + convertAngle (1 :: CircleFrac)) | a <= b = arc a b | otherwise = arc' a (b + convertAngle (1 :: CircleFrac)) arcCW' a b = reversePath (arc' b a) arcV u v = arc' (direction u) (direction v :: CircleFrac) arcVCW u v = arcCW' (direction u) (direction v :: CircleFrac) -- Negative r means CW fixedArc :: Double -> P2 -> P2 -> P2 -> [FixedSegment R2] fixedArc r c a b = f . head . fixPath . moveTo c \$ fs where fs | r < 0 = scale (-r) \$ arcVCW (a .-. c) (b .-. c) | otherwise = scale r \$ arcV (a .-. c) (b .-. c) f fs | start fs =~= a && end fs =~= b = fs | otherwise = error ("fixedArc: " ++ show (r,c,a,b,fs)) a =~= b = magnitude (a .-. b) < 0.01 class HasEnds a b where start :: a -> b end :: a -> b instance HasEnds (FixedSegment R2) (Point R2) where start (FLinear a _) = a start (FCubic a _ _ _) = a end (FLinear _ b) = b end (FCubic _ _ _ d) = d instance HasEnds a b => HasEnds [a] b where start = start . head end = end . last fromFixed :: [FixedSegment R2] -> (Point R2, Trail R2) fromFixed fs = fromFixed' . map (uncurry checkEnds) . (zip <*> tail) \$ fs where checkEnds :: FixedSegment R2 -> FixedSegment R2 -> FixedSegment R2 checkEnds a b | end a =~= start b = a | otherwise = error ("fromFixed: " ++ show (a,b)) (=~=) :: P2 -> P2 -> Bool a =~= b = magnitude (a .-. b) < 0.01 fromFixed' :: [FixedSegment R2] -> (Point R2, Trail R2) fromFixed' [] = (p2 zeroV, Trail [] False) -- ??? fromFixed' (s:ss) = (a, Trail (b : map (snd . rel) ss) True) where (a, b) = rel s rel (FLinear a b) = (a, Linear \$ b .-. a) rel (FCubic a b c d) = (a, Cubic (b .-. a) (c .-. a) (d .-. a)) -- roundedCornerPath