From e3318520ba46adce3c18a115df9683ec5a50535b Mon Sep 17 00:00:00 2001 From: Ryan Yates Date: Tue, 27 Aug 2013 23:00:10 -0400 Subject: [PATCH] Add more documentation and miter join. --- diagrams/offsetTrailLeftExample.svg | 4 ++ src/Diagrams/TwoD/Offset.hs | 95 +++++++++++++++++++++-------- 2 files changed, 72 insertions(+), 27 deletions(-) create mode 100644 diagrams/offsetTrailLeftExample.svg diff --git a/diagrams/offsetTrailLeftExample.svg b/diagrams/offsetTrailLeftExample.svg new file mode 100644 index 00000000..f9bd1f44 --- /dev/null +++ b/diagrams/offsetTrailLeftExample.svg @@ -0,0 +1,4 @@ + + + \ No newline at end of file diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index bf76ebc6..468ad231 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} @@ -49,6 +50,7 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Path import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector @@ -182,27 +184,33 @@ locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) -- involving multiple segments. data OffsetOpts = OffsetOpts { offsetJoin :: LineJoin - -- ^ Specifies the style of join for between adjacent offset segments + -- ^ Specifies the style of join for between adjacent offset segments. + , offsetMiterLimit :: Double + -- ^ Specifies the miter limit for the join. , offsetEpsilon :: Double -- ^ Epsilon perimeter for 'offsetSegment'. } deriving (Eq, Show) --- | The default offset options use the default 'LineJoin' ('LineJoinMiter') and --- 'stdTolerance'. +-- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a +-- miter limit of 10, and epsilon of 'stdTolerance'. instance Default OffsetOpts where - def = OffsetOpts def stdTolerance + def = OffsetOpts def 10 stdTolerance -- | Offset a 'Trail' with options and by a given radius. This generates a new -- trail that is always radius 'r' away from the given 'Trail' (depending on --- the line join option). +-- the line join option) on the right. -- -- The styles applied to an outside corner can be seen here (with the original -- trail in blue and the result of 'offsetTrail'' in green): -- -- <> -- +-- When a negative radius is given, the offset trail will be on the left: +-- +-- <> +-- offsetTrail' :: OffsetOpts -> Double -> Located (Trail R2) -> Located (Trail R2) -offsetTrail' OffsetOpts{..} r t = joinSegments j r ends . offset r $ t +offsetTrail' OffsetOpts{..} r t = joinSegments j offsetMiterLimit r ends . offset r $ t where offset r = map (bindLoc (offsetSegment offsetEpsilon r)) . locatedTrailSegments ends = tail . trailVertices $ t @@ -222,8 +230,11 @@ offsetPath' opts r = mconcat offsetPath :: Double -> Path R2 -> Path R2 offsetPath = offsetPath' def +-- TODO: Include arrowheads on examples to indicate direction so the "left" and +-- "right" make sense. +-- -- > import Diagrams.TwoD.Offset --- > import Diagrams.Coordinates +-- > import Diagrams.Coordinates -- > import Data.Default.Class -- > -- > corner :: Located (Trail R2) @@ -240,11 +251,21 @@ offsetPath = offsetPath' def -- > showStyle j s = centerXY (trailLike corner # lc blue -- > <> trailLike (offsetTrail' def { offsetJoin = j } 2 corner) # lc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) +-- > +-- > offsetTrailLeftExample :: Diagram SVG R2 +-- > offsetTrailLeftExample = pad 1.1 . centerXY . lw 0.2 +-- > $ (trailLike c # lc blue) +-- > <> (lc green . trailLike +-- > . offsetTrail' def { offsetJoin = LineJoinRound } (-2) $ c) +-- > where +-- > c = reflectY corner -- | Options for specifying how a 'Trail' should be expanded. data ExpandOpts = ExpandOpts { expandJoin :: LineJoin - -- ^ Specifies the style of join for between adjacent offset segments + -- ^ Specifies the style of join for between adjacent offset segments. + , expandMiterLimit :: Double + -- ^ Specifies the miter limit for the join. , expandCap :: LineCap -- ^ Specifies how the ends are handled. , expandEpsilon :: Double @@ -252,9 +273,10 @@ data ExpandOpts = ExpandOpts } deriving (Eq, Show) -- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), --- default 'LineCap' ('LineCapButt'), and epsilon value of 'stdTolerance'. +-- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon +-- value of 'stdTolerance'. instance Default ExpandOpts where - def = ExpandOpts def def stdTolerance + def = ExpandOpts def 10 def stdTolerance -- | Expand a 'Trail' with the given options and radius 'r' around a given 'Trail'. -- Expanding can be thought of as generating the loop that, when filled, represents @@ -269,7 +291,7 @@ expandTrail' :: ExpandOpts -> Double -> Located (Trail R2) -> Located (Trail R2) expandTrail' ExpandOpts{..} r t = caps cap r s e (f r) (f $ -r) where offset r = map (bindLoc (offsetSegment expandEpsilon r)) . locatedTrailSegments - f r = joinSegments (fromLineJoin expandJoin) r ends . offset r $ t + f r = joinSegments (fromLineJoin expandJoin) expandMiterLimit r ends . offset r $ t ends = tail . trailVertices $ t s = atStartL t e = atEndL t @@ -367,15 +389,16 @@ arcVCW u v = arcCW (direction u) (direction v :: CircleFrac) -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: (Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) - -> Double -> [Point R2] -> [Located (Trail R2)] -> Located (Trail R2) -joinSegments _ _ _ [] = mempty `at` origin -joinSegments j r es ts@(t:_) = mapLoc (<> t') $ t +joinSegments :: (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) + -> Double -> Double -> [Point R2] -> [Located (Trail R2)] -> Located (Trail R2) +joinSegments _ _ _ _ [] = mempty `at` origin +joinSegments j ml r es ts@(t:_) = mapLoc (<> t') $ t where - t' = mconcat [j r e a b <> unLoc b | (e,(a,b)) <- zip es . (zip <*> tail) $ ts] + t' = mconcat [j ml r e a b <> unLoc b | (e,(a,b)) <- zip es . (zip <*> tail) $ ts] -- | Take a join style and give the join function to be used by joinSegments. -fromLineJoin :: LineJoin -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +fromLineJoin + :: LineJoin -> Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 fromLineJoin j = case j of LineJoinMiter -> joinSegmentIntersect LineJoinRound -> joinSegmentArc @@ -385,8 +408,8 @@ fromLineJoin j = case j of -- how useful it is graphically, I mostly had it as it was useful for debugging -- | Join with segments going back to the original corner. -joinSegmentCut :: Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 -joinSegmentCut r e a b = fromSegments +joinSegmentCut :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentCut _ r e a b = fromSegments [ straight (e .-. atEndL a) , straight (atStartL b .-. e) ] @@ -394,14 +417,32 @@ joinSegmentCut r e a b = fromSegments -- | Join by directly connecting the end points. 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 :: Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 -joinSegmentClip _ _ a b = fromSegments [straight $ atStartL b .-. atEndL a] +joinSegmentClip :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentClip _ _ _ a b = fromSegments [straight $ atStartL b .-. atEndL a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible. -joinSegmentArc :: Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 -joinSegmentArc r e a b = capArc r e (atEndL a) (atStartL b) - --- TODO: joinSegmentIntersect -joinSegmentIntersect :: Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 -joinSegmentIntersect = joinSegmentCut -- error "joinSegmentIntersect not implemented." +joinSegmentArc :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentArc _ r e a b = capArc r e (atEndL a) (atStartL b) + +-- | Join to the intersection of the incoming trails projected tangent to their ends. +-- If the intersection is beyond the miter limit times the radius, stop at the limit. +joinSegmentIntersect + :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentIntersect miterLimit r e a b = case traceP pa va t of + -- TODO: Verify that this should stay at the limit and not + -- drop back to the clip join. I think some renderers do + -- clip join when exactly at + Nothing -> unLoc $ fromVertices + [ pa, pa .+^ (miter va) + , pb .+^ (miter vb), pb + ] + Just p -> unLoc $ fromVertices [ pa, p, pb ] + where + -- TODO: is there really no instance for Traced (Located (Trail R2)) ? + t = strokeLocT (fromSegments [straight (miter vb)] `at` pb) :: Diagram NullBackend R2 + va = -unitPerp (pa .-. e) + vb = -unitPerp (pb .-. e) + pa = atEndL a + pb = atStartL b + miter v = (miterLimit * r) *^ v