{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# 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 { forall a. Located a -> Point (V a) (N a)
loc   :: Point (V a) (N a)  -- ^ Project out the
                                --   location of a @Located@
                                --   value.
      , forall a. Located a -> a
unLoc :: a              -- ^ Project the value
                                --   of type @a@ out of
                                --   a @Located a@,
                                --   discarding the
                                --   location.
      } deriving (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 :: forall a. a -> Point (V a) (N a) -> Located a
at a
a Point (V a) (N a)
p = 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 :: forall a. Located a -> (Point (V a) (N a), a)
viewLoc (Loc Point (V a) (N a)
p 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 :: forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc a -> b
f (Loc Point (V a) (N a)
p a
a) = forall a. Point (V a) (N a) -> a -> Located a
Loc Point (V a) (N a)
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 :: forall a b. SameSpace a b => Lens (Located a) (Located b) a b
located a -> f b
f (Loc Point (V a) (N a)
p a
a) = forall a. Point (V a) (N a) -> a -> Located a
Loc Point (V a) (N a)
p 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 :: forall a. Lens' (Located a) (Point (V a) (N a))
_loc Point (V a) (N a) -> f (Point (V a) (N a))
f (Loc Point (V a) (N a)
p a
a) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Point (V a) (N a) -> a -> Located a
Loc a
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 Int
d (Loc Point (V a) (N a)
p a
a) = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
5) forall a b. (a -> b) -> a -> b
$
    forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" `at` " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 Point (V a) (N a)
p

instance (Read (V a (N a)), Read a) => Read (Located a) where
  readPrec :: ReadPrec (Located a)
readPrec = forall a. ReadPrec a -> ReadPrec a
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
5 forall a b. (a -> b) -> a -> b
$ do
    a
a <- forall a. Read a => ReadPrec a
readPrec
    Punc String
"`"   <- ReadPrec Lexeme
lexP
    Ident String
"at" <- ReadPrec Lexeme
lexP
    Punc String
"`"   <- ReadPrec Lexeme
lexP
    Point (V a) (N a)
p <- forall a. Read a => ReadPrec a
readPrec
    forall (m :: * -> *) a. Monad m => a -> m a
return (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 Point (V (Located a)) (N (Located a))
o (Loc Point (V a) (N a)
p a
a) = forall a. Point (V a) (N a) -> a -> Located a
Loc (forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo 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 V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
t1 V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
t2 V (Located a) (N (Located a))
_) (Loc Point (V a) (N a)
p a
a)
    = forall a. Point (V a) (N a) -> a -> Located a
Loc (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Located a)) (N (Located a))
t Point (V a) (N a)
p) (forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (forall (v :: * -> *) n.
(v n :-: v n) -> (v n :-: v n) -> v n -> Transformation v n
Transformation V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
t1 V (Located a) (N (Located a)) :-: V (Located a) (N (Located a))
t2 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 Point (V a) (N a)
p a
a) = forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo Point (V a) (N a)
p (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 = 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 Point (V a) (N a)
p a
a) = forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo Point (V a) (N a)
p (forall a. Traced a => a -> Trace (V a) (N a)
getTrace a
a)

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

instance Qualifiable a => Qualifiable (Located a) where
  a
n .>> :: forall a. IsName a => a -> Located a -> Located a
.>> Loc Point (V a) (N a)
p a
a = forall a. Point (V a) (N a) -> a -> Located a
Loc Point (V a) (N a)
p (a
n 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 Point (V a) (N a)
x a
a atParam :: Located a -> N (Located a) -> Codomain (Located a) (N (Located a))
`atParam` N (Located a)
p = Point (V a) (N a)
x forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (a
a forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` N (Located a)
p)

instance DomainBounds a => DomainBounds (Located a) where
  domainLower :: Located a -> N (Located a)
domainLower (Loc Point (V a) (N a)
_ a
a) = forall p. DomainBounds p => p -> N p
domainLower a
a
  domainUpper :: Located a -> N (Located a)
domainUpper (Loc Point (V a) (N a)
_ a
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 Point (V a) (N a)
x a
a) N (Located a)
p = (forall a. Point (V a) (N a) -> a -> Located a
Loc Point (V a) (N a)
x a
a1, forall a. Point (V a) (N a) -> a -> Located a
Loc (Point (V a) (N a)
x forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (a
a forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` N (Located a)
p)) a
a2)
    where (a
a1,a
a2) = forall p. Sectionable p => p -> N p -> (p, p)
splitAtParam a
a N (Located a)
p

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

  reverseDomain :: Located a -> Located a
reverseDomain (Loc Point (V a) (N a)
x a
a) = forall a. Point (V a) (N a) -> a -> Located a
Loc (Point (V a) (N a)
x forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Codomain a (N a)
y) (forall p. Sectionable p => p -> p
reverseDomain a
a)
    where y :: Codomain a (N a)
y = a
a forall p. Parametric p => p -> N p -> Codomain p (N p)
`atParam` 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 N (Located a)
eps (Loc Point (V a) (N a)
_ a
a) = forall p. HasArcLength p => N p -> p -> Interval (N p)
arcLengthBounded N (Located a)
eps a
a
  arcLengthToParam :: N (Located a) -> Located a -> N (Located a) -> N (Located a)
arcLengthToParam N (Located a)
eps (Loc Point (V a) (N a)
_ a
a) = forall p. HasArcLength p => N p -> p -> N p -> N p
arcLengthToParam N (Located a)
eps a
a