{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TrailLike
-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- The 'TrailLike' class abstracts over anything which can be
-- constructed from a concretely located 'Trail', including
-- lines, loops, trails, paths, vertex lists, and diagrams.
--
-----------------------------------------------------------------------------

module Diagrams.TrailLike
       (
         -- * The TrailLike class

         TrailLike(..)

         -- * Constructing TrailLikes

       , fromSegments, fromLocSegments, fromOffsets, fromLocOffsets, fromVertices
       , (~~), explodeTrail

       ) where

import           Control.Lens     (view, _Unwrapped')

import           Diagrams.Core
import           Diagrams.Located
import           Diagrams.Segment
import           Diagrams.Trail

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector

------------------------------------------------------------
--  TrailLike class
------------------------------------------------------------

-- | A type class for trail-like things, /i.e./ things which can be
--   constructed from a concretely located 'Trail'.  Instances include
--   lines, loops, trails, paths, lists of vertices, two-dimensional
--   'Diagram's, and 'Located' variants of all the above.
--
--   Usually, type variables with 'TrailLike' constraints are used as
--   the /output/ types of functions, like
--
--   @
--   foo :: (TrailLike t) => ... -> t
--   @
--
--   Functions with such a type can be used to construct trails,
--   paths, diagrams, lists of points, and so on, depending on the
--   context.
--
--   To write a function with a signature like the above, you can of
--   course call 'trailLike' directly; more typically, one would use
--   one of the provided functions like 'fromOffsets', 'fromVertices',
--   'fromSegments', or '~~'.
class (Metric (V t), OrderedField (N t)) => TrailLike t where

  trailLike
    :: Located (Trail (V t) (N t)) -- ^ The concretely located trail.  Note
                                   --   that some trail-like things
                                   --   (e.g. 'Trail's) may ignore the
                                   --   location.
    -> t

------------------------------------------------------------
--  Instances  ---------------------------------------------

-- | A list of points is trail-like; this instance simply
--   computes the vertices of the trail, using 'trailPoints'.
instance (Metric v, OrderedField n) => TrailLike [Point v n] where
  trailLike :: Located (Trail (V [Point v n]) (N [Point v n])) -> [Point v n]
trailLike = Located (Trail v n) -> [Point v n]
Located (Trail (V [Point v n]) (N [Point v n])) -> [Point v n]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Located (Trail v n) -> [Point v n]
trailPoints

-- | Lines are trail-like.  If given a 'Trail' which contains a loop,
--   the loop will be cut with 'cutLoop'.  The location is ignored.
instance (Metric v, OrderedField n) => TrailLike (Trail' Line v n) where
  trailLike :: Located (Trail (V (Trail' Line v n)) (N (Trail' Line v n)))
-> Trail' Line v n
trailLike = (Trail' Line v n -> Trail' Line v n)
-> (Trail' Loop v n -> Trail' Line v n)
-> Trail v n
-> Trail' Line v n
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line v n -> Trail' Line v n
forall a. a -> a
id Trail' Loop v n -> Trail' Line v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop (Trail v n -> Trail' Line v n)
-> (Located (Trail v n) -> Trail v n)
-> Located (Trail v n)
-> Trail' Line v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail v n) -> Trail v n
forall a. Located a -> a
unLoc

-- | Loops are trail-like.  If given a 'Trail' containing a line, the
--   line will be turned into a loop using 'glueLine'.  The location
--   is ignored.
instance (Metric v, OrderedField n) => TrailLike (Trail' Loop v n) where
  trailLike :: Located (Trail (V (Trail' Loop v n)) (N (Trail' Loop v n)))
-> Trail' Loop v n
trailLike = (Trail' Line v n -> Trail' Loop v n)
-> (Trail' Loop v n -> Trail' Loop v n)
-> Trail v n
-> Trail' Loop v n
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line v n -> Trail' Loop v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Line v n -> Trail' Loop v n
glueLine Trail' Loop v n -> Trail' Loop v n
forall a. a -> a
id (Trail v n -> Trail' Loop v n)
-> (Located (Trail v n) -> Trail v n)
-> Located (Trail v n)
-> Trail' Loop v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail v n) -> Trail v n
forall a. Located a -> a
unLoc

-- | 'Trail's are trail-like; the location is simply ignored.
instance (Metric v, OrderedField n) => TrailLike (Trail v n) where
  trailLike :: Located (Trail (V (Trail v n)) (N (Trail v n))) -> Trail v n
trailLike = Located (Trail v n) -> Trail v n
Located (Trail (V (Trail v n)) (N (Trail v n))) -> Trail v n
forall a. Located a -> a
unLoc

-- | Translationally invariant things are trail-like as long as the
--   underlying type is.
instance TrailLike t => TrailLike (TransInv t) where
  trailLike :: Located (Trail (V (TransInv t)) (N (TransInv t))) -> TransInv t
trailLike = Getting (TransInv t) t (TransInv t) -> t -> TransInv t
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (TransInv t) t (TransInv t)
(TransInv t -> Const (TransInv t) (TransInv t))
-> Unwrapped (TransInv t)
-> Const (TransInv t) (Unwrapped (TransInv t))
forall s. Wrapped s => Iso' (Unwrapped s) s
Iso' (Unwrapped (TransInv t)) (TransInv t)
_Unwrapped' (t -> TransInv t)
-> (Located (Trail (V t) (N t)) -> t)
-> Located (Trail (V t) (N t))
-> TransInv t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike

-- | 'Located' things are trail-like as long as the underlying type
--   is.  The location is taken to be the location of the input
--   located trail.
instance TrailLike t => TrailLike (Located t) where
  trailLike :: Located (Trail (V (Located t)) (N (Located t))) -> Located t
trailLike Located (Trail (V (Located t)) (N (Located t)))
t = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike Located (Trail (V t) (N t))
Located (Trail (V (Located t)) (N (Located t)))
t t -> Point (V t) (N t) -> Located t
forall a. a -> Point (V a) (N a) -> Located a
`at` Located (Trail (V t) (N t))
-> Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
forall a. Located a -> Point (V a) (N a)
loc Located (Trail (V t) (N t))
Located (Trail (V (Located t)) (N (Located t)))
t

------------------------------------------------------------
--  Constructing TrailLike things  -------------------------
------------------------------------------------------------

-- | Construct a trail-like thing from a list of segments, with the
--   origin as the location.
--
--   <<diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg#diagram=fromSegmentsEx&height=200>>
--
--   > fromSegmentsEx = fromSegments
--   >   [ straight (r2 (1,1))
--   >   , bézier3  (r2 (1,1)) unitX unit_Y
--   >   , straight unit_X
--   >   ]
--   >   # centerXY # pad 1.1
fromSegments :: TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments :: forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments = Located [Segment Closed (V t) (N t)] -> t
forall t. TrailLike t => Located [Segment Closed (V t) (N t)] -> t
fromLocSegments (Located [Segment Closed (V t) (N t)] -> t)
-> ([Segment Closed (V t) (N t)]
    -> Located [Segment Closed (V t) (N t)])
-> [Segment Closed (V t) (N t)]
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Segment Closed (V t) (N t)]
-> Point
     (V [Segment Closed (V t) (N t)]) (N [Segment Closed (V t) (N t)])
-> Located [Segment Closed (V t) (N t)]
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V t) (N t)
Point
  (V [Segment Closed (V t) (N t)]) (N [Segment Closed (V t) (N t)])
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)

-- | Construct a trail-like thing from a located list of segments.
fromLocSegments :: TrailLike t => Located [Segment Closed (V t) (N t)] -> t
fromLocSegments :: forall t. TrailLike t => Located [Segment Closed (V t) (N t)] -> t
fromLocSegments = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail (V t) (N t)) -> t)
-> (Located [Segment Closed (V t) (N t)]
    -> Located (Trail (V t) (N t)))
-> Located [Segment Closed (V t) (N t)]
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Segment Closed (V t) (N t)] -> Trail (V t) (N t))
-> Located [Segment Closed (V t) (N t)]
-> Located (Trail (V t) (N t))
forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc [Segment Closed (V t) (N t)] -> Trail (V t) (N t)
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments

