{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- We have an orphan Transformable FingerTree instance here. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trail -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines /trails/, translationally invariant paths -- through space. Trails form a central part of the diagrams-lib API, -- so the documentation for this module merits careful study. -- -- Related modules include: -- -- * The 'TrailLike' class ("Diagrams.TrailLike") exposes a generic -- API for building a wide range of things out of trails. -- -- * 'Path's ("Diagrams.Path") are collections of 'Located' -- ("Diagrams.Located") trails. -- -- * Trails are composed of 'Segment's (see "Diagrams.Segment"), -- though most users should not need to work with segments directly. -- ----------------------------------------------------------------------------- module Diagrams.Trail ( -- * Type definitions -- ** Lines and loops Trail'(..) , glueLine , closeLine , cutLoop -- ** Generic trails , Trail(..) , wrapTrail, wrapLine, wrapLoop , onTrail, onLine , glueTrail, closeTrail, cutTrail -- * Constructing trails , emptyLine, emptyTrail , lineFromVertices, trailFromVertices , lineFromOffsets, trailFromOffsets , lineFromSegments, trailFromSegments -- * Eliminating trails , withTrail', withTrail, withLine , isLineEmpty, isTrailEmpty , isLine, isLoop , trailSegments, lineSegments, loopSegments , onLineSegments , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailVertices, lineVertices, loopVertices , fixTrail -- * Modifying trails , reverseTrail, reverseLocTrail , reverseLine, reverseLocLine , reverseLoop, reverseLocLoop -- * Internals -- $internals -- ** Type tags , Line, Loop -- ** Segment trees , SegTree(..), trailMeasure, numSegs, offset -- ** Extracting segments , GetSegment(..), getSegment ) where import Control.Arrow ((***)) import Control.Lens (AnIso', iso, view, op, Wrapped(..)) import Data.AffineSpace import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) import qualified Numeric.Interval as I import Diagrams.Core hiding ((|>)) import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -- $internals -- -- Most users of diagrams should not need to use anything in this -- section directly, but they are exported on the principle that we -- can't forsee what uses people might have for them. ------------------------------------------------------------ -- FingerTree instances ------------------------------------------------------------ type instance V (FingerTree m a) = V a instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) , FT.Measured m a, Transformable a ) => Transformable (FingerTree m a) where transform = FT.fmap' . transform ------------------------------------------------------------ -- Segment trees ----------------------------------------- ------------------------------------------------------------ -- | A @SegTree@ represents a sequence of closed segments, stored in a -- fingertree so we can easily recover various monoidal measures of -- the segments (number of segments, arc length, envelope...) and -- also easily slice and dice them according to the measures -- (/e.g./, split off the smallest number of segments from the -- beginning which have a combined arc length of at least 5). newtype SegTree v = SegTree (FingerTree (SegMeasure v) (Segment Closed v)) deriving (Eq, Ord, Show) instance Wrapped (FingerTree (SegMeasure v) (Segment Closed v)) (FingerTree (SegMeasure v) (Segment Closed v)) (SegTree v) (SegTree v) where wrapped = iso SegTree $ \(SegTree x) -> x type instance V (SegTree v) = v deriving instance (OrderedField (Scalar v), InnerSpace v) => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (SegTree v) where transform t = SegTree . transform t . op SegTree type instance Codomain (SegTree v) = v instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (SegTree v) where atParam t p = offset . fst $ splitAtParam t p instance Num (Scalar v) => DomainBounds (SegTree v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v), Num (Scalar v)) => EndValues (SegTree v) instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (SegTree v) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit seg :< t' -> case seg `splitAtParam` (p * tSegs) of (seg1, seg2) -> ( SegTree $ FT.singleton seg1 , SegTree $ seg2 <| t' ) | p >= 1 = case FT.viewr t of EmptyR -> emptySplit t' :> seg -> case seg `splitAtParam` (1 - (1 - p)*tSegs) of (seg1, seg2) -> ( SegTree $ t' |> seg1 , SegTree $ FT.singleton seg2 ) | otherwise = case FT.viewl after of EmptyL -> emptySplit seg :< after' -> case seg `splitAtParam` (snd . propFrac $ p * tSegs) of (seg1, seg2) -> ( SegTree $ before |> seg1 , SegTree $ seg2 <| after' ) where (before, after) = FT.split ((p * tSegs <) . numSegs) t tSegs = numSegs t emptySplit = (SegTree t, SegTree t) reverseDomain (SegTree t) = SegTree $ FT.reverse t' where t' = FT.fmap' reverseSegment t -- XXX seems like it should be possible to collapse some of the -- above cases into one? instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (SegTree v) where arcLengthBounded eps t -- Use the cached value if it is accurate enough; otherwise fall -- back to recomputing a more accurate value | I.width i <= eps = i | otherwise = fun (eps / numSegs t) where i = trailMeasure (I.singleton 0) (getArcLengthCached :: ArcLength v -> I.Interval (Scalar v)) t fun = trailMeasure (const 0) (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) t arcLengthToParam eps st@(SegTree t) l | l < 0 = case FT.viewl t of EmptyL -> 0 seg :< _ -> arcLengthToParam eps seg l / tSegs | l >= totalAL = case FT.viewr t of EmptyR -> 0 t' :> seg -> let p = arcLengthToParam (eps/2) seg (l - arcLength (eps/2) (SegTree t')) in (p - 1)/tSegs + 1 | otherwise = case FT.viewl after of EmptyL -> 0 seg :< _ -> let p = arcLengthToParam (eps/2) seg (l - arcLength (eps/2) (SegTree before)) in (numSegs before + p) / tSegs where totalAL = arcLength eps st tSegs = numSegs t before, after :: FingerTree (SegMeasure v) (Segment Closed v) (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval (Scalar v)))) t -- | Given a default result (to be used in the case of an empty -- trail), and a function to map a single measure to a result, -- extract the given measure for a trail and use it to compute a -- result. Put another way, lift a function on a single measure -- (along with a default value) to a function on an entire trail. trailMeasure :: ( InnerSpace v, OrderedField (Scalar v) , SegMeasure v :>: m, FT.Measured (SegMeasure v) t ) => a -> (m -> a) -> t -> a trailMeasure d f = option d f . get . FT.measure -- | Compute the number of segments of anything measured by -- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, -- @Trail@s...) numSegs :: ( Floating (Scalar v), Num c, Ord (Scalar v), InnerSpace v, FT.Measured (SegMeasure v) a ) => a -> c numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, FT.Measured (SegMeasure v) t ) => t -> v offset = trailMeasure zeroV (op TotalOffset . view oeOffset) ------------------------------------------------------------ -- Trails ------------------------------------------------ ------------------------------------------------------------ -- Eventually we should use DataKinds for this, but not until we drop -- support for GHC 7.4. -- | Type tag for trails with distinct endpoints. data Line -- | Type tag for \"loopy\" trails which return to their starting -- point. data Loop -------------------------------------------------- -- The Trail' type -- | Intuitively, a trail is a single, continuous path through space. -- However, a trail has no fixed starting point; it merely specifies -- /how/ to move through space, not /where/. For example, \"take -- three steps forward, then turn right twenty degrees and take two -- more steps\" is an intuitive analog of a trail; these -- instructions specify a path through space from any given starting -- location. To be precise, trails are /translation-invariant/; -- applying a translation to a trail has no effect. -- -- A @'Located' Trail@, on the other hand, is a trail paired with -- some concrete starting location (\"start at the big tree on the -- corner, then take three steps forward, ...\"). See the -- "Diagrams.Located" module for help working with 'Located' values. -- -- Formally, the semantics of a trail is a continuous (though not -- necessarily differentiable) function from the real interval [0,1] -- to vectors in some vector space. (In contrast, a 'Located' trail -- is a continuous function from [0,1] to /points/ in some /affine/ -- space.) -- -- There are two types of trails: -- -- * A \"line\" (think of the \"train\", \"subway\", or \"bus\" -- variety, rather than the \"straight\" variety...) is a trail -- with two distinct endpoints. Actually, a line can have the -- same start and end points, but it is still /drawn/ as if it had -- distinct endpoints: the two endpoints will have the appropriate -- end caps, and the trail will not be filled. Lines have a -- @Monoid@ instance where @mappend@ corresponds to concatenation, -- /i.e./ chaining one line after the other. -- -- * A \"loop\" is required to end in the same place it starts (that -- is, t(0) = t(1)). Loops are filled and are drawn as one -- continuous loop, with the appropriate join at the -- start/endpoint rather than end caps. Loops do not have a -- @Monoid@ instance. -- -- To convert between lines and loops, see 'glueLine', -- 'closeLine', and 'cutLoop'. -- -- To construct trails, see 'emptyTrail', 'trailFromSegments', -- 'trailFromVertices', 'trailFromOffsets', and friends. You can -- also get any type of trail from any function which returns a -- 'TrailLike' (/e.g./ functions in "Diagrams.TwoD.Shapes", and many -- others; see "Diagrams.TrailLike"). -- -- To extract information from trails, see 'withLine', 'isLoop', -- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. data Trail' l v where Line :: SegTree v -> Trail' Line v Loop :: SegTree v -> Segment Open v -> Trail' Loop v -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r withTrail' line _ t@(Line{}) = line t withTrail' _ loop t@(Loop{}) = loop t deriving instance Show v => Show (Trail' l v) deriving instance Eq v => Eq (Trail' l v) deriving instance Ord v => Ord (Trail' l v) type instance V (Trail' l v) = v type instance Codomain (Trail' l v) = v instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail' Line v) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) -- | The empty trail is constantly the zero vector. Trails are -- composed via concatenation. Note that only lines have a monoid -- instance (and not loops). instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail' Line v) where mempty = emptyLine mappend = (<>) instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Trail' l v) where transform tr (Line t ) = Line (transform tr t) transform tr (Loop t s) = Loop (transform tr t) (transform tr s) -- | The envelope for a trail is based at the trail's start. instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail' l v) where getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where ftEnv :: Trail' Line v -> Envelope v ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) $ t instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Renderable (Trail' o v) NullBackend where render _ _ = mempty instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (Trail' l v) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) (\l -> cutLoop l `atParam` mod1 p) t -- | Compute the remainder mod 1. Convenient for constructing loop -- parameterizations that wrap around. mod1 :: RealFrac a => a -> a mod1 p = p' where pf = snd . propFrac $ p p' | p >= 0 = pf | otherwise = 1 + pf -- Get rid of defaulting warnings propFrac :: RealFrac a => a -> (Int, a) propFrac = properFraction instance Num (Scalar v) => DomainBounds (Trail' l v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (Trail' l v) instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (Trail' Line v) where splitAtParam (Line t) p = (Line t1, Line t2) where (t1, t2) = splitAtParam t p reverseDomain = reverseLine instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail' l v) where arcLengthBounded eps = withTrail' (\(Line t) -> arcLengthBounded eps t) (arcLengthBounded eps . cutLoop) arcLengthToParam eps tr l = withTrail' (\(Line t) -> arcLengthToParam eps t l) (\lp -> arcLengthToParam eps (cutLoop lp) l) tr -------------------------------------------------- -- Extracting segments -- | A newtype wrapper around trails which exists solely for its -- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea -- is that if @tr@ is a trail, you can write, /e.g./ -- -- @ -- getSegment tr `atParam` 0.6 -- @ -- -- or -- -- @ -- atStart (getSegment tr) -- @ -- -- to get the segment at parameter 0.6 or the first segment in the -- trail, respectively. -- -- The codomain for 'GetSegment', /i.e./ the result you get from -- calling 'atParam', 'atStart', or 'atEnd', is @Maybe (v, Segment -- Closed v, AnIso' (Scalar v) (Scalar v))@. @Nothing@ results if -- the trail is empty; otherwise, you get: -- -- * the offset from the start of the trail to the beginning of the -- segment, -- -- * the segment itself, and -- -- * a reparameterization isomorphism: in the forward direction, it -- translates from parameters on the whole trail to a parameters -- on the segment. Note that for technical reasons you have to -- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism -- you can use. newtype GetSegment t = GetSegment t -- | Create a 'GetSegment' wrapper around a trail, after which you can -- call 'atParam', 'atStart', or 'atEnd' to extract a segment. getSegment :: t -> GetSegment t getSegment = GetSegment type instance V (GetSegment t) = V t type instance Codomain (GetSegment t) = Maybe ( V t -- offset from trail start to segment start , Segment Closed (V t) -- the segment , AnIso' (Scalar (V t)) (Scalar (V t)) -- reparameterization, trail <-> segment ) -- | Parameters less than 0 yield the first segment; parameters -- greater than 1 yield the last. A parameter exactly at the -- junction of two segments yields the second segment (/i.e./ the -- one with higher parameter values). instance (InnerSpace v, OrderedField (Scalar v)) => Parametric (GetSegment (Trail' Line v)) where atParam (GetSegment (Line (SegTree ft))) p | p <= 0 = case FT.viewl ft of EmptyL -> Nothing seg :< _ -> Just (zeroV, seg, reparam 0) | p >= 1 = case FT.viewr ft of EmptyR -> Nothing ft' :> seg -> Just (offset ft', seg, reparam (n-1)) | otherwise = let (before, after) = FT.split ((p*n <) . numSegs) $ ft in case FT.viewl after of EmptyL -> Nothing seg :< _ -> Just (offset before, seg, reparam (numSegs before)) where n = numSegs ft reparam k = iso (subtract k . (*n)) ((/n) . (+ k)) -- | The parameterization for loops wraps around, /i.e./ parameters -- are first reduced \"mod 1\". instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (GetSegment (Trail' Loop v)) where atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (GetSegment (Trail v)) where atParam (GetSegment t) p = withTrail ((`atParam` p) . GetSegment) ((`atParam` p) . GetSegment) t instance DomainBounds t => DomainBounds (GetSegment t) where domainLower (GetSegment t) = domainLower t domainUpper (GetSegment t) = domainUpper t instance (InnerSpace v, OrderedField (Scalar v)) => EndValues (GetSegment (Trail' Line v)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of EmptyL -> Nothing seg :< _ -> let n = numSegs ft in Just (zeroV, seg, iso (*n) (/n)) atEnd (GetSegment (Line (SegTree ft))) = case FT.viewr ft of EmptyR -> Nothing ft' :> seg -> let n = numSegs ft in Just (offset ft', seg, iso (subtract (n-1) . (*n)) ((/n) . (+ (n-1))) ) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (GetSegment (Trail' Loop v)) where atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (GetSegment (Trail v)) where atStart (GetSegment t) = withTrail (\l -> atStart (GetSegment l)) (\l -> atStart (GetSegment l)) t atEnd (GetSegment t) = withTrail (\l -> atEnd (GetSegment l)) (\l -> atEnd (GetSegment l)) t -------------------------------------------------- -- The Trail type -- | @Trail@ is a wrapper around @Trail'@, hiding whether the -- underlying @Trail'@ is a line or loop (though which it is can be -- recovered; see /e.g./ 'withTrail'). data Trail v where Trail :: Trail' l v -> Trail v deriving instance Show v => Show (Trail v) instance Eq v => Eq (Trail v) where t1 == t2 = withTrail (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) t1 instance Ord v => Ord (Trail v) where compare t1 t2 = withTrail (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) (\lp1 -> withTrail (const GT) (\lp2 -> compare lp1 lp2) t2) t1 -- | Two @Trail@s are combined by first ensuring they are both lines -- (using 'cutTrail' on loops) and then concatenating them. The -- result, in general, is a line. However, there is a special case -- for the empty line, which acts as the identity (so combining the -- empty line with a loop results in a loop). instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail v) where (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 t1 <> t2 = flip withLine t1 $ \l1 -> flip withLine t2 $ \l2 -> wrapLine (l1 <> l2) -- | @Trail@s are combined as described in the 'Semigroup' instance; -- the empty line is the identity element, with special cases so -- that combining the empty line with a loop results in the -- unchanged loop (in all other cases loops will be cut). Note that -- this does, in fact, satisfy the monoid laws, though it is a bit -- strange. Mostly it is provided for convenience, so one can work -- directly with @Trail@s instead of working with @Trail' Line@s and -- then wrapping. instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail v) where mempty = wrapLine emptyLine mappend = (<>) type instance V (Trail v) = v type instance Codomain (Trail v) = v instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Trail v) where transform t = onTrail (transform t) (transform t) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where getEnvelope = withTrail getEnvelope getEnvelope instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (Trail v) where atParam t p = withTrail (`atParam` p) (`atParam` p) t instance Num (Scalar v) => DomainBounds (Trail v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (Trail v) -- | Note that there is no @Sectionable@ instance for @Trail' Loop@, -- because it does not make sense (splitting a loop at a parameter -- results in a single line, not two loops). However, it's -- convenient to have a @Sectionable@ instance for @Trail@; if the -- @Trail@ contains a loop the loop will first be cut and then -- @splitAtParam@ called on the resulting line. This is -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (Trail v) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t reverseDomain = reverseTrail instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail v) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr -------------------------------------------------- -- Constructors and eliminators for Trail -- | A generic eliminator for 'Trail', taking functions specifying -- what to do in the case of a line or a loop. withTrail :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail v -> r withTrail line loop (Trail t) = withTrail' line loop t -- | Modify a @Trail@, specifying two separate transformations for the -- cases of a line or a loop. onTrail :: (Trail' Line v -> Trail' l1 v) -> (Trail' Loop v -> Trail' l2 v) -> (Trail v -> Trail v) onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) -- | An eliminator for @Trail@ based on eliminating lines: if the -- trail is a line, the given function is applied; if it is a loop, it -- is first converted to a line with 'cutLoop'. That is, -- -- @ -- withLine f === 'withTrail' f (f . 'cutLoop') -- @ withLine :: (InnerSpace v, OrderedField (Scalar v)) => (Trail' Line v -> r) -> Trail v -> r withLine f = withTrail f (f . cutLoop) -- | Modify a @Trail@ by specifying a transformation on lines. If the -- trail is a line, the transformation will be applied directly. If -- it is a loop, it will first be cut using 'cutLoop', the -- transformation applied, and then glued back into a loop with -- 'glueLine'. That is, -- -- @ -- onLine f === onTrail f (glueLine . f . cutLoop) -- @ -- -- Note that there is no corresponding @onLoop@ function, because -- there is no nice way in general to convert a line into a loop, -- operate on it, and then convert back. onLine :: (InnerSpace v, OrderedField (Scalar v)) => (Trail' Line v -> Trail' Line v) -> Trail v -> Trail v onLine f = onTrail f (glueLine . f . cutLoop) -- | Convert a 'Trail'' into a 'Trail', hiding the type-level -- distinction between lines and loops. wrapTrail :: Trail' l v -> Trail v wrapTrail = Trail -- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. wrapLine :: Trail' Line v -> Trail v wrapLine = wrapTrail -- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. wrapLoop :: Trail' Loop v -> Trail v wrapLoop = wrapTrail ------------------------------------------------------------ -- Constructing trails ----------------------------------- ------------------------------------------------------------ -- | The empty line, which is the identity for concatenation of lines. emptyLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v emptyLine = Line mempty -- | A wrapped variant of 'emptyLine'. emptyTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v emptyTrail = wrapLine emptyLine -- | Construct a line from a list of closed segments. lineFromSegments :: (InnerSpace v, OrderedField (Scalar v)) => [Segment Closed v] -> Trail' Line v lineFromSegments = Line . SegTree . FT.fromList -- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for -- conveniently constructing a @Trail@ instead of a @Trail'@. trailFromSegments :: (InnerSpace v, OrderedField (Scalar v)) => [Segment Closed v] -> Trail v trailFromSegments = wrapTrail . lineFromSegments -- | Construct a line containing only linear segments from a list of -- vectors, where each vector represents the offset from one vertex -- to the next. See also 'fromOffsets'. -- -- <<diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg#diagram=lineFromOffsetsEx&width=300>> -- -- > import Diagrams.Coordinates -- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] lineFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) => [v] -> Trail' Line v lineFromOffsets = lineFromSegments . map straight -- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. trailFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) => [v] -> Trail v trailFromOffsets = wrapTrail . lineFromOffsets -- | Construct a line containing only linear segments from a list of -- vertices. Note that only the relative offsets between the -- vertices matters; the information about their absolute position -- will be discarded. That is, for all vectors @v@, -- -- @ -- lineFromVertices === lineFromVertices . 'translate' v -- @ -- -- If you want to retain the position information, you should -- instead use the more general 'fromVertices' function to -- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' -- ('Trail' v)@. -- -- <<diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg#diagram=lineFromVerticesEx&width=300>> -- -- > import Diagrams.Coordinates -- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine -- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1] lineFromVertices :: (InnerSpace v, OrderedField (Scalar v)) => [Point v] -> Trail' Line v lineFromVertices [] = emptyLine lineFromVertices [_] = emptyLine lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps -- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. trailFromVertices :: (InnerSpace v, OrderedField (Scalar v)) => [Point v] -> Trail v trailFromVertices = wrapTrail . lineFromVertices ------------------------------------------------------------ -- Converting between lines and loops -------------------- ------------------------------------------------------------ -- | Make a line into a loop by \"gluing\" the endpoint to the -- starting point. In particular, the offset of the final segment -- is modified so that it ends at the starting point of the entire -- trail. Typically, you would first construct a line which you -- know happens to end where it starts, and then call 'glueLine' to -- turn it into a loop. -- -- <<diagrams/src_Diagrams_Trail_glueLineEx.svg#diagram=glueLineEx&width=500>> -- -- > glueLineEx = pad 1.1 . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] -- > -- > almostClosed :: Trail' Line R2 -- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)] -- -- @glueLine@ is left inverse to 'cutLoop', that is, -- -- @ -- glueLine . cutLoop === id -- @ glueLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Loop v glueLine (Line (SegTree t)) = case FT.viewr t of FT.EmptyR -> Loop mempty (Linear OffsetOpen) t' :> (Linear _) -> Loop (SegTree t') (Linear OffsetOpen) t' :> (Cubic c1 c2 _) -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) -- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. -- It performs 'glueLine' on lines and is the identity on loops. glueTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v glueTrail = onTrail glueLine id -- | Make a line into a loop by adding a new linear segment from the -- line's end to its start. -- -- @closeLine@ does not have any particularly nice theoretical -- properties, but can be useful /e.g./ when you want to make a -- closed polygon out of a list of points where the initial point is -- not repeated at the end. To use 'glueLine', one would first have -- to duplicate the initial vertex, like -- -- @ -- 'glueLine' . 'lineFromVertices' $ ps ++ [head ps] -- @ -- -- Using @closeLine@, however, one can simply -- -- @ -- closeLine . lineFromVertices $ ps -- @ -- -- <<diagrams/src_Diagrams_Trail_closeLineEx.svg#diagram=closeLineEx&width=500>> -- -- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] closeLine :: Trail' Line v -> Trail' Loop v closeLine (Line t) = Loop t (Linear OffsetOpen) -- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which -- performs 'closeLine' on lines and is the identity on loops. closeTrail :: Trail v -> Trail v closeTrail = onTrail closeLine id -- | Turn a loop into a line by \"cutting\" it at the common start/end -- point, resulting in a line which just happens to start and end at -- the same place. -- -- @cutLoop@ is right inverse to 'glueLine', that is, -- -- @ -- glueLine . cutLoop === id -- @ cutLoop :: forall v. (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> Trail' Line v cutLoop (Loop (SegTree t) c) = case (FT.null t, c) of (True, Linear OffsetOpen) -> emptyLine (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where offV :: v offV = negateV . trailMeasure zeroV (op TotalOffset .view oeOffset) $ t off = OffsetClosed offV -- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is -- the identity on lines and performs 'cutLoop' on loops. cutTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v cutTrail = onTrail id cutLoop ------------------------------------------------------------ -- Eliminating trails ------------------------------------ ------------------------------------------------------------ -- | Test whether a line is empty. isLineEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Bool isLineEmpty (Line (SegTree t)) = FT.null t -- | Test whether a trail is empty. Note that loops are never empty. isTrailEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Bool isTrailEmpty = withTrail isLineEmpty (const False) -- | Determine whether a trail is a line. isLine :: Trail v -> Bool isLine = not . isLoop -- | Determine whether a trail is a loop. isLoop :: Trail v -> Bool isLoop = withTrail (const False) (const True) -- | Extract the segments comprising a line. lineSegments :: Trail' Line v -> [Segment Closed v] lineSegments (Line (SegTree t)) = F.toList t -- | Modify a line by applying a function to its list of segments. onLineSegments :: (InnerSpace v, OrderedField (Scalar v)) => ([Segment Closed v] -> [Segment Closed v]) -> Trail' Line v -> Trail' Line v onLineSegments f = lineFromSegments . f . lineSegments -- | Extract the segments comprising a loop: a list of closed -- segments, and one final open segment. loopSegments :: Trail' Loop v -> ([Segment Closed v], Segment Open v) loopSegments (Loop (SegTree t) c) = (F.toList t, c) -- | Extract the segments of a trail. If the trail is a loop it will -- first have 'cutLoop' applied. trailSegments :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [Segment Closed v] trailSegments = withLine lineSegments -- | Extract the offsets of the segments of a trail. trailOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [v] trailOffsets = withLine lineOffsets -- | Compute the offset from the start of a trail to the end. Satisfies -- -- @ -- trailOffset === sumV . trailOffsets -- @ -- -- but is more efficient. -- -- <<diagrams/src_Diagrams_Trail_trailOffsetEx.svg#diagram=trailOffsetEx&width=300>> -- -- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 -- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] -- > # stroke # lc red # lw 0.05 trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v trailOffset = withLine lineOffset -- | Extract the offsets of the segments of a line. lineOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> [v] lineOffsets = map segOffset . lineSegments -- | Extract the offsets of the segments of a loop. loopOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> [v] loopOffsets = lineOffsets . cutLoop -- | Compute the offset from the start of a line to the end. (Note, -- there is no corresponding @loopOffset@ function because by -- definition it would be constantly zero.) lineOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v lineOffset (Line t) = trailMeasure zeroV (op TotalOffset . view oeOffset) t -- | Extract the vertices of a concretely located trail. Note that -- for loops, the starting vertex will /not/ be repeated at the end. -- If you want this behavior, you can use 'cutTrail' to make the -- loop into a line first, which happens to repeat the same vertex -- at the start and end, /e.g./ with @trailVertices . mapLoc -- cutTrail@. -- -- Note that it does not make sense to ask for the vertices of a -- 'Trail' by itself; if you want the vertices of a trail -- with the first vertex at, say, the origin, you can use -- @trailVertices . (\`at\` origin)@. trailVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [Point v] trailVertices (viewLoc -> (p,t)) = withTrail (lineVertices . (`at` p)) (loopVertices . (`at` p)) t -- | Extract the vertices of a concretely located line. See -- 'trailVertices' for more information. lineVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Line v) -> [Point v] lineVertices (viewLoc -> (p,t)) = segmentVertices p . lineSegments $ t -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailVertices' for -- more information. loopVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Loop v) -> [Point v] loopVertices (viewLoc -> (p,t)) = segmentVertices p . fst . loopSegments $ t segmentVertices :: AdditiveGroup v => Point v -> [Segment Closed v] -> [Point v] segmentVertices p = scanl (.+^) p . map segOffset -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] fixTrail t = zipWith ((mkFixedSeg .) . at) (trailSegments (unLoc t)) (trailVertices t) ------------------------------------------------------------ -- Modifying trails -------------------------------------- ------------------------------------------------------------ -- | Reverse a trail. Semantically, if a trail given by a function t -- from [0,1] to vectors, then the reverse of t is given by t'(s) = -- t(1-s). @reverseTrail@ is an involution, that is, -- -- @ -- reverseTrail . reverseTrail === id -- @ reverseTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v reverseTrail = onTrail reverseLine reverseLoop -- | Reverse a concretely located trail. The endpoint of the original -- trail becomes the starting point of the reversed trail, so the -- original and reversed trails comprise exactly the same set of -- points. @reverseLocTrail@ is an involution, /i.e./ -- -- @ -- reverseLocTrail . reverseLocTrail === id -- @ reverseLocTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Located (Trail v) reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) -- | Reverse a line. See 'reverseTrail'. reverseLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Line v reverseLine = onLineSegments (reverse . map reverseSegment) -- | Reverse a concretely located line. See 'reverseLocTrail'. reverseLocLine :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Line v) -> Located (Trail' Line v) reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) -- | Reverse a loop. See 'reverseTrail'. reverseLoop :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> Trail' Loop v reverseLoop = glueLine . reverseLine . cutLoop -- | Reverse a concretely located loop. See 'reverseLocTrail'. Note -- that this is guaranteed to preserve the location. reverseLocLoop :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Loop v) -> Located (Trail' Loop v) reverseLocLoop = mapLoc reverseLoop