{-# LANGUAGE ConstraintKinds #-}
{-# 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 :: forall a b. (a -> b) -> Offset c v a -> Offset c v b
fmap a -> b
_ Offset c v a
OffsetOpen       = forall (v :: * -> *) n. Offset Open v n
OffsetOpen
  fmap a -> b
f (OffsetClosed v a
v) = forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f v a
v)

instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where
  each :: Traversal (Offset c v n) (Offset c v' n') (v n) (v' n')
each v n -> f (v' n')
f (OffsetClosed v n
v) = forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v n -> f (v' n')
f v n
v
  each v n -> f (v' n')
_ Offset c v n
OffsetOpen       = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (v :: * -> *) n. Offset Open v n
OffsetOpen
  {-# INLINE each #-}

-- | Reverses the direction of closed offsets.
instance (Additive v, Num n) => Reversing (Offset c v n) where
  reversing :: Offset c v n -> Offset c v n
reversing (OffsetClosed v n
off) = forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
off
  reversing a :: Offset c v n
a@Offset c v n
OffsetOpen       = Offset c v n
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 :: Transformation (V (Offset c v n)) (N (Offset c v n))
-> Offset c v n -> Offset c v n
transform Transformation (V (Offset c v n)) (N (Offset c v n))
_ Offset c v n
OffsetOpen       = forall (v :: * -> *) n. Offset Open v n
OffsetOpen
  transform Transformation (V (Offset c v n)) (N (Offset c v n))
t (OffsetClosed v n
v) = forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed (forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation (V (Offset c v n)) (N (Offset c v n))
t v n
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 (forall a b. a -> Segment c v b -> Segment c v a
forall a b. (a -> b) -> Segment c v a -> Segment c v b
forall c (v :: * -> *) a b.
Functor v =>
a -> Segment c v b -> Segment c v a
forall c (v :: * -> *) a b.
Functor v =>
(a -> b) -> Segment c v a -> Segment c v b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Segment c v b -> Segment c v a
$c<$ :: forall c (v :: * -> *) a b.
Functor v =>
a -> Segment c v b -> Segment c v a
fmap :: forall a b. (a -> b) -> Segment c v a -> Segment c v b
$cfmap :: forall c (v :: * -> *) a b.
Functor v =>
(a -> b) -> Segment c v a -> Segment c v b
Functor, Segment c v n -> Segment c v n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c (v :: * -> *) n.
Eq (v n) =>
Segment c v n -> Segment c v n -> Bool
/= :: Segment c v n -> Segment c v n -> Bool
$c/= :: forall c (v :: * -> *) n.
Eq (v n) =>
Segment c v n -> Segment c v n -> Bool
== :: Segment c v n -> Segment c v n -> Bool
$c== :: forall c (v :: * -> *) n.
Eq (v n) =>
Segment c v n -> Segment c v n -> Bool
Eq, Segment c v n -> Segment c v n -> Bool
Segment c v n -> Segment c v n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {c} {v :: * -> *} {n}. Ord (v n) => Eq (Segment c v n)
forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Bool
forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Ordering
forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Segment c v n
min :: Segment c v n -> Segment c v n -> Segment c v n
$cmin :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Segment c v n
max :: Segment c v n -> Segment c v n -> Segment c v n
$cmax :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Segment c v n
>= :: Segment c v n -> Segment c v n -> Bool
$c>= :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Bool
> :: Segment c v n -> Segment c v n -> Bool
$c> :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Bool
<= :: Segment c v n -> Segment c v n -> Bool
$c<= :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Bool
< :: Segment c v n -> Segment c v n -> Bool
$c< :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Bool
compare :: Segment c v n -> Segment c v n -> Ordering
$ccompare :: forall c (v :: * -> *) n.
Ord (v n) =>
Segment c v n -> Segment c v n -> Ordering
Ord)

instance Show (v n) => Show (Segment c v n) where
  showsPrec :: Int -> Segment c v n -> ShowS
showsPrec Int
d Segment c v n
seg = case Segment c v n
seg of
    Linear (OffsetClosed v n
v)       -> Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"straight " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v
    Cubic v n
v1 v n
v2 (OffsetClosed v n
v3) -> Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"bézier3  " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v3
    Linear Offset c v n
OffsetOpen             -> String -> ShowS
showString String
"openLinear"
    Cubic v n
v1 v n
v2 Offset c v n
OffsetOpen        -> Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"openCubic " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 v n
v2


instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where
  each :: Traversal (Segment c v n) (Segment c v' n') (v n) (v' n')
each v n -> f (v' n')
f (Linear Offset c v n
offset)      = forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s t a b. Each s t a b => Traversal s t a b
each v n -> f (v' n')
f Offset c v n
offset
  each v n -> f (v' n')
f (Cubic v n
v1 v n
v2 Offset c v n
offset) = forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v n -> f (v' n')
f v n
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> v n -> f (v' n')
f v n
v2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s t a b. Each s t a b => Traversal s t a b
each v n -> f (v' n')
f Offset c v n
offset
  {-# INLINE each #-}

-- | Reverse the direction of a segment.
instance (Additive v, Num n) => Reversing (Segment Closed v n) where
  reversing :: Segment Closed v n -> Segment Closed v n
reversing = forall n (v :: * -> *).
(Num n, Additive v) =>
Segment Closed v n -> Segment Closed v n
reverseSegment

-- | Map over the vectors of each segment.
mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n'
mapSegmentVectors :: forall (v :: * -> *) n (v' :: * -> *) n' c.
(v n -> v' n') -> Segment c v n -> Segment c v' n'
mapSegmentVectors = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Each s t a b => Traversal s t a b
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 :: Transformation (V (Segment c v n)) (N (Segment c v n))
-> Segment c v n -> Segment c v n
transform = forall (v :: * -> *) n (v' :: * -> *) n' c.
(v n -> v' n') -> Segment c v n -> Segment c v' n'
mapSegmentVectors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply

instance Renderable (Segment c v n) NullBackend where
  render :: NullBackend
-> Segment c v n
-> Render NullBackend (V (Segment c v n)) (N (Segment c v n))
render NullBackend
_ Segment c v n
_ = forall a. Monoid a => a
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 :: forall (v :: * -> *) n. v n -> Segment Closed v n
straight = forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. v n -> Offset Closed v n
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 :: forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 v n
c1 v n
c2 v n
x = forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic v n
c1 v n
c2 (forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed v n
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 :: forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bézier3 = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
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 :: Segment Closed v n
-> N (Segment Closed v n)
-> Codomain (Segment Closed v n) (N (Segment Closed v n))
atParam (Linear (OffsetClosed v n
x)) N (Segment Closed v n)
t       = N (Segment Closed v n)
t forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
x
  atParam (Cubic v n
c1 v n
c2 (OffsetClosed v n
x2)) N (Segment Closed v n)
t =     (n
3 forall a. Num a => a -> a -> a
* n
t'forall a. Num a => a -> a -> a
*n
t'forall a. Num a => a -> a -> a
*N (Segment Closed v n)
t ) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c1
                                              forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (n
3 forall a. Num a => a -> a -> a
* n
t'forall a. Num a => a -> a -> a
*N (Segment Closed v n)
t forall a. Num a => a -> a -> a
*N (Segment Closed v n)
t ) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c2
                                              forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (    N (Segment Closed v n)
t forall a. Num a => a -> a -> a
*N (Segment Closed v n)
t forall a. Num a => a -> a -> a
*N (Segment Closed v n)
t ) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
x2
    where t' :: n
t' = n
1forall a. Num a => a -> a -> a
-N (Segment Closed v n)
t

instance Num n => DomainBounds (Segment Closed v n)

instance (Additive v, Num n) => EndValues (Segment Closed v n) where
  atStart :: Segment Closed v n
-> Codomain (Segment Closed v n) (N (Segment Closed v n))
atStart                            = forall a b. a -> b -> a
const forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  atEnd :: Segment Closed v n
-> Codomain (Segment Closed v n) (N (Segment Closed v n))
atEnd (Linear (OffsetClosed v n
v))    = v n
v
  atEnd (Cubic v n
_ v n
_ (OffsetClosed v n
v)) = v n
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 :: forall (v :: * -> *) n. Segment Closed v n -> v n
segOffset (Linear (OffsetClosed v n
v))    = v n
v
segOffset (Cubic v n
_ v n
_ (OffsetClosed v n
v)) = v n
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 :: forall (v :: * -> *) n. Segment Open v n
openLinear = forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear forall (v :: * -> *) n. Offset Open v n
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 :: forall (v :: * -> *) n. v n -> v n -> Segment Open v n
openCubic v n
v1 v n
v2 = forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic v n
v1 v n
v2 forall (v :: * -> *) n. Offset Open v n
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 :: Segment Closed v n
-> Envelope (V (Segment Closed v n)) (N (Segment Closed v n))
getEnvelope (s :: Segment Closed v n
s@(Linear {})) = forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope forall a b. (a -> b) -> a -> b
$ \V (Segment Closed v n) (N (Segment Closed v n))
v ->
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (\n
t -> (Segment Closed v n
s forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
t) forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V (Segment Closed v n) (N (Segment Closed v n))
v) [n
0,n
1]) forall a. Fractional a => a -> a -> a
/ forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V (Segment Closed v n) (N (Segment Closed v n))
v

  getEnvelope (s :: Segment Closed v n
s@(Cubic v n
c1 v n
c2 (OffsetClosed v n
x2))) = forall (v :: * -> *) n. (v n -> n) -> Envelope v n
mkEnvelope forall a b. (a -> b) -> a -> b
$ \V (Segment Closed v n) (N (Segment Closed v n))
v ->
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map (\n
t -> ((Segment Closed v n
s forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` n
t) forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V (Segment Closed v n) (N (Segment Closed v n))
v) forall a. Fractional a => a -> a -> a
/ forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance V (Segment Closed v n) (N (Segment Closed v n))
v) forall a b. (a -> b) -> a -> b
$
    [n
0,n
1] forall a. [a] -> [a] -> [a]
++
    forall a. (a -> Bool) -> [a] -> [a]
filter (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (forall a. Ord a => a -> a -> Bool
>n
0) (forall a. Ord a => a -> a -> Bool
<n
1))
      (forall d. (Floating d, Ord d) => d -> d -> d -> [d]
quadForm (n
3 forall a. Num a => a -> a -> a
* ((n
3 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c1 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ n
3 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ v n
x2) forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V (Segment Closed v n) (N (Segment Closed v n))
v))
                (n
6 forall a. Num a => a -> a -> a
* (((-n
2) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c1 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ v n
c2) forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V (Segment Closed v n) (N (Segment Closed v n))
v))
                ((n
3 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
c1) forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V (Segment Closed v n) (N (Segment Closed v n))
v))

------------------------------------------------------------
--  Manipulating segments
------------------------------------------------------------

instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where
  splitAtParam :: Segment Closed v n
-> N (Segment Closed v n)
-> (Segment Closed v n, Segment Closed v n)
splitAtParam (Linear (OffsetClosed v n
x1)) N (Segment Closed v n)
t = (Segment Closed v n
left, Segment Closed v n
right)
    where left :: Segment Closed v n
left  = forall (v :: * -> *) n. v n -> Segment Closed v n
straight v n
p
          right :: Segment Closed v n
right = forall (v :: * -> *) n. v n -> Segment Closed v n
straight (v n
x1 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
p)
          p :: v n
p = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
x1 forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  splitAtParam (Cubic v n
c1 v n
c2 (OffsetClosed v n
x2)) N (Segment Closed v n)
t = (Segment Closed v n
left, Segment Closed v n
right)
    where left :: Segment Closed v n
left  = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 v n
a v n
b v n
e
          right :: Segment Closed v n
right = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (v n
c forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
e) (v n
d forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
e) (v n
x2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
e)
          p :: v n
p = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
c2 v n
c1
          a :: v n
a = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
c1 forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
          b :: v n
b = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
p v n
a
          d :: v n
d = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
x2 v n
c2
          c :: v n
c = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
d v n
p
          e :: v n
e = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (Segment Closed v n)
t v n
c v n
b

  reverseDomain :: Segment Closed v n -> Segment Closed v n
reverseDomain = forall n (v :: * -> *).
(Num n, Additive v) =>
Segment Closed v n -> Segment Closed v n
reverseSegment

-- | Reverse the direction of a segment.
reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n
reverseSegment :: forall n (v :: * -> *).
(Num n, Additive v) =>
Segment Closed v n -> Segment Closed v n
reverseSegment (Linear (OffsetClosed v n
v))       = forall (v :: * -> *) n. v n -> Segment Closed v n
straight (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
v)
reverseSegment (Cubic v n
c1 v n
c2 (OffsetClosed v n
x2)) = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (v n
c2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
x2) (v n
c1 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
x2) (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
x2)

-- Imitates I.elem for intervals<0.8 and I.member for intervals>=0.8
member :: Ord a => a -> I.Interval a -> Bool
member :: forall a. Ord a => a -> Interval a -> Bool
member a
x (I.I a
a a
b) = a
x forall a. Ord a => a -> a -> Bool
>= a
a Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
<= a
b
{-# INLINE member #-}

instance (Metric v, OrderedField n)
      => HasArcLength (Segment Closed v n) where

  arcLengthBounded :: N (Segment Closed v n)
-> Segment Closed v n -> Interval (N (Segment Closed v n))
arcLengthBounded N (Segment Closed v n)
_ (Linear (OffsetClosed v n
x1)) = forall a. a -> Interval a
I.singleton forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm v n
x1
  arcLengthBounded N (Segment Closed v n)
m s :: Segment Closed v n
s@(Cubic v n
c1 v n
c2 (OffsetClosed v n
x2))
    | n
ub forall a. Num a => a -> a -> a
- n
lb forall a. Ord a => a -> a -> Bool
< N (Segment Closed v n)
m = forall a. a -> a -> Interval a
I n
lb n
ub
    | Bool
otherwise   = forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded (N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
2) Segment Closed v n
l forall a. Num a => a -> a -> a
+ forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded (N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
2) Segment Closed v n
r
   where (Segment Closed v n
l,Segment Closed v n
r) = Segment Closed v n
s forall p. Sectionable p => p -> N p -> (p, p)
`splitAtParam` n
0.5
         ub :: n
ub    = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm [v n
c1, v n
c2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
c1, v n
x2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ v n
c2])
         lb :: n
lb    = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm v n
x2

  arcLengthToParam :: N (Segment Closed v n)
-> Segment Closed v n
-> N (Segment Closed v n)
-> N (Segment Closed v n)
arcLengthToParam N (Segment Closed v n)
m Segment Closed v n
s N (Segment Closed v n)
_ | forall p. HasArcLength p => N p -> p -> N p
arcLength N (Segment Closed v n)
m Segment Closed v n
s forall a. Eq a => a -> a -> Bool
== n
0 = n
0.5
  arcLengthToParam N (Segment Closed v n)
m s :: Segment Closed v n
s@(Linear {}) N (Segment Closed v n)
len = N (Segment Closed v n)
len forall a. Fractional a => a -> a -> a
/ forall p. HasArcLength p => N p -> p -> N p
arcLength N (Segment Closed v n)
m Segment Closed v n
s
  arcLengthToParam N (Segment Closed v n)
m s :: Segment Closed v n
s@(Cubic {})  N (Segment Closed v n)
len
    | N (Segment Closed v n)
len forall a. Ord a => a -> Interval a -> Bool
`member` forall a. a -> a -> Interval a
I (-N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
2) (N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
2) = n
0
    | N (Segment Closed v n)
len forall a. Ord a => a -> a -> Bool
< n
0              = - forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam N (Segment Closed v n)
m (forall a b. (a, b) -> a
fst (forall p. Sectionable p => p -> N p -> (p, p)
splitAtParam Segment Closed v n
s (-n
1))) (-N (Segment Closed v n)
len)
    | N (Segment Closed v n)
len forall a. Ord a => a -> Interval a -> Bool
`member` Interval (N (Segment Closed v n))
slen    = n
1
    | N (Segment Closed v n)
len forall a. Ord a => a -> a -> Bool
> forall a. Interval a -> a
I.sup Interval (N (Segment Closed v n))
slen     = n
2 forall a. Num a => a -> a -> a
* forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam N (Segment Closed v n)
m (forall a b. (a, b) -> a
fst (forall p. Sectionable p => p -> N p -> (p, p)
splitAtParam Segment Closed v n
s n
2)) N (Segment Closed v n)
len
    | N (Segment Closed v n)
len forall a. Ord a => a -> a -> Bool
< forall a. Interval a -> a
I.sup Interval (N (Segment Closed v n))
llen     = (forall a. Num a => a -> a -> a
*n
0.5) forall a b. (a -> b) -> a -> b
$ forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam N (Segment Closed v n)
m Segment Closed v n
l N (Segment Closed v n)
len
    | Bool
otherwise            = (forall a. Num a => a -> a -> a
+n
0.5) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*n
0.5)
                           forall a b. (a -> b) -> a -> b
$ forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam (n
9forall a. Num a => a -> a -> a
*N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
10) Segment Closed v n
r (N (Segment Closed v n)
len forall a. Num a => a -> a -> a
- forall a. Fractional a => Interval a -> a
I.midpoint Interval (N (Segment Closed v n))
llen)
    where (Segment Closed v n
l,Segment Closed v n
r) = Segment Closed v n
s forall p. Sectionable p => p -> N p -> (p, p)
`splitAtParam` n
0.5
          llen :: Interval (N (Segment Closed v n))
llen  = forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded (N (Segment Closed v n)
mforall a. Fractional a => a -> a -> a
/n
10) Segment Closed v n
l
          slen :: Interval (N (Segment Closed v n))
slen  = forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded N (Segment Closed v n)
m Segment Closed v n
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 (FixedSegment v n -> FixedSegment v n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *) n.
Eq (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
/= :: FixedSegment v n -> FixedSegment v n -> Bool
$c/= :: forall (v :: * -> *) n.
Eq (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
== :: FixedSegment v n -> FixedSegment v n -> Bool
$c== :: forall (v :: * -> *) n.
Eq (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
Eq, FixedSegment v n -> FixedSegment v n -> Bool
FixedSegment v n -> FixedSegment v n -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {v :: * -> *} {n}. Ord (v n) => Eq (FixedSegment v n)
forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Ordering
forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> FixedSegment v n
min :: FixedSegment v n -> FixedSegment v n -> FixedSegment v n
$cmin :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> FixedSegment v n
max :: FixedSegment v n -> FixedSegment v n -> FixedSegment v n
$cmax :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> FixedSegment v n
>= :: FixedSegment v n -> FixedSegment v n -> Bool
$c>= :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
> :: FixedSegment v n -> FixedSegment v n -> Bool
$c> :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
<= :: FixedSegment v n -> FixedSegment v n -> Bool
$c<= :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
< :: FixedSegment v n -> FixedSegment v n -> Bool
$c< :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Bool
compare :: FixedSegment v n -> FixedSegment v n -> Ordering
$ccompare :: forall (v :: * -> *) n.
Ord (v n) =>
FixedSegment v n -> FixedSegment v n -> Ordering
Ord, Int -> FixedSegment v n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: * -> *) n.
Show (v n) =>
Int -> FixedSegment v n -> ShowS
forall (v :: * -> *) n. Show (v n) => [FixedSegment v n] -> ShowS
forall (v :: * -> *) n. Show (v n) => FixedSegment v n -> String
showList :: [FixedSegment v n] -> ShowS
$cshowList :: forall (v :: * -> *) n. Show (v n) => [FixedSegment v n] -> ShowS
show :: FixedSegment v n -> String
$cshow :: forall (v :: * -> *) n. Show (v n) => FixedSegment v n -> String
showsPrec :: Int -> FixedSegment v n -> ShowS
$cshowsPrec :: forall (v :: * -> *) n.
Show (v n) =>
Int -> FixedSegment v n -> ShowS
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 :: Traversal
  (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n')
each Point v n -> f (Point v' n')
f (FLinear Point v n
p0 Point v n
p1)      = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point v n -> f (Point v' n')
f Point v n
p0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point v n -> f (Point v' n')
f Point v n
p1
  each Point v n -> f (Point v' n')
f (FCubic Point v n
p0 Point v n
p1 Point v n
p2 Point v n
p3) = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point v n -> f (Point v' n')
f Point v n
p0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point v n -> f (Point v' n')
f Point v n
p1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point v n -> f (Point v' n')
f Point v n
p2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point v n -> f (Point v' n')
f Point v n
p3
  {-# INLINE each #-}

-- | Reverses the control points.
instance Reversing (FixedSegment v n) where
  reversing :: FixedSegment v n -> FixedSegment v n
reversing (FLinear Point v n
p0 Point v n
p1)      = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear Point v n
p1 Point v n
p0
  reversing (FCubic Point v n
p0 Point v n
p1 Point v n
p2 Point v n
p3) = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic Point v n
p3 Point v n
p2 Point v n
p1 Point v n
p0

instance (Additive v, Num n) => Transformable (FixedSegment v n) where
  transform :: Transformation (V (FixedSegment v n)) (N (FixedSegment v n))
-> FixedSegment v n -> FixedSegment v n
transform Transformation (V (FixedSegment v n)) (N (FixedSegment v n))
t = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Each s t a b => Traversal s t a b
each (forall (v :: * -> *) n.
(Additive v, Num n) =>
Transformation v n -> Point v n -> Point v n
papply Transformation (V (FixedSegment v n)) (N (FixedSegment v n))
t)

instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where
  moveOriginTo :: Point (V (FixedSegment v n)) (N (FixedSegment v n))
-> FixedSegment v n -> FixedSegment v n
moveOriginTo Point (V (FixedSegment v n)) (N (FixedSegment v n))
o = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Each s t a b => Traversal s t a b
each (forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (FixedSegment v n)) (N (FixedSegment v n))
o)

instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where
  getEnvelope :: FixedSegment v n
-> Envelope (V (FixedSegment v n)) (N (FixedSegment v n))
getEnvelope FixedSegment v n
f = forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo Point (V (Segment Closed v n)) (N (Segment Closed v n))
p (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Segment Closed v n
s)
    where (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p, Segment Closed v n
s) = forall a. Located a -> (Point (V a) (N a), a)
viewLoc forall a b. (a -> b) -> a -> b
$ forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg FixedSegment v n
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 :: N (FixedSegment v n)
-> FixedSegment v n -> Interval (N (FixedSegment v n))
arcLengthBounded N (FixedSegment v n)
m FixedSegment v n
s = forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded N (FixedSegment v n)
m (forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg FixedSegment v n
s)
  arcLengthToParam :: N (FixedSegment v n)
-> FixedSegment v n -> N (FixedSegment v n) -> N (FixedSegment v n)
arcLengthToParam N (FixedSegment v n)
m FixedSegment v n
s = forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam N (FixedSegment v n)
m (forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg FixedSegment v n
s)

-- | Create a 'FixedSegment' from a located 'Segment'.
mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n
mkFixedSeg :: forall n (v :: * -> *).
(Num n, Additive v) =>
Located (Segment Closed v n) -> FixedSegment v n
mkFixedSeg Located (Segment Closed v n)
ls =
  case forall a. Located a -> (Point (V a) (N a), a)
viewLoc Located (Segment Closed v n)
ls of
    (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p, Linear (OffsetClosed v n
v))       -> forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear Point (V (Segment Closed v n)) (N (Segment Closed v n))
p (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ v n
v)
    (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p, Cubic v n
c1 v n
c2 (OffsetClosed v n
x2)) -> forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic  Point (V (Segment Closed v n)) (N (Segment Closed v n))
p (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ v n
c1) (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ v n
c2) (Point (V (Segment Closed v n)) (N (Segment Closed v n))
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ v n
x2)

-- | Convert a 'FixedSegment' back into a located 'Segment'.
fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg :: forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg (FLinear Point v n
p1 Point v n
p2)      = forall (v :: * -> *) n. v n -> Segment Closed v n
straight (Point v n
p2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
p1) forall a. a -> Point (V a) (N a) -> Located a
`at` Point v n
p1
fromFixedSeg (FCubic Point v n
x1 Point v n
c1 Point v n
c2 Point v n
x2) = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (Point v n
c1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
x1) (Point v n
c2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
x1) (Point v n
x2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
x1) forall a. a -> Point (V a) (N a) -> Located a
`at` Point v n
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 :: forall n (v :: * -> *).
(Num n, Additive v) =>
Iso' (FixedSegment v n) (Located (Segment Closed v n))
fixedSegIso = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg forall n (v :: * -> *).
(Num n, Additive v) =>
Located (Segment Closed v n) -> FixedSegment v n
mkFixedSeg

type instance Codomain (FixedSegment v n) = Point v

instance (Additive v, Num n) => Parametric (FixedSegment v n) where
  atParam :: FixedSegment v n
-> N (FixedSegment v n)
-> Codomain (FixedSegment v n) (N (FixedSegment v n))
atParam (FLinear Point v n
p1 Point v n
p2) N (FixedSegment v n)
t = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p2 Point v n
p1
  atParam (FCubic Point v n
x1 Point v n
c1 Point v n
c2 Point v n
x2) N (FixedSegment v n)
t = Point v n
p3
    where p11 :: Point v n
p11 = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
c1 Point v n
x1
          p12 :: Point v n
p12 = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
c2 Point v n
c1
          p13 :: Point v n
p13 = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
x2 Point v n
c2

          p21 :: Point v n
p21 = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p12 Point v n
p11
          p22 :: Point v n
p22 = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p13 Point v n
p12

          p3 :: Point v n
p3  = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p22 Point v n
p21

instance Num n => DomainBounds (FixedSegment v n)

instance (Additive v, Num n) => EndValues (FixedSegment v n) where
  atStart :: FixedSegment v n
-> Codomain (FixedSegment v n) (N (FixedSegment v n))
atStart (FLinear Point v n
p0 Point v n
_)     = Point v n
p0
  atStart (FCubic  Point v n
p0 Point v n
_ Point v n
_ Point v n
_) = Point v n
p0
  atEnd :: FixedSegment v n
-> Codomain (FixedSegment v n) (N (FixedSegment v n))
atEnd   (FLinear Point v n
_ Point v n
p1)     = Point v n
p1
  atEnd   (FCubic Point v n
_ Point v n
_ Point v n
_ Point v n
p1 ) = Point v n
p1

instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where
  splitAtParam :: FixedSegment v n
-> N (FixedSegment v n) -> (FixedSegment v n, FixedSegment v n)
splitAtParam (FLinear Point v n
p0 Point v n
p1) N (FixedSegment v n)
t = (FixedSegment v n
left, FixedSegment v n
right)
    where left :: FixedSegment v n
left  = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear Point v n
p0 Point v n
p
          right :: FixedSegment v n
right = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear Point v n
p  Point v n
p1
          p :: Point v n
p = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p1 Point v n
p0
  splitAtParam (FCubic Point v n
p0 Point v n
c1 Point v n
c2 Point v n
p1) N (FixedSegment v n)
t = (FixedSegment v n
left, FixedSegment v n
right)
    where left :: FixedSegment v n
left  = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic Point v n
p0 Point v n
a Point v n
b Point v n
cut
          right :: FixedSegment v n
right = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic Point v n
cut Point v n
c Point v n
d Point v n
p1
          -- first round
          a :: Point v n
a   = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
c1 Point v n
p0
          p :: Point v n
p   = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
c2 Point v n
c1
          d :: Point v n
d   = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p1 Point v n
c2
          -- second round
          b :: Point v n
b   = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
p Point v n
a
          c :: Point v n
c   = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
d Point v n
p
          -- final round
          cut :: Point v n
cut = forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp N (FixedSegment v n)
t Point v n
c Point v n
b

  reverseDomain :: FixedSegment v n -> FixedSegment v n
reverseDomain (FLinear Point v n
p0 Point v n
p1) = forall (v :: * -> *) n. Point v n -> Point v n -> FixedSegment v n
FLinear Point v n
p1 Point v n
p0
  reverseDomain (FCubic Point v n
p0 Point v n
c1 Point v n
c2 Point v n
p1) = forall (v :: * -> *) n.
Point v n
-> Point v n -> Point v n -> Point v n -> FixedSegment v n
FCubic Point v n
p1 Point v n
c2 Point v n
c1 Point v n
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 (NonEmpty SegCount -> SegCount
SegCount -> SegCount -> SegCount
forall b. Integral b => b -> SegCount -> SegCount
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> SegCount -> SegCount
$cstimes :: forall b. Integral b => b -> SegCount -> SegCount
sconcat :: NonEmpty SegCount -> SegCount
$csconcat :: NonEmpty SegCount -> SegCount
<> :: SegCount -> SegCount -> SegCount
$c<> :: SegCount -> SegCount -> SegCount
Semigroup, Semigroup SegCount
SegCount
[SegCount] -> SegCount
SegCount -> SegCount -> SegCount
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [SegCount] -> SegCount
$cmconcat :: [SegCount] -> SegCount
mappend :: SegCount -> SegCount -> SegCount
$cmappend :: SegCount -> SegCount -> SegCount
mempty :: SegCount
$cmempty :: SegCount
Monoid)

instance Wrapped SegCount where
  type Unwrapped SegCount = Sum Int
  _Wrapped' :: Iso' SegCount (Unwrapped SegCount)
_Wrapped' = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(SegCount Sum Int
x) -> Sum Int
x) Sum Int -> SegCount
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 n) (Unwrapped (ArcLength n))
_Wrapped' = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(ArcLength (Sum (Interval n), n -> Sum (Interval n))
x) -> (Sum (Interval n), n -> Sum (Interval n))
x) forall n. (Sum (Interval n), n -> Sum (Interval n)) -> ArcLength n
ArcLength

instance Rewrapped (ArcLength n) (ArcLength n')

-- | Project out the cached arc length, stored together with error
--   bounds.
getArcLengthCached :: ArcLength n -> Interval n
getArcLengthCached :: forall n. ArcLength n -> Interval n
getArcLengthCached = forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall n. (Sum (Interval n), n -> Sum (Interval n)) -> ArcLength n
ArcLength

-- | Project out the generic arc length function taking the tolerance as
--   an argument.
getArcLengthFun :: ArcLength n -> n -> Interval n
getArcLengthFun :: forall n. ArcLength n -> n -> Interval n
getArcLengthFun = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall n. (Sum (Interval n), n -> Sum (Interval n)) -> ArcLength n
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 :: forall n. (Num n, Ord n) => n -> ArcLength n -> Interval n
getArcLengthBounded n
eps ArcLength n
al
  | forall a. Num a => Interval a -> a
I.width Interval n
cached forall a. Ord a => a -> a -> Bool
<= n
eps = Interval n
cached
  | Bool
otherwise             = forall n. ArcLength n -> n -> Interval n
getArcLengthFun ArcLength n
al n
eps
  where
    cached :: Interval n
cached = forall n. ArcLength n -> Interval n
getArcLengthCached ArcLength n
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 v n) (Unwrapped (TotalOffset v n))
_Wrapped' = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(TotalOffset v n
x) -> v n
x) forall (v :: * -> *) n. v n -> TotalOffset v n
TotalOffset

instance Rewrapped (TotalOffset v n) (TotalOffset v' n')

instance (Num n, Additive v) => Semigroup (TotalOffset v n) where
  TotalOffset v n
v1 <> :: TotalOffset v n -> TotalOffset v n -> TotalOffset v n
<> TotalOffset v n
v2 = forall (v :: * -> *) n. v n -> TotalOffset v n
TotalOffset (v n
v1 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ v n
v2)

instance (Num n, Additive v) => Monoid (TotalOffset v n) where
  mempty :: TotalOffset v n
mempty  = forall (v :: * -> *) n. v n -> TotalOffset v n
TotalOffset forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
  mappend :: TotalOffset v n -> TotalOffset v n -> TotalOffset v n
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | 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
  { forall (v :: * -> *) n. OffsetEnvelope v n -> TotalOffset v n
_oeOffset   :: !(TotalOffset v n)
  , forall (v :: * -> *) n. OffsetEnvelope v n -> Envelope v n
_oeEnvelope :: Envelope v n
  }

makeLenses ''OffsetEnvelope

instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where
  (OffsetEnvelope TotalOffset v n
o1 Envelope v n
e1) <> :: OffsetEnvelope v n -> OffsetEnvelope v n -> OffsetEnvelope v n
<> (OffsetEnvelope TotalOffset v n
o2 Envelope v n
e2)
    = let !negOff :: v n
negOff = forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall (v :: * -> *) n. v n -> TotalOffset v n
TotalOffset forall a b. (a -> b) -> a -> b
$ TotalOffset v n
o1
          e2Off :: Envelope v n
e2Off = forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy v n
negOff Envelope v n
e2
          !_unused :: ()
_unused = forall b a. b -> (a -> b) -> Maybe a -> b
maybe () (\v n -> n
f -> v n -> n
f seq :: forall a b. a -> b -> b
`seq` ()) forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n. Envelope v n -> Maybe (v n -> n)
appEnvelope Envelope v n
e2Off
      in forall (v :: * -> *) n.
TotalOffset v n -> Envelope v n -> OffsetEnvelope v n
OffsetEnvelope
          (TotalOffset v n
o1 forall a. Semigroup a => a -> a -> a
<> TotalOffset v n
o2)
          (Envelope v n
e1 forall a. Semigroup a => a -> a -> a
<> Envelope v n
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 :: SegMeasure v n -> SegMeasure v n
measure = forall a. a -> a
id

instance (OrderedField n, Metric v)
    => Measured (SegMeasure v n) (Segment Closed v n) where
  measure :: Segment Closed v n -> SegMeasure v n
measure Segment Closed v n
s = (Sum Int -> SegCount
SegCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Sum a
Sum) Int
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
            forall a l. a -> l -> a ::: l
*: forall n. (Sum (Interval n), n -> Sum (Interval n)) -> ArcLength n
ArcLength ( forall a. a -> Sum a
Sum forall a b. (a -> b) -> a -> b
$ forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded (forall a. Fractional a => a
stdToleranceforall a. Fractional a => a -> a -> a
/n
100) Segment Closed v n
s
                         , forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded Segment Closed v n
s               )

            forall a l. a -> l -> a ::: l
*: forall (v :: * -> *) n.
TotalOffset v n -> Envelope v n -> OffsetEnvelope v n
OffsetEnvelope (forall (v :: * -> *) n. v n -> TotalOffset v n
TotalOffset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Segment Closed v n -> v n
segOffset forall a b. (a -> b) -> a -> b
$ Segment Closed v n
s)
                              (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Segment Closed v n
s)

            forall a l. a -> l -> a ::: l
*: ()

------------------------------------------------------------
--  Serialize instances
------------------------------------------------------------

instance (Serialize (v n)) => Serialize (Segment Open v n) where
  {-# INLINE put #-}
  put :: Putter (Segment Open v n)
put Segment Open v n
segment = case Segment Open v n
segment of
    Linear Offset Open v n
OffsetOpen    -> forall t. Serialize t => Putter t
Serialize.put Bool
True
    Cubic v n
v v n
w Offset Open v n
OffsetOpen -> do
      forall t. Serialize t => Putter t
Serialize.put Bool
False
      forall t. Serialize t => Putter t
Serialize.put v n
v
      forall t. Serialize t => Putter t
Serialize.put v n
w

  {-# INLINE get #-}
  get :: Get (Segment Open v n)
get = do
    Bool
isLinear <- forall t. Serialize t => Get t
Serialize.get
    case Bool
isLinear of
      Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear forall (v :: * -> *) n. Offset Open v n
OffsetOpen)
      Bool
False -> do
        v n
v <- forall t. Serialize t => Get t
Serialize.get
        v n
w <- forall t. Serialize t => Get t
Serialize.get
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic v n
v v n
w forall (v :: * -> *) n. Offset Open v n
OffsetOpen)

instance (Serialize (v n)) => Serialize (Segment Closed v n) where
  {-# INLINE put #-}
  put :: Putter (Segment Closed v n)
put Segment Closed v n
segment = case Segment Closed v n
segment of
    Linear (OffsetClosed v n
z)    -> do
      forall t. Serialize t => Putter t
Serialize.put v n
z
      forall t. Serialize t => Putter t
Serialize.put Bool
True
    Cubic v n
v v n
w (OffsetClosed v n
z) -> do
      forall t. Serialize t => Putter t
Serialize.put v n
z
      forall t. Serialize t => Putter t
Serialize.put Bool
False
      forall t. Serialize t => Putter t
Serialize.put v n
v
      forall t. Serialize t => Putter t
Serialize.put v n
w

  {-# INLINE get #-}
  get :: Get (Segment Closed v n)
get = do
    v n
z <- forall t. Serialize t => Get t
Serialize.get
    Bool
isLinear <- forall t. Serialize t => Get t
Serialize.get
    case Bool
isLinear of
      Bool
True  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall c (v :: * -> *) n. Offset c v n -> Segment c v n
Linear (forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed v n
z))
      Bool
False -> do
        v n
v <- forall t. Serialize t => Get t
Serialize.get
        v n
w <- forall t. Serialize t => Get t
Serialize.get
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall c (v :: * -> *) n.
v n -> v n -> Offset c v n -> Segment c v n
Cubic v n
v v n
w (forall (v :: * -> *) n. v n -> Offset Closed v n
OffsetClosed v n
z))