{-# 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