{-# 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(..), Rewrapped)
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.Kaucher    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 (SegTree v) where
    type Unwrapped (SegTree v) = FingerTree (SegMeasure v) (Segment Closed v)
    _Wrapped' = iso (\(SegTree x) -> x) SegTree

instance Rewrapped (SegTree v) (SegTree v')

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