From 1b74b14d78dc268527ae3c6fd37511638c9524fe Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Mon, 4 Mar 2024 14:07:54 -0600 Subject: [PATCH] fix more warnings --- src/Diagrams/Segment.hs | 501 +++++++++++--------- src/Diagrams/TwoD/Arrow.hs | 795 +++++++++++++++++--------------- src/Diagrams/TwoD/Arrowheads.hs | 408 ++++++++-------- src/Diagrams/TwoD/Path.hs | 484 +++++++++++-------- src/Diagrams/TwoD/Segment.hs | 438 +++++++++--------- 5 files changed, 1418 insertions(+), 1208 deletions(-) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index c18b5a93..0eacd7d3 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -1,19 +1,22 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.Segment -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) @@ -32,59 +35,63 @@ -- "Diagrams.Trail", "Diagrams.TrailLike", and "Diagrams.Path" should -- usually suffice. However, directly manipulating segments can -- occasionally be useful. --- ------------------------------------------------------------------------------ - -module Diagrams.Segment - ( -- * Open/closed tags - - Open, Closed - - -- * Segment offsets - - , Offset(..) , segOffset - - -- * Constructing and modifying segments - - , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors - , openLinear, openCubic - - -- * Fixed (absolutely located) segments - , FixedSegment(..) - , mkFixedSeg, fromFixedSeg - , fixedSegIso - - -- * Segment measures - -- $segmeas - - , SegCount(..) - , ArcLength(..) - , getArcLengthCached, getArcLengthFun, getArcLengthBounded - , TotalOffset(..) - , OffsetEnvelope(..), oeOffset, oeEnvelope - , SegMeasure - - ) where - -import Control.Lens hiding (at, transform) -import Data.FingerTree -import Data.Monoid.MList -import Data.Semigroup -import Numeric.Interval.Kaucher (Interval (..)) -import qualified Numeric.Interval.Kaucher as I - -import Linear.Affine -import Linear.Metric -import Linear.Vector - -import Control.Applicative -import Diagrams.Core hiding (Measured) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Solve.Polynomial - -import Data.Serialize (Serialize) -import qualified Data.Serialize as Serialize +module Diagrams.Segment ( + -- * Open/closed tags + Open, + Closed, + + -- * Segment offsets + Offset (..), + segOffset, + + -- * Constructing and modifying segments + Segment (..), + straight, + bezier3, + bézier3, + reverseSegment, + mapSegmentVectors, + openLinear, + openCubic, + + -- * Fixed (absolutely located) segments + FixedSegment (..), + mkFixedSeg, + fromFixedSeg, + fixedSegIso, + + -- * Segment measures + -- $segmeas + SegCount (..), + ArcLength (..), + getArcLengthCached, + getArcLengthFun, + getArcLengthBounded, + TotalOffset (..), + OffsetEnvelope (..), + oeOffset, + oeEnvelope, + SegMeasure, +) where + +import Control.Lens hiding (at, transform) +import Data.FingerTree +import Data.Monoid.MList +import Data.Semigroup +import Numeric.Interval.Kaucher (Interval (..)) +import qualified Numeric.Interval.Kaucher as I + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +import Diagrams.Core hiding (Measured) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Solve.Polynomial + +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize ------------------------------------------------------------ -- Open/closed type tags --------------------------------- @@ -109,32 +116,32 @@ data Closed -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. data Offset c v n where - OffsetOpen :: Offset Open v n + OffsetOpen :: Offset Open v n OffsetClosed :: v n -> Offset Closed v n deriving instance Show (v n) => Show (Offset c v n) -deriving instance Eq (v n) => Eq (Offset c v n) -deriving instance Ord (v n) => Ord (Offset c v n) +deriving instance Eq (v n) => Eq (Offset c v n) +deriving instance Ord (v n) => Ord (Offset c v n) instance Functor v => Functor (Offset c v) where - fmap _ OffsetOpen = OffsetOpen + fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f v) instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where each f (OffsetClosed v) = OffsetClosed <$> f v - each _ OffsetOpen = pure OffsetOpen + each _ OffsetOpen = pure OffsetOpen {-# INLINE each #-} -- | Reverses the direction of closed offsets. instance (Additive v, Num n) => Reversing (Offset c v n) where reversing (OffsetClosed off) = OffsetClosed $ negated off - reversing a@OffsetOpen = a + reversing a@OffsetOpen = a type instance V (Offset c v n) = v type instance N (Offset c v n) = n instance Transformable (Offset c v n) where - transform _ OffsetOpen = OffsetOpen + transform _ OffsetOpen = OffsetOpen transform t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------ @@ -149,35 +156,40 @@ instance Transformable (Offset c v n) where -- however, affected by other transformations such as rotations and -- scales. data Segment c v n - = Linear !(Offset c v n) - -- ^ A linear segment with given offset. - - | Cubic !(v n) !(v n) !(Offset c v n) - -- ^ A cubic Bézier segment specified by - -- three offsets from the starting - -- point to the first control point, - -- second control point, and ending - -- point, respectively. - + = -- | A linear segment with given offset. + Linear !(Offset c v n) + | -- | A cubic Bézier segment specified by + -- three offsets from the starting + -- point to the first control point, + -- second control point, and ending + -- point, respectively. + Cubic !(v n) !(v n) !(Offset c v n) deriving (Functor, Eq, Ord) instance Show (v n) => Show (Segment c v n) where showsPrec d seg = case seg of - Linear (OffsetClosed v) -> showParen (d > 10) $ - showString "straight " . showsPrec 11 v - Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $ - showString "bézier3 " . showsPrec 11 v1 . showChar ' ' - . showsPrec 11 v2 . showChar ' ' - . showsPrec 11 v3 - Linear OffsetOpen -> showString "openLinear" - Cubic v1 v2 OffsetOpen -> showParen (d > 10) $ - showString "openCubic " . showsPrec 11 v1 . showChar ' ' - . showsPrec 11 v2 - + Linear (OffsetClosed v) -> + showParen (d > 10) $ + showString "straight " . showsPrec 11 v + Cubic v1 v2 (OffsetClosed v3) -> + showParen (d > 10) $ + showString "bézier3 " + . showsPrec 11 v1 + . showChar ' ' + . showsPrec 11 v2 + . showChar ' ' + . showsPrec 11 v3 + Linear OffsetOpen -> showString "openLinear" + Cubic v1 v2 OffsetOpen -> + showParen (d > 10) $ + showString "openCubic " + . showsPrec 11 v1 + . showChar ' ' + . showsPrec 11 v2 instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where - each f (Linear offset) = Linear <$> each f offset - each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset + each f (Linear offset) = Linear <$> each f offset + each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset {-# INLINE each #-} -- | Reverse the direction of a segment. @@ -229,24 +241,29 @@ type instance Codomain (Segment Closed v n) = v -- the segment for each value of the parameter between @0@ and @1@. -- It is designed to be used infix, like @seg ``atParam`` 0.5@. instance (Additive v, Num n) => Parametric (Segment Closed v n) where - atParam (Linear (OffsetClosed x)) t = t *^ x - atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1 - ^+^ (3 * t'*t *t ) *^ c2 - ^+^ ( t *t *t ) *^ x2 - where t' = 1-t + atParam (Linear (OffsetClosed x)) t = t *^ x + atParam (Cubic c1 c2 (OffsetClosed x2)) t = + (3 * t' * t' * t) + *^ c1 + ^+^ (3 * t' * t * t) + *^ c2 + ^+^ (t * t * t) + *^ x2 + where + t' = 1 - t instance Num n => DomainBounds (Segment Closed v n) instance (Additive v, Num n) => EndValues (Segment Closed v n) where - atStart = const zero - atEnd (Linear (OffsetClosed v)) = v + atStart = const zero + atEnd (Linear (OffsetClosed v)) = v atEnd (Cubic _ _ (OffsetClosed v)) = v -- | Compute the offset from the start of a segment to the -- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. segOffset :: Segment Closed v n -> v n -segOffset (Linear (OffsetClosed v)) = v +segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v -- | An open linear segment. This means the trail makes a straight line @@ -287,18 +304,19 @@ openCubic v1 v2 = Cubic v1 v2 OffsetOpen -- | The envelope for a segment is based at the segment's start. instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where - getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> - maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v - + maximum (map (\t -> (s `atParam` t) `dot` v) [0, 1]) / quadrance v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> - maximum . - map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $ - [0,1] ++ - filter (liftA2 (&&) (>0) (<1)) - (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) - (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) - ((3 *^ c1) `dot` v)) + maximum + . map (\t -> ((s `atParam` t) `dot` v) / quadrance v) + $ [0, 1] + ++ filter + (liftA2 (&&) (> 0) (< 1)) + ( quadForm + (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) + (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) + ((3 *^ c1) `dot` v) + ) ------------------------------------------------------------ -- Manipulating segments @@ -306,24 +324,26 @@ instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) - where left = straight p - right = straight (x1 ^-^ p) - p = lerp t x1 zero + where + left = straight p + right = straight (x1 ^-^ p) + p = lerp t x1 zero splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) - where left = bezier3 a b e - right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) - p = lerp t c2 c1 - a = lerp t c1 zero - b = lerp t p a - d = lerp t x2 c2 - c = lerp t d p - e = lerp t c b + where + left = bezier3 a b e + right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) + p = lerp t c2 c1 + a = lerp t c1 zero + b = lerp t p a + d = lerp t x2 c2 + c = lerp t d p + e = lerp t c b reverseDomain = reverseSegment -- | Reverse the direction of a segment. reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n -reverseSegment (Linear (OffsetClosed v)) = straight (negated v) +reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -- Imitates I.elem for intervals<0.8 and I.member for intervals>=0.8 @@ -331,34 +351,38 @@ member :: Ord a => a -> I.Interval a -> Bool member x (I.I a b) = x >= a && x <= b {-# INLINE member #-} -instance (Metric v, OrderedField n) - => HasArcLength (Segment Closed v n) where - +instance + (Metric v, OrderedField n) => + HasArcLength (Segment Closed v n) + where arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1 arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2)) | ub - lb < m = I lb ub - | otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r - where (l,r) = s `splitAtParam` 0.5 - ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2]) - lb = norm x2 + | otherwise = arcLengthBounded (m / 2) l + arcLengthBounded (m / 2) r + where + (l, r) = s `splitAtParam` 0.5 + ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2]) + lb = norm x2 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s - arcLengthToParam m s@(Cubic {}) len - | len `member` I (-m/2) (m/2) = 0 - | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) - | len `member` slen = 1 - | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len - | len < I.sup llen = (*0.5) $ arcLengthToParam m l len - | otherwise = (+0.5) . (*0.5) - $ arcLengthToParam (9*m/10) r (len - I.midpoint llen) - where (l,r) = s `splitAtParam` 0.5 - llen = arcLengthBounded (m/10) l - slen = arcLengthBounded m s - - -- Note, the above seems to be quite slow since it duplicates a lot of - -- work. We could trade off some time for space by building a tree of - -- parameter values (up to a certain depth...) + arcLengthToParam m s@(Cubic {}) len + | len `member` I (-m / 2) (m / 2) = 0 + | len < 0 = -arcLengthToParam m (fst (splitAtParam s (-1))) (-len) + | len `member` slen = 1 + | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len + | len < I.sup llen = (* 0.5) $ arcLengthToParam m l len + | otherwise = + (+ 0.5) . (* 0.5) $ + arcLengthToParam (9 * m / 10) r (len - I.midpoint llen) + where + (l, r) = s `splitAtParam` 0.5 + llen = arcLengthBounded (m / 10) l + slen = arcLengthBounded m s + +-- Note, the above seems to be quite slow since it duplicates a lot of +-- work. We could trade off some time for space by building a tree of +-- parameter values (up to a certain depth...) ------------------------------------------------------------ -- Fixed segments @@ -369,21 +393,22 @@ instance (Metric v, OrderedField n) -- (Segment Closed v)@, as witnessed by 'mkFixedSeg' and -- 'fromFixedSeg', but @FixedSegment@ is convenient when one needs -- the absolute locations of the vertices and control points. -data FixedSegment v n = FLinear (Point v n) (Point v n) - | FCubic (Point v n) (Point v n) (Point v n) (Point v n) +data FixedSegment v n + = FLinear (Point v n) (Point v n) + | FCubic (Point v n) (Point v n) (Point v n) (Point v n) deriving (Eq, Ord, Show) type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where - each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1 - each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 + each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1 + each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 {-# INLINE each #-} -- | Reverses the control points. instance Reversing (FixedSegment v n) where - reversing (FLinear p0 p1) = FLinear p1 p0 + reversing (FLinear p0 p1) = FLinear p1 p0 reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 instance (Additive v, Num n) => Transformable (FixedSegment v n) where @@ -394,15 +419,18 @@ instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) - where (p, s) = viewLoc $ fromFixedSeg f + where + (p, s) = viewLoc $ fromFixedSeg f - -- Eventually we might decide it's cleaner/more efficient (?) to - -- have all the computation in the FixedSegment instance of - -- Envelope, and implement the Segment instance in terms of it, - -- instead of the other way around +-- Eventually we might decide it's cleaner/more efficient (?) to +-- have all the computation in the FixedSegment instance of +-- Envelope, and implement the Segment instance in terms of it, +-- instead of the other way around -instance (Metric v, OrderedField n) - => HasArcLength (FixedSegment v n) where +instance + (Metric v, OrderedField n) => + HasArcLength (FixedSegment v n) + where arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) @@ -410,12 +438,12 @@ instance (Metric v, OrderedField n) mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n mkFixedSeg ls = case viewLoc ls of - (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) - (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) + (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) + (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n) -fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 +fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -- | Use a 'FixedSegment' to make an 'Iso' between an @@ -428,40 +456,43 @@ type instance Codomain (FixedSegment v n) = Point v instance (Additive v, Num n) => Parametric (FixedSegment v n) where atParam (FLinear p1 p2) t = lerp t p2 p1 atParam (FCubic x1 c1 c2 x2) t = p3 - where p11 = lerp t c1 x1 - p12 = lerp t c2 c1 - p13 = lerp t x2 c2 + where + p11 = lerp t c1 x1 + p12 = lerp t c2 c1 + p13 = lerp t x2 c2 - p21 = lerp t p12 p11 - p22 = lerp t p13 p12 + p21 = lerp t p12 p11 + p22 = lerp t p13 p12 - p3 = lerp t p22 p21 + p3 = lerp t p22 p21 instance Num n => DomainBounds (FixedSegment v n) instance (Additive v, Num n) => EndValues (FixedSegment v n) where - atStart (FLinear p0 _) = p0 - atStart (FCubic p0 _ _ _) = p0 - atEnd (FLinear _ p1) = p1 - atEnd (FCubic _ _ _ p1 ) = p1 + atStart (FLinear p0 _) = p0 + atStart (FCubic p0 _ _ _) = p0 + atEnd (FLinear _ p1) = p1 + atEnd (FCubic _ _ _ p1) = p1 instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where splitAtParam (FLinear p0 p1) t = (left, right) - where left = FLinear p0 p - right = FLinear p p1 - p = lerp t p1 p0 + where + left = FLinear p0 p + right = FLinear p p1 + p = lerp t p1 p0 splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) - where left = FCubic p0 a b cut - right = FCubic cut c d p1 - -- first round - a = lerp t c1 p0 - p = lerp t c2 c1 - d = lerp t p1 c2 - -- second round - b = lerp t p a - c = lerp t d p - -- final round - cut = lerp t c b + where + left = FCubic p0 a b cut + right = FCubic cut c d p1 + -- first round + a = lerp t c1 p0 + p = lerp t c2 c1 + d = lerp t p1 c2 + -- second round + b = lerp t p a + c = lerp t d p + -- final round + cut = lerp t c b reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 @@ -489,7 +520,6 @@ instance Rewrapped SegCount SegCount -- computed to within a tolerance of @10e-6@. The second component is -- a generic arc length function taking the tolerance as an -- argument. - newtype ArcLength n = ArcLength (Sum (Interval n), n -> Sum (Interval n)) @@ -512,15 +542,19 @@ getArcLengthFun = fmap getSum . snd . op ArcLength -- | Given a specified tolerance, project out the cached arc length if -- it is accurate enough; otherwise call the generic arc length -- function with the given tolerance. -getArcLengthBounded :: (Num n, Ord n) - => n -> ArcLength n -> Interval n +getArcLengthBounded :: + (Num n, Ord n) => + n -> + ArcLength n -> + Interval n getArcLengthBounded eps al | I.width cached <= eps = cached - | otherwise = getArcLengthFun al eps - where - cached = getArcLengthCached al + | otherwise = getArcLengthFun al eps + where + cached = getArcLengthCached al + deriving instance (Num n, Ord n) => Semigroup (ArcLength n) -deriving instance (Num n, Ord n) => Monoid (ArcLength n) +deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments. @@ -536,7 +570,7 @@ instance (Num n, Additive v) => Semigroup (TotalOffset v n) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) instance (Num n, Additive v) => Monoid (TotalOffset v n) where - mempty = TotalOffset zero + mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of @@ -544,58 +578,65 @@ instance (Num n, Additive v) => Monoid (TotalOffset v n) where -- combining the envelopes of two consecutive chains needs to take -- the offset of the first into account. data OffsetEnvelope v n = OffsetEnvelope - { _oeOffset :: !(TotalOffset v n) + { _oeOffset :: !(TotalOffset v n) , _oeEnvelope :: Envelope v n } makeLenses ''OffsetEnvelope instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where - (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) - = let !negOff = negated . op TotalOffset $ o1 - e2Off = moveOriginBy negOff e2 - !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off - in OffsetEnvelope + (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = + let !negOff = negated . op TotalOffset $ o1 + e2Off = moveOriginBy negOff e2 + !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. -type SegMeasure v n = SegCount - ::: ArcLength n - ::: OffsetEnvelope v n - ::: () - -- unfortunately we can't cache Trace, since there is not a generic - -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). - -instance (Metric v, OrderedField n) - => Measured (SegMeasure v n) (SegMeasure v n) where +type SegMeasure v n = + SegCount + ::: ArcLength n + ::: OffsetEnvelope v n + ::: () + +-- unfortunately we can't cache Trace, since there is not a generic +-- instance Traced (Segment Closed v), only Traced (Segment Closed R2). + +instance + (Metric v, OrderedField n) => + Measured (SegMeasure v n) (SegMeasure v n) + where measure = id -instance (OrderedField n, Metric v) - => Measured (SegMeasure v n) (Segment Closed v n) where - measure s = (SegCount . Sum) 1 - - -- cache arc length with two orders of magnitude more - -- accuracy than standard, so we have a hope of coming out - -- with an accurate enough total arc length for - -- reasonable-length trails - *: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s - , Sum . flip arcLengthBounded s ) - - *: OffsetEnvelope (TotalOffset . segOffset $ s) - (getEnvelope s) - - *: () +instance + (OrderedField n, Metric v) => + Measured (SegMeasure v n) (Segment Closed v n) + where + measure s = + (SegCount . Sum) 1 + -- cache arc length with two orders of magnitude more + -- accuracy than standard, so we have a hope of coming out + -- with an accurate enough total arc length for + -- reasonable-length trails + *: ArcLength + ( Sum $ arcLengthBounded (stdTolerance / 100) s + , Sum . flip arcLengthBounded s + ) + *: OffsetEnvelope + (TotalOffset . segOffset $ s) + (getEnvelope s) + *: () ------------------------------------------------------------ -- Serialize instances ------------------------------------------------------------ -instance (Serialize (v n)) => Serialize (Segment Open v n) where +instance Serialize (v n) => Serialize (Segment Open v n) where {-# INLINE put #-} put segment = case segment of - Linear OffsetOpen -> Serialize.put True + Linear OffsetOpen -> Serialize.put True Cubic v w OffsetOpen -> do Serialize.put False Serialize.put v @@ -605,16 +646,16 @@ instance (Serialize (v n)) => Serialize (Segment Open v n) where get = do isLinear <- Serialize.get case isLinear of - True -> return (Linear OffsetOpen) + True -> return (Linear OffsetOpen) False -> do v <- Serialize.get w <- Serialize.get return (Cubic v w OffsetOpen) -instance (Serialize (v n)) => Serialize (Segment Closed v n) where +instance Serialize (v n) => Serialize (Segment Closed v n) where {-# INLINE put #-} put segment = case segment of - Linear (OffsetClosed z) -> do + Linear (OffsetClosed z) -> do Serialize.put z Serialize.put True Cubic v w (OffsetClosed z) -> do @@ -628,7 +669,7 @@ instance (Serialize (v n)) => Serialize (Segment Closed v n) where z <- Serialize.get isLinear <- Serialize.get case isLinear of - True -> return (Linear (OffsetClosed z)) + True -> return (Linear (OffsetClosed z)) False -> do v <- Serialize.get w <- Serialize.get diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 5d74f8a2..ca4c2213 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Arrow -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) @@ -20,161 +23,164 @@ -- Drawing arrows in two dimensions. For a tutorial on drawing arrows -- using this module, see the diagrams website: -- . --- ------------------------------------------------------------------------------ +module Diagrams.TwoD.Arrow ( + -- * Examples + -- ** Example 1 -module Diagrams.TwoD.Arrow - ( -- * Examples - -- ** Example 1 --- | <> --- --- > -- Connecting two diagrams at their origins. --- > --- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick --- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right") --- > --- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)]) --- > --- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill --- > & arrowShaft .~ shaft --- > & headLength .~ huge & tailLength .~ veryLarge) --- > "left" "right" # pad 1.1 - - -- ** Example 2 - --- | <> --- --- > -- Comparing connect, connectPerim, and arrowAt. --- > --- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin --- > dias = oct # named "first" ||| strut 3 ||| oct # named "second" --- > --- > -- Connect two diagrams and two points on their trails. --- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second" --- > # connectPerim' (with & lengths .~ veryLarge) --- > "first" "second" (15/16 @@ turn) (9/16 @@ turn) --- > --- > -- Place an arrow at (0,0) the size and direction of (0,1). --- > ex3 = arrowAt origin unit_Y --- > --- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 - - -- * Creating arrows - arrowV - , arrowV' - , arrowAt - , arrowAt' - , arrowBetween - , arrowBetween' - , connect - , connect' - , connectPerim - , connectPerim' - , connectOutside - , connectOutside' - - , arrow - , arrow' - - , arrowFromLocatedTrail - , arrowFromLocatedTrail' - - -- * Options - , ArrowOpts(..) - - , arrowHead - , arrowTail - , arrowShaft - , headGap - , tailGap - , gaps, gap - , headTexture - , headStyle - , headLength - , tailTexture - , tailStyle - , tailLength - , lengths - , shaftTexture - , shaftStyle - , straightShaft - - -- | See "Diagrams.TwoD.Arrowheads" for a list of standard - -- arrowheads and help creating your own. - , module Diagrams.TwoD.Arrowheads - ) where - -import Control.Lens (Lens', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), - (.~), (^.)) -import Data.Default.Class -import Data.Maybe (fromMaybe) -import Data.Monoid.Coproduct (untangle) -import Data.Semigroup -import Data.Typeable - -import Data.Colour hiding (atop) -import Diagrams.Core -import Diagrams.Core.Style (unmeasureAttrs) -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') - -import Diagrams.Angle -import Diagrams.Attributes -import Diagrams.Direction hiding (dir) -import Diagrams.Located (Located (..), unLoc) -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Solve.Polynomial (quadForm) -import Diagrams.Tangent (tangentAtEnd, tangentAtStart) -import Diagrams.Trail -import Diagrams.TwoD.Arrowheads -import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (reflectY, translateX) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unit_X) -import Diagrams.Util (( # )) - -import Linear.Affine -import Linear.Metric -import Linear.Vector - - -data ArrowOpts n - = ArrowOpts - { _arrowHead :: ArrowHT n - , _arrowTail :: ArrowHT n - , _arrowShaft :: Trail V2 n - , _headGap :: Measure n - , _tailGap :: Measure n - , _headStyle :: Style V2 n - , _headLength :: Measure n - , _tailStyle :: Style V2 n - , _tailLength :: Measure n - , _shaftStyle :: Style V2 n - } + -- | <> + -- + -- > -- Connecting two diagrams at their origins. + -- > + -- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick + -- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right") + -- > + -- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)]) + -- > + -- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill + -- > & arrowShaft .~ shaft + -- > & headLength .~ huge & tailLength .~ veryLarge) + -- > "left" "right" # pad 1.1 + + -- ** Example 2 + + -- | <> + -- + -- > -- Comparing connect, connectPerim, and arrowAt. + -- > + -- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin + -- > dias = oct # named "first" ||| strut 3 ||| oct # named "second" + -- > + -- > -- Connect two diagrams and two points on their trails. + -- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second" + -- > # connectPerim' (with & lengths .~ veryLarge) + -- > "first" "second" (15/16 @@ turn) (9/16 @@ turn) + -- > + -- > -- Place an arrow at (0,0) the size and direction of (0,1). + -- > ex3 = arrowAt origin unit_Y + -- > + -- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 + + -- * Creating arrows + arrowV, + arrowV', + arrowAt, + arrowAt', + arrowBetween, + arrowBetween', + connect, + connect', + connectPerim, + connectPerim', + connectOutside, + connectOutside', + arrow, + arrow', + arrowFromLocatedTrail, + arrowFromLocatedTrail', + + -- * Options + ArrowOpts (..), + arrowHead, + arrowTail, + arrowShaft, + headGap, + tailGap, + gaps, + gap, + headTexture, + headStyle, + headLength, + tailTexture, + tailStyle, + tailLength, + lengths, + shaftTexture, + shaftStyle, + straightShaft, + -- | See "Diagrams.TwoD.Arrowheads" for a list of standard + -- arrowheads and help creating your own. + module Diagrams.TwoD.Arrowheads, +) where + +import Control.Lens ( + Lens', + Traversal', + both, + generateSignatures, + lensRules, + makeLensesWith, + over, + view, + (%~), + (&), + (.~), + (^.), + ) +import Data.Default.Class +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup +import Data.Typeable + +import Data.Colour hiding (atop, over) +import Diagrams.Core +import Diagrams.Core.Style (unmeasureAttrs) +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction hiding (dir) +import Diagrams.Located (Located (..), unLoc) +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Solve.Polynomial (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Trail +import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (reflectY, translateX) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X) +import Diagrams.Util ((#)) + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +data ArrowOpts n = ArrowOpts + { _arrowHead :: ArrowHT n + , _arrowTail :: ArrowHT n + , _arrowShaft :: Trail V2 n + , _headGap :: Measure n + , _tailGap :: Measure n + , _headStyle :: Style V2 n + , _headLength :: Measure n + , _tailStyle :: Style V2 n + , _tailLength :: Measure n + , _shaftStyle :: Style V2 n + } -- | Straight line arrow shaft. straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] instance TypeableFloat n => Default (ArrowOpts n) where - def = ArrowOpts - { _arrowHead = dart - , _arrowTail = noTail - , _arrowShaft = straightShaft - , _headGap = none - , _tailGap = none - - -- See note [Default arrow style attributes] - , _headStyle = mempty - , _headLength = normal - , _tailStyle = mempty - , _tailLength = normal - , _shaftStyle = mempty - } + def = + ArrowOpts + { _arrowHead = dart + , _arrowTail = noTail + , _arrowShaft = straightShaft + , _headGap = none + , _tailGap = none + , -- See note [Default arrow style attributes] + _headStyle = mempty + , _headLength = normal + , _tailStyle = mempty + , _tailLength = normal + , _shaftStyle = mempty + } makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts @@ -195,9 +201,10 @@ tailGap :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headGap@ and @tailGap@ simultaneously. gaps :: Traversal' (ArrowOpts n) (Measure n) -gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) - <$> f (opts ^. headGap) - <*> f (opts ^. tailGap) +gaps f opts = + (\h t -> opts & headGap .~ h & tailGap .~ t) + <$> f (opts ^. headGap) + <*> f (opts ^. tailGap) -- | Same as gaps, provided for backward compatiiblity. gap :: Traversal' (ArrowOpts n) (Measure n) @@ -252,23 +259,23 @@ shaftTexture = shaftStyle . _lineTexture -- The semigroup stucture of the lw attribute will insure that the default -- is only used if it has not been set in @opts@. shaftSty :: ArrowOpts n -> Style V2 n -shaftSty opts = opts^.shaftStyle +shaftSty opts = opts ^. shaftStyle -- Set the default head style. See `shaftSty`. headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n -headSty opts = fc black (opts^.headStyle) +headSty opts = fc black (opts ^. headStyle) -- Set the default tail style. See `shaftSty`. tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n -tailSty opts = fc black (opts^.tailStyle) +tailSty opts = fc black (opts ^. tailStyle) -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. xWidth :: Floating n => (Traced t, V t ~ V2, N t ~ n) => t -> n xWidth p = a + b - where - a = fromMaybe 0 (norm <$> traceV origin unitX p) - b = fromMaybe 0 (norm <$> traceV origin unit_X p) + where + a = fromMaybe 0 (norm <$> traceV origin unitX p) + b = fromMaybe 0 (norm <$> traceV origin unit_X p) -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity. @@ -276,12 +283,11 @@ colorJoint :: TypeableFloat n => Style V2 n -> Style V2 n colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle - in - case (c, o) of - (Nothing, Nothing) -> fillColor black mempty - (Just t, Nothing) -> fillTexture t mempty - (Nothing, Just o') -> opacity o' . fillColor black $ mempty - (Just t, Just o') -> opacity o' . fillTexture t $ mempty + in case (c, o) of + (Nothing, Nothing) -> fillColor black mempty + (Just t, Nothing) -> fillTexture t mempty + (Nothing, Just o') -> opacity o' . fillColor black $ mempty + (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n @@ -293,31 +299,53 @@ widthOfJoint sStyle gToO nToO = -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) => - n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkHead :: + (TypeableFloat n, Renderable (Path V2 n) b) => + n -> + ArrowOpts n -> + n -> + n -> + Bool -> + (QDiagram b V2 n Any, n) mkHead = mkHT unit_X arrowHead headSty -mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => - n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkTail :: + (TypeableFloat n, Renderable (Path V2 n) b) => + n -> + ArrowOpts n -> + n -> + n -> + Bool -> + (QDiagram b V2 n Any, n) mkTail = mkHT unitX arrowTail tailSty -mkHT - :: (TypeableFloat n, Renderable (Path V2 n) b) - => V2 n -> Lens' (ArrowOpts n) (ArrowHT n) -> (ArrowOpts n -> Style V2 n) - -> n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) -mkHT xDir htProj styProj sz opts gToO nToO reflect - = ( (j <> ht) - # (if reflect then reflectY else id) - # moveOriginBy (jWidth *^ xDir) # lwO 0 - , htWidth + jWidth - ) - where - (ht', j') = (opts^.htProj) sz - (widthOfJoint (shaftSty opts) gToO nToO) - htWidth = xWidth ht' - jWidth = xWidth j' - ht = stroke ht' # applyStyle (styProj opts) - j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) +mkHT :: + (TypeableFloat n, Renderable (Path V2 n) b) => + V2 n -> + Lens' (ArrowOpts n) (ArrowHT n) -> + (ArrowOpts n -> Style V2 n) -> + n -> + ArrowOpts n -> + n -> + n -> + Bool -> + (QDiagram b V2 n Any, n) +mkHT xDir htProj styProj sz opts gToO nToO reflect = + ( (j <> ht) + # (if reflect then reflectY else id) + # moveOriginBy (jWidth *^ xDir) + # lwO 0 + , htWidth + jWidth + ) + where + (ht', j') = + (opts ^. htProj) + sz + (widthOfJoint (shaftSty opts) gToO nToO) + htWidth = xWidth ht' + jWidth = xWidth j' + ht = stroke ht' # applyStyle (styProj opts) + j = stroke j' # applyStyle (colorJoint (opts ^. shaftStyle)) -- | @spine tr tw hw sz@ makes a trail with the same angles and offset -- as an arrow with tail width @t@w, head width @hw@ and shaft @tr@, @@ -325,18 +353,17 @@ mkHT xDir htProj styProj sz opts gToO nToO reflect -- calculating the offset of an arrow. spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n spine tr tw hw sz = tS <> tr # scale sz <> hS - where - tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw - hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw - hS = if hw > 0 then hSpine else mempty - tS = if tw > 0 then tSpine else mempty + where + tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw + hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw + hS = if hw > 0 then hSpine else mempty + tS = if tw > 0 then tSpine else mempty -- | @scaleFactor tr tw hw t@ calculates the amount required to scale -- a shaft trail @tr@ so that an arrow with head width @hw@ and tail -- width @tw@ has offset @t@. scaleFactor :: TypeableFloat n => Trail V2 n -> n -> n -> n -> n -scaleFactor tr tw hw t - +scaleFactor tr tw hw t = -- Let tv be a vector representing the tail width, i.e. a vector -- of length tw tangent to the trail's start; similarly for hv. -- Let v be the vector offset of the trail. @@ -348,30 +375,30 @@ scaleFactor tr tw hw t -- We can solve by squaring both sides and expanding the LHS as a -- dot product, resulting in a quadratic in k. - = case quadForm - (quadrance v) - (2* (v `dot` (tv ^+^ hv))) - (quadrance (tv ^+^ hv) - t*t) - of - [] -> 1 -- no scale works, just return 1 - [s] -> s -- single solution - ss -> maximum ss - -- we will usually get both a positive and a negative solution; - -- return the maximum (i.e. positive) solution - where - tv = tw *^ (tangentAtStart tr # signorm) - hv = hw *^ (tangentAtEnd tr # signorm) - v = trailOffset tr + case quadForm + (quadrance v) + (2 * (v `dot` (tv ^+^ hv))) + (quadrance (tv ^+^ hv) - t * t) of + [] -> 1 -- no scale works, just return 1 + [s] -> s -- single solution + ss -> maximum ss + where + -- we will usually get both a positive and a negative solution; + -- return the maximum (i.e. positive) solution + + tv = tw *^ (tangentAtStart tr # signorm) + hv = hw *^ (tangentAtEnd tr # signorm) + v = trailOffset tr -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. arrowEnv :: TypeableFloat n => ArrowOpts n -> n -> Envelope V2 n arrowEnv opts len = getEnvelope horizShaft - where - horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) - m = norm v - v = trailOffset shaft - shaft = opts ^. arrowShaft + where + horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) + m = norm v + v = trailOffset shaft + shaft = opts ^. arrowShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point @@ -384,92 +411,97 @@ arrow = arrow' def -- @(len,0)@. In particular, it scales the given 'arrowShaft' so -- that the entire arrow has length @len@. arrow' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> QDiagram b V2 n Any -arrow' opts len = mkQD' (DelayedLeaf delayedArrow) - - -- Currently we approximate the envelope of an arrow by using the - -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty. - (arrowEnv opts len) mempty mempty mempty - - where - - -- Once we learn the global transformation context (da) and the two scale - -- factors, normal to output (n) and global to output (g), this arrow is - -- drawn in, we can apply it to the origin and (len,0) to find out - -- the actual final points between which this arrow should be - -- drawn. We need to know this to draw it correctly, since the - -- head and tail are scale invariant, and hence the precise points - -- between which we need to draw the shaft do not transform - -- uniformly as the transformation applied to the entire arrow. - -- See https://github.com/diagrams/diagrams-lib/issues/112. - delayedArrow da g n = - let (trans, globalSty) = maybe mempty untangle . fst $ da - in dArrow globalSty trans len g n - - -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). - dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) - # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) - # rotate (((q .-. p)^._theta) ^-^ (dir^._theta)) - # moveTo p - where - - p = origin # transform tr - q = origin # translateX ln # transform tr - - -- Use the existing line color for head, tail, and shaft by - -- default (can be overridden by explicitly setting headStyle, - -- tailStyle, or shaftStyle). Also use existing global line width - -- for shaft if not explicitly set in shaftStyle. - globalLC = getLineTexture <$> getAttr sty - opts' = opts - & headStyle %~ maybe id fillTexture globalLC - & tailStyle %~ maybe id fillTexture globalLC - & shaftStyle %~ applyStyle sty . transform tr - - -- The head size, tail size, head gap, and tail gap are obtained - -- from the style and converted to output units. - scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr) - hSize = scaleFromMeasure $ opts ^. headLength - tSize = scaleFromMeasure $ opts ^. tailLength - hGap = scaleFromMeasure $ opts ^. headGap - tGap = scaleFromMeasure $ opts ^. tailGap - - -- Make the head and tail and save their widths. - (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr) - (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) - - rawShaftTrail = opts^.arrowShaft - shaftTrail - = rawShaftTrail - -- rotate it so it is pointing in the positive X direction - # rotate (negated . view _theta . trailOffset $ rawShaftTrail) - -- apply the context transformation -- in case it includes - -- things like flips and shears (the possibility of shears - -- is why we must rotate it to a neutral position first) - # transform tr - - -- Adjust the head width and tail width to take gaps into account - tWidth = tWidth' + tGap - hWidth = hWidth' + hGap - - -- Calculate the angles that the head and tail should point. - tAngle = tangentAtStart shaftTrail ^. _theta - hAngle = tangentAtEnd shaftTrail ^. _theta - - -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire - -- arrow will be of length len. Then apply it to the shaft and make the - -- shaft into a Diagram with using its style. - sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) - shaftTrail' = shaftTrail # scale sf - shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') - - -- Adjust the head and tail to point in the directions of the shaft ends. - h' = h # rotate hAngle - # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') - t' = t # rotate tAngle - - -- Find out what direction the arrow is pointing so we can set it back - -- to point in the direction unitX when we are done. - dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) +arrow' opts len = + mkQD' + (DelayedLeaf delayedArrow) + -- Currently we approximate the envelope of an arrow by using the + -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty. + (arrowEnv opts len) + mempty + mempty + mempty + where + -- Once we learn the global transformation context (da) and the two scale + -- factors, normal to output (n) and global to output (g), this arrow is + -- drawn in, we can apply it to the origin and (len,0) to find out + -- the actual final points between which this arrow should be + -- drawn. We need to know this to draw it correctly, since the + -- head and tail are scale invariant, and hence the precise points + -- between which we need to draw the shaft do not transform + -- uniformly as the transformation applied to the entire arrow. + -- See https://github.com/diagrams/diagrams-lib/issues/112. + delayedArrow da g n = + let (trans, globalSty) = maybe mempty untangle . fst $ da + in dArrow globalSty trans len g n + + -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). + dArrow sty tr ln gToO nToO = + (h' <> t' <> shaft) + # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) + # rotate (((q .-. p) ^. _theta) ^-^ (dir ^. _theta)) + # moveTo p + where + p = origin # transform tr + q = origin # translateX ln # transform tr + + -- Use the existing line color for head, tail, and shaft by + -- default (can be overridden by explicitly setting headStyle, + -- tailStyle, or shaftStyle). Also use existing global line width + -- for shaft if not explicitly set in shaftStyle. + globalLC = getLineTexture <$> getAttr sty + opts' = + opts + & headStyle %~ maybe id fillTexture globalLC + & tailStyle %~ maybe id fillTexture globalLC + & shaftStyle %~ applyStyle sty . transform tr + + -- The head size, tail size, head gap, and tail gap are obtained + -- from the style and converted to output units. + scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr) + hSize = scaleFromMeasure $ opts ^. headLength + tSize = scaleFromMeasure $ opts ^. tailLength + hGap = scaleFromMeasure $ opts ^. headGap + tGap = scaleFromMeasure $ opts ^. tailGap + + -- Make the head and tail and save their widths. + (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr) + (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) + + rawShaftTrail = opts ^. arrowShaft + shaftTrail = + rawShaftTrail + -- rotate it so it is pointing in the positive X direction + # rotate (negated . view _theta . trailOffset $ rawShaftTrail) + -- apply the context transformation -- in case it includes + -- things like flips and shears (the possibility of shears + -- is why we must rotate it to a neutral position first) + # transform tr + + -- Adjust the head width and tail width to take gaps into account + tWidth = tWidth' + tGap + hWidth = hWidth' + hGap + + -- Calculate the angles that the head and tail should point. + tAngle = tangentAtStart shaftTrail ^. _theta + hAngle = tangentAtEnd shaftTrail ^. _theta + + -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire + -- arrow will be of length len. Then apply it to the shaft and make the + -- shaft into a Diagram with using its style. + sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) + shaftTrail' = shaftTrail # scale sf + shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') + + -- Adjust the head and tail to point in the directions of the shaft ends. + h' = + h + # rotate hAngle + # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') + t' = t # rotate tAngle + + -- Find out what direction the arrow is pointing so we can set it back + -- to point in the direction unitX when we are done. + dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. @@ -480,9 +512,12 @@ arrowBetween = arrowBetween' def -- @e@ using the given options. In particular, it scales and -- rotates @arrowShaft@ to go between @s@ and @e@, taking head, -- tail, and gaps into account. -arrowBetween' - :: (TypeableFloat n, Renderable (Path V2 n) b) => - ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any +arrowBetween' :: + (TypeableFloat n, Renderable (Path V2 n) b) => + ArrowOpts n -> + Point V2 n -> + Point V2 n -> + QDiagram b V2 n Any arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by @@ -490,14 +525,19 @@ arrowBetween' opts s e = arrowAt' opts s (e .-. s) arrowAt :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> QDiagram b V2 n Any arrowAt = arrowAt' def -arrowAt' - :: (TypeableFloat n, Renderable (Path V2 n) b) => - ArrowOpts n -> Point V2 n -> V2 n -> QDiagram b V2 n Any -arrowAt' opts s v = arrow' opts len - # rotate dir # moveTo s - where - len = norm v - dir = v ^. _theta +arrowAt' :: + (TypeableFloat n, Renderable (Path V2 n) b) => + ArrowOpts n -> + Point V2 n -> + V2 n -> + QDiagram b V2 n Any +arrowAt' opts s v = + arrow' opts len + # rotate dir + # moveTo s + where + len = norm v + dir = v ^. _theta -- | @arrowV v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin), using default @@ -507,82 +547,109 @@ arrowV = arrowV' def -- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin). -arrowV' - :: (TypeableFloat n, Renderable (Path V2 n) b) - => ArrowOpts n -> V2 n -> QDiagram b V2 n Any +arrowV' :: + (TypeableFloat n, Renderable (Path V2 n) b) => + ArrowOpts n -> + V2 n -> + QDiagram b V2 n Any arrowV' opts = arrowAt' opts origin -- | Turn a located trail into a default arrow by putting an -- arrowhead at the end of the trail. -arrowFromLocatedTrail - :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) - => Located (Trail V2 n) -> QDiagram b V2 n Any +arrowFromLocatedTrail :: + (Renderable (Path V2 n) b, RealFloat n, Typeable n) => + Located (Trail V2 n) -> + QDiagram b V2 n Any arrowFromLocatedTrail = arrowFromLocatedTrail' def -- | Turn a located trail into an arrow using the given options. -arrowFromLocatedTrail' - :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) - => ArrowOpts n -> Located (Trail V2 n) -> QDiagram b V2 n Any +arrowFromLocatedTrail' :: + (Renderable (Path V2 n) b, RealFloat n, Typeable n) => + ArrowOpts n -> + Located (Trail V2 n) -> + QDiagram b V2 n Any arrowFromLocatedTrail' opts trail = arrowBetween' opts' start end - where - opts' = opts & arrowShaft .~ unLoc trail - start = atStart trail - end = atEnd trail + where + opts' = opts & arrowShaft .~ unLoc trail + start = atStart trail + end = atEnd trail -- | Connect two diagrams with a straight arrow. -connect - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connect :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + n1 -> + n2 -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connect = connect' def -- | Connect two diagrams with an arbitrary arrow. -connect' - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connect' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + ArrowOpts n -> + n1 -> + n2 -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connect' opts n1 n2 = withName n1 $ \sub1 -> - withName n2 $ \sub2 -> - let [s,e] = map location [sub1, sub2] - in atop (arrowBetween' opts s e) + withName n2 $ \sub2 -> + let (s, e) = over both location (sub1, sub2) + in atop (arrowBetween' opts s e) -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. -connectPerim - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => n1 -> n2 -> Angle n -> Angle n - -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectPerim :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + n1 -> + n2 -> + Angle n -> + Angle n -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connectPerim = connectPerim' def -connectPerim' - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n - -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectPerim' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + ArrowOpts n -> + n1 -> + n2 -> + Angle n -> + Angle n -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 -> - withName n2 $ \sub2 -> - let [os, oe] = map location [sub1, sub2] - s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1) - e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2) - in atop (arrowBetween' opts s e) + withName n2 $ \sub2 -> + let (os, oe) = over both location (sub1, sub2) + s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1) + e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2) + in atop (arrowBetween' opts s e) -- | Draw an arrow from diagram named "n1" to diagram named "n2". The -- arrow lies on the line between the centres of the diagrams, but is -- drawn so that it stops at the boundaries of the diagrams, using traces -- to find the intersection points. -connectOutside - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectOutside :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + n1 -> + n2 -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connectOutside = connectOutside' def -connectOutside' - :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) - => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectOutside' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => + ArrowOpts n -> + n1 -> + n2 -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any connectOutside' opts n1 n2 = withName n1 $ \b1 -> - withName n2 $ \b2 -> - let v = location b2 .-. location b1 - midpoint = location b1 .+^ (v ^/ 2) - s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1 - e' = fromMaybe (location b2) $ traceP midpoint v b2 - in - atop (arrowBetween' opts s' e') + withName n2 $ \b2 -> + let v = location b2 .-. location b1 + midpoint = location b1 .+^ (v ^/ 2) + s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1 + e' = fromMaybe (location b2) $ traceP midpoint v b2 + in atop (arrowBetween' opts s' e') diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 4dd6834c..a7092415 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,10 +1,14 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +----------------------------------------------------------------------------- + ----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Arrowheads -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) @@ -14,76 +18,74 @@ -- Standard arrowheads and tails. Each arrowhead or tail is designed -- to be drawn filled, with a line width of 0, and is normalized to -- fit inside a circle of diameter 1. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Arrowheads - ( - -- * Arrowheads - -- ** Standard arrowheads - tri - , dart - , halfDart - , spike - , thorn - , lineHead - , noHead - - -- ** Configurable arrowheads - -- | Creates arrowheads of the same shape as the standard heads but - -- where the angle parameter is used to specify the angle to the top - -- left point of the arrowhead. - , arrowheadTriangle - , arrowheadDart - , arrowheadHalfDart - , arrowheadSpike - , arrowheadThorn - - -- * Arrow tails - -- ** Standard arrow tails - , tri' - , dart' - , halfDart' - , spike' - , thorn' - , lineTail - , noTail - , quill - , block - - -- ** Configurable arrow tails - - , arrowtailQuill - , arrowtailBlock - - -- * Internals - , ArrowHT - ) where - -import Control.Lens ((&), (.~), (<>~), (^.)) -import Data.Default.Class -import Data.Monoid (mempty, (<>)) - -import Diagrams.Angle -import Diagrams.Core - -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike (fromOffsets) -import Diagrams.TwoD.Align -import Diagrams.TwoD.Arc (arc') -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Polygons -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unit_X, xDir) -import Diagrams.Util (( # )) - -import Linear.Affine -import Linear.Metric -import Linear.Vector +module Diagrams.TwoD.Arrowheads ( + -- * Arrowheads + + -- ** Standard arrowheads + tri, + dart, + halfDart, + spike, + thorn, + lineHead, + noHead, + + -- ** Configurable arrowheads + + -- | Creates arrowheads of the same shape as the standard heads but + -- where the angle parameter is used to specify the angle to the top + -- left point of the arrowhead. + arrowheadTriangle, + arrowheadDart, + arrowheadHalfDart, + arrowheadSpike, + arrowheadThorn, + + -- * Arrow tails + + -- ** Standard arrow tails + tri', + dart', + halfDart', + spike', + thorn', + lineTail, + noTail, + quill, + block, + + -- ** Configurable arrow tails + arrowtailQuill, + arrowtailBlock, + + -- * Internals + ArrowHT, +) where + +import Control.Lens (both, over, (&), (.~), (<>~), (^.)) +import Data.Default.Class +import Data.Monoid (mempty, (<>)) + +import Diagrams.Angle +import Diagrams.Core + +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike (fromOffsets) +import Diagrams.TwoD.Align +import Diagrams.TwoD.Arc (arc') +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X, xDir) +import Diagrams.Util ((#)) + +import Linear.Affine +import Linear.Metric +import Linear.Vector ----------------------------------------------------------------------------- @@ -108,106 +110,121 @@ closedPath = pathFromTrail . closeTrail -- > <> square 0.6 # alignL # lw none # frame 0.1 arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n arrowheadTriangle theta = aHead - where - aHead len _ = (p, mempty) - where - psi = pi - (theta ^. rad) - r = len / (1 + cos psi) - p = polygon (def & polyType .~ PolyPolar [theta, (-2) *^ theta] - (repeat r) & polyOrient .~ NoOrient) # alignL - + where + aHead len _ = (p, mempty) + where + psi = pi - (theta ^. rad) + r = len / (1 + cos psi) + p = + polygon + ( def + & polyType + .~ PolyPolar + [theta, (-2) *^ theta] + (repeat r) + & polyOrient .~ NoOrient + ) + # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. arrowheadDart :: RealFloat n => Angle n -> ArrowHT n arrowheadDart theta len shaftWidth = (hd # scale sz, jt) - where - hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] - jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] - v = rotate theta unitX - (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v) - [b1, b2] = map (reflectY . negated) [t1, t2] - psi = pi - negated t2 ^. _theta . rad - jLength = shaftWidth / (2 * tan psi) - - -- If the shaft is too wide, set the size to a default value of 1. - sz = max 1 ((len - jLength) / 1.5) + where + hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] + v = rotate theta unitX + (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v) + (b1, b2) = over both (reflectY . negated) (t1, t2) + psi = pi - negated t2 ^. _theta . rad + jLength = shaftWidth / (2 * tan psi) + + -- If the shaft is too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) -- | Top half of an 'arrowheadDart'. arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n arrowheadHalfDart theta len shaftWidth = (hd, jt) - where - hd = fromOffsets [t1, t2] - # closeTrail # pathFromTrail - # translateX 1.5 # scale sz - # translateY (-shaftWidth/2) - # snugL - jt = snugR . translateY (-shaftWidth/2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth] - v = rotate theta unitX - (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v) - psi = pi - negated t2 ^. _theta . rad - jLength = shaftWidth / tan psi - - -- If the shaft is too wide, set the size to a default value of 1. - sz = max 1 ((len - jLength) / 1.5) + where + hd = + fromOffsets [t1, t2] + # closeTrail + # pathFromTrail + # translateX 1.5 + # scale sz + # translateY (-shaftWidth / 2) + # snugL + jt = snugR . translateY (-shaftWidth / 2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth] + v = rotate theta unitX + (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v) + psi = pi - negated t2 ^. _theta . rad + jLength = shaftWidth / tan psi + + -- If the shaft is too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n -arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) - where - hd = snugL . closedPath $ l1 <> c <> l2 - jt = alignR . centerY . pathFromTrail - . closeTrail $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi) - l1 = trailFromSegments [straight $ unit_X ^+^ v] - l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)] - c = arc' 1 (rotate α xDir) ((-2) *^ α) - α = (1/2 @@ turn) ^-^ theta - v = rotate theta unitX - - -- The length of the head without its joint is, -2r cos theta and - -- the length of the joint is r - sqrt (r^2 - y^2). So the total - -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2). - -- Solving the quadratic gives two roots, we want the larger one. - - -- 1/4 turn < theta < 2/3 turn. - a = 1 - 2 * cos (theta ^. rad) - y = shaftWidth / 2 - - -- If the shaft is too wide for the head, we default the radius r to - -- 2/3 * len by setting d=1 and phi=pi/2. - d = max 1 (len**2 + (1 - a**2) * y**2) - r = (a * len + sqrt d) / (a**2 -1) - phi = asinA (min 1 (y/r)) +arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) + where + hd = snugL . closedPath $ l1 <> c <> l2 + jt = + alignR + . centerY + . pathFromTrail + . closeTrail + $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi) + l1 = trailFromSegments [straight $ unit_X ^+^ v] + l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)] + c = arc' 1 (rotate α xDir) ((-2) *^ α) + α = (1 / 2 @@ turn) ^-^ theta + v = rotate theta unitX + + -- The length of the head without its joint is, -2r cos theta and + -- the length of the joint is r - sqrt (r^2 - y^2). So the total + -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2). + -- Solving the quadratic gives two roots, we want the larger one. + + -- 1/4 turn < theta < 2/3 turn. + a = 1 - 2 * cos (theta ^. rad) + y = shaftWidth / 2 + + -- If the shaft is too wide for the head, we default the radius r to + -- 2/3 * len by setting d=1 and phi=pi/2. + d = max 1 (len ** 2 + (1 - a ** 2) * y ** 2) + r = (a * len + sqrt d) / (a ** 2 - 1) + phi = asinA (min 1 (y / r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n arrowheadThorn theta len shaftWidth = (hd # scale sz, jt) - where - hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop - hTop = closeTrail . trailFromSegments $ [c, l] - jt = pathFromTrail . glueTrail $ j <> reflectY j - j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] - c = curvedSide theta - v = rotate theta unitX - l = reverseSegment . straight $ t - t = v ^-^ V2 (-0.5) 0 - psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta) - jLength = shaftWidth / (2 * tanA psi) - - -- If the shaft if too wide, set the size to a default value of 1. - sz = max 1 ((len - jLength) / 1.5) + where + hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop + hTop = closeTrail . trailFromSegments $ [c, l] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] + c = curvedSide theta + v = rotate theta unitX + l = reverseSegment . straight $ t + t = v ^-^ V2 (-0.5) 0 + psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta) + jLength = shaftWidth / (2 * tanA psi) + + -- If the shaft if too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. curvedSide :: Floating n => Angle n -> Segment Closed V2 n curvedSide theta = bezier3 ctrl1 ctrl2 end - where - v0 = unit_X - v1 = rotate theta unitX - ctrl1 = v0 - ctrl2 = v0 ^+^ v1 - end = v0 ^+^ v1 + where + v0 = unit_X + v1 = rotate theta unitX + ctrl1 = v0 + ctrl2 = v0 ^+^ v1 + end = v0 ^+^ v1 -- Standard heads --------------------------------------------------------- + -- | A line the same width as the shaft. lineHead :: RealFloat n => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) @@ -219,31 +236,31 @@ noHead _ _ = (mempty, mempty) -- > triEx = drawHead tri tri :: RealFloat n => ArrowHT n -tri = arrowheadTriangle (1/3 @@ turn) +tri = arrowheadTriangle (1 / 3 @@ turn) -- | <> -- > spikeEx = drawHead spike spike :: RealFloat n => ArrowHT n -spike = arrowheadSpike (3/8 @@ turn) +spike = arrowheadSpike (3 / 8 @@ turn) -- | <> -- > thornEx = drawHead thorn thorn :: RealFloat n => ArrowHT n -thorn = arrowheadThorn (3/8 @@ turn) +thorn = arrowheadThorn (3 / 8 @@ turn) -- | <> -- > dartEx = drawHead dart dart :: RealFloat n => ArrowHT n -dart = arrowheadDart (2/5 @@ turn) +dart = arrowheadDart (2 / 5 @@ turn) -- | <> -- > halfDartEx = drawHead halfDart halfDart :: RealFloat n => ArrowHT n -halfDart = arrowheadHalfDart (2/5 @@ turn) +halfDart = arrowheadHalfDart (2 / 5 @@ turn) -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none @@ -255,47 +272,50 @@ halfDart = arrowheadHalfDart (2/5 @@ turn) -- attached at the start of the trail. headToTail :: OrderedField n => ArrowHT n -> ArrowHT n headToTail hd = tl - where - tl sz shaftWidth = (t, j) - where - (t', j') = hd sz shaftWidth - t = reflectX t' - j = reflectX j' - -arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n + where + tl sz shaftWidth = (t, j) + where + (t', j') = hd sz shaftWidth + t = reflectX t' + j = reflectX j' + +arrowtailBlock :: forall n. RealFloat n => Angle n -> ArrowHT n arrowtailBlock theta = aTail - where - aTail len _ = (t, mempty) - where - t = rect len (len * x) # alignR - a' :: V2 n - a' = rotate theta unitX - a = a' ^-^ reflectY a' - x = norm a + where + aTail len _ = (t, mempty) + where + t = rect len (len * x) # alignR + a' :: V2 n + a' = rotate theta unitX + a = a' ^-^ reflectY a' + x = norm a -- | The angle is where the top left corner intersects the circle. arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n arrowtailQuill theta = aTail - where - aTail len shaftWidth = (t, j) - where - t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) - # scale sz # alignR - sz = len / 0.6 - v0 = p2 (0.5, 0) - v2 = origin .+^ (rotate theta unitX # scale 0.5) - v1 = v2 # translateX (5/8) - v3 = p2 (-0.1, 0) - v4 = v2 # reflectY - v5 = v4 # translateX (5/8) - s = 1 - shaftWidth / norm (v1 .-. v5) - n1 = v0 # translateY (0.5 * shaftWidth) - n2 = v1 .-^ ((v1 .-. v0) # scale s) - n3 = v5 .-^ ((v5 .-. v0) # scale s) - n4 = n1 # reflectY - j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] + where + aTail len shaftWidth = (t, j) + where + t = + closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) + # scale sz + # alignR + sz = len / 0.6 + v0 = p2 (0.5, 0) + v2 = origin .+^ (rotate theta unitX # scale 0.5) + v1 = v2 # translateX (5 / 8) + v3 = p2 (-0.1, 0) + v4 = v2 # reflectY + v5 = v4 # translateX (5 / 8) + s = 1 - shaftWidth / norm (v1 .-. v5) + n1 = v0 # translateY (0.5 * shaftWidth) + n2 = v1 .-^ ((v1 .-. v0) # scale s) + n3 = v5 .-^ ((v5 .-. v0) # scale s) + n4 = n1 # reflectY + j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] -- Standard tails --------------------------------------------------------- + -- | A line the same width as the shaft. lineTail :: RealFloat n => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) @@ -337,10 +357,10 @@ halfDart' = headToTail halfDart -- > quillEx = drawTail quill quill :: (Floating n, Ord n) => ArrowHT n -quill = arrowtailQuill (2/5 @@ turn) +quill = arrowtailQuill (2 / 5 @@ turn) -- | <> -- > blockEx = drawTail block block :: RealFloat n => ArrowHT n -block = arrowtailBlock (7/16 @@ turn) +block = arrowtailBlock (7 / 16 @@ turn) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index e0e8f9a2..d36fa3e2 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Path -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) @@ -25,69 +27,82 @@ -- create a 2D diagram, and (eventually) perform operations such as -- intersection and union. They also have a trace, whereas paths in -- higher dimensions do not. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Path - ( -- * Constructing path-based diagrams - - stroke, stroke' - , strokePath, strokeP, strokePath', strokeP' - , strokeTrail, strokeT, strokeTrail', strokeT' - , strokeLine, strokeLoop - , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop - - -- ** Stroke options - - , FillRule(..) - , getFillRule, fillRule, _fillRule - , StrokeOpts(..), vertexNames, queryFillRule - - -- ** Inside/outside testing - - , Crossings (..) - , isInsideWinding - , isInsideEvenOdd - - -- * Clipping - - , Clip(..), _Clip, _clip - , clipBy, clipTo, clipped - - -- * Intersections - - , intersectPoints, intersectPoints' - , intersectPointsP, intersectPointsP' - , intersectPointsT, intersectPointsT' - ) where - -import Control.Applicative (liftA2) -import Control.Lens hiding (at, transform) -import qualified Data.Foldable as F -import Data.Semigroup -import Data.Typeable - -import Data.Default.Class - -import Diagrams.Angle -import Diagrams.Combinators (withEnvelope, withTrace) -import Diagrams.Core -import Diagrams.Core.Trace -import Diagrams.Located (Located, mapLoc, unLoc) -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Query -import Diagrams.Segment -import Diagrams.Solve.Polynomial -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Segment -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util (tau) - -import Linear.Affine -import Linear.Vector +module Diagrams.TwoD.Path ( + -- * Constructing path-based diagrams + stroke, + stroke', + strokePath, + strokeP, + strokePath', + strokeP', + strokeTrail, + strokeT, + strokeTrail', + strokeT', + strokeLine, + strokeLoop, + strokeLocTrail, + strokeLocT, + strokeLocLine, + strokeLocLoop, + + -- ** Stroke options + FillRule (..), + getFillRule, + fillRule, + _fillRule, + StrokeOpts (..), + vertexNames, + queryFillRule, + + -- ** Inside/outside testing + Crossings (..), + isInsideWinding, + isInsideEvenOdd, + + -- * Clipping + Clip (..), + _Clip, + _clip, + clipBy, + clipTo, + clipped, + + -- * Intersections + intersectPoints, + intersectPoints', + intersectPointsP, + intersectPointsP', + intersectPointsT, + intersectPointsT', +) where + +import Control.Lens hiding (at, transform) +import qualified Data.Foldable as F +import Data.Semigroup +import Data.Typeable + +import Data.Default.Class + +import Diagrams.Angle +import Diagrams.Combinators (withEnvelope, withTrace) +import Diagrams.Core +import Diagrams.Core.Trace +import Diagrams.Located (Located, mapLoc, unLoc) +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Solve.Polynomial +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Segment +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util (tau) + +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Trail and path traces --------------------------------- @@ -98,11 +113,12 @@ import Linear.Vector -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. instance RealFloat n => Traced (Trail V2 n) where - getTrace = withLine $ + getTrace = + withLine $ foldr (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty - . lineSegments + . lineSegments instance RealFloat n => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path @@ -115,14 +131,16 @@ instance RealFloat n => Traced (Path V2 n) where -- points lie in the interior of a (possibly self-intersecting) -- path. data FillRule - = Winding -- ^ Interior points are those with a nonzero - -- /winding/ /number/. See - -- . - | EvenOdd -- ^ Interior points are those where a ray - -- extended infinitely in a particular direction crosses - -- the path an odd number of times. See - -- . - deriving (Show, Typeable, Eq, Ord) + = -- | Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + Winding + | -- | Interior points are those where a ray + -- extended infinitely in a particular direction crosses + -- the path an odd number of times. See + -- . + EvenOdd + deriving (Show, Typeable, Eq, Ord) instance AttributeClass FillRule instance Semigroup FillRule where @@ -134,13 +152,10 @@ instance Default FillRule where -- | A record of options that control how a path is stroked. -- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ -- records can be created using @'with' { ... }@ notation. -data StrokeOpts a - = StrokeOpts - { _vertexNames :: [[a]] - - , _queryFillRule :: FillRule - - } +data StrokeOpts a = StrokeOpts + { _vertexNames :: [[a]] + , _queryFillRule :: FillRule + } makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts @@ -153,7 +168,6 @@ makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts -- so on. -- -- The default value is the empty list. - vertexNames :: Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] -- | The fill rule used for determining which points are inside the path. @@ -163,10 +177,11 @@ vertexNames :: Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] queryFillRule :: Lens' (StrokeOpts a) FillRule instance Default (StrokeOpts a) where - def = StrokeOpts - { _vertexNames = [] - , _queryFillRule = def - } + def = + StrokeOpts + { _vertexNames = [] + , _queryFillRule = def + } -- | Convert a 'ToPath' object into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices. @@ -180,8 +195,10 @@ instance Default (StrokeOpts a) where -- 'stroke' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Diagram' b -- 'stroke' :: 'Located' ('Trail'' 'Line' 'V2' 'Double') -> 'Diagram' b -- @ -stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) - => t -> QDiagram b V2 n Any +stroke :: + (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) => + t -> + QDiagram b V2 n Any stroke = strokeP . toPath -- | A variant of 'stroke' that takes an extra record of options to @@ -191,101 +208,139 @@ stroke = strokeP . toPath -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> t -> QDiagram b V2 n Any +stroke' :: + (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> + t -> + QDiagram b V2 n Any stroke' opts = strokeP' opts . toPath -- | 'stroke' specialised to 'Path'. -strokeP :: (TypeableFloat n, Renderable (Path V2 n) b) - => Path V2 n -> QDiagram b V2 n Any +strokeP :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Path V2 n -> + QDiagram b V2 n Any strokeP = strokeP' (def :: StrokeOpts ()) -- | 'stroke' specialised to 'Path'. -strokePath :: (TypeableFloat n, Renderable (Path V2 n) b) - => Path V2 n -> QDiagram b V2 n Any +strokePath :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Path V2 n -> + QDiagram b V2 n Any strokePath = strokeP -instance (TypeableFloat n, Renderable (Path V2 n) b) - => TrailLike (QDiagram b V2 n Any) where +instance + (TypeableFloat n, Renderable (Path V2 n) b) => + TrailLike (QDiagram b V2 n Any) + where trailLike = strokeP . trailLike -- | 'stroke'' specialised to 'Path'. -strokeP' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any +strokeP' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> + Path V2 n -> + QDiagram b V2 n Any strokeP' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines - | otherwise = mkP pLines <> mkP pLoops - where - (pLines,pLoops) = partitionPath (isLine . unLoc) path - mkP p - = mkQD (Prim p) - (getEnvelope p) - (getTrace p) - (fromNames . concat $ - zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) - ) - (Query $ Any . (runFillRule (opts^.queryFillRule)) p) + | otherwise = mkP pLines <> mkP pLoops + where + (pLines, pLoops) = partitionPath (isLine . unLoc) path + mkP p = + mkQD + (Prim p) + (getEnvelope p) + (getTrace p) + ( fromNames . concat $ + zipWith zip (opts ^. vertexNames) ((map . map) subPoint (pathVertices p)) + ) + (Query $ Any . (runFillRule (opts ^. queryFillRule)) p) -- | 'stroke'' specialised to 'Path'. -strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any +strokePath' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> + Path V2 n -> + QDiagram b V2 n Any strokePath' = strokeP' -- | 'stroke' specialised to 'Trail'. -strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail V2 n -> QDiagram b V2 n Any +strokeTrail :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Trail V2 n -> + QDiagram b V2 n Any strokeTrail = stroke . pathFromTrail -- | 'stroke' specialised to 'Trail'. -strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail V2 n -> QDiagram b V2 n Any +strokeT :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Trail V2 n -> + QDiagram b V2 n Any strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any +strokeTrail' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> + Trail V2 n -> + QDiagram b V2 n Any strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''. -strokeT' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any +strokeT' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> + Trail V2 n -> + QDiagram b V2 n Any strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail' Line V2 n -> QDiagram b V2 n Any +strokeLine :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Trail' Line V2 n -> + QDiagram b V2 n Any strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail' Loop V2 n -> QDiagram b V2 n Any +strokeLoop :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Trail' Loop V2 n -> + QDiagram b V2 n Any strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail V2 n) -> QDiagram b V2 n Any +strokeLocTrail :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Located (Trail V2 n) -> + QDiagram b V2 n Any strokeLocTrail = strokeP . trailLike -- | Deprecated synonym for 'strokeLocTrail'. -strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail V2 n) -> QDiagram b V2 n Any +strokeLocT :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Located (Trail V2 n) -> + QDiagram b V2 n Any strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail' Line V2 n) -> QDiagram b V2 n Any +strokeLocLine :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Located (Trail' Line V2 n) -> + QDiagram b V2 n Any strokeLocLine = strokeP . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any +strokeLocLoop :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Located (Trail' Loop V2 n) -> + QDiagram b V2 n Any strokeLocLoop = strokeP . trailLike . mapLoc wrapLoop ------------------------------------------------------------ @@ -336,7 +391,7 @@ instance Semigroup Crossings where Crossings a <> Crossings b = Crossings (a + b) instance Monoid Crossings where - mempty = Crossings 0 + mempty = Crossings 0 mappend = (<>) instance RealFloat n => HasQuery (Located (Trail V2 n)) Crossings where @@ -379,41 +434,49 @@ isInsideEvenOdd t = odd . sample t -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Crossings - - -- non-loop trails have no inside or outside, so don't contribute crossings +-- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 - -trailCrossings p@(unp2 -> (x,y)) tr - = F.foldMap test $ fixTrail tr - where - test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) - | ay <= y && by > y && isLeft a b > 0 = 1 - | by <= y && ay > y && isLeft a b < 0 = -1 - | otherwise = 0 - - test c@(FCubic (P x1@(V2 _ x1y)) - (P c1@(V2 _ c1y)) - (P c2@(V2 _ c2y)) - (P x2@(V2 _ x2y)) - ) = - sum . map testT $ ts - where ts = filter (liftA2 (&&) (>=0) (<=1)) - $ cubForm (- x1y + 3*c1y - 3*c2y + x2y) - ( 3*x1y - 6*c1y + 3*c2y) - (-3*x1y + 3*c1y) - (x1y - y) - testT t = let (unp2 -> (px,_)) = c `atParam` t - in if px > x then signFromDerivAt t else 0 - signFromDerivAt t = - let v = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) - ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) - ^+^ ((-3)*^x1 ^+^ 3*^c1) - ang = v ^. _theta . rad - in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 - | -tau/2 < ang && ang < 0 && t > 0 -> -1 - | otherwise -> 0 - - isLeft a b = cross2 (b .-. a) (p .-. a) +trailCrossings p@(unp2 -> (x, y)) tr = + F.foldMap test $ fixTrail tr + where + test (FLinear a@(unp2 -> (_, ay)) b@(unp2 -> (_, by))) + | ay <= y && by > y && isLeft a b > 0 = 1 + | by <= y && ay > y && isLeft a b < 0 = -1 + | otherwise = 0 + test + c@( FCubic + (P x1@(V2 _ x1y)) + (P c1@(V2 _ c1y)) + (P c2@(V2 _ c2y)) + (P x2@(V2 _ x2y)) + ) = + sum . map testT $ ts + where + ts = + filter (liftA2 (&&) (>= 0) (<= 1)) $ + cubForm + (-x1y + 3 * c1y - 3 * c2y + x2y) + (3 * x1y - 6 * c1y + 3 * c2y) + (-3 * x1y + 3 * c1y) + (x1y - y) + testT t = + let (unp2 -> (px, _)) = c `atParam` t + in if px > x then signFromDerivAt t else 0 + signFromDerivAt t = + let v = + (3 * t * t) + *^ ((-1) *^ x1 ^+^ 3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) + ^+^ (2 * t) + *^ (3 *^ x1 ^-^ 6 *^ c1 ^+^ 3 *^ c2) + ^+^ ((-3) *^ x1 ^+^ 3 *^ c1) + ang = v ^. _theta . rad + in case () of + _ + | 0 < ang && ang < tau / 2 && t < 1 -> 1 + | -tau / 2 < ang && ang < 0 && t > 0 -> -1 + | otherwise -> 0 + + isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ---------------------------------------------- @@ -437,7 +500,7 @@ instance AsEmpty (Clip n) where type instance V (Clip n) = V2 type instance N (Clip n) = n -instance (OrderedField n) => Transformable (Clip n) where +instance OrderedField n => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) -- | A point inside a clip if the point is in 'All' invididual clipping @@ -460,36 +523,44 @@ _clip = atTAttr . non' _Empty . _Clip -- -- * The envelope of the diagram is unaffected. clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a -clipBy = applyTAttr . Clip . (:[]) +clipBy = applyTAttr . Clip . (: []) -- | Clip a diagram to the given path setting its envelope to the -- pointwise minimum of the envelopes of the diagram and path. The -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. -clipTo :: TypeableFloat n - => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipTo :: + TypeableFloat n => + Path V2 n -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d - where - envP = appEnvelope . getEnvelope $ p - envD = appEnvelope . getEnvelope $ d - toEnvelope = case (envP, envD) of - (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) - (_, _) -> id - intersectionTrace = Trace traceIntersections - traceIntersections pt v = - -- on boundary of d, inside p - onSortedList (filter pInside) (appTrace (getTrace d) pt v) <> - -- or on boundary of p, inside d - onSortedList (filter dInside) (appTrace (getTrace p) pt v) where - newPt dist = pt .+^ v ^* dist - pInside dDist = runFillRule Winding p (newPt dDist) - dInside pDist = getAny . sample d $ newPt pDist + where + envP = appEnvelope . getEnvelope $ p + envD = appEnvelope . getEnvelope $ d + toEnvelope = case (envP, envD) of + (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) + (_, _) -> id + intersectionTrace = Trace traceIntersections + traceIntersections pt v = + -- on boundary of d, inside p + onSortedList (filter pInside) (appTrace (getTrace d) pt v) + <> + -- or on boundary of p, inside d + onSortedList (filter dInside) (appTrace (getTrace p) pt v) + where + newPt dist = pt .+^ v ^* dist + pInside dDist = runFillRule Winding p (newPt dDist) + dInside pDist = getAny . sample d $ newPt pDist -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. -clipped :: TypeableFloat n - => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipped :: + TypeableFloat n => + Path V2 n -> + QDiagram b V2 n Any -> + QDiagram b V2 n Any clipped p = withTrace p . withEnvelope p . clipBy p ------------------------------------------------------------ @@ -497,14 +568,21 @@ clipped p = withTrace p . withEnvelope p . clipBy p ------------------------------------------------------------ -- | Find the intersect points of two objects that can be converted to a path. -intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) - => t -> s -> [P2 n] +intersectPoints :: + (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) => + t -> + s -> + [P2 n] intersectPoints = intersectPoints' 1e-8 -- | Find the intersect points of two objects that can be converted to a path -- within the given tolerance. -intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) - => n -> t -> s -> [P2 n] +intersectPoints' :: + (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) => + n -> + t -> + s -> + [P2 n] intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) -- | Compute the intersect points between two paths. diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index ecacbd23..5e2ca8b5 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,16 +1,19 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + -- Orphan Traced instances for Segment Closed V2 and FixedSegment V2. -- They can't go in Traced; but they shouldn't really go in -- Diagrams.Segment either because we only have Traced instances for -- the special case of R2. ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Segment -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) @@ -19,47 +22,42 @@ -- -- Segments in two dimensions are special since we may meaningfully -- compute their point of intersection with a ray. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Segment - ( -- * Segment intersections - - intersectPointsS - , intersectPointsS' - - -- * Closest point on a segment - - , closestPoint - , closestPoint' - , closestDistance - , closestDistance' - , closestParam - , closestParam' - - -- ** Low level functions - , segmentSegment - , lineSegment - ) - where - -import Control.Lens hiding (at, contains, transform, ( # )) -import Data.Maybe - -import Diagrams.Core - -import Diagrams.Direction -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.TwoD.Points -import Diagrams.TwoD.Segment.Bernstein -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types hiding (p2) -import Diagrams.TwoD.Vector - -import Linear.Affine -import Linear.Metric +module Diagrams.TwoD.Segment ( + -- * Segment intersections + intersectPointsS, + intersectPointsS', + + -- * Closest point on a segment + closestPoint, + closestPoint', + closestDistance, + closestDistance', + closestParam, + closestParam', + + -- ** Low level functions + segmentSegment, + lineSegment, +) +where + +import Control.Lens hiding (at, contains, transform, (#)) +import Data.Maybe + +import Diagrams.Core + +import Diagrams.Direction +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.TwoD.Points +import Diagrams.TwoD.Segment.Bernstein +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types hiding (p2) +import Diagrams.TwoD.Vector + +import Linear.Affine +import Linear.Metric {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. @@ -109,21 +107,22 @@ closestParam = closestParam' defEps -- tolerance. closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] closestParam' _ (FLinear p0 p1) p - | t < 0 = [0] - | t > 1 = [1] + | t < 0 = [0] + | t > 1 = [1] | otherwise = [t] - where - vp = p .-. p0 - v = p1 .-. p0 - dp = vp `dot` v - t = dp / quadrance v + where + vp = p .-. p0 + v = p1 .-. p0 + dp = vp `dot` v + t = dp / quadrance v closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1 - where - (bx, by) = bezierToBernstein cb - bx' = bernsteinDeriv bx - by' = bernsteinDeriv by - poly = (bx - listToBernstein [px, px, px, px]) * bx' - + (by - listToBernstein [py, py, py, py]) * by' + where + (bx, by) = bezierToBernstein cb + bx' = bernsteinDeriv bx + by' = bernsteinDeriv by + poly = + (bx - listToBernstein [px, px, px, px]) * bx' + + (by - listToBernstein [py, py, py, py]) * by' ------------------------------------------------------------------------ -- Low level @@ -133,68 +132,70 @@ closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1 -- intersects. segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)] segmentSegment eps s1 s2 = - case (s1,s2) of - (FCubic{}, FCubic{}) -> map (\(t1,t2) -> (t1,t2, s1 `atParam` t1)) - $ bezierClip eps s1 s2 - (FCubic{}, FLinear{}) -> map flip12 $ linearSeg (segLine s2) s1 - _ -> linearSeg (segLine s1) s2 -- s1 is linear - where - linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s - flip12 (a,b,c) = (b,a,c) + case (s1, s2) of + (FCubic {}, FCubic {}) -> + map (\(t1, t2) -> (t1, t2, s1 `atParam` t1)) $ + bezierClip eps s1 s2 + (FCubic {}, FLinear {}) -> map flip12 $ linearSeg (segLine s2) s1 + _ -> linearSeg (segLine s1) s2 -- s1 is linear + where + linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s + flip12 (a, b, c) = (b, a, c) -- | Return the intersection points with the parameters at which the line and segment -- intersect. lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)] -lineSegment _ l1 p@(FLinear p0 p1) - = map (\(tl,tp) -> (tl, tp, p `atParam` tp)) - . filter (inRange . snd) . maybeToList $ lineLine l1 (mkLine p0 p1) -lineSegment eps (viewLoc -> (p,r)) cb = map addPoint params - where - params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1 - cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb - -- - addPoint bt = (lt, bt, intersect) - where - intersect = cb `atParam` bt - lt = (cb' `atParam` bt) ^. _x / norm r +lineSegment _ l1 p@(FLinear p0 p1) = + map (\(tl, tp) -> (tl, tp, p `atParam` tp)) + . filter (inRange . snd) + . maybeToList + $ lineLine l1 (mkLine p0 p1) +lineSegment eps (viewLoc -> (p, r)) cb = map addPoint params + where + params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1 + cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb + -- + addPoint bt = (lt, bt, intersect) + where + intersect = cb `atParam` bt + lt = (cb' `atParam` bt) ^. _x / norm r -- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier -- | Use the Bêzier clipping algorithm to return the parameters at which the -- Bêzier curves intersect. bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)] -bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN - $ go p_ q_ 0 1 0 1 0 False - where - go p q tmin tmax umin umax clip revCurves - | isNothing chopInterval = [] - - -- This check happens before the subdivision - -- test to avoid non-termination as values - -- transition to within epsilon. - | max (umax - umin) (tmax' - tmin') < eps = - if revCurves -- return parameters in correct order - then [ (avg umin umax, avg tmin' tmax') ] - else [ (avg tmin' tmax', avg umin umax ) ] - - -- split the curve if there isn't enough reduction - | clip > 0.8 && clip' > 0.8 = - if tmax' - tmin' > umax - umin -- split the longest segment - then let (pl, pr) = p' `splitAtParam` 0.5 - tmid = avg tmin' tmax' - in go q pl umin umax tmin' tmid clip' (not revCurves) ++ - go q pr umin umax tmid tmax' clip' (not revCurves) - else let (ql, qr) = q `splitAtParam` 0.5 - umid = avg umin umax - in go ql p' umin umid tmin' tmax' clip' (not revCurves) ++ - go qr p' umid umax tmin' tmax' clip' (not revCurves) - - -- iterate with the curves reversed. - | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves) - where - chopInterval = chopCubics p q - Just (tminChop, tmaxChop) = chopInterval - p' = section p tminChop tmaxChop +bezierClip eps p_ q_ = + filter (allOf both inRange) $ -- sometimes this returns NaN + go p_ q_ 0 1 0 1 0 False + where + go p q tmin tmax umin umax clip revCurves = case chopCubics p q of + Nothing -> [] + Just (tminChop, tmaxChop) + -- This check happens before the subdivision + -- test to avoid non-termination as values + -- transition to within epsilon. + | max (umax - umin) (tmax' - tmin') < eps -> + if revCurves -- return parameters in correct order + then [(avg umin umax, avg tmin' tmax')] + else [(avg tmin' tmax', avg umin umax)] + -- split the curve if there isn't enough reduction + | clip > 0.8 && clip' > 0.8 -> + if tmax' - tmin' > umax - umin -- split the longest segment + then + let (pl, pr) = p' `splitAtParam` 0.5 + tmid = avg tmin' tmax' + in go q pl umin umax tmin' tmid clip' (not revCurves) + ++ go q pr umin umax tmid tmax' clip' (not revCurves) + else + let (ql, qr) = q `splitAtParam` 0.5 + umid = avg umin umax + in go ql p' umin umid tmin' tmax' clip' (not revCurves) + ++ go qr p' umid umax tmin' tmax' clip' (not revCurves) + -- iterate with the curves reversed. + | otherwise -> go q p' umin umax tmin' tmax' clip' (not revCurves) + where + p' = section p tminChop tmaxChop clip' = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) @@ -202,63 +203,68 @@ bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN -- | Find the zero of a 1D Bêzier curve of any degree. Note that this -- can be used as a Bernstein polynomial root solver by converting from -- the power basis to the Bernstein basis. -bezierFindRoot :: OrderedField n - => n -- ^ The accuracy - -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial - -> n -- ^ The lower bound of the interval - -> n -- ^ The upper bound of the interval - -> [n] -- ^ The roots found -bezierFindRoot eps p tmin tmax - | isNothing chopInterval = [] - | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 - tmid = tmin' + (tmax' - tmin') / 2 - in bezierFindRoot eps p1 tmin' tmid ++ - bezierFindRoot eps p2 tmid tmax' - | tmax' - tmin' < eps = [avg tmin' tmax'] - | otherwise = bezierFindRoot eps newP tmin' tmax' - where - chopInterval = chopYs (bernsteinCoeffs p) - Just (tminChop, tmaxChop) = chopInterval - newP = section p tminChop tmaxChop - clip = tmaxChop - tminChop +bezierFindRoot :: + OrderedField n => + -- | The accuracy + n -> + -- | the Bernstein coefficients of the polynomial + BernsteinPoly n -> + -- | The lower bound of the interval + n -> + -- | The upper bound of the interval + n -> + -- | The roots found + [n] +bezierFindRoot eps p tmin tmax = case chopYs (bernsteinCoeffs p) of + Nothing -> [] + Just (tminChop, tmaxChop) + | clip > 0.8 -> + let (p1, p2) = splitAtParam newP 0.5 + tmid = tmin' + (tmax' - tmin') / 2 + in bezierFindRoot eps p1 tmin' tmid + ++ bezierFindRoot eps p2 tmid tmax' + | tmax' - tmin' < eps -> [avg tmin' tmax'] + | otherwise -> bezierFindRoot eps newP tmin' tmax' + where + newP = section p tminChop tmaxChop + clip = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) - - ------------------------------------------------------------------------ -- Internal ------------------------------------------------------------------------ -- | An approximation of the fat line for a cubic Bêzier segment. Returns -- @(0,0)@ for a linear segment. -fatLine :: OrderedField n => FixedSegment V2 n -> (n,n) -fatLine (FCubic p0 p1 p2 p3) - = case (d1 > 0, d2 > 0) of - (True, True) -> (0, 0.75 * max d1 d2) - (False, False) -> (0.75 * min d1 d2, 0 ) - (True, False) -> (4/9 * d2, 4/9 * d1 ) - (False, True) -> (4/9 * d1, 4/9 * d2 ) - where - d = lineDistance p0 p3 - d1 = d p1; d2 = d p2 -fatLine _ = (0,0) +fatLine :: OrderedField n => FixedSegment V2 n -> (n, n) +fatLine (FCubic p0 p1 p2 p3) = + case (d1 > 0, d2 > 0) of + (True, True) -> (0, 0.75 * max d1 d2) + (False, False) -> (0.75 * min d1 d2, 0) + (True, False) -> (4 / 9 * d2, 4 / 9 * d1) + (False, True) -> (4 / 9 * d1, 4 / 9 * d2) + where + d = lineDistance p0 p3 + d1 = d p1 + d2 = d p2 +fatLine _ = (0, 0) chopYs :: OrderedField n => [n] -> Maybe (n, n) chopYs ds = chopHull 0 0 points - where - points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0..n]] ds - n = length ds - 1 - -chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n,n) -chopCubics p q@(FCubic q0 _ _ q3) - = chopHull dmin dmax dps - where - dps = zipWith mkP2 [0, 1/3, 2/3, 1] ds - ds = p ^.. each . to d - d = lineDistance q0 q3 - -- - (dmin,dmax) = fatLine q + where + points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0 .. n]] ds + n = length ds - 1 + +chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n) +chopCubics p q@(FCubic q0 _ _ q3) = + chopHull dmin dmax dps + where + dps = zipWith mkP2 [0, 1 / 3, 2 / 3, 1] ds + ds = p ^.. each . to d + d = lineDistance q0 q3 + -- + (dmin, dmax) = fatLine q chopCubics _ _ = Nothing -- Reduce the interval which the intersection is known to lie in using the fat @@ -266,43 +272,42 @@ chopCubics _ _ = Nothing -- the thin line of the other chopHull :: OrderedField n => n -> n -> [P2 n] -> Maybe (n, n) chopHull dmin dmax dps = do - tL <- testBelow upper $ testBetween (head upper) $ testAbove lower + tL <- testBelow upper $ testBetween (head upper) $ testAbove lower tR <- testBelow (reverse upper) $ testBetween (last upper) $ testAbove (reverse lower) Just (tL, tR) - where - (upper, lower) = sortedConvexHull dps - - testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue - | y1 >= dmin = continue - | y1 > y2 = Nothing - | y2 < dmin = testBelow (p2:ps) continue - | otherwise = Just $ intersectPt dmin p1 p2 - testBelow _ _ = Nothing - - testBetween (P (V2 x y)) continue - | y <= dmax = Just x - | otherwise = continue - - testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) - | y1 < y2 = Nothing - | y2 > dmax = testAbove (p2:ps) - | y2 - y1 == 0 = Nothing -- Check this condition to prevent - -- division by zero in `intersectPt`. - | otherwise = Just $ intersectPt dmax p1 p2 - testAbove _ = Nothing - - -- find the x value where the line through the two points - -- intersect the line y=d. Note that `y2 - y1 != 0` due - -- to checks above. - intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = - x1 + (d - y1) * (x2 - x1) / (y2 - y1) - - + where + (upper, lower) = sortedConvexHull dps + + testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue + | y1 >= dmin = continue + | y1 > y2 = Nothing + | y2 < dmin = testBelow (p2 : ps) continue + | otherwise = Just $ intersectPt dmin p1 p2 + testBelow _ _ = Nothing + + testBetween (P (V2 x y)) continue + | y <= dmax = Just x + | otherwise = continue + + testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) + | y1 < y2 = Nothing + | y2 > dmax = testAbove (p2 : ps) + | y2 - y1 == 0 = Nothing -- Check this condition to prevent + -- division by zero in `intersectPt`. + | otherwise = Just $ intersectPt dmax p1 p2 + testAbove _ = Nothing + + -- find the x value where the line through the two points + -- intersect the line y=d. Note that `y2 - y1 != 0` due + -- to checks above. + intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = + x1 + (d - y1) * (x2 - x1) / (y2 - y1) bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n) bezierToBernstein seg = - (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) - where coeffs = toListOf each seg + (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) + where + coeffs = toListOf each seg ------------------------------------------------------------------------ -- Lines @@ -315,41 +320,41 @@ bezierToBernstein seg = -- @d@ as it may not be needed in all cases and @d@ may be zero. lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n, n) lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c, d) - where - c = -(x1*a + y1*b) - a = y1 - y2 - b = x2 - x1 - d = a*a + b*b + where + c = -(x1 * a + y1 * b) + a = y1 - y2 + b = x2 - x1 + d = a * a + b * b -- | Return the distance from a point to the line. lineDistance :: (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n lineDistance p1 p2 p3@(P (V2 x y)) - -- I have included the check that d' <= 0 in case - -- there exists some d > 0 where sqrt d == 0. I don't - -- think this can happen as sqrt is at least recommended - -- to be within one value of correct for sqrt and near - -- zero values get bigger. - | d <= 0 || d' <= 0 = norm (p1 .-. p3) - | otherwise = (a*x + b*y + c) / d' - where - (a, b, c, d) = lineEquation p1 p2 - d' = sqrt d + -- I have included the check that d' <= 0 in case + -- there exists some d > 0 where sqrt d == 0. I don't + -- think this can happen as sqrt is at least recommended + -- to be within one value of correct for sqrt and near + -- zero values get bigger. + | d <= 0 || d' <= 0 = norm (p1 .-. p3) + | otherwise = (a * x + b * y + c) / d' + where + (a, b, c, d) = lineEquation p1 p2 + d' = sqrt d -- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool -- clockwise a b = a `cross2` b <= 0 avg :: Fractional n => n -> n -> n -avg a b = (a + b)/2 - -lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n,n) -lineLine (viewLoc -> (p,r)) (viewLoc -> (q,s)) - | x1 == 0 && x2 /= 0 = Nothing -- parallel - | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear - where - x1 = r × s - x2 = v × r - x3 = v × s - v = q .-. p +avg a b = (a + b) / 2 + +lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n, n) +lineLine (viewLoc -> (p, r)) (viewLoc -> (q, s)) + | x1 == 0 && x2 /= 0 = Nothing -- parallel + | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear + where + x1 = r × s + x2 = v × r + x3 = v × s + v = q .-. p (×) :: Num n => V2 n -> V2 n -> n (×) = cross2 @@ -358,12 +363,11 @@ mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n) mkLine p0 p1 = (p1 .-. p0) `at` p0 segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n) -segLine (FLinear p0 p1) = mkLine p0 p1 +segLine (FLinear p0 p1) = mkLine p0 p1 segLine (FCubic p0 _ _ p3) = mkLine p0 p3 -- This function uses `defEps`, but is used in functions -- above that take an epsilon parameter. It would be nice -- to clearify the meaning of each of these epsilons. inRange :: (Fractional n, Ord n) => n -> Bool -inRange x = x < (1+defEps) && x > (-defEps) - +inRange x = x < (1 + defEps) && x > (-defEps)