Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.