Permalink
Fetching contributors…
Cannot retrieve contributors at this time
635 lines (509 sloc) 23.3 KB
{-# 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
import Data.Serialize (Serialize)
import qualified Data.Serialize as Serialize
------------------------------------------------------------
-- 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)
-- Imitates I.elem for intervals<0.8 and I.member for intervals>=0.8
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
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 `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
------------------------------------------------------------
-- | @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)
*: ()
------------------------------------------------------------
-- Serialize instances
------------------------------------------------------------
instance (Serialize (v n)) => Serialize (Segment Open v n) where
{-# INLINE put #-}
put segment = case segment of
Linear OffsetOpen -> Serialize.put True
Cubic v w OffsetOpen -> do
Serialize.put False
Serialize.put v
Serialize.put w
{-# INLINE get #-}
get = do
isLinear <- Serialize.get
case isLinear of
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
{-# INLINE put #-}
put segment = case segment of
Linear (OffsetClosed z) -> do
Serialize.put z
Serialize.put True
Cubic v w (OffsetClosed z) -> do
Serialize.put z
Serialize.put False
Serialize.put v
Serialize.put w
{-# INLINE get #-}
get = do
z <- Serialize.get
isLinear <- Serialize.get
case isLinear of
True -> return (Linear (OffsetClosed z))
False -> do
v <- Serialize.get
w <- Serialize.get
return (Cubic v w (OffsetClosed z))