-- | Construct a trail-like thing of linear segments from a list
--   of offsets, with the origin as the location.
--
--   <<diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg#diagram=fromOffsetsEx&width=300>>
--
--   > fromOffsetsEx = fromOffsets
--   >   [ unitX
--   >   , unitX # rotateBy (1/6)
--   >   , unitX # rotateBy (-1/6)
--   >   , unitX
--   >   ]
--   >   # centerXY # pad 1.1
fromOffsets :: TrailLike t => [Vn t] -> t
fromOffsets :: forall t. TrailLike t => [Vn t] -> t
fromOffsets = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail (V t) (N t)) -> t)
-> ([V t (N t)] -> Located (Trail (V t) (N t))) -> [V t (N t)] -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail (V t) (N t)
-> Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
-> Located (Trail (V t) (N t))
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V t) (N t)
Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) (Trail (V t) (N t) -> Located (Trail (V t) (N t)))
-> ([V t (N t)] -> Trail (V t) (N t))
-> [V t (N t)]
-> Located (Trail (V t) (N t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V t (N t)] -> Trail (V t) (N t)
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[v n] -> Trail v n
trailFromOffsets

-- | Construct a trail-like thing of linear segments from a located
--   list of offsets.
fromLocOffsets :: (V t ~ v, N t ~ n, V (v n) ~ v, N (v n) ~ n, TrailLike t) => Located [v n] -> t
fromLocOffsets :: forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, V (v n) ~ v, N (v n) ~ n, TrailLike t) =>
Located [v n] -> t
fromLocOffsets = Located (Trail v n) -> t
Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail v n) -> t)
-> (Located [v n] -> Located (Trail v n)) -> Located [v n] -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([v n] -> Trail v n) -> Located [v n] -> Located (Trail v n)
forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc [v n] -> Trail v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[v n] -> Trail v n
trailFromOffsets

