{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Segment -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A /segment/ is a translation-invariant, atomic path. Currently, -- there are two types: linear (/i.e./ just a straight line to the -- endpoint) and cubic Bézier curves (/i.e./ a curve to an endpoint -- with two control points). This module contains tools for creating -- and manipulating segments, as well as a definition of segments with -- a fixed location (useful for backend implementors). -- -- Generally speaking, casual users of diagrams should not need this -- module; the higher-level functionality provided by -- "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 ------------------------------------------------------------ -- Open/closed type tags --------------------------------- ------------------------------------------------------------ -- Eventually we should use DataKinds for this, but not until we drop -- support for GHC 7.4. -- | Type tag for open segments. data Open -- | Type tag for closed segments. data Closed ------------------------------------------------------------ -- Segment offsets --------------------------------------- ------------------------------------------------------------ -- | The /offset/ of a segment is the vector from its starting point -- to its end. The offset for an /open/ segment is determined by -- the context, /i.e./ its endpoint is not fixed. The offset for a -- /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 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) instance Functor v => Functor (Offset c v) where 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 {-# 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 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 t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------ -- Constructing segments --------------------------------- ------------------------------------------------------------ -- | The atomic constituents of the concrete representation currently -- used for trails are /segments/, currently limited to -- single straight lines or cubic Bézier curves. Segments are -- /translationally invariant/, that is, they have no particular -- \"location\" and are unaffected by translations. They are, -- 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. 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 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 {-# INLINE each #-} -- | Reverse the direction of a segment. instance (Additive v, Num n) => Reversing (Segment Closed v n) where reversing = reverseSegment -- | Map over the vectors of each segment. mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' mapSegmentVectors = over each -- Note, can't yet have Haddock comments on GADT constructors; see -- http://trac.haskell.org/haddock/ticket/43. For now we don't need -- Segment to be a GADT but we might in the future. (?) type instance V (Segment c v n) = v type instance N (Segment c v n) = n instance Transformable (Segment c v n) where transform = mapSegmentVectors . apply instance Renderable (Segment c v n) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. straight :: v n -> Segment Closed v n straight = Linear . OffsetClosed -- Note, if we didn't have a Linear constructor we could also create -- linear segments with @Cubic (v ^/ 3) (2 *^ (v ^/ 3)) v@. Those -- would not be precisely the same, however, since we can actually -- observe how segments are parametrized. -- | @bezier3 c1 c2 x@ constructs a translationally invariant cubic -- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively -- given by @c1@, @c2@, and @x@. bezier3 :: v n -> v n -> v n -> Segment Closed v n bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) -- | @bézier3@ is the same as @bezier3@, but with more snobbery. bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 type instance Codomain (Segment Closed v n) = v -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of -- 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 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 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 (Cubic _ _ (OffsetClosed v)) = v -- | An open linear segment. This means the trail makes a straight line -- from the last segment the beginning to form a loop. openLinear :: Segment Open v n openLinear = Linear OffsetOpen -- | An open cubic segment. This means the trail makes a cubic bézier -- with control vectors @v1@ and @v2@ to form a loop. openCubic :: v n -> v n -> Segment Open v n openCubic v1 v2 = Cubic v1 v2 OffsetOpen ------------------------------------------------------------ -- Computing segment envelope ------------------------------ ------------------------------------------------------------ {- 3 (1-t)^2 t c1 + 3 (1-t) t^2 c2 + t^3 x2 Can we compute the projection of B(t) onto a given vector v? u.v = |u||v| cos th |proj_v u| = cos th * |u| = (u.v/|v|) so B_v(t) = (B(t).v/|v|) Then take the derivative of this wrt. t, get a quadratic, solve. B_v(t) = (1/|v|) * -- note this does not affect max/min, can solve for t first 3 (1-t)^2 t (c1.v) + 3 (1-t) t^2 (c2.v) + t^3 (x2.v) = t^3 ((3c1 - 3c2 + x2).v) + t^2 ((-6c1 + 3c2).v) + t (3c1.v) B_v'(t) = t^2 (3(3c1 - 3c2 + x2).v) + t (6(-2c1 + c2).v) + 3c1.v Set equal to zero, use quadratic formula. -} -- | 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 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)) ------------------------------------------------------------ -- Manipulating segments ------------------------------------------------------------ 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 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 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 (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) 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 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s arcLengthToParam m s@(Cubic {}) len | len `I.elem` I (-m/2) (m/2) = 0 | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) | len `I.elem` 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 ------------------------------------------------------------ -- | @FixedSegment@s are like 'Segment's except that they have -- absolute locations. @FixedSegment v@ is isomorphic to @Located -- (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) deriving 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 {-# INLINE each #-} -- | Reverses the control points. instance Reversing (FixedSegment v n) where 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 transform t = over each (papply t) instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where moveOriginTo o = over each (moveOriginTo o) instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) 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 instance (Metric v, OrderedField n) => HasArcLength (FixedSegment v n) where arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) -- | Create a 'FixedSegment' from a located 'Segment'. 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) -- | 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 (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -- | Use a 'FixedSegment' to make an 'Iso' between an -- a fixed segment and a located segment. fixedSegIso :: (Num n, Additive v) => Iso' (FixedSegment v n) (Located (Segment Closed v n)) fixedSegIso = iso fromFixedSeg mkFixedSeg 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 p21 = lerp t p12 p11 p22 = lerp t p13 p12 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 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 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 reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 ------------------------------------------------------------ -- Segment measures -------------------------------------- ------------------------------------------------------------ -- $segmeas -- Trails store a sequence of segments in a fingertree, which can -- automatically track various monoidal \"measures\" on segments. -- | A type to track the count of segments in a 'Trail'. newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) instance Wrapped SegCount where type Unwrapped SegCount = Sum Int _Wrapped' = iso (\(SegCount x) -> x) SegCount instance Rewrapped SegCount SegCount -- | A type to represent the total arc length of a chain of -- segments. The first component is a \"standard\" arc length, -- 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)) instance Wrapped (ArcLength n) where type Unwrapped (ArcLength n) = (Sum (Interval n), n -> Sum (Interval n)) _Wrapped' = iso (\(ArcLength x) -> x) ArcLength instance Rewrapped (ArcLength n) (ArcLength n') -- | Project out the cached arc length, stored together with error -- bounds. getArcLengthCached :: ArcLength n -> Interval n getArcLengthCached = getSum . fst . op ArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. getArcLengthFun :: ArcLength n -> n -> Interval n 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 eps al | I.width cached <= eps = cached | 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) -- | A type to represent the total cumulative offset of a chain of -- segments. newtype TotalOffset v n = TotalOffset (v n) instance Wrapped (TotalOffset v n) where type Unwrapped (TotalOffset v n) = v n _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset instance Rewrapped (TotalOffset v n) (TotalOffset v' n') 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 mappend = (<>) -- | A type to represent the offset and envelope of a chain of -- segments. They have to be paired into one data structure, since -- 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) , _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 (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 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) *: ()