    {-# LANGUAGE ConstraintKinds       #-}
    {-# LANGUAGE DeriveGeneric         #-}
    {-# LANGUAGE FlexibleContexts      #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE StandaloneDeriving    #-}
    {-# LANGUAGE TypeFamilies          #-}
    {-# LANGUAGE UndecidableInstances  #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Diagrams.Located
    -- Copyright   :  (c) 2013-2015 diagrams-lib team (see LICENSE)
    -- License     :  BSD-style (see LICENSE)
    -- Maintainer  :  diagrams-discuss@googlegroups.com
    --
    -- \"Located\" things, /i.e./ things with a concrete location:
    -- intuitively, @Located a ~ (a, Point)@.  Wrapping a translationally
    -- invariant thing (/e.g./ a 'Segment' or 'Trail') in @Located@ pins
    -- it down to a particular location and makes it no longer
    -- translationally invariant.
    --
    -----------------------------------------------------------------------------

    module Diagrams.Located
        ( Located (..)
        , at, viewLoc, mapLoc, located, _loc
        )
        where

    import           Control.Lens            (Lens, Lens')
    import           Text.Read

    import           Linear.Affine
    import           Linear.Vector

    import           Diagrams.Align
    import           Diagrams.Core
    import           Diagrams.Core.Transform
    import           Diagrams.Parametric

    import           Data.Serialize          (Serialize)
    import           GHC.Generics            (Generic)

    -- | \"Located\" things, /i.e./ things with a concrete location:
    --   intuitively, @Located a ~ (Point, a)@.  Wrapping a translationally
    --   invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins
    --   it down to a particular location and makes it no longer
    --   translationally invariant.
    --
    --   @Located@ is intentionally abstract.  To construct @Located@
    --   values, use 'at'.  To destruct, use 'viewLoc', 'unLoc', or 'loc'.
    --   To map, use 'mapLoc'.
    --
    --   Much of the utility of having a concrete type for the @Located@
    --   concept lies in the type class instances we can give it.  The
    --   'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and
    --   'TrailLike' instances are particularly useful; see the documented
    --   instances below for more information.
    data Located a =
      Loc { Located a -> Point (V a) (N a)
    loc   :: Point (V a) (N a)  -- ^ Project out the
                                    --   location of a @Located@
                                    --   value.
          , Located a -> a
    unLoc :: a              -- ^ Project the value
                                    --   of type @a@ out of
                                    --   a @Located a@,
                                    --   discarding the
                                    --   location.
          } deriving ((forall x. Located a -> Rep (Located a) x)
    -> (forall x. Rep (Located a) x -> Located a)
    -> Generic (Located a)
    forall x. Rep (Located a) x -> Located a
    forall x. Located a -> Rep (Located a) x
    forall a.
    (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
    forall a x. Rep (Located a) x -> Located a
    forall a x. Located a -> Rep (Located a) x
    $cto :: forall a x. Rep (Located a) x -> Located a
    $cfrom :: forall a x. Located a -> Rep (Located a) x
    Generic)

    instance (Serialize a, Serialize (V a (N a))) => Serialize (Located a)

    infix 5 `at`

    -- | Construct a @Located a@ from a value of type @a@ and a location.
    --   @at@ is intended to be used infix, like @x \`at\` origin@.
    at :: a -> Point (V a) (N a) -> Located a
    at :: a -> Point (V a) (N a) -> Located a
    at a :: a
    a p :: Point (V a) (N a)
    p = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    p a
    a

    -- | Deconstruct a @Located a@ into a location and a value of type
    --   @a@.  @viewLoc@ can be especially useful in conjunction with the
    --   @ViewPatterns@ extension.
    viewLoc :: Located a -> (Point (V a) (N a), a)
    viewLoc :: Located a -> (Point (V a) (N a), a)
    viewLoc (Loc p :: Point (V a) (N a)
    p a :: a
    a) = (Point (V a) (N a)
    p,a
    a)

    -- | 'Located' is not a @Functor@, since changing the type could
    --   change the type of the associated vector space, in which case the
    --   associated location would no longer have the right type. 'mapLoc'
    --   has an extra constraint specifying that the vector space must
    --   stay the same.
    --
    --   (Technically, one can say that for every vector space @v@,
    --   @Located@ is a little-f (endo)functor on the category of types
    --   with associated vector space @v@; but that is not covered by the
    --   standard @Functor@ class.)
    mapLoc :: SameSpace a b => (a -> b) -> Located a -> Located b
    mapLoc :: (a -> b) -> Located a -> Located b
    mapLoc f :: a -> b
    f (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Point (V b) (N b) -> b -> Located b
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    Point (V b) (N b)
    p (a -> b
    f a
    a)

    -- | A lens giving access to the object within a 'Located' wrapper.
    located :: SameSpace a b => Lens (Located a) (Located b) a b
    located :: Lens (Located a) (Located b) a b
    located f :: a -> f b
    f (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Point (V b) (N b) -> b -> Located b
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    Point (V b) (N b)
    p (b -> Located b) -> f b -> f (Located b)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> a -> f b
    f a
    a

    -- | Lens onto the location of something 'Located'.
    _loc :: Lens' (Located a) (Point (V a) (N a))
    _loc :: (Point (V a) (N a) -> f (Point (V a) (N a)))
    -> Located a -> f (Located a)
    _loc f :: Point (V a) (N a) -> f (Point (V a) (N a))
    f (Loc p :: Point (V a) (N a)
    p a :: a
    a) = (Point (V a) (N a) -> a -> Located a)
    -> a -> Point (V a) (N a) -> Located a
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc a
    a (Point (V a) (N a) -> Located a)
    -> f (Point (V a) (N a)) -> f (Located a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Point (V a) (N a) -> f (Point (V a) (N a))
    f Point (V a) (N a)
    p

    deriving instance (Eq   (V a (N a)), Eq a  ) => Eq   (Located a)
    deriving instance (Ord  (V a (N a)), Ord a ) => Ord  (Located a)

    instance (Show (V a (N a)), Show a) => Show (Located a) where
      showsPrec :: Int -> Located a -> ShowS
    showsPrec d :: Int
    d (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Bool -> ShowS -> ShowS
    showParen (Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 5) (ShowS -> ShowS) -> ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $
        Int -> a -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec 6 a
    a ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString " `at` " ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Point (V a) (N a) -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec 6 Point (V a) (N a)
    p

    instance (Read (V a (N a)), Read a) => Read (Located a) where
      readPrec :: ReadPrec (Located a)
    readPrec = ReadPrec (Located a) -> ReadPrec (Located a)
    forall a. ReadPrec a -> ReadPrec a
    parens (ReadPrec (Located a) -> ReadPrec (Located a))
    -> (ReadPrec (Located a) -> ReadPrec (Located a))
    -> ReadPrec (Located a)
    -> ReadPrec (Located a)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> ReadPrec (Located a) -> ReadPrec (Located a)
    forall a. Int -> ReadPrec a -> ReadPrec a
    prec 5 (ReadPrec (Located a) -> ReadPrec (Located a))
    -> ReadPrec (Located a) -> ReadPrec (Located a)
    forall a b. (a -> b) -> a -> b
    $ do
        a
    a <- ReadPrec a
    forall a. Read a => ReadPrec a
    readPrec
        Punc "`"   <- ReadPrec Lexeme
    lexP
        Ident "at" <- ReadPrec Lexeme
    lexP
        Punc "`"   <- ReadPrec Lexeme
    lexP
        Point (V a) (N a)
    p <- ReadPrec (Point (V a) (N a))
    forall a. Read a => ReadPrec a
    readPrec
        Located a -> ReadPrec (Located a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    p a
    a)

    type instance V (Located a) = V a
    type instance N (Located a) = N a

    -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not.
    --   In particular, translating a @Located a@ simply translates the
    --   associated point (and does /not/ affect the value of type @a@).
    instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where
      moveOriginTo :: Point (V (Located a)) (N (Located a)) -> Located a -> Located a
    moveOriginTo o :: Point (V (Located a)) (N (Located a))
    o (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc (Point (V (Point (V a) (N a))) (N (Point (V a) (N a)))
    -> Point (V a) (N a) -> Point (V a) (N a)
    forall t. HasOrigin t => Point (V t) (N t) -> t -> t
    moveOriginTo Point (V (Point (V a) (N a))) (N (Point (V a) (N a)))
    Point (V (Located a)) (N (Located a))
    o Point (V a) (N a)
    p) a
    a

    -- | Applying a transformation @t@ to a @Located a@ results in the
    --   transformation being applied to the location, and the /linear/
    --   /portion/ of @t@ being applied to the value of type @a@ (/i.e./
    --   it is not translated).
    instance (Additive (V a), Num (N a), Transformable a) => Transformable (Located a) where
      transform :: Transformation (V (Located a)) (N (Located a))
    -> Located a -> Located a
    transform t :: Transformation (V (Located a)) (N (Located a))
    t@(Transformation t1 :: V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
    t1 t2 :: V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
    t2 _) (Loc p :: Point (V a) (N a)
    p a :: a
    a)
        = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc (Transformation (V (Point (V a) (N a))) (N (Point (V a) (N a)))
    -> Point (V a) (N a) -> Point (V a) (N a)
    forall t. Transformable t => Transformation (V t) (N t) -> t -> t
    transform Transformation (V (Point (V a) (N a))) (N (Point (V a) (N a)))
    Transformation (V (Located a)) (N (Located a))
    t Point (V a) (N a)
    p) (Transformation (V a) (N a) -> a -> a
    forall t. Transformable t => Transformation (V t) (N t) -> t -> t
    transform ((V a (N a) :-: V a (N a))
    -> (V a (N a) :-: V a (N a))
    -> V a (N a)
    -> Transformation (V a) (N a)
    forall (v :: * -> *) n.
    (v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
    Transformation V a (N a) :-: V a (N a)
    V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
    t1 V a (N a) :-: V a (N a)
    V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
    t2 V a (N a)
    forall (f :: * -> *) a. (Additive f, Num a) => f a
    zero) a
    a)

    -- | The envelope of a @Located a@ is the envelope of the @a@,
    --   translated to the location.
    instance Enveloped a => Enveloped (Located a) where
      getEnvelope :: Located a -> Envelope (V (Located a)) (N (Located a))
    getEnvelope (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Point (V a) (N a) -> Envelope (V a) (N a) -> Envelope (V a) (N a)
    forall (v :: * -> *) n t.
    (InSpace v n t, HasOrigin t) =>
    Point v n -> t -> t
    moveTo Point (V a) (N a)
    p (a -> Envelope (V a) (N a)
    forall a. Enveloped a => a -> Envelope (V a) (N a)
    getEnvelope a
    a)

    instance Enveloped a => Juxtaposable (Located a) where
      juxtapose :: Vn (Located a) -> Located a -> Located a -> Located a
    juxtapose = Vn (Located a) -> Located a -> Located a -> Located a
    forall a. (Enveloped a, HasOrigin a) => Vn a -> a -> a -> a
    juxtaposeDefault

    -- | The trace of a @Located a@ is the trace of the @a@,
    --   translated to the location.
    instance (Traced a, Num (N a)) => Traced (Located a) where
      getTrace :: Located a -> Trace (V (Located a)) (N (Located a))
    getTrace (Loc p :: Point (V a) (N a)
    p a :: a
    a) = Point (V a) (N a) -> Trace (V a) (N a) -> Trace (V a) (N a)
    forall (v :: * -> *) n t.
    (InSpace v n t, HasOrigin t) =>
    Point v n -> t -> t
    moveTo Point (V a) (N a)
    p (a -> Trace (V a) (N a)
    forall a. Traced a => a -> Trace (V a) (N a)
    getTrace a
    a)

    instance Alignable a => Alignable (Located a) where
      defaultBoundary :: v n -> Located a -> Point v n
    defaultBoundary v :: v n
    v = v n -> a -> Point v n
    forall a (v :: * -> *) n.
    (Alignable a, V a ~ v, N a ~ n) =>
    v n -> a -> Point v n
    defaultBoundary v n
    v (a -> Point v n) -> (Located a -> a) -> Located a -> Point v n
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Located a -> a
    forall a. Located a -> a
    unLoc

    instance Qualifiable a => Qualifiable (Located a) where
      n :: a
    n .>> :: a -> Located a -> Located a
    .>> Loc p :: Point (V a) (N a)
    p a :: a
    a = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    p (a
    n a -> a -> a
    forall q a. (Qualifiable q, IsName a) => a -> q -> q
    .>> a
    a)

    type instance Codomain (Located a) = Point (Codomain a)

    instance (InSpace v n a, Parametric a, Codomain a ~ v)
        => Parametric (Located a) where
      Loc x :: Point (V a) (N a)
    x a :: a
    a atParam :: Located a -> N (Located a) -> Codomain (Located a) (N (Located a))
    `atParam` p :: N (Located a)
    p = Point v n
    Point (V a) (N a)
    x Point v n -> Diff (Point v) n -> Point v n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
    .+^ (a
    a a -> N a -> Codomain a (N a)
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` N a
    N (Located a)
    p)

    instance DomainBounds a => DomainBounds (Located a) where
      domainLower :: Located a -> N (Located a)
    domainLower (Loc _ a :: a
    a) = a -> N a
    forall p. DomainBounds p => p -> N p
    domainLower a
    a
      domainUpper :: Located a -> N (Located a)
    domainUpper (Loc _ a :: a
    a) = a -> N a
    forall p. DomainBounds p => p -> N p
    domainUpper a
    a

    instance (InSpace v n a, EndValues a, Codomain a ~ v) => EndValues (Located a)

    instance (InSpace v n a, Fractional n, Parametric a, Sectionable a, Codomain a ~ v)
        => Sectionable (Located a) where
      splitAtParam :: Located a -> N (Located a) -> (Located a, Located a)
    splitAtParam (Loc x :: Point (V a) (N a)
    x a :: a
    a) p :: N (Located a)
    p = (Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc Point (V a) (N a)
    x a
    a1, Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc (Point v n
    Point (V a) (N a)
    x Point v n -> Diff (Point v) n -> Point v n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
    .+^ (a
    a a -> N a -> Codomain a (N a)
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` N a
    N (Located a)
    p)) a
    a2)
        where (a1 :: a
    a1,a2 :: a
    a2) = a -> N a -> (a, a)
    forall p. Sectionable p => p -> N p -> (p, p)
    splitAtParam a
    a N a
    N (Located a)
    p

      section :: Located a -> N (Located a) -> N (Located a) -> Located a
    section (Loc x :: Point (V a) (N a)
    x a :: a
    a) p1 :: N (Located a)
    p1 p2 :: N (Located a)
    p2 = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc (Point v n
    Point (V a) (N a)
    x Point v n -> Diff (Point v) n -> Point v n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
    .+^ (a
    a a -> N a -> Codomain a (N a)
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` N a
    N (Located a)
    p1)) (a -> N a -> N a -> a
    forall p. Sectionable p => p -> N p -> N p -> p
    section a
    a N a
    N (Located a)
    p1 N a
    N (Located a)
    p2)

      reverseDomain :: Located a -> Located a
    reverseDomain (Loc x :: Point (V a) (N a)
    x a :: a
    a) = Point (V a) (N a) -> a -> Located a
    forall a. Point (V a) (N a) -> a -> Located a
    Loc (Point v n
    Point (V a) (N a)
    x Point v n -> Diff (Point v) n -> Point v n
    forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
    .+^ Diff (Point v) n
    Codomain a (N a)
    y) (a -> a
    forall p. Sectionable p => p -> p
    reverseDomain a
    a)
        where y :: Codomain a (N a)
    y = a
    a a -> N a -> Codomain a (N a)
    forall p. Parametric p => p -> N p -> Codomain p (N p)
    `atParam` a -> N a
    forall p. DomainBounds p => p -> N p
    domainUpper a
    a

    instance (InSpace v n a, Fractional n, HasArcLength a, Codomain a ~ v)
        => HasArcLength (Located a) where
      arcLengthBounded :: N (Located a) -> Located a -> Interval (N (Located a))
    arcLengthBounded eps :: N (Located a)
    eps (Loc _ a :: a
    a) = N a -> a -> Interval (N a)
    forall p. HasArcLength p => N p -> p -> Interval (N p)
    arcLengthBounded N a
    N (Located a)
    eps a
    a
      arcLengthToParam :: N (Located a) -> Located a -> N (Located a) -> N (Located a)
    arcLengthToParam eps :: N (Located a)
    eps (Loc _ a :: a
    a) = N a -> a -> N a -> N a
    forall p. HasArcLength p => N p -> p -> N p -> N p
    arcLengthToParam N a
    N (Located a)
    eps a
    a