-- | Construct a trail-like thing connecting the given vertices with
--   linear segments, with the first vertex as the location.  If no
--   vertices are given, the empty trail is used with the origin as
--   the location.
--
--   <<diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg#diagram=fromVerticesEx&width=300>>
--
--   > import Data.List (transpose)
--   >
--   > fromVerticesEx =
--   >   ( [ pentagon 1
--   >     , pentagon 1.3 # rotateBy (1/15)
--   >     , pentagon 1.5 # rotateBy (2/15)
--   >     ]
--   >     # transpose
--   >     # concat
--   >   )
--   >   # fromVertices
--   >   # closeTrail # strokeTrail
--   >   # centerXY # pad 1.1
fromVertices :: TrailLike t => [Point (V t) (N t)] -> t
fromVertices :: forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices []       = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Trail (V t) (N t)
forall (v :: * -> *) n. (Metric v, OrderedField n) => Trail v n
emptyTrail Trail (V t) (N t)
-> Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
-> Located (Trail (V t) (N t))
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V t) (N t)
Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)
fromVertices ps :: [Point (V t) (N t)]
ps@(Point (V t) (N t)
p:[Point (V t) (N t)]
_) = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike ([Segment Closed (V t) (N t)] -> Trail (V t) (N t)
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments ([Point (V t) (N t)] -> [Segment Closed (V t) (N t)]
forall (v :: * -> *) n.
(Additive v, Num n) =>
[Point v n] -> [Segment Closed v n]
segmentsFromVertices [Point (V t) (N t)]
ps) Trail (V t) (N t)
-> Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
-> Located (Trail (V t) (N t))
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V t) (N t)
Point (V (Trail (V t) (N t))) (N (Trail (V t) (N t)))
p)

