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
--
-- Generic functionality for constructing and manipulating /trails/
-- (sequences of linear or cubic Bezier segments) and /paths/
-- (collections of concretely located trails).
--
-----------------------------------------------------------------------------

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
       , fixTrail

         -- * Paths

       , Path(..)

         -- ** Constructing paths from trails

       , pathFromTrail
       , pathFromTrailAt

         -- ** Computing with paths

       , pathVertices
       , pathOffsets
       , reversePath
       , fixPath

         -- * Miscellaneous

       , explodeTrail
       , explodePath
       , (~~)

       ) where

import Graphics.Rendering.Diagrams

import Diagrams.Segment
import Diagrams.Util

import Data.VectorSpace
import Data.AffineSpace

import Control.Newtype
import Data.Monoid
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, Ord 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

-- | 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
  Trail t1 c1 `mappend` Trail t2 c2 = Trail (t1 ++ t2) (c1 || c2)

-- | 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 bounding function for a trail is based at the trail's start.
instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Trail v) where

  getBounds (Trail segs _) =
    foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getBounds seg)
          mempty
          segs

------------------------------------------------------------
--  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)

-- | Convert a starting point and a trail into a list of fixed segments.
fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v]
fixTrail start tr = zipWith mkFixedSeg (trailVertices start tr)
                      (trailSegments tr ++ closeSeg)
  where closeSeg | isClosed tr = [Linear . negateV . trailOffset $ tr]
                 | otherwise   = []

------------------------------------------------------------
--  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, Monoid, Eq, Ord)

type instance V (Path v) = v

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

instance (Ord v, 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 (Ord v, VectorSpace v) => PathLike (Path v) where
  pathLike s cl segs = Path [(s, pathLike origin cl segs)]

-- See Note [Transforming paths]
instance (HasLinearMap v, Ord 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)) => Boundable (Path v) where
  getBounds = F.foldMap trailBounds . pathTrails
          -- this type signature is necessary to work around an apparent bug in ghc 6.12.1
    where trailBounds :: (Point v, Trail v) -> Bounds v
          trailBounds (p, t) = moveOriginTo ((-1) *. p) (getBounds t)

------------------------------------------------------------
--  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

-- | 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 => Point v -> Trail v -> [Path v]
explodeTrail start = snd . mapAccumL mkPath start . trailSegments'
  where mkPath p seg = (p .+^ segOffset seg, pathFromTrailAt (fromSegments [seg]) p)

-- | \"Explode\" a path by exploding every component trail (see 'explodeTrail').
explodePath :: VectorSpace v => Path v -> [[Path v]]
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]