diagrams-core-0.7.0.1/0000755000000000000000000000000012221174047012560 5ustar0000000000000000diagrams-core-0.7.0.1/Setup.hs0000644000000000000000000000005612221174047014215 0ustar0000000000000000import Distribution.Simple main = defaultMain diagrams-core-0.7.0.1/diagrams-core.cabal0000644000000000000000000000503412221174047016263 0ustar0000000000000000Name: diagrams-core Version: 0.7.0.1 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language for compositional, declarative drawing. Homepage: http://projects.haskell.org/diagrams License: BSD3 License-file: LICENSE Author: Brent Yorgey Maintainer: diagrams-discuss@googlegroups.com Bug-reports: https://github.com/diagrams/diagrams-core/issues Category: Graphics Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown Tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git location: git://github.com/diagrams/diagrams-core.git Library Exposed-modules: Diagrams.Core, Diagrams.Core.Envelope, Diagrams.Core.HasOrigin, Diagrams.Core.Juxtapose, Diagrams.Core.Names, Diagrams.Core.Points, Diagrams.Core.Style, Diagrams.Core.Trace, Diagrams.Core.Transform, Diagrams.Core.Types, Diagrams.Core.V, Diagrams.Core.Query Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.12, vector-space >= 0.8.4 && < 0.9, vector-space-points >= 0.1 && < 0.2, MemoTrie >= 0.4.7 && < 0.7, newtype >= 0.2 && < 0.3, monoid-extras >= 0.3 && < 0.4, dual-tree >= 0.1 && < 0.2 hs-source-dirs: src Other-extensions: DeriveDataTypeable EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverlappingInstances ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances Default-language: Haskell2010 diagrams-core-0.7.0.1/README.markdown0000644000000000000000000000050712221174047015263 0ustar0000000000000000[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-core.png)](http://travis-ci.org/diagrams/diagrams-core) The core modules defining the basic data structures and algorithms for [diagrams](http://projects.haskell.org/diagrams), a Haskell embedded domain-specific language for compositional, declarative drawing. diagrams-core-0.7.0.1/LICENSE0000644000000000000000000000345012221174047013567 0ustar0000000000000000Copyright (c) 2011-2013 diagrams-core team: Daniel Bergey Conal Elliott Sam Griffin Vilhelm Sjöberg Michael Sloan Scott Walck Ryan Yates Brent Yorgey All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Brent Yorgey nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diagrams-core-0.7.0.1/CHANGES.markdown0000644000000000000000000002001512221174047015372 0ustar00000000000000000.7.0.1 (26 September 2013) --------------------------- allow semigroups-0.11 0.7: 9 August 2013 ------------------ * **New features** - new function `onBasis`, to extract the matrix equivalent of a `Transformation` - `SubMap`s are now `Deletable` - new function `localize` for hiding/deleting names from scope - new `IsPrim` class, containing `transformWithFreeze` function. This is primarily intended to support scale-invariant primitives (*e.g.* arrowheads) but may be useful for other stuff as well. The default implementation of `renderDia` now uses `transformWithFreeze`. - optimized `Transformable` instance for `TransInv` * **New instances** - `Eq`, `Ord`, `Enveloped`, `Traced`, and `Qualifiable` instances for `TransInv` - `Transformable` instance for functions, which acts by conjugation * **API changes** - `named` and `namePoint` have moved to the `diagrams-lib` package. * **Dependency/version changes** - allow `base-4.7` - upgrade to `monoid-extras-0.3` 0.6.0.2: 5 March 2013 --------------------- * bug fix: the 'diameter' and 'radius' functions now work correctly. 0.6.0.1: 7 January 2013 ----------------------- * allow `semigroups-0.9` 0.6: 11 December 2012 --------------------- * **New features** - Proper support for subdiagrams: previous versions of diagrams-core had a mechanism for associating names with a pair of a location and an envelope. Now, names are associated with actual subdiagrams (including their location and envelope, along with all the other information stored by a diagram). See [`Diagrams.Core.Types`](https://github.com/diagrams/diagrams-core/blob/27b275f45cad514caefcd3035e4e261f1b4adf6f/src/Diagrams/Core/Types.hs#L493). - Traces: in addition to an envelope, each diagram now stores a "trace", which is like an embedded raytracer: given any ray (represented by a base point and a vector), the trace computes the closest point of intersection with the diagram along the ray. This is useful for determining points on the boundary of a diagram, *e.g.* when drawing arrows between diagrams. See [`Diagrams.Core.Trace`](https://github.com/diagrams/diagrams-core/blob/2f8727fdfa60cdf46456a23f358c8a771b2cd90d/src/Diagrams/Core/Trace.hs). * **API changes** - The modules have all been renamed to be more consistent with the module naming scheme in the rest of the diagrams universe. In particular: `Graphics.Rendering.Diagrams` --> `Diagrams.Core` `Grahpics.Rendering.Diagrams.Core` --> `Diagrams.Core.Types` `Graphics.Rendering.Diagrams.*` --> `Diagrams.Core.*` - `Graphics.Rendering.Diagrams.UDTree` has been split out into a separate [`dual-tree`](http://hackage.haskell.org/package/dual%2Dtree) package (which has also been substantially rewritten). - `Graphics.Rendering.Diagrams.{Monoids,MList}` have been split out into a separate [`monoid-extras`](http://hackage.haskell.org/package/monoid%2Dextras) package. - The `names` function now returns a list of names and their associated locations, instead of the associated subdiagrams. In particular the output is suitable to be rendered to a `String` using `show`. - The new `subMap` function fills a similar role that `names` used to play, returning the entire mapping from names to subdiagrams. - New functions `envelope[VP]May` `envelopeV` and `envelopeP` return the zero vector and origin, respectively, when called on an empty envelope. However, sometimes it's useful to actually know whether the envelope was empty or not (the zero vector and the origin are legitimate outputs from non-empty envelopes). The new functions have their return type wrapped in `Maybe` for this purpose. - New functions `envelopeS` and `envelopeSMay` Like `envelope[VP](May)`, but returning a scalar multiple of the input vector. - The `Graphics.Rendering.Diagrams.Util` module has been removed, along with the `withLength` function. Calls to `withLength` can be replaced using `withLength s v = s *^ normalized v` - Add needed constraints `(InnerSpace v, OrderedField (Scalar v), Monoid' m)` to the type of the `renderDias` method in the `MultiBackend` class. - Generalized `Transformable` instances for pairs and tuples Previously, the components of the tuples were required to have the same type; but everything still works as long as they all share the same vector space. This is actually useful in practice: say, if we wanted to pair a diagram with a path and then apply the same transformation to both. * **Improvements** - More efficient implementation of `diameter` * **Dependency/version changes** - Tested with GHC 7.6.1 - allow `base-4.6` - allow `containers-0.5.*` - allow `MemoTrie-0.6.1` * **Bug fixes** - juxtaposeDefault now correctly handles empty envelopes (#37) `juxtaposeDefault` is now the identity on the second object if either one has an empty envelope. In particular this means that `mempty` is now an identity element for `beside` and friends. 0.5.0.1: 11 May 2012 -------------------- * Update `MemoTrie` upper bound to allow `MemoTrie-0.5` 0.5: 9 March 2012 ----------------- * New features: - New `Juxtaposable` class - New `NullBackend` and `D` types, for conveniently giving a monomorphic type to diagrams when we don't care which one it is. - [\#27](http://code.google.com/p/diagrams/issues/detail?id=27): Change type of `adjustDia` to return a new options record (with an explicitly filled-in size) * New instances: - `Enveloped`, `HasOrigin`, `Juxtaposable`, `HasStyle`, and `Transformable` instances for `Set`s and tuples - `V Double = Double` - `Juxtaposable` and `Boundable` instances for `Map` * API changes - `AnnDiagram` renamed to `QDiagram` - [\#61](http://code.google.com/p/diagrams/issues/detail?id=61): terminology change from "bounds" to "envelope" + `boundary` -> `envelopeP` + "bounding region" -> "envelope" + `Bounds` -> `Envelope` + `Boundable` -> `Enveloped` + `getBounds` -> `getEnvelope` + *etc.* - Split out definition of `Point` into separate package ([`vector-space-points`](http://hackage.haskell.org/package/vector%2Dspace%2Dpoints)) - The `Point` constructor `P` is no longer exported from `Graphics.Rendering.Diagrams`. See the `Diagrams.TwoD.Types` module from `diagrams-lib` for new tools for working with abstract 2D points. If you really need the `P` constructor, import `Graphics.Rendering.Diagrams.Points`. - Name-related functions now return "located bounding functions" instead of pairs of points and bounds, to allow for future expansion. * Dependency/version changes: - `vector-space` 0.8 is now required. - Bump base upper bound to allow 4.5; now tested with GHC 7.4.1. * Bug fixes: - Bug fix related to empty envelopes 0.4: 23 October 2011 -------------------- * improved documentation * a few new instances (Newtype Point, Boundable Point) * new functions (value, clearValue, resetValue) for working with alternate query monoids 0.3: 18 June 2011 ----------------- * big overhaul of name maps: - allow arbitrary types as atomic names - carry along bounding functions as well as names in NameMaps - additional functions for querying information associated with names * fix for issue #34 (fix behavior of setBounds) * Transformable and HasOrigin instances for Transformations 0.2: 3 June 2011 ---------------- * bounding regions can now be overridden * new namePoint function for more flexibly assigning names to arbitrary points * add HasStyle, Boundable, and HasOrigin instances for lists * add a "trivial backend" * transformable attributes 0.1.1: 18 May 2011 ------------------ * link to new website 0.1: 17 May 2011 ---------------- * initial preview release diagrams-core-0.7.0.1/src/0000755000000000000000000000000012221174047013347 5ustar0000000000000000diagrams-core-0.7.0.1/src/Diagrams/0000755000000000000000000000000012221174047015076 5ustar0000000000000000diagrams-core-0.7.0.1/src/Diagrams/Core.hs0000644000000000000000000000755112221174047016332 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The core library of primitives forming the basis of an embedded -- domain-specific language for describing and rendering diagrams. -- Normal users of the diagrams library should almost never need to -- import anything from this package directly; instead, import modules -- (especially "Diagrams.Prelude") from the diagrams-lib package, -- which re-exports most things of value to users. -- -- For most library code needing access to core internals, it should -- be sufficient to import this module, which simply re-exports useful -- functionality from other modules in the core library. Library -- writers needing finer-grained access or functionality may -- occasionally find it useful to directly import one of the -- constituent core modules. -- ----------------------------------------------------------------------------- module Diagrams.Core ( -- * Associated vector spaces V -- * Points , Point, origin, (*.) -- * Transformations -- ** Invertible linear transformations , (:-:), (<->), linv, lapp -- ** General transformations , Transformation , inv, transp, transl , apply , papply , fromLinear -- ** Some specific transformations , translation, translate, moveTo, place , scaling, scale -- ** The Transformable class , Transformable(..) -- ** Translational invariance , TransInv(..) -- * Names , AName , Name, IsName(..) , Qualifiable(..), (.>) -- ** Subdiagram maps , SubMap(..) , fromNames , rememberAs , lookupSub -- * Attributes and styles , AttributeClass , Attribute, mkAttr, mkTAttr, unwrapAttr , Style, HasStyle(..) , getAttr, combineAttr , applyAttr, applyTAttr -- * Envelopes , Envelope , inEnvelope, appEnvelope, onEnvelope, mkEnvelope , Enveloped(..) , envelopeVMay, envelopeV, envelopePMay, envelopeP , diameter, radius -- * Traces , Trace(..) , inTrace, mkTrace , Traced(..) , traceV, traceP , maxTraceV, maxTraceP -- * Things with local origins , HasOrigin(..), moveOriginBy -- * Juxtaposable things , Juxtaposable(..), juxtaposeDefault -- * Queries , Query(..) -- * Primtives , Prim(..), IsPrim(..), nullPrim -- * Diagrams , QDiagram, mkQD, Diagram , prims , envelope, trace, subMap, names, query, sample , value, resetValue, clearValue , nameSub , withName , withNameAll , withNames , localize , freeze, setEnvelope, setTrace , atop -- ** Subdiagrams , Subdiagram(..), mkSubdiagram , getSub, rawSub , location , subPoint -- * Backends , Backend(..) , MultiBackend(..) , Renderable(..) -- ** The null backend , NullBackend, D -- * Convenience classes , HasLinearMap , OrderedField , Monoid' ) where import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin import Diagrams.Core.Juxtapose import Diagrams.Core.Names import Diagrams.Core.Points import Diagrams.Core.Query import Diagrams.Core.Style import Diagrams.Core.Trace import Diagrams.Core.Transform import Diagrams.Core.Types import Diagrams.Core.V import Data.Monoid.WithSemigroup (Monoid') diagrams-core-0.7.0.1/src/Diagrams/Core/0000755000000000000000000000000012221174047015766 5ustar0000000000000000diagrams-core-0.7.0.1/src/Diagrams/Core/Points.hs0000644000000000000000000000142512221174047017600 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Points -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A type for /points/ (as distinct from vectors). -- ----------------------------------------------------------------------------- module Diagrams.Core.Points ( -- * Points Point(..), origin, (*.) ) where -- We just import from Data.AffineSpace.Point (defined in the -- vector-space-points package) and re-export. We also define an -- instance of V for Point here. import Data.AffineSpace.Point import Diagrams.Core.V type instance V (Point v) = vdiagrams-core-0.7.0.1/src/Diagrams/Core/Juxtapose.hs0000644000000000000000000000473712221174047020317 0ustar0000000000000000{-# LANGUAGE FlexibleContexts , UndecidableInstances , TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Juxtapose -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Things which can be placed \"next to\" other things, for some -- appropriate notion of \"next to\". -- ----------------------------------------------------------------------------- module Diagrams.Core.Juxtapose ( Juxtaposable(..), juxtaposeDefault ) where import Data.Functor ((<$>)) import qualified Data.Map as M import qualified Data.Set as S import Data.VectorSpace import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin import Diagrams.Core.V -- | Class of things which can be placed \"next to\" other things, for some -- appropriate notion of \"next to\". class Juxtaposable a where -- | @juxtapose v a1 a2@ positions @a2@ next to @a1@ in the -- direction of @v@. In particular, place @a2@ so that @v@ points -- from the local origin of @a1@ towards the old local origin of -- @a2@; @a1@'s local origin becomes @a2@'s new local origin. The -- result is just a translated version of @a2@. (In particular, -- this operation does not /combine/ @a1@ and @a2@ in any way.) juxtapose :: V a -> a -> a -> a -- | Default implementation of 'juxtapose' for things which are -- instances of 'Enveloped' and 'HasOrigin'. If either envelope is -- empty, the second object is returned unchanged. juxtaposeDefault :: (Enveloped a, HasOrigin a) => V a -> a -> a -> a juxtaposeDefault v a1 a2 = case (mv1, mv2) of (Just v1, Just v2) -> moveOriginBy (v1 ^+^ v2) a2 _ -> a2 where mv1 = negateV <$> envelopeVMay v a1 mv2 = envelopeVMay (negateV v) a2 instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Envelope v) where juxtapose = juxtaposeDefault instance (Enveloped a, HasOrigin a, Enveloped b, HasOrigin b, V a ~ V b) => Juxtaposable (a,b) where juxtapose = juxtaposeDefault instance (Enveloped b, HasOrigin b) => Juxtaposable [b] where juxtapose = juxtaposeDefault instance (Enveloped b, HasOrigin b) => Juxtaposable (M.Map k b) where juxtapose = juxtaposeDefault instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where juxtapose = juxtaposeDefaultdiagrams-core-0.7.0.1/src/Diagrams/Core/Trace.hs0000644000000000000000000001474612221174047017374 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Trace -- Copyright : (c) 2012 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- @diagrams-core@ defines the core library of primitives -- forming the basis of an embedded domain-specific language for -- describing and rendering diagrams. -- -- The @Trace@ module defines a data type and type class for -- \"traces\", aka functional boundaries, essentially corresponding to -- embedding a raytracer with each diagram. -- ----------------------------------------------------------------------------- module Diagrams.Core.Trace ( -- * Traces Trace(..) , inTrace , mkTrace -- * Traced class , Traced(..) -- * Computing with traces , traceV, traceP , maxTraceV, maxTraceP ) where import Control.Applicative import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S import Data.AffineSpace import Data.Monoid.Inf import Data.VectorSpace import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V ------------------------------------------------------------ -- Trace ------------------------------------------------- ------------------------------------------------------------ -- | Every diagram comes equipped with a /trace/. Intuitively, the -- trace for a diagram is like a raytracer: given a line -- (represented as a base point and a direction), the trace computes -- the distance from the base point along the line to the first -- intersection with the diagram. The distance can be negative if -- the intersection is in the opposite direction from the base -- point, or infinite if the ray never intersects the diagram. -- Note: to obtain the distance to the /furthest/ intersection -- instead of the /closest/, just negate the direction vector and -- then negate the result. -- -- Note that the output should actually be interpreted not as an -- absolute distance, but as a multiplier relative to the input -- vector. That is, if the input vector is @v@ and the returned -- scalar is @s@, the distance from the base point to the -- intersection is given by @s * magnitude v@. newtype Trace v = Trace { appTrace :: Point v -> v -> PosInf (Scalar v) } inTrace :: ((Point v -> v -> PosInf (Scalar v)) -> (Point v -> v -> PosInf (Scalar v))) -> Trace v -> Trace v inTrace f = Trace . f . appTrace mkTrace :: (Point v -> v -> PosInf (Scalar v)) -> Trace v mkTrace = Trace -- | Traces form a semigroup with pointwise minimum as composition. -- Hence, if @t1@ is the trace for diagram @d1@, and -- @e2@ is the trace for @d2@, then @e1 \`mappend\` e2@ -- is the trace for @d1 \`atop\` d2@. deriving instance Ord (Scalar v) => Semigroup (Trace v) -- | The identity for the 'Monoid' instance is the constantly infinite -- trace. deriving instance Ord (Scalar v) => Monoid (Trace v) type instance V (Trace v) = v instance (VectorSpace v) => HasOrigin (Trace v) where moveOriginTo (P u) = inTrace $ \f p -> f (p .+^ u) instance Show (Trace v) where show _ = "" ------------------------------------------------------------ -- Transforming traces ----------------------------------- ------------------------------------------------------------ instance HasLinearMap v => Transformable (Trace v) where transform t = inTrace $ \f p v -> f (papply (inv t) p) (apply (inv t) v) ------------------------------------------------------------ -- Traced class ------------------------------------------ ------------------------------------------------------------ -- | @Traced@ abstracts over things which have a trace. class (Ord (Scalar (V a)), VectorSpace (V a)) => Traced a where -- | Compute the trace of an object. getTrace :: a -> Trace (V a) instance (Ord (Scalar v), VectorSpace v) => Traced (Trace v) where getTrace = id -- | The trace of a single point is the empty trace, /i.e./ the one -- which returns positive infinity for every query. Arguably it -- should return a finite distance for vectors aimed directly at the -- given point and infinity for everything else, but due to -- floating-point inaccuracy this is problematic. Note that the -- envelope for a single point is /not/ the empty envelope (see -- "Diagrams.Core.Envelope"). instance (Ord (Scalar v), VectorSpace v) => Traced (Point v) where getTrace p = mempty instance Traced t => Traced (TransInv t) where getTrace = getTrace . unTransInv instance (Traced a, Traced b, V a ~ V b) => Traced (a,b) where getTrace (x,y) = getTrace x <> getTrace y instance (Traced b) => Traced [b] where getTrace = mconcat . map getTrace instance (Traced b) => Traced (M.Map k b) where getTrace = mconcat . map getTrace . M.elems instance (Traced b) => Traced (S.Set b) where getTrace = mconcat . map getTrace . S.elems ------------------------------------------------------------ -- Computing with traces --------------------------------- ------------------------------------------------------------ -- | Compute the vector from the given point to the boundary of the -- given object in the given direction, or @Nothing@ if there is no -- intersection. traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) traceV p v a = case appTrace (getTrace a) p v of Finite s -> Just (s *^ v) Infinity -> Nothing -- | Given a base point and direction, compute the closest point on -- the boundary of the given object, or @Nothing@ if there is no -- intersection in the given direction. traceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) traceP p v a = (p .+^) <$> traceV p v a -- | Like 'traceV', but computes a vector to the *furthest* point on -- the boundary instead of the closest. maxTraceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) maxTraceV p = traceV p . negateV -- | Like 'traceP', but computes the *furthest* point on the boundary -- instead of the closest. maxTraceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) maxTraceP p v a = (p .+^) <$> maxTraceV p v a diagrams-core-0.7.0.1/src/Diagrams/Core/V.hs0000644000000000000000000000302012221174047016522 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.MList -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Type family for identifying associated vector spaces. -- ----------------------------------------------------------------------------- module Diagrams.Core.V ( V ) where import Data.Map import Data.Monoid.Coproduct import Data.Monoid.Deletable import Data.Monoid.Split import Data.Semigroup import Data.Set ------------------------------------------------------------ -- Vector spaces ------------------------------------------- ------------------------------------------------------------ -- | Many sorts of objects have an associated vector space in which -- they \"live\". The type function @V@ maps from object types to -- the associated vector space. type family V a :: * type instance V Double = Double type instance V Rational = Rational -- Note, to use these instances one often needs a constraint of the form -- V a ~ V b, etc. type instance V (a,b) = V a type instance V (a,b,c) = V a type instance V (a -> b) = V b type instance V [a] = V a type instance V (Option a) = V a type instance V (Set a) = V a type instance V (Map k a) = V a type instance V (Deletable m) = V m type instance V (Split m) = V m type instance V (m :+: n) = V mdiagrams-core-0.7.0.1/src/Diagrams/Core/Query.hs0000644000000000000000000000333012221174047017426 0ustar0000000000000000{-# LANGUAGE TypeFamilies , GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Query -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The @Query@ module defines a type for \"queries\" on diagrams, which -- are functions from points in a vector space to some monoid. -- ----------------------------------------------------------------------------- module Diagrams.Core.Query ( Query(..) ) where import Control.Applicative import Data.Semigroup import Data.AffineSpace import Data.VectorSpace import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V ------------------------------------------------------------ -- Queries ----------------------------------------------- ------------------------------------------------------------ -- | A query is a function that maps points in a vector space to -- values in some monoid. Queries naturally form a monoid, with -- two queries being combined pointwise. -- -- The idea for annotating diagrams with monoidal queries came from -- the graphics-drawingcombinators package, . newtype Query v m = Query { runQuery :: Point v -> m } deriving (Functor, Applicative, Semigroup, Monoid) type instance V (Query v m) = v instance VectorSpace v => HasOrigin (Query v m) where moveOriginTo (P u) (Query f) = Query $ \p -> f (p .+^ u) instance HasLinearMap v => Transformable (Query v m) where transform t (Query f) = Query $ f . papply (inv t)diagrams-core-0.7.0.1/src/Diagrams/Core/Types.hs0000644000000000000000000010515412221174047017434 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Types -- Copyright : (c) 2011-2012 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The core library of primitives forming the basis of an embedded -- domain-specific language for describing and rendering diagrams. -- -- "Diagrams.Core.Types" defines types and classes for -- primitives, diagrams, and backends. -- ----------------------------------------------------------------------------- {- ~~~~ Note [breaking up Types module] Although it's not as bad as it used to be, this module has a lot of stuff in it, and it might seem a good idea in principle to break it up into smaller modules. However, it's not as easy as it sounds: everything in this module cyclically depends on everything else. -} module Diagrams.Core.Types ( -- * Diagrams -- ** Annotations UpAnnots, DownAnnots , QDiagram(..), mkQD, Diagram -- * Operations on diagrams -- ** Extracting information , prims , envelope, trace, subMap, names, query, sample , value, resetValue, clearValue -- ** Combining diagrams -- | For many more ways of combining diagrams, see -- "Diagrams.Combinators" from the diagrams-lib package. , atop -- ** Modifying diagrams -- *** Names , nameSub , withName , withNameAll , withNames , localize -- *** Other , freeze , setEnvelope , setTrace -- * Subdiagrams , Subdiagram(..), mkSubdiagram , getSub, rawSub , location , subPoint -- * Subdiagram maps , SubMap(..) , fromNames, rememberAs, lookupSub -- * Primtives -- $prim , Prim(..), IsPrim(..), nullPrim -- * Backends , Backend(..) , MultiBackend(..) -- ** Null backend , NullBackend, D -- * Renderable , Renderable(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, second, (***)) import Control.Monad (mplus) import Control.Newtype import Data.AffineSpace ((.-.)) import Data.List (isSuffixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe, listToMaybe) import Data.Semigroup import qualified Data.Traversable as T import Data.Typeable import Data.VectorSpace import Data.Monoid.Action import Data.Monoid.Coproduct import Data.Monoid.Deletable import Data.Monoid.MList import Data.Monoid.Split import Data.Monoid.WithSemigroup import qualified Data.Tree.DUAL as D import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin import Diagrams.Core.Juxtapose import Diagrams.Core.Names import Diagrams.Core.Points import Diagrams.Core.Query import Diagrams.Core.Style import Diagrams.Core.Trace import Diagrams.Core.Transform import Diagrams.Core.V -- XXX TODO: add lots of actual diagrams to illustrate the -- documentation! Haddock supports \<\\>. ------------------------------------------------------------ -- Diagrams ---------------------------------------------- ------------------------------------------------------------ -- | Monoidal annotations which travel up the diagram tree, /i.e./ which -- are aggregated from component diagrams to the whole: -- -- * envelopes (see "Diagrams.Core.Envelope"). -- The envelopes are \"deletable\" meaning that at any point we can -- throw away the existing envelope and replace it with a new one; -- sometimes we want to consider a diagram as having a different -- envelope unrelated to its \"natural\" envelope. -- -- * traces (see "Diagrams.Core.Trace"), also -- deletable. -- -- * name/subdiagram associations (see "Diagrams.Core.Names") -- -- * query functions (see "Diagrams.Core.Query") type UpAnnots b v m = Deletable (Envelope v) ::: Deletable (Trace v) ::: Deletable (SubMap b v m) ::: Query v m ::: () -- | Monoidal annotations which travel down the diagram tree, -- /i.e./ which accumulate along each path to a leaf (and which can -- act on the upwards-travelling annotations): -- -- * transformations (split at the innermost freeze): see -- "Diagrams.Core.Transform" -- -- * styles (see "Diagrams.Core.Style") -- -- * names (see "Diagrams.Core.Names") type DownAnnots v = (Split (Transformation v) :+: Style v) ::: Name ::: () -- Note that we have to put the transformations and styles together -- using a coproduct because the transformations can act on the -- styles. -- | Inject a transformation into a default downwards annotation -- value. transfToAnnot :: Transformation v -> DownAnnots v transfToAnnot = inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) . M -- | Extract the (total) transformation from a downwards annotation -- value. transfFromAnnot :: HasLinearMap v => DownAnnots v -> Transformation v transfFromAnnot = option mempty (unsplit . killR) . fst -- | The fundamental diagram type is represented by trees of -- primitives with various monoidal annotations. The @Q@ in -- @QDiagram@ stands for \"Queriable\", as distinguished from -- 'Diagram', a synonym for @QDiagram@ with the query type -- specialized to 'Any'. newtype QDiagram b v m = QD { unQD :: D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v) } deriving (Typeable) instance Newtype (QDiagram b v m) (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v)) where pack = QD unpack = unQD type instance V (QDiagram b v m) = v -- | The default sort of diagram is one where querying at a point -- simply tells you whether the diagram contains that point or not. -- Transforming a default diagram into one with a more interesting -- query can be done via the 'Functor' instance of @'QDiagram' b@ or -- the 'value' function. type Diagram b v = QDiagram b v Any -- | Create a \"point diagram\", which has no content, no trace, an -- empty query, and a point envelope. pointDiagram :: (Fractional (Scalar v), InnerSpace v) => Point v -> QDiagram b v m pointDiagram p = QD $ D.leafU (inj . toDeletable $ pointEnvelope p) -- | Extract a list of primitives from a diagram, together with their -- associated transformations and styles. prims :: HasLinearMap v => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] prims = (map . second) (untangle . option mempty id . fst) . D.flatten . unQD -- | A useful variant of 'getU' which projects out a certain -- component. getU' :: (Monoid u', u :>: u') => D.DUALTree d u a l -> u' getU' = maybe mempty (option mempty id . get) . D.getU -- | Get the envelope of a diagram. envelope :: (Ord (Scalar v)) => QDiagram b v m -> Envelope v envelope = unDelete . getU' . unQD -- | Replace the envelope of a diagram. setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) => Envelope v -> QDiagram b v m -> QDiagram b v m setEnvelope e = over QD ( D.applyUpre (inj . toDeletable $ e) . D.applyUpre (inj (deleteL :: Deletable (Envelope v))) . D.applyUpost (inj (deleteR :: Deletable (Envelope v))) ) -- | Get the trace of a diagram. trace :: (Ord (Scalar v), VectorSpace v, HasLinearMap v) => QDiagram b v m -> Trace v trace = unDelete . getU' . unQD -- | Replace the trace of a diagram. setTrace :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Semigroup m) => Trace v -> QDiagram b v m -> QDiagram b v m setTrace t = over QD ( D.applyUpre (inj . toDeletable $ t) . D.applyUpre (inj (deleteL :: Deletable (Trace v))) . D.applyUpost (inj (deleteR :: Deletable (Trace v))) ) -- | Get the subdiagram map (/i.e./ an association from names to -- subdiagrams) of a diagram. subMap :: QDiagram b v m -> SubMap b v m subMap = unDelete . getU' . unQD -- | Get a list of names of subdiagrams and their locations. names :: HasLinearMap v => QDiagram b v m -> [(Name, [Point v])] names = (map . second . map) location . M.assocs . unpack . subMap -- | Attach an atomic name to a certain subdiagram, computed from the -- given diagram. nameSub :: ( IsName n , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => (QDiagram b v m -> Subdiagram b v m) -> n -> QDiagram b v m -> QDiagram b v m nameSub s n d = over QD (D.applyUpre . inj . toDeletable $ fromNames [(n,s d)]) d -- | Given a name and a diagram transformation indexed by a -- subdiagram, perform the transformation using the most recent -- subdiagram associated with (some qualification of) the name, -- or perform the identity transformation if the name does not exist. withName :: IsName n => n -> (Subdiagram b v m -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withName n f d = maybe id f (lookupSub (toName n) (subMap d) >>= listToMaybe) d -- | Given a name and a diagram transformation indexed by a list of -- subdiagrams, perform the transformation using the -- collection of all such subdiagrams associated with (some -- qualification of) the given name. withNameAll :: IsName n => n -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (subMap d))) d -- | Given a list of names and a diagram transformation indexed by a -- list of subdiagrams, perform the transformation using the -- list of most recent subdiagrams associated with (some qualification -- of) each name. Do nothing (the identity transformation) if any -- of the names do not exist. withNames :: IsName n => [n] -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) -> QDiagram b v m -> QDiagram b v m withNames ns f d = maybe id f (T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns)) d where nd = subMap d -- | \"Localize\" a diagram by hiding all the names, so they are no -- longer visible to the outside. localize :: forall b v m. ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) , Semigroup m ) => QDiagram b v m -> QDiagram b v m localize = over QD ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m))) . D.applyUpost (inj (deleteR :: Deletable (SubMap b v m))) ) -- | Get the query function associated with a diagram. query :: Monoid m => QDiagram b v m -> Query v m query = getU' . unQD -- | Sample a diagram's query function at a given point. sample :: Monoid m => QDiagram b v m -> Point v -> m sample = runQuery . query -- | Set the query value for 'True' points in a diagram (/i.e./ points -- \"inside\" the diagram); 'False' points will be set to 'mempty'. value :: Monoid m => m -> QDiagram b v Any -> QDiagram b v m value m = fmap fromAny where fromAny (Any True) = m fromAny (Any False) = mempty -- | Reset the query values of a diagram to @True@/@False@: any values -- equal to 'mempty' are set to 'False'; any other values are set to -- 'True'. resetValue :: (Eq m, Monoid m) => QDiagram b v m -> QDiagram b v Any resetValue = fmap toAny where toAny m | m == mempty = Any False | otherwise = Any True -- | Set all the query values of a diagram to 'False'. clearValue :: QDiagram b v m -> QDiagram b v Any clearValue = fmap (const (Any False)) -- | Create a diagram from a single primitive, along with an envelope, -- trace, subdiagram map, and query function. mkQD :: Prim b v -> Envelope v -> Trace v -> SubMap b v m -> Query v m -> QDiagram b v m mkQD p e t n q = QD $ D.leaf (toDeletable e *: toDeletable t *: toDeletable n *: q *: ()) p ------------------------------------------------------------ -- Instances ------------------------------------------------------------ ---- Monoid -- | Diagrams form a monoid since each of their components do: the -- empty diagram has no primitives, an empty envelope, an empty -- trace, no named subdiagrams, and a constantly empty query -- function. -- -- Diagrams compose by aligning their respective local origins. The -- new diagram has all the primitives and all the names from the two -- diagrams combined, and query functions are combined pointwise. -- The first diagram goes on top of the second. \"On top of\" -- probably only makes sense in vector spaces of dimension lower -- than 3, but in theory it could make sense for, say, 3-dimensional -- diagrams when viewed by 4-dimensional beings. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Monoid (QDiagram b v m) where mempty = QD D.empty mappend = (<>) instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Semigroup (QDiagram b v m) where (QD d1) <> (QD d2) = QD (d2 <> d1) -- swap order so that primitives of d2 come first, i.e. will be -- rendered first, i.e. will be on the bottom. -- | A convenient synonym for 'mappend' on diagrams, designed to be -- used infix (to help remember which diagram goes on top of which -- when combining them, namely, the first on top of the second). atop :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => QDiagram b v m -> QDiagram b v m -> QDiagram b v m atop = (<>) infixl 6 `atop` ---- Functor instance Functor (QDiagram b v) where fmap f = (over QD . D.mapU . second . second) ( (first . fmap . fmap . fmap) f . (second . first . fmap . fmap) f ) ---- Applicative -- XXX what to do with this? -- A diagram with queries of result type @(a -> b)@ can be \"applied\" -- to a diagram with queries of result type @a@, resulting in a -- combined diagram with queries of result type @b@. In particular, -- all components of the two diagrams are combined as in the -- @Monoid@ instance, except the queries which are combined via -- @(<*>)@. -- instance (Backend b v, s ~ Scalar v, AdditiveGroup s, Ord s) -- => Applicative (QDiagram b v) where -- pure a = Diagram mempty mempty mempty (Query $ const a) -- (Diagram ps1 bs1 ns1 smp1) <*> (Diagram ps2 bs2 ns2 smp2) -- = Diagram (ps1 <> ps2) (bs1 <> bs2) (ns1 <> ns2) (smp1 <*> smp2) ---- HasStyle instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasStyle (QDiagram b v m) where applyStyle = over QD . D.applyD . inj . (inR :: Style v -> Split (Transformation v) :+: Style v) -- | By default, diagram attributes are not affected by -- transformations. This means, for example, that @lw 0.01 circle@ -- and @scale 2 (lw 0.01 circle)@ will be drawn with lines of the -- /same/ width, and @scaleY 3 circle@ will be an ellipse drawn with -- a uniform line. Once a diagram is frozen, however, -- transformations do affect attributes, so, for example, @scale 2 -- (freeze (lw 0.01 circle))@ will be drawn with a line twice as -- thick as @lw 0.01 circle@, and @scaleY 3 (freeze circle)@ will be -- drawn with a \"stretched\", variable-width line. -- -- Another way of thinking about it is that pre-@freeze@, we are -- transforming the \"abstract idea\" of a diagram, and the -- transformed version is then drawn; when doing a @freeze@, we -- produce a concrete drawing of the diagram, and it is this visual -- representation itself which is acted upon by subsequent -- transformations. freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => QDiagram b v m -> QDiagram b v m freeze = over QD . D.applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) $ split ---- Juxtaposable instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Juxtaposable (QDiagram b v m) where juxtapose = juxtaposeDefault ---- Enveloped instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v) ) => Enveloped (QDiagram b v m) where getEnvelope = envelope ---- Traced instance (HasLinearMap v, VectorSpace v, Ord (Scalar v)) => Traced (QDiagram b v m) where getTrace = trace ---- HasOrigin -- | Every diagram has an intrinsic \"local origin\" which is the -- basis for all combining operations. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => HasOrigin (QDiagram b v m) where moveOriginTo = translate . (origin .-.) ---- Transformable -- | Diagrams can be transformed by transforming each of their -- components appropriately. instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) => Transformable (QDiagram b v m) where transform = over QD . D.applyD . transfToAnnot ---- Qualifiable -- | Diagrams can be qualified so that all their named points can -- now be referred to using the qualification prefix. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Qualifiable (QDiagram b v m) where (|>) = over QD . D.applyD . inj . toName ------------------------------------------------------------ -- Subdiagrams ------------------------------------------------------------ -- | A @Subdiagram@ represents a diagram embedded within the context -- of a larger diagram. Essentially, it consists of a diagram -- paired with any accumulated information from the larger context -- (transformations, attributes, etc.). data Subdiagram b v m = Subdiagram (QDiagram b v m) (DownAnnots v) type instance V (Subdiagram b v m) = v -- | Turn a diagram into a subdiagram with no accumulated context. mkSubdiagram :: QDiagram b v m -> Subdiagram b v m mkSubdiagram d = Subdiagram d empty -- | Create a \"point subdiagram\", that is, a 'pointDiagram' (with no -- content and a point envelope) treated as a subdiagram with local -- origin at the given point. Note this is not the same as -- @mkSubdiagram . pointDiagram@, which would result in a subdiagram -- with local origin at the parent origin, rather than at the given -- point. subPoint :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => Point v -> Subdiagram b v m subPoint p = Subdiagram (pointDiagram origin) (transfToAnnot $ translation (p .-. origin)) instance Functor (Subdiagram b v) where fmap f (Subdiagram d a) = Subdiagram (fmap f d) a instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Enveloped (Subdiagram b v m) where getEnvelope (Subdiagram d a) = transform (transfFromAnnot a) $ getEnvelope d instance (Ord (Scalar v), VectorSpace v, HasLinearMap v) => Traced (Subdiagram b v m) where getTrace (Subdiagram d a) = transform (transfFromAnnot a) $ getTrace d instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => HasOrigin (Subdiagram b v m) where moveOriginTo = translate . (origin .-.) instance ( HasLinearMap v, InnerSpace v, Floating (Scalar v)) => Transformable (Subdiagram b v m) where transform t (Subdiagram d a) = Subdiagram d (transfToAnnot t <> a) -- | Get the location of a subdiagram; that is, the location of its -- local origin /with respect to/ the vector space of its parent -- diagram. In other words, the point where its local origin -- \"ended up\". location :: HasLinearMap v => Subdiagram b v m -> Point v location (Subdiagram _ a) = transform (transfFromAnnot a) origin -- | Turn a subdiagram into a normal diagram, including the enclosing -- context. Concretely, a subdiagram is a pair of (1) a diagram and -- (2) a \"context\" consisting of an extra transformation and -- attributes. @getSub@ simply applies the transformation and -- attributes to the diagram to get the corresponding \"top-level\" -- diagram. getSub :: ( HasLinearMap v, InnerSpace v , Floating (Scalar v), Ord (Scalar v) , Semigroup m ) => Subdiagram b v m -> QDiagram b v m getSub (Subdiagram d a) = over QD (D.applyD a) d -- | Extract the \"raw\" content of a subdiagram, by throwing away the -- context. rawSub :: Subdiagram b v m -> QDiagram b v m rawSub (Subdiagram d _) = d ------------------------------------------------------------ -- Subdiagram maps --------------------------------------- ------------------------------------------------------------ -- | A 'SubMap' is a map associating names to subdiagrams. There can -- be multiple associations for any given name. newtype SubMap b v m = SubMap (M.Map Name [Subdiagram b v m]) -- See Note [SubMap Set vs list] instance Newtype (SubMap b v m) (M.Map Name [Subdiagram b v m]) where pack = SubMap unpack (SubMap m) = m -- ~~~~ [SubMap Set vs list] -- In some sense it would be nicer to use -- Sets instead of a list, but then we would have to put Ord -- constraints on v everywhere. =P type instance V (SubMap b v m) = v instance Functor (SubMap b v) where fmap = over SubMap . fmap . map . fmap instance Semigroup (SubMap b v m) where SubMap s1 <> SubMap s2 = SubMap $ M.unionWith (++) s1 s2 -- | 'SubMap's form a monoid with the empty map as the identity, and -- map union as the binary operation. No information is ever lost: -- if two maps have the same name in their domain, the resulting map -- will associate that name to the concatenation of the information -- associated with that name. instance Monoid (SubMap b v m) where mempty = SubMap M.empty mappend = (<>) instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => HasOrigin (SubMap b v m) where moveOriginTo = over SubMap . moveOriginTo instance (InnerSpace v, Floating (Scalar v), HasLinearMap v) => Transformable (SubMap b v m) where transform = over SubMap . transform -- | 'SubMap's are qualifiable: if @ns@ is a 'SubMap', then @a |> -- ns@ is the same 'SubMap' except with every name qualified by -- @a@. instance Qualifiable (SubMap b v m) where a |> (SubMap m) = SubMap $ M.mapKeys (a |>) m -- | Construct a 'SubMap' from a list of associations between names -- and subdiagrams. fromNames :: IsName a => [(a, Subdiagram b v m)] -> SubMap b v m fromNames = SubMap . M.fromListWith (++) . map (toName *** (:[])) -- | Add a name/diagram association to a submap. rememberAs :: IsName a => a -> QDiagram b v m -> SubMap b v m -> SubMap b v m rememberAs n b = over SubMap $ M.insertWith (++) (toName n) [mkSubdiagram b] -- | A name acts on a name map by qualifying every name in it. instance Action Name (SubMap b v m) where act = (|>) instance Action Name a => Action Name (Deletable a) where act n (Deletable l a r) = Deletable l (act n a) r -- Names do not act on other things. instance Action Name (Query v m) instance Action Name (Envelope v) instance Action Name (Trace v) -- | Look for the given name in a name map, returning a list of -- subdiagrams associated with that name. If no names match the -- given name exactly, return all the subdiagrams associated with -- names of which the given name is a suffix. lookupSub :: IsName n => n -> SubMap b v m -> Maybe [Subdiagram b v m] lookupSub a (SubMap m) = M.lookup n m `mplus` (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 flatten [] = Nothing flatten xs = Just . concatMap snd $ xs n = toName a ------------------------------------------------------------ -- Primitives -------------------------------------------- ------------------------------------------------------------ -- $prim -- Ultimately, every diagram is essentially a list of /primitives/, -- basic building blocks which can be rendered by backends. However, -- not every backend must be able to render every type of primitive; -- the collection of primitives a given backend knows how to render is -- determined by instances of 'Renderable'. -- | A type class for primitive things which know how to handle being -- transformed by both a normal transformation and a \"frozen\" -- transformation. The default implementation simply applies both. -- At the moment, 'ScaleInv' is the only type with a non-default -- instance of 'IsPrim'. class Transformable p => IsPrim p where transformWithFreeze :: Transformation (V p) -> Transformation (V p) -> p -> p transformWithFreeze t1 t2 = transform (t1 <> t2) -- | A value of type @Prim b v@ is an opaque (existentially quantified) -- primitive which backend @b@ knows how to render in vector space @v@. data Prim b v where Prim :: (IsPrim p, Renderable p b) => p -> Prim b (V p) type instance V (Prim b v) = v instance HasLinearMap v => IsPrim (Prim b v) where transformWithFreeze t1 t2 (Prim p) = Prim $ transformWithFreeze t1 t2 p -- | The 'Transformable' instance for 'Prim' just pushes calls to -- 'transform' down through the 'Prim' constructor. instance HasLinearMap v => Transformable (Prim b v) where transform v (Prim p) = Prim (transform v p) -- | The 'Renderable' instance for 'Prim' just pushes calls to -- 'render' down through the 'Prim' constructor. instance HasLinearMap v => Renderable (Prim b v) b where render b (Prim p) = render b p -- | The null primitive. data NullPrim v = NullPrim type instance (V (NullPrim v)) = v instance HasLinearMap v => IsPrim (NullPrim v) instance HasLinearMap v => Transformable (NullPrim v) where transform _ _ = NullPrim instance (HasLinearMap v, Monoid (Render b v)) => Renderable (NullPrim v) b where render _ _ = mempty -- | The null primitive, which every backend can render by doing -- nothing. nullPrim :: (HasLinearMap v, Monoid (Render b v)) => Prim b v nullPrim = Prim NullPrim ------------------------------------------------------------ -- Backends ----------------------------------------------- ------------------------------------------------------------ -- | Abstract diagrams are rendered to particular formats by -- /backends/. Each backend/vector space combination must be an -- instance of the 'Backend' class. A minimal complete definition -- consists of the three associated types and implementations for -- 'withStyle' and 'doRender'. -- class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- | The type of rendering operations used by this backend, which -- must be a monoid. For example, if @Render b v = M ()@ for some -- monad @M@, a monoid instance can be made with @mempty = return -- ()@ and @mappend = (>>)@. data Render b v :: * -- | The result of running/interpreting a rendering operation. type Result b v :: * -- | Backend-specific rendering options. data Options b v :: * -- | Perform a rendering operation with a local style. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ Style to use -> Transformation v -- ^ Transformation to be applied to the style -> Render b v -- ^ Rendering operation to run -> Render b v -- ^ Rendering operation using the style locally -- | 'doRender' is used to interpret rendering operations. doRender :: b -- ^ Backend token (needed only for type inference) -> Options b v -- ^ Backend-specific collection of rendering options -> Render b v -- ^ Rendering operation to perform -> Result b v -- ^ Output of the rendering operation -- | 'adjustDia' allows the backend to make adjustments to the final -- diagram (e.g. to adjust the size based on the options) before -- rendering it. It can also make adjustments to the options -- record, usually to fill in incompletely specified size -- information. A default implementation is provided which makes -- no adjustments. See the diagrams-lib package for other useful -- implementations. adjustDia :: Monoid' m => b -> Options b v -> QDiagram b v m -> (Options b v, QDiagram b v m) adjustDia _ o d = (o,d) -- XXX expand this comment. Explain about freeze, split -- transformations, etc. -- | Render a diagram. This has a default implementation in terms -- of 'adjustDia', 'withStyle', 'doRender', and the 'render' -- operation from the 'Renderable' class (first 'adjustDia' is -- used, then 'withStyle' and 'render' are used to render each -- primitive, the resulting operations are combined with -- 'mconcat', and the final operation run with 'doRender') but -- backends may override it if desired. renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) => b -> Options b v -> QDiagram b v m -> Result b v renderDia b opts d = doRender b opts' . mconcat . map renderOne . prims $ d' where (opts', d') = adjustDia b opts d renderOne :: (Prim b v, (Split (Transformation v), Style v)) -> Render b v renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p)) renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transformWithFreeze t1 t2 p)) -- See Note [backend token] -- | The @D@ type is provided for convenience in situations where you -- must give a diagram a concrete, monomorphic type, but don't care -- which one. Such situations arise when you pass a diagram to a -- function which is polymorphic in its input but monomorphic in its -- output, such as 'width', 'height', 'phantom', or 'names'. Such -- functions compute some property of the diagram, or use it to -- accomplish some other purpose, but do not result in the diagram -- being rendered. If the diagram does not have a monomorphic type, -- GHC complains that it cannot determine the diagram's type. -- -- For example, here is the error we get if we try to compute the -- width of an image (this example requires @diagrams-lib@): -- -- > ghci> width (image "foo.png" 200 200) -- > -- > :8:8: -- > No instance for (Renderable Diagrams.TwoD.Image.Image b0) -- > arising from a use of `image' -- > Possible fix: -- > add an instance declaration for -- > (Renderable Diagrams.TwoD.Image.Image b0) -- > In the first argument of `width', namely -- > `(image "foo.png" 200 200)' -- > In the expression: width (image "foo.png" 200 200) -- > In an equation for `it': it = width (image "foo.png" 200 200) -- -- GHC complains that there is no instance for @Renderable Image -- b0@; what is really going on is that it does not have enough -- information to decide what backend to use (hence the -- uninstantiated @b0@). This is annoying because /we/ know that the -- choice of backend cannot possibly affect the width of the image -- (it's 200! it's right there in the code!); /but/ there is no way -- for GHC to know that. -- -- The solution is to annotate the call to 'image' with the type -- @'D' 'R2'@, like so: -- -- > ghci> width (image "foo.png" 200 200 :: D R2) -- > 200.00000000000006 -- -- (It turns out the width wasn't 200 after all...) -- -- As another example, here is the error we get if we try to compute -- the width of a radius-1 circle: -- -- > ghci> width (circle 1) -- > -- > :4:1: -- > Couldn't match type `V a0' with `R2' -- > In the expression: width (circle 1) -- > In an equation for `it': it = width (circle 1) -- -- There's even more ambiguity here. Whereas 'image' always returns -- a 'Diagram', the 'circle' function can produce any 'PathLike' -- type, and the 'width' function can consume any 'Enveloped' type, -- so GHC has no idea what type to pick to go in the middle. -- However, the solution is the same: -- -- > ghci> width (circle 1 :: D R2) -- > 1.9999999999999998 type D v = Diagram NullBackend v -- | A null backend which does no actual rendering. It is provided -- mainly for convenience in situations where you must give a -- diagram a concrete, monomorphic type, but don't actually care -- which one. See 'D' for more explanation and examples. -- -- It is courteous, when defining a new primitive @P@, to make an instance -- -- > instance Renderable P NullBackend where -- > render _ _ = mempty -- -- This ensures that the trick with 'D' annotations can be used for -- diagrams containing your primitive. data NullBackend -- Note: we can't make a once-and-for-all instance -- -- > instance Renderable a NullBackend where -- > render _ _ = mempty -- -- because it overlaps with the Renderable instance for NullPrim. instance Monoid (Render NullBackend v) where mempty = NullBackendRender mappend _ _ = NullBackendRender instance HasLinearMap v => Backend NullBackend v where data Render NullBackend v = NullBackendRender type Result NullBackend v = () data Options NullBackend v withStyle _ _ _ _ = NullBackendRender doRender _ _ _ = () -- | A class for backends which support rendering multiple diagrams, -- e.g. to a multi-page pdf or something similar. class Backend b v => MultiBackend b v where -- | Render multiple diagrams at once. renderDias :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) => b -> Options b v -> [QDiagram b v m] -> Result b v -- See Note [backend token] -- | The Renderable type class connects backends to primitives which -- they know how to render. class Transformable t => Renderable t b where render :: b -> t -> Render b (V t) -- ^ Given a token representing the backend and a -- transformable object, render it in the appropriate rendering -- context. -- See Note [backend token] {- ~~~~ Note [backend token] A bunch of methods here take a "backend token" as an argument. The backend token is expected to carry no actual information; it is solely to help out the type system. The problem is that all these methods return some associated type applied to b (e.g. Render b) and unifying them with something else will never work, since type families are not necessarily injective. -} diagrams-core-0.7.0.1/src/Diagrams/Core/HasOrigin.hs0000644000000000000000000000640312221174047020210 0ustar0000000000000000{-# LANGUAGE FlexibleInstances , FlexibleContexts , TypeFamilies , UndecidableInstances #-} -- The UndecidableInstances flag is needed under 6.12.3 for the -- HasOrigin (a,b) instance. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.HasOrigin -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Types which have an intrinsic notion of a \"local origin\", -- /i.e./ things which are /not/ invariant under translation. -- ----------------------------------------------------------------------------- module Diagrams.Core.HasOrigin ( HasOrigin(..), moveOriginBy, moveTo, place ) where import qualified Data.Map as M import qualified Data.Set as S import Data.AffineSpace ((.-^), (.-.)) import Data.VectorSpace import Diagrams.Core.Points import Diagrams.Core.V -- | Class of types which have an intrinsic notion of a \"local -- origin\", i.e. things which are not invariant under translation, -- and which allow the origin to be moved. -- -- One might wonder why not just use 'Transformable' instead of -- having a separate class for 'HasOrigin'; indeed, for types which -- are instances of both we should have the identity -- -- > moveOriginTo (origin .^+ v) === translate (negateV v) -- -- The reason is that some things (e.g. vectors, 'Trail's) are -- transformable but are translationally invariant, i.e. have no -- origin. class VectorSpace (V t) => HasOrigin t where -- | Move the local origin to another point. -- -- Note that this function is in some sense dual to 'translate' -- (for types which are also 'Transformable'); moving the origin -- itself while leaving the object \"fixed\" is dual to fixing the -- origin and translating the diagram. moveOriginTo :: Point (V t) -> t -> t -- | Move the local origin by a relative vector. moveOriginBy :: HasOrigin t => V t -> t -> t moveOriginBy = moveOriginTo . P -- | Translate the object by the translation that sends the origin to -- the given point. Note that this is dual to 'moveOriginTo', i.e. we -- should have -- -- > moveTo (origin .^+ v) === moveOriginTo (origin .^- v) -- -- For types which are also 'Transformable', this is essentially the -- same as 'translate', i.e. -- -- > moveTo (origin .^+ v) === translate v moveTo :: HasOrigin t => Point (V t) -> t -> t moveTo = moveOriginBy . (origin .-.) -- | A flipped variant of 'moveTo', provided for convenience. Useful -- when writing a function which takes a point as an argument, such -- as when using 'withName' and friends. place :: HasOrigin t => t -> Point (V t) -> t place = flip moveTo instance VectorSpace v => HasOrigin (Point v) where moveOriginTo (P u) p = p .-^ u instance (HasOrigin a, HasOrigin b, V a ~ V b) => HasOrigin (a,b) where moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) instance HasOrigin a => HasOrigin [a] where moveOriginTo = map . moveOriginTo instance (HasOrigin a, Ord a) => HasOrigin (S.Set a) where moveOriginTo = S.map . moveOriginTo instance HasOrigin a => HasOrigin (M.Map k a) where moveOriginTo = M.map . moveOriginTodiagrams-core-0.7.0.1/src/Diagrams/Core/Style.hs0000644000000000000000000002125112221174047017423 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables , GADTs , KindSignatures , FlexibleInstances , MultiParamTypeClasses , TypeFamilies , UndecidableInstances #-} -- The UndecidableInstances flag is needed under 6.12.3 for the -- HasStyle (a,b) instance. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Style -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A definition of /styles/ for diagrams as extensible, heterogeneous -- collections of attributes. -- ----------------------------------------------------------------------------- module Diagrams.Core.Style ( -- * Attributes -- $attr AttributeClass , Attribute(..) , mkAttr, mkTAttr, unwrapAttr , applyAttr, applyTAttr -- * Styles -- $style , Style(..) , attrToStyle, tAttrToStyle , getAttr, setAttr, addAttr, combineAttr , HasStyle(..) ) where import Control.Arrow ((***)) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S import Data.Typeable import Data.Monoid.Action import Diagrams.Core.Transform import Diagrams.Core.V ------------------------------------------------------------ -- Attributes -------------------------------------------- ------------------------------------------------------------ -- $attr -- An /attribute/ is anything that determines some aspect of a -- diagram's rendering. The standard diagrams library defines several -- standard attributes (line color, line width, fill color, etc.) but -- additional attributes may easily be created. Additionally, a given -- backend need not handle (or even know about) attributes used in -- diagrams it renders. -- -- The attribute code is inspired by xmonad's @Message@ type, which -- was in turn based on ideas in: -- -- Simon Marlow. -- /An Extensible Dynamically-Typed Hierarchy of Exceptions/. -- Proceedings of the 2006 ACM SIGPLAN workshop on -- Haskell. . -- | Every attribute must be an instance of @AttributeClass@, which -- simply guarantees 'Typeable' and 'Semigroup' constraints. The -- 'Semigroup' instance for an attribute determines how it will combine -- with other attributes of the same type. class (Typeable a, Semigroup a) => AttributeClass a where -- | An existential wrapper type to hold attributes. Some attributes -- are affected by transformations and some are not. data Attribute v :: * where Attribute :: AttributeClass a => a -> Attribute v TAttribute :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v type instance V (Attribute v) = v -- | Wrap up an attribute. mkAttr :: AttributeClass a => a -> Attribute v mkAttr = Attribute -- | Wrap up a transformable attribute. mkTAttr :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v mkTAttr = TAttribute -- | Unwrap an unknown 'Attribute' type, performing a dynamic (but -- safe) check on the type of the result. If the required type -- matches the type of the attribute, the attribute value is -- returned wrapped in @Just@; if the types do not match, @Nothing@ -- is returned. unwrapAttr :: AttributeClass a => Attribute v -> Maybe a unwrapAttr (Attribute a) = cast a unwrapAttr (TAttribute a) = cast a -- | Attributes form a semigroup, where the semigroup operation simply -- returns the right-hand attribute when the types do not match, and -- otherwise uses the semigroup operation specific to the (matching) -- types. instance Semigroup (Attribute v) where (Attribute a1) <> a2 = case unwrapAttr a2 of Nothing -> a2 Just a2' -> Attribute (a1 <> a2') (TAttribute a1) <> a2 = case unwrapAttr a2 of Nothing -> a2 Just a2' -> TAttribute (a1 <> a2') instance HasLinearMap v => Transformable (Attribute v) where transform _ (Attribute a) = Attribute a transform t (TAttribute a) = TAttribute (transform t a) ------------------------------------------------------------ -- Styles ------------------------------------------------ ------------------------------------------------------------ -- $style -- A 'Style' is a heterogeneous collection of attributes, containing -- at most one attribute of any given type. This is also based on -- ideas stolen from xmonad, specifically xmonad's implementation of -- user-extensible state. -- | A @Style@ is a heterogeneous collection of attributes, containing -- at most one attribute of any given type. newtype Style v = Style (M.Map String (Attribute v)) -- The String keys are serialized TypeRep values, corresponding to -- the type of the stored attribute. type instance V (Style v) = v -- | Helper function for operating on styles. inStyle :: (M.Map String (Attribute v) -> M.Map String (Attribute v)) -> Style v -> Style v inStyle f (Style s) = Style (f s) -- | Extract an attribute from a style of a particular type. If the -- style contains an attribute of the requested type, it will be -- returned wrapped in @Just@; otherwise, @Nothing@ is returned. getAttr :: forall a v. AttributeClass a => Style v -> Maybe a getAttr (Style s) = M.lookup ty s >>= unwrapAttr where ty = show . typeOf $ (undefined :: a) -- the unwrapAttr should never fail, since we maintain the invariant -- that attributes of type T are always stored with the key "T". -- | Create a style from a single attribute. attrToStyle :: forall a v. AttributeClass a => a -> Style v attrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkAttr a)) -- | Create a style from a single transformable attribute. tAttrToStyle :: forall a v. (AttributeClass a, Transformable a, V a ~ v) => a -> Style v tAttrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkTAttr a)) -- | Add a new attribute to a style, or replace the old attribute of -- the same type if one exists. setAttr :: forall a v. AttributeClass a => a -> Style v -> Style v setAttr a = inStyle $ M.insert (show . typeOf $ (undefined :: a)) (mkAttr a) -- | Attempt to add a new attribute to a style, but if an attribute of -- the same type already exists, do not replace it. addAttr :: AttributeClass a => a -> Style v -> Style v addAttr a s = attrToStyle a <> s -- | Add a new attribute to a style that does not already contain an -- attribute of this type, or combine it on the left with an existing -- attribute. combineAttr :: AttributeClass a => a -> Style v -> Style v combineAttr a s = case getAttr s of Nothing -> setAttr a s Just a' -> setAttr (a <> a') s instance Semigroup (Style v) where Style s1 <> Style s2 = Style $ M.unionWith (<>) s1 s2 -- | The empty style contains no attributes; composition of styles is -- a union of attributes; if the two styles have attributes of the -- same type they are combined according to their semigroup -- structure. instance Monoid (Style v) where mempty = Style M.empty mappend = (<>) instance HasLinearMap v => Transformable (Style v) where transform t = inStyle $ M.map (transform t) -- | Styles have no action on other monoids. instance Action (Style v) m -- | Type class for things which have a style. class HasStyle a where -- | /Apply/ a style by combining it (on the left) with the -- existing style. applyStyle :: Style (V a) -> a -> a instance HasStyle (Style v) where applyStyle = mappend instance (HasStyle a, HasStyle b, V a ~ V b) => HasStyle (a,b) where applyStyle s = applyStyle s *** applyStyle s instance HasStyle a => HasStyle [a] where applyStyle = fmap . applyStyle instance HasStyle b => HasStyle (a -> b) where applyStyle = fmap . applyStyle instance HasStyle a => HasStyle (M.Map k a) where applyStyle = fmap . applyStyle instance (HasStyle a, Ord a) => HasStyle (S.Set a) where applyStyle = S.map . applyStyle -- | Apply an attribute to an instance of 'HasStyle' (such as a -- diagram or a style). If the object already has an attribute of -- the same type, the new attribute is combined on the left with the -- existing attribute, according to their semigroup structure. applyAttr :: (AttributeClass a, HasStyle d) => a -> d -> d applyAttr = applyStyle . attrToStyle -- | Apply a transformable attribute to an instance of 'HasStyle' -- (such as a diagram or a style). If the object already has an -- attribute of the same type, the new attribute is combined on the -- left with the existing attribute, according to their semigroup -- structure. applyTAttr :: (AttributeClass a, Transformable a, V a ~ V d, HasStyle d) => a -> d -> d applyTAttr = applyStyle . tAttrToStylediagrams-core-0.7.0.1/src/Diagrams/Core/Names.hs0000644000000000000000000000672012221174047017372 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Names -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines a type of names which can be used for referring -- to subdiagrams, and related types. -- ----------------------------------------------------------------------------- module Diagrams.Core.Names (-- * Names -- ** Atomic names AName(..) -- ** Names , Name(..), IsName(..), (.>) -- ** Qualifiable , Qualifiable(..) ) where import Data.List (intercalate) import Data.Semigroup import Data.Typeable import Diagrams.Core.Transform ------------------------------------------------------------ -- Names ------------------------------------------------- ------------------------------------------------------------ -- | Class for those types which can be used as names. They must -- support 'Typeable' (to facilitate extracting them from -- existential wrappers), 'Ord' (for comparison and efficient -- storage) and 'Show'. class (Typeable a, Ord a, Show a) => IsName a where toName :: a -> Name toName = Name . (:[]) . AName instance IsName () instance IsName Bool instance IsName Char instance IsName Int instance IsName Float instance IsName Double instance IsName Integer instance IsName String instance IsName a => IsName [a] instance (IsName a, IsName b) => IsName (a,b) instance (IsName a, IsName b, IsName c) => IsName (a,b,c) -- | Atomic names. @AName@ is just an existential wrapper around -- things which are 'Typeable', 'Ord' and 'Show'. data AName where AName :: (Typeable a, Ord a, Show a) => a -> AName deriving (Typeable) instance IsName AName where toName = Name . (:[]) instance Eq AName where (AName a1) == (AName a2) = case cast a2 of Nothing -> False Just a2' -> a1 == a2' instance Ord AName where (AName a1) `compare` (AName a2) = case cast a2 of Nothing -> show (typeOf a1) `compare` show (typeOf a2) Just a2' -> a1 `compare` a2' instance Show AName where show (AName a) = show a -- | A (qualified) name is a (possibly empty) sequence of atomic names. newtype Name = Name [AName] deriving (Eq, Ord, Semigroup, Monoid, Typeable) instance Show Name where show (Name ns) = intercalate " .> " $ map show ns instance IsName Name where toName = id -- | Convenient operator for writing qualified names with atomic -- components of different types. Instead of writing @toName a1 \<\> -- toName a2 \<\> toName a3@ you can just write @a1 .> a2 .> a3@. (.>) :: (IsName a1, IsName a2) => a1 -> a2 -> Name a1 .> a2 = toName a1 <> toName a2 -- | Instances of 'Qualifiable' are things which can be qualified by -- prefixing them with a name. class Qualifiable q where -- | Qualify with the given name. (|>) :: IsName a => a -> q -> q -- | Of course, names can be qualified using @(.>)@. instance Qualifiable Name where (|>) = (.>) instance Qualifiable a => Qualifiable (TransInv a) where (|>) n = TransInv . (|>) n . unTransInv infixr 5 |> infixr 5 .> diagrams-core-0.7.0.1/src/Diagrams/Core/Transform.hs0000644000000000000000000002554412221174047020307 0ustar0000000000000000{-# LANGUAGE TypeOperators , FlexibleContexts , FlexibleInstances , UndecidableInstances , TypeFamilies , MultiParamTypeClasses , GeneralizedNewtypeDeriving , TypeSynonymInstances , ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Transform -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- "Diagrams" defines the core library of primitives -- forming the basis of an embedded domain-specific language for -- describing and rendering diagrams. -- -- The @Transform@ module defines generic transformations -- parameterized by any vector space. -- ----------------------------------------------------------------------------- module Diagrams.Core.Transform ( -- * Transformations -- ** Invertible linear transformations (:-:)(..), (<->), linv, lapp -- ** General transformations , Transformation(..) , inv, transp, transl , apply , papply , fromLinear , onBasis -- * The Transformable class , HasLinearMap , Transformable(..) -- * Translational invariance , TransInv(..) -- * Vector space independent transformations -- | Most transformations are specific to a particular vector -- space, but a few can be defined generically over any -- vector space. , translation, translate , scaling, scale ) where import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S import Data.AdditiveGroup import Data.AffineSpace ((.-.)) import Data.Basis import Data.LinearMap import Data.MemoTrie import Data.Monoid.Action import Data.Monoid.Deletable import Data.VectorSpace import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.V ------------------------------------------------------------ -- Transformations --------------------------------------- ------------------------------------------------------------ ------------------------------------------------------- -- Invertible linear transformations ---------------- ------------------------------------------------------- -- | @(v1 :-: v2)@ is a linear map paired with its inverse. data (:-:) u v = (u :-* v) :-: (v :-* u) infixr 7 :-: -- | Create an invertible linear map from two functions which are -- assumed to be linear inverses. (<->) :: (HasLinearMap u, HasLinearMap v) => (u -> v) -> (v -> u) -> (u :-: v) f <-> g = linear f :-: linear g instance HasLinearMap v => Semigroup (v :-: v) where (f :-: f') <> (g :-: g') = f *.* g :-: g' *.* f' -- | Invertible linear maps from a vector space to itself form a -- monoid under composition. instance HasLinearMap v => Monoid (v :-: v) where mempty = idL :-: idL mappend = (<>) -- | Invert a linear map. linv :: (u :-: v) -> (v :-: u) linv (f :-: g) = g :-: f -- | Apply a linear map to a vector. lapp :: (VectorSpace v, Scalar u ~ Scalar v, HasLinearMap u) => (u :-: v) -> u -> v lapp (f :-: _) = lapply f -------------------------------------------------- -- Affine transformations ---------------------- -------------------------------------------------- -- | General (affine) transformations, represented by an invertible -- linear map, its /transpose/, and a vector representing a -- translation component. -- -- By the /transpose/ of a linear map we mean simply the linear map -- corresponding to the transpose of the map's matrix -- representation. For example, any scale is its own transpose, -- since scales are represented by matrices with zeros everywhere -- except the diagonal. The transpose of a rotation is the same as -- its inverse. -- -- The reason we need to keep track of transposes is because it -- turns out that when transforming a shape according to some linear -- map L, the shape's /normal vectors/ transform according to L's -- inverse transpose. This is exactly what we need when -- transforming bounding functions, which are defined in terms of -- /perpendicular/ (i.e. normal) hyperplanes. data Transformation v = Transformation (v :-: v) (v :-: v) v type instance V (Transformation v) = v -- | Invert a transformation. inv :: HasLinearMap v => Transformation v -> Transformation v inv (Transformation t t' v) = Transformation (linv t) (linv t') (negateV (lapp (linv t) v)) -- | Get the transpose of a transformation (ignoring the translation -- component). transp :: Transformation v -> (v :-: v) transp (Transformation _ t' _) = t' -- | Get the translational component of a transformation. transl :: Transformation v -> v transl (Transformation _ _ v) = v -- | Transformations are closed under composition; @t1 <> t2@ is the -- transformation which performs first @t2@, then @t1@. instance HasLinearMap v => Semigroup (Transformation v) where Transformation t1 t1' v1 <> Transformation t2 t2' v2 = Transformation (t1 <> t2) (t2' <> t1') (v1 ^+^ lapp t1 v2) instance HasLinearMap v => Monoid (Transformation v) where mempty = Transformation mempty mempty zeroV mappend = (<>) -- | Transformations can act on transformable things. instance (HasLinearMap v, v ~ (V a), Transformable a) => Action (Transformation v) a where act = transform -- | Apply a transformation to a vector. Note that any translational -- component of the transformation will not affect the vector, since -- vectors are invariant under translation. apply :: HasLinearMap v => Transformation v -> v -> v apply (Transformation t _ _) = lapp t -- | Apply a transformation to a point. papply :: HasLinearMap v => Transformation v -> Point v -> Point v papply (Transformation t _ v) (P p) = P $ lapp t p ^+^ v -- | Create a general affine transformation from an invertible linear -- transformation and its transpose. The translational component is -- assumed to be zero. fromLinear :: AdditiveGroup v => (v :-: v) -> (v :-: v) -> Transformation v fromLinear l1 l2 = Transformation l1 l2 zeroV -- | Get the matrix equivalent of the linear transform, -- (as a list of columns) and the translation vector. This -- is mostly useful for implementing backends. onBasis :: forall v. HasLinearMap v => Transformation v -> ([v], v) onBasis t = (vmat, tr) where tr :: v tr = transl t basis :: [Basis v] basis = map fst (decompose tr) es :: [v] es = map basisValue basis vmat :: [v] vmat = map (apply t) es ------------------------------------------------------------ -- The Transformable class ------------------------------- ------------------------------------------------------------ -- | 'HasLinearMap' is a poor man's class constraint synonym, just to -- help shorten some of the ridiculously long constraint sets. class (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v instance (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v -- | Type class for things @t@ which can be transformed. class HasLinearMap (V t) => Transformable t where -- | Apply a transformation to an object. transform :: Transformation (V t) -> t -> t instance HasLinearMap v => Transformable (Transformation v) where transform t1 t2 = t1 <> t2 instance HasLinearMap v => HasOrigin (Transformation v) where moveOriginTo p = translate (origin .-. p) instance (Transformable a, Transformable b, V a ~ V b) => Transformable (a,b) where transform t (x,y) = ( transform t x , transform t y ) instance (Transformable a, Transformable b, Transformable c, V a ~ V b, V a ~ V c) => Transformable (a,b,c) where transform t (x,y,z) = ( transform t x , transform t y , transform t z ) -- Transform functions by conjugation. That is, reverse-transform argument and -- forward-transform result. Intuition: If someone shrinks you, you see your -- environment enlarged. If you rotate right, you see your environment -- rotating left. Etc. This technique was used extensively in Pan for modular -- construction of image filters. Works well for curried functions, since all -- arguments get inversely transformed. instance ( HasBasis (V b), HasTrie (Basis (V b)) , Transformable a, Transformable b, V b ~ V a) => Transformable (a -> b) where transform tr f = transform tr . f . transform (inv tr) instance Transformable t => Transformable [t] where transform = map . transform instance (Transformable t, Ord t) => Transformable (S.Set t) where transform = S.map . transform instance Transformable t => Transformable (M.Map k t) where transform = M.map . transform instance HasLinearMap v => Transformable (Point v) where transform = papply instance Transformable m => Transformable (Deletable m) where transform = fmap . transform instance Transformable Double where transform = apply instance Transformable Rational where transform = apply ------------------------------------------------------------ -- Translational invariance ------------------------------ ------------------------------------------------------------ -- | @TransInv@ is a wrapper which makes a transformable type -- translationally invariant; the translational component of -- transformations will no longer affect things wrapped in -- @TransInv@. newtype TransInv t = TransInv { unTransInv :: t } deriving (Eq, Ord, Show, Semigroup, Monoid) type instance V (TransInv t) = V t instance VectorSpace (V t) => HasOrigin (TransInv t) where moveOriginTo = const id instance Transformable t => Transformable (TransInv t) where transform (Transformation a a' _) (TransInv t) = TransInv (transform (Transformation a a' zeroV) t) ------------------------------------------------------------ -- Generic transformations ------------------------------- ------------------------------------------------------------ -- | Create a translation. translation :: HasLinearMap v => v -> Transformation v translation = Transformation mempty mempty -- | Translate by a vector. translate :: (Transformable t, HasLinearMap (V t)) => V t -> t -> t translate = transform . translation -- | Create a uniform scaling transformation. scaling :: (HasLinearMap v, Fractional (Scalar v)) => Scalar v -> Transformation v scaling s = fromLinear lin lin -- scaling is its own transpose where lin = (s *^) <-> (^/ s) -- | Scale uniformly in every dimension by the given scalar. scale :: (Transformable t, Fractional (Scalar (V t)), Eq (Scalar (V t))) => Scalar (V t) -> t -> t scale 0 = error "scale by zero! Halp!" -- XXX what should be done here? scale s = transform $ scaling s diagrams-core-0.7.0.1/src/Diagrams/Core/Envelope.hs0000644000000000000000000002447212221174047020110 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.Envelope -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- "Graphics.Rendering.Diagrams" defines the core library of primitives -- forming the basis of an embedded domain-specific language for -- describing and rendering diagrams. -- -- The @Envelope@ module defines a data type and type class for -- \"envelopes\", aka functional bounding regions. -- ----------------------------------------------------------------------------- module Diagrams.Core.Envelope ( -- * Envelopes Envelope(..) , inEnvelope , appEnvelope , onEnvelope , mkEnvelope , pointEnvelope , Enveloped(..) -- * Utility functions , diameter , radius , envelopeVMay, envelopeV, envelopePMay, envelopeP, envelopeSMay, envelopeS -- * Miscellaneous , OrderedField ) where import Control.Applicative ((<$>)) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup import qualified Data.Set as S import Data.AffineSpace ((.+^), (.-^)) import Data.VectorSpace import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V ------------------------------------------------------------ -- Envelopes --------------------------------------------- ------------------------------------------------------------ -- | Every diagram comes equipped with an /envelope/. What is an envelope? -- -- Consider first the idea of a /bounding box/. A bounding box -- expresses the distance to a bounding plane in every direction -- parallel to an axis. That is, a bounding box can be thought of -- as the intersection of a collection of half-planes, two -- perpendicular to each axis. -- -- More generally, the intersection of half-planes in /every/ -- direction would give a tight \"bounding region\", or convex hull. -- However, representing such a thing intensionally would be -- impossible; hence bounding boxes are often used as an -- approximation. -- -- An envelope is an /extensional/ representation of such a -- \"bounding region\". Instead of storing some sort of direct -- representation, we store a /function/ which takes a direction as -- input and gives a distance to a bounding half-plane as output. -- The important point is that envelopes can be composed, and -- transformed by any affine transformation. -- -- Formally, given a vector @v@, the envelope computes a scalar @s@ such -- that -- -- * for every point @u@ inside the diagram, -- if the projection of @(u - origin)@ onto @v@ is @s' *^ v@, then @s' <= s@. -- -- * @s@ is the smallest such scalar. -- -- There is also a special \"empty envelope\". -- -- The idea for envelopes came from -- Sebastian Setzer; see -- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . newtype Envelope v = Envelope { unEnvelope :: Option (v -> Max (Scalar v)) } inEnvelope :: (Option (v -> Max (Scalar v)) -> Option (v -> Max (Scalar v))) -> Envelope v -> Envelope v inEnvelope f = Envelope . f . unEnvelope appEnvelope :: Envelope v -> Maybe (v -> Scalar v) appEnvelope (Envelope (Option e)) = (getMax .) <$> e onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v onEnvelope t = (inEnvelope . fmap) ((Max .) . t . (getMax .)) mkEnvelope :: (v -> Scalar v) -> Envelope v mkEnvelope = Envelope . Option . Just . (Max .) -- | Create an envelope for the given point. pointEnvelope :: (Fractional (Scalar v), InnerSpace v) => Point v -> Envelope v pointEnvelope p = moveTo p (mkEnvelope (const zeroV)) -- | Envelopes form a semigroup with pointwise maximum as composition. -- Hence, if @e1@ is the envelope for diagram @d1@, and -- @e2@ is the envelope for @d2@, then @e1 \`mappend\` e2@ -- is the envelope for @d1 \`atop\` d2@. deriving instance Ord (Scalar v) => Semigroup (Envelope v) -- | The special empty envelope is the identity for the -- 'Monoid' instance. deriving instance Ord (Scalar v) => Monoid (Envelope v) -- XXX add some diagrams here to illustrate! Note that Haddock supports -- inline images, using a \<\\> syntax. type instance V (Envelope v) = v -- | The local origin of an envelope is the point with respect to -- which bounding queries are made, /i.e./ the point from which the -- input vectors are taken to originate. instance (InnerSpace v, Fractional (Scalar v)) => HasOrigin (Envelope v) where moveOriginTo (P u) = onEnvelope $ \f v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) instance Show (Envelope v) where show _ = "" ------------------------------------------------------------ -- Transforming envelopes -------------------------------- ------------------------------------------------------------ -- XXX can we get away with removing this Floating constraint? It's the -- call to normalized here which is the culprit. instance ( HasLinearMap v, InnerSpace v, Floating (Scalar v)) => Transformable (Envelope v) where transform t = -- XXX add lots of comments explaining this! moveOriginTo (P . negateV . transl $ t) . (onEnvelope $ \f v -> let v' = normalized $ lapp (transp t) v vi = apply (inv t) v in f v' / (v' <.> vi) ) ------------------------------------------------------------ -- Enveloped class ------------------------------------------------------------ -- | When dealing with envelopes we often want scalars to be an -- ordered field (i.e. support all four arithmetic operations and be -- totally ordered) so we introduce this class as a convenient -- shorthand. class (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s instance (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s -- | @Enveloped@ abstracts over things which have an envelope. class (InnerSpace (V a), OrderedField (Scalar (V a))) => Enveloped a where -- | Compute the envelope of an object. For types with an intrinsic -- notion of \"local origin\", the envelope will be based there. -- Other types (e.g. 'Trail') may have some other default -- reference point at which the envelope will be based; their -- instances should document what it is. getEnvelope :: a -> Envelope (V a) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Envelope v) where getEnvelope = id instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (Point v) where getEnvelope p = moveTo p . mkEnvelope $ const zeroV instance Enveloped t => Enveloped (TransInv t) where getEnvelope = getEnvelope . unTransInv instance (Enveloped a, Enveloped b, V a ~ V b) => Enveloped (a,b) where getEnvelope (x,y) = getEnvelope x <> getEnvelope y instance (Enveloped b) => Enveloped [b] where getEnvelope = mconcat . map getEnvelope instance (Enveloped b) => Enveloped (M.Map k b) where getEnvelope = mconcat . map getEnvelope . M.elems instance (Enveloped b) => Enveloped (S.Set b) where getEnvelope = mconcat . map getEnvelope . S.elems ------------------------------------------------------------ -- Computing with envelopes ------------------------------------------------------------ -- | Compute the vector from the local origin to a separating -- hyperplane in the given direction, or @Nothing@ for the empty -- envelope. envelopeVMay :: Enveloped a => V a -> a -> Maybe (V a) envelopeVMay v = fmap ((*^ v) . ($ v)) . appEnvelope . getEnvelope -- | Compute the vector from the local origin to a separating -- hyperplane in the given direction. Returns the zero vector for -- the empty envelope. envelopeV :: Enveloped a => V a -> a -> V a envelopeV v = fromMaybe zeroV . envelopeVMay v -- | Compute the point on a separating hyperplane in the given -- direction, or @Nothing@ for the empty envelope. envelopePMay :: Enveloped a => V a -> a -> Maybe (Point (V a)) envelopePMay v = fmap P . envelopeVMay v -- | Compute the point on a separating hyperplane in the given -- direction. Returns the origin for the empty envelope. envelopeP :: Enveloped a => V a -> a -> Point (V a) envelopeP v = P . envelopeV v -- | Equivalent to the magnitude of 'envelopeVMay': -- -- @ envelopeSMay v x == fmap magnitude (envelopeVMay v x) @ -- -- (other than differences in rounding error) -- -- Note that the 'envelopeVMay' / 'envelopePMay' functions above should be -- preferred, as this requires a call to magnitude. However, it is more -- efficient than calling magnitude on the results of those functions. envelopeSMay :: Enveloped a => V a -> a -> Maybe (Scalar (V a)) envelopeSMay v = fmap ((* magnitude v) . ($ v)) . appEnvelope . getEnvelope -- | Equivalent to the magnitude of 'envelopeV': -- -- @ envelopeS v x == magnitude (envelopeV v x) @ -- -- (other than differences in rounding error) -- -- Note that the 'envelopeV' / 'envelopeP' functions above should be -- preferred, as this requires a call to magnitude. However, it is more -- efficient than calling magnitude on the results of those functions. envelopeS :: (Enveloped a, Num (Scalar (V a))) => V a -> a -> Scalar (V a) envelopeS v = fromMaybe 0 . envelopeSMay v -- | Compute the diameter of a enveloped object along a particular -- vector. Returns zero for the empty envelope. diameter :: Enveloped a => V a -> a -> Scalar (V a) diameter v a = case appEnvelope $ getEnvelope a of (Just env) -> (env v + env (negateV v)) * magnitude v Nothing -> 0 -- | Compute the \"radius\" (1\/2 the diameter) of an enveloped object -- along a particular vector. radius :: Enveloped a => V a -> a -> Scalar (V a) radius v = (0.5*) . diameter v