Path.hs

{-# LANGUAGE TypeFamilies
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
           , DeriveFunctor
           , GeneralizedNewtypeDeriving
           , UndecidableInstances
           , ScopedTypeVariables
  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Path
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- This module defines /trails/ (translationally invariant sequences
-- of linear or cubic Bézier segments) and /paths/ (collections of
-- concretely located trails).  Trails and paths can be used for
-- drawing shapes, laying out other diagrams, clipping, and other
-- things.
--
-----------------------------------------------------------------------------

module Diagrams.Path
       (
         -- * Constructing path-like things

         PathLike(..), fromSegments, fromOffsets, fromVertices, segmentsFromVertices
       , pathLikeFromTrail

         -- * Closeable things

       , Closeable(..)

         -- * Trails

       , Trail(..)

         -- ** Computing with trails

       , trailSegments'
       , trailOffsets, trailOffset
       , trailVertices, reverseTrail
       , addClosingSegment
       , fixTrail

         -- * Paths

       , Path(..)

         -- ** Constructing paths from trails

       , pathFromTrail
       , pathFromTrailAt

         -- ** Computing with paths

       , pathVertices
       , pathOffsets
       , pathCentroid
       , scalePath
       , reversePath
       , fixPath

         -- * Miscellaneous

       , explodeTrail
       , explodePath
       , (~~)

       ) where

import Diagrams.Core
import Diagrams.Core.Points

import Diagrams.Align
import Diagrams.Segment
import Diagrams.Points
import Diagrams.Transform

import Data.VectorSpace
import Data.AffineSpace

import Control.Newtype hiding (under)
import Data.Semigroup
import qualified Data.Foldable as F

import Data.List (mapAccumL)

import Control.Arrow ((***), first, second)

------------------------------------------------------------
--  PathLike class
------------------------------------------------------------

-- | Type class for path-like things, which must be monoids.
--   Instances include 'Trail's, 'Path's, and two-dimensional 'Diagram's.
class (Monoid' p, VectorSpace (V p)) => PathLike p where

  pathLike :: Point (V p)      -- ^ The starting point of the
                               --   path.  Some path-like things
                               --   (e.g. 'Trail's) may ignore this.
           -> Bool             -- ^ Should the path be closed?
           -> [Segment (V p)]  -- ^ Segments of the path.
           -> p

-- | A list of points is path-like; this instance simply computes the
--   vertices of a path-like thing.
instance VectorSpace v => PathLike [Point v] where
  pathLike start cl segs = trailVertices start (pathLike start cl segs)

-- | Construct an open path-like thing with the origin as a starting
--   point.
fromSegments :: PathLike p => [Segment (V p)] -> p
fromSegments = pathLike origin False

-- | Construct an open path-like thing of linear segments from a list
--   of offsets.  The starting point is the origin.
fromOffsets :: PathLike p => [V p] -> p
fromOffsets = pathLike origin False . map Linear

-- | Construct a path-like thing of linear segments from a list of
--   vertices, with the first vertex as the starting point.
fromVertices :: PathLike p => [Point (V p)] -> p
fromVertices []         = mempty
fromVertices vvs@(v:_) = pathLike v False (segmentsFromVertices vvs)

-- | Construct a list of linear segments from a list of vertices.  The
--   input list must contain at least two points to generate a
--   non-empty list of segments.
segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment v]
segmentsFromVertices [] = []
segmentsFromVertices vvs@(_:vs) = map Linear (zipWith (flip (.-.)) vvs vs)

------------------------------------------------------------
--  Closeable class
------------------------------------------------------------

-- | Path-like things that can be \"open\" or \"closed\".
class PathLike p => Closeable p where
  -- | \"Open\" a path-like thing.
  open  :: p -> p

  -- | \"Close\" a path-like thing, by implicitly connecting the
  --   endpoint(s) back to the starting point(s).
  close :: p -> p

instance VectorSpace v => Closeable (Trail v) where
  close (Trail segs _) = Trail segs True
  open  (Trail segs _) = Trail segs False

instance VectorSpace v => Closeable (Path v) where
  close = (over Path . map . second) close
  open  = (over Path . map . second) open

------------------------------------------------------------
--  Trails  ------------------------------------------------
------------------------------------------------------------

-- | A /trail/ is a sequence of segments placed end-to-end.  Trails
--   are thus translationally invariant, and form a monoid under
--   concatenation.  Trails can also be /open/ (the default) or
--   /closed/ (the final point in a closed trail is implicitly
--   connected back to the starting point).
data Trail v = Trail { trailSegments :: [Segment v]
                     , isClosed      :: Bool
                     }
  deriving (Show, Functor, Eq, Ord)

type instance V (Trail v) = v

instance Semigroup (Trail v) where
  Trail t1 c1 <> Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2)

