Located.hs

{-# LANGUAGE CPP                   #-}
{-# 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')
#if __GLASGOW_HASKELL__ < 710
import           Data.Functor            ((<$>))
#endif
import           Text.Read

import           Linear.Affine
import           Linear.Vector

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

-- | \"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 { loc   :: Point (V a) (N a)  -- ^ Project out the
                                --   location of a @Located@
                                --   value.
      , unLoc :: a              -- ^ Project the value
                                --   of type @a@ out of
                                --   a @Located a@,
                                --   discarding the
                                --   location.
      }

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 p = Loc p 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 (Loc p a) = (p,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 f (Loc p a) = Loc p (f a)

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

-- | Lens onto the location of something 'Located'.
_loc :: Lens' (Located a) (Point (V a) (N a))
_loc f (Loc p a) = flip Loc a <$> f 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 d (Loc p a) = showParen (d > 5) $
    showsPrec 6 a . showString " `at` " . showsPrec 6 p

instance (Read (V a (N a)), Read a) => Read (Located a) where
  readPrec = parens . prec 5 $ do
    a <- readPrec
    Punc "`"   <- lexP
    Ident "at" <- lexP
    Punc "`"   <- lexP
    p <- readPrec
    return (Loc p 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 o (Loc p a) = Loc (moveOriginTo o p) 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 t@(Transformation t1 t2 _) (Loc p a)
    = Loc (transform t p) (transform (Transformation t1 t2 zero) 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 (Loc p a) = moveTo p (getEnvelope a)

instance Enveloped a => Juxtaposable (Located a) where
  juxtapose = 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 (Loc p a) = moveTo p (getTrace a)

instance Qualifiable a => Qualifiable (Located a) where
  n .>> Loc p a = Loc p (n .>> 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 a `atParam` p = x .+^ (a `atParam` p)

instance DomainBounds a => DomainBounds (Located a) where
  domainLower (Loc _ a) = domainLower a
  domainUpper (Loc _ a) = domainUpper 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 (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2)
    where (a1,a2) = splitAtParam a p

  reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a)
    where y = a `atParam` domainUpper a

instance (InSpace v n a, Fractional n, HasArcLength a, Codomain a ~ v)
    => HasArcLength (Located a) where
  arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a
  arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a