{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Located
-- Copyright : (c) 2013 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, unLoc, loc, mapLoc, located
)
where
import Control.Lens (Lens)
import Data.AffineSpace
import Data.Functor ((<$>))
import Data.VectorSpace
import Diagrams.Core
import Diagrams.Core.Points ()
import Diagrams.Core.Transform
import Diagrams.Parametric
-- for GHC 7.4 type family bug
-- | \"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) -- ^ 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) -> 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), 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 :: (V a ~ V 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 :: (V a ~ V a') => Lens (Located a) (Located a') a a'
located f (Loc p a) = Loc p <$> f a
deriving instance (Eq (V a), Eq a ) => Eq (Located a)
deriving instance (Ord (V a), Ord a ) => Ord (Located a)
deriving instance (Show (V a), Show a) => Show (Located a)
type instance V (Located a) = V 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 VectorSpace (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 Transformable a => Transformable (Located a) where
transform t@(Transformation t1 t2 _) (Loc p a)
= Loc (transform t p) (transform (Transformation t1 t2 zeroV) 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 => 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 (Codomain a ~ V a, AdditiveGroup (V a), Parametric a)
=> 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 (Codomain a ~ V a, AdditiveGroup (V a), EndValues a)
=> EndValues (Located a)
instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a)
, Sectionable a, Parametric a
)
=> 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 ( Codomain a ~ V a, AdditiveGroup (V a), Fractional (Scalar (V a))
, HasArcLength a
)
=> HasArcLength (Located a) where
arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a
arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l