-- | The empty trail has no segments.  Trails are composed via
--   concatenation.  @t1 ``mappend`` t2@ is closed iff either @t1@ or
--   @t2@ are.
instance Monoid (Trail v) where
  mempty = Trail [] False
  mappend = (<>)

-- | Trails are 'PathLike' things.  Note that since trails are
--   translationally invariant, 'setStart' has no effect.
--   'fromSegments' creates an open trail.
instance VectorSpace v => PathLike (Trail v) where
  pathLike _ cl segs = Trail segs cl

instance HasLinearMap v => Transformable (Trail v) where
  transform t (Trail segs c) = Trail (transform t segs) c

-- | The envelope for a trail is based at the trail's start.
instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where

  getEnvelope (Trail segs _) =
    foldr (\seg bds -> moveOriginBy (negateV . segOffset $ seg) bds <> getEnvelope seg)
          mempty
          segs

  -- XXX can we improve the efficiency of the above?  E.g. note the
  -- last segment in each trail ends up getting translated O(n) times,
  -- so overall we do O(n^2) work!  (to find the max over the bounds
  -- for O(n) segments, where the ith segment requires working through
  -- a stack of i translations...)
  --
  -- The idea would be to first convert to a list of FixedSegments (to
  -- cache the translation work) then take the bounds of those.
  --
  -- Also, use a balanced fold!
  --
  -- Need to make some benchmarks I guess.

instance HasLinearMap v => Renderable (Trail v) NullBackend where
  render _ _ = mempty

------------------------------------------------------------
--  Computing with trails  ---------------------------------
------------------------------------------------------------

-- | @trailSegments'@ is like 'trailSegments', but explicitly includes
--   the implicit closing segment at the end of the list for closed trails.
trailSegments' :: AdditiveGroup v => Trail v -> [Segment v]
trailSegments' t | isClosed t = trailSegments t
                                ++ [straight . negateV . trailOffset $ t]
                 | otherwise  = trailSegments t

-- | Extract the offsets of the segments of a trail.
trailOffsets :: Trail v -> [v]
trailOffsets (Trail segs _) = map segOffset segs

-- | Compute the offset from the start of a trail to the end.
trailOffset :: AdditiveGroup v => Trail v -> v
trailOffset = sumV . trailOffsets

-- | Extract the vertices of a trail, given a concrete location at
--   which to place the first vertex.
trailVertices :: AdditiveGroup v => Point v -> Trail v -> [Point v]
trailVertices p = scanl (.+^) p . trailOffsets

-- | Reverse a trail's direction of travel.
reverseTrail :: AdditiveGroup v => Trail v -> Trail v
reverseTrail t@(Trail {trailSegments = []}) = t
reverseTrail t@(Trail {trailSegments = ss})
  | isClosed t = t { trailSegments = straight (trailOffset t) : reverseSegs ss }
  | otherwise  = t { trailSegments = reverseSegs ss }
  where reverseSegs = fmap reverseSegment . reverse

-- | Reverse a trail with a fixed starting point.
reverseRootedTrail :: AdditiveGroup v => (Point v, Trail v) -> (Point v, Trail v)
reverseRootedTrail (p, t)
  | isClosed t = (p, reverseTrail t)
  | otherwise  = (p .+^ trailOffset t, reverseTrail t)

-- | Convert a trail to any path-like thing.  @pathLikeFromTrail@ is the
--   identity on trails.
pathLikeFromTrail :: PathLike p => Trail (V p) -> p
pathLikeFromTrail t = pathLike origin (isClosed t) (trailSegments t)

-- | If the trail is closed, this adds in the closing segment. Otherwise,
--   the trail is returned unmodified.
addClosingSegment :: AdditiveGroup v => Trail v -> Trail v
addClosingSegment t | isClosed t = Trail (trailSegments t ++ [closeSeg]) False
                    | otherwise = t
 where closeSeg = Linear . negateV $ trailOffset t

-- | Convert a starting point and a trail into a list of fixed segments.
fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v]
fixTrail start t = zipWith mkFixedSeg (trailVertices start t)
                                      (trailSegments $ addClosingSegment t)

------------------------------------------------------------
--  Paths  -------------------------------------------------
------------------------------------------------------------