segmentsFromVertices :: (Additive v, Num n) => [Point v n] -> [Segment Closed v n]
segmentsFromVertices :: forall (v :: * -> *) n.
(Additive v, Num n) =>
[Point v n] -> [Segment Closed v n]
segmentsFromVertices []         = []
segmentsFromVertices vvs :: [Point v n]
vvs@(Point v n
_:[Point v n]
vs) = (v n -> Segment Closed v n) -> [v n] -> [Segment Closed v n]
forall a b. (a -> b) -> [a] -> [b]
map v n -> Segment Closed v n
forall (v :: * -> *) n. v n -> Segment Closed v n
straight ((Point v n -> Point v n -> v n)
-> [Point v n] -> [Point v n] -> [v n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Point v n -> Point v n -> v n) -> Point v n -> Point v n -> v n
forall a b c. (a -> b -> c) -> b -> a -> c
flip Point v n -> Point v n -> v n
Point v n -> Point v n -> Diff (Point v) n
forall a. Num a => Point v a -> Point v a -> Diff (Point v) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
(.-.)) [Point v n]
vvs [Point v n]
vs)

-- | Create a linear trail between two given points.
--
--   <<diagrams/src_Diagrams_TrailLike_twiddleEx.svg#diagram=twiddleEx&width=300>>
--
--   > twiddleEx
--   >   = mconcat ((~~) <$> hexagon 1 <*> hexagon 1)
--   >   # centerXY # pad 1.1
(~~) :: (V t ~ v, N t ~ n, TrailLike t) => Point v n -> Point v n -> t
Point v n
p1 ~~ :: forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Point v n -> Point v n -> t
~~ Point v n
p2 = [Point (V t) (N t)] -> t
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices [Point v n
Point (V t) (N t)
p1, Point v n
Point (V t) (N t)
p2]

-- | Given a concretely located trail, \"explode\" it by turning each
--   segment into its own separate trail.  Useful for (say) applying a
--   different style to each segment.
--
--   <<diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg#diagram=explodeTrailEx&width=300>>
--
--   > explodeTrailEx
--   >   = pentagon 1
--   >   # explodeTrail  -- generate a list of diagrams
--   >   # zipWith lc [orange, green, yellow, red, blue]
--   >   # mconcat # centerXY # pad 1.1
explodeTrail :: (V t ~ v, N t ~ n, TrailLike t) => Located (Trail v n) -> [t]
explodeTrail :: forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Located (Trail v n) -> [t]
explodeTrail = (FixedSegment v n -> t) -> [FixedSegment v n] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map (Located (Segment Closed v n) -> t
Located (Segment Closed (V t) (N t)) -> t
mkTrail (Located (Segment Closed v n) -> t)
-> (FixedSegment v n -> Located (Segment Closed v n))
-> FixedSegment v n
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixedSegment v n -> Located (Segment Closed v n)
forall n (v :: * -> *).
(Num n, Additive v) =>
FixedSegment v n -> Located (Segment Closed v n)
fromFixedSeg) ([FixedSegment v n] -> [t])
-> (Located (Trail v n) -> [FixedSegment v n])
-> Located (Trail v n)
-> [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail v n) -> [FixedSegment v n]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Located (Trail v n) -> [FixedSegment v n]
fixTrail
  where
    mkTrail :: Located (Segment Closed (V t) (N t)) -> t
mkTrail = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail (V t) (N t)) -> t)
-> (Located (Segment Closed (V t) (N t))
    -> Located (Trail (V t) (N t)))
-> Located (Segment Closed (V t) (N t))
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment Closed (V t) (N t) -> Trail (V t) (N t))
-> Located (Segment Closed (V t) (N t))
-> Located (Trail (V t) (N t))
forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc ([Segment Closed (V t) (N t)] -> Trail (V t) (N t)
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments ([Segment Closed (V t) (N t)] -> Trail (V t) (N t))
-> (Segment Closed (V t) (N t) -> [Segment Closed (V t) (N t)])
-> Segment Closed (V t) (N t)
-> Trail (V t) (N t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment Closed (V t) (N t)
-> [Segment Closed (V t) (N t)] -> [Segment Closed (V t) (N t)]
forall a. a -> [a] -> [a]
:[]))