{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- 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.Align
import Diagrams.Core
import Diagrams.Core.Transform
import Diagrams.Parametric
import GHC.Generics (Generic)
import Data.Serialize (Serialize)
-- | \"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.
} deriving (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 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 Alignable a => Alignable (Located a) where
defaultBoundary v = defaultBoundary v . unLoc
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