-- | A /path/ is a (possibly empty) list of trails, with each
--   trail paired with an absolute starting point. Hence, paths
--   are /not/ translationally invariant, and form a monoid under
--   superposition.
newtype Path v = Path { pathTrails :: [(Point v, Trail v)] }
  deriving (Show, Semigroup, Monoid, Eq, Ord)

type instance V (Path v) = v

instance Newtype (Path v) [(Point v, Trail v)] where
  pack   = Path
  unpack = pathTrails

instance VectorSpace v => HasOrigin (Path v) where
  moveOriginTo = over Path . map . first . moveOriginTo

-- | Paths are (of course) path-like. 'fromSegments' creates a path
--   with start point at the origin.
instance VectorSpace v => PathLike (Path v) where
  pathLike s cl segs = Path [(s, pathLike origin cl segs)]

-- See Note [Transforming paths]
instance HasLinearMap v => Transformable (Path v) where
  transform t = (over Path . map) (transform t *** transform t)

{- ~~~~ Note [Transforming paths]

Careful!  It's tempting to just define

> transform = fmap . transform

but that doesn't take into account the fact that some
of the v's are inside Points and hence ought to be translated.
-}

instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where
  getEnvelope = F.foldMap trailEnvelope . pathTrails
          -- this type signature is necessary to work around an apparent bug in ghc 6.12.1
    where trailEnvelope :: (Point v, Trail v) -> Envelope v
          trailEnvelope (p, t) = moveOriginTo ((-1) *. p) (getEnvelope t)

instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where
  juxtapose = juxtaposeDefault

instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where
  alignBy = alignByDefault

instance HasLinearMap v => Renderable (Path v) NullBackend where
  render _ _ = mempty

------------------------------------------------------------
--  Constructing paths from trails  ------------------------
------------------------------------------------------------

-- | Convert a trail to a path beginning at the origin.
pathFromTrail :: AdditiveGroup v => Trail v -> Path v
pathFromTrail t = Path [(origin, t)]

-- | Convert a trail to a path with a particular starting point.
pathFromTrailAt :: Trail v -> Point v -> Path v
pathFromTrailAt t p = Path [(p, t)]

------------------------------------------------------------
--  Computing with paths  ----------------------------------
------------------------------------------------------------

-- | Extract the vertices of a path.
pathVertices :: AdditiveGroup v => Path v -> [[Point v]]
pathVertices = map (uncurry trailVertices) . pathTrails

-- | Compute the total offset of each trail comprising a path.
pathOffsets :: AdditiveGroup v => Path v -> [v]
pathOffsets = map (trailOffset . snd) . pathTrails

-- | Compute the /centroid/ of a path (/i.e./ the average of its
--   vertices).
pathCentroid :: (VectorSpace v, Fractional (Scalar v)) => Path v -> Point v
pathCentroid = centroid . concat . pathVertices

-- | Scale a path using its centroid (see 'pathCentroid') as the base
--   point for the scale.
scalePath :: (HasLinearMap v, VectorSpace v, Fractional (Scalar v), Eq (Scalar v))
          => Scalar v -> Path v -> Path v
scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p

-- | Reverse the direction of all the component trails of a path.
reversePath :: AdditiveGroup v => Path v -> Path v
reversePath = (over Path . map) reverseRootedTrail

-- | Convert a path into a list of lists of 'FixedSegment's.
fixPath :: AdditiveGroup v => Path v -> [[FixedSegment v]]
fixPath = map (uncurry fixTrail) . unpack

------------------------------------------------------------
--  Other functions  ---------------------------------------
------------------------------------------------------------

-- | Given a starting point, \"explode\" a trail by turning each
--   segment (including the implicit closing segment, if the trail is
--   closed) into its own separate path.  Useful for (say) applying a
--   different style to each segment.
explodeTrail :: (VectorSpace (V p), PathLike p) => Point (V p) -> Trail (V p) -> [p]
explodeTrail start = snd . mapAccumL mkPath start . trailSegments'
  where mkPath p seg = (p .+^ segOffset seg, pathLike p False [seg])

-- | \"Explode\" a path by exploding every component trail (see 'explodeTrail').
explodePath :: (VectorSpace (V p), PathLike p) => Path (V p) -> [[p]]
explodePath = map (uncurry explodeTrail) . pathTrails

-- | Create a single-segment path between two given points.
(~~) :: PathLike p => Point (V p) -> Point (V p) -> p
p1 ~~ p2 = fromVertices [p1, p2]