diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,78 +0,0 @@ -* 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: 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 Sets and tuples - - V Double = Double - - Juxtaposable and Boundable instances for Map - - * API changes - - - AnnDiagram -> QDiagram - - - #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) - - - 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 monoids0.1: 17 May 2011 - * initial preview release - -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 diff --git a/CHANGES.markdown b/CHANGES.markdown new file mode 100644 --- /dev/null +++ b/CHANGES.markdown @@ -0,0 +1,184 @@ +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 diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,9 +0,0 @@ -The core modules underlying diagrams, a Haskell embedded -domain-specific language for compositional, declarative drawing. See - - http://projects.haskell.org/diagrams/ - -for more information about the project, including installation -instructions, tutorials, a user manual, a gallery of example images, -and links to the mailing list, IRC channel, developer wiki and bug -tracker. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,6 @@ +[![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. + diff --git a/diagrams-core.cabal b/diagrams-core.cabal --- a/diagrams-core.cabal +++ b/diagrams-core.cabal @@ -1,5 +1,5 @@ Name: diagrams-core -Version: 0.5.0.1 +Version: 0.6 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language @@ -9,38 +9,57 @@ 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.6 -Extra-source-files: CHANGES, README -Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 +Cabal-version: >=1.10 +Extra-source-files: CHANGES.markdown, README.markdown +Tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 Source-repository head - type: darcs - location: http://patch-tag.com/r/byorgey/diagrams-core + type: git + location: git://github.com/diagrams/diagrams-core.git Library - Exposed-modules: Graphics.Rendering.Diagrams, - Graphics.Rendering.Diagrams.Monoids, - Graphics.Rendering.Diagrams.MList, - Graphics.Rendering.Diagrams.UDTree, - Graphics.Rendering.Diagrams.V, - Graphics.Rendering.Diagrams.Query, - Graphics.Rendering.Diagrams.Transform, - Graphics.Rendering.Diagrams.Envelope, - Graphics.Rendering.Diagrams.HasOrigin, - Graphics.Rendering.Diagrams.Juxtapose, - Graphics.Rendering.Diagrams.Points, - Graphics.Rendering.Diagrams.Names, - Graphics.Rendering.Diagrams.Style, - Graphics.Rendering.Diagrams.Util, - Graphics.Rendering.Diagrams.Core + 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.6, - containers >= 0.3 && < 0.5, + Build-depends: base >= 4.2 && < 4.7, + containers >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.9, - vector-space >= 0.8 && < 0.9, + vector-space >= 0.8.4 && < 0.9, vector-space-points >= 0.1 && < 0.2, - MemoTrie >= 0.4.7 && < 0.6, - newtype >= 0.2 && < 0.3 + MemoTrie >= 0.4.7 && < 0.7, + newtype >= 0.2 && < 0.3, + monoid-extras >= 0.2 && < 0.3, + 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 diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..), nullPrim + + -- * Diagrams + + , QDiagram, mkQD, Diagram + , prims + , envelope, trace, subMap, names, query, sample + , value, resetValue, clearValue + + , named, nameSub, namePoint + , withName + , withNameAll + , withNames + + , 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.Types +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 + +import Data.Monoid.WithSemigroup (Monoid') diff --git a/src/Diagrams/Core/Envelope.hs b/src/Diagrams/Core/Envelope.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Envelope.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE TypeFamilies + , FlexibleInstances + , FlexibleContexts + , UndecidableInstances + , GeneralizedNewtypeDeriving + , StandaloneDeriving + , MultiParamTypeClasses + #-} +----------------------------------------------------------------------------- +-- | +-- 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 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 diff --git a/src/Diagrams/Core/HasOrigin.hs b/src/Diagrams/Core/HasOrigin.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/HasOrigin.hs @@ -0,0 +1,94 @@ +{-# 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 . moveOriginTo diff --git a/src/Diagrams/Core/Juxtapose.hs b/src/Diagrams/Core/Juxtapose.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Juxtapose.hs @@ -0,0 +1,68 @@ +{-# 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 = juxtaposeDefault diff --git a/src/Diagrams/Core/Names.hs b/src/Diagrams/Core/Names.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Names.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverlappingInstances #-} +----------------------------------------------------------------------------- +-- | +-- 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 locations within diagrams, 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 + +------------------------------------------------------------ +-- 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 + (|>) = (.>) + +infixr 5 |> +infixr 5 .> diff --git a/src/Diagrams/Core/Points.hs b/src/Diagrams/Core/Points.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Points.hs @@ -0,0 +1,28 @@ +{-# 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) = v diff --git a/src/Diagrams/Core/Query.hs b/src/Diagrams/Core/Query.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Query.hs @@ -0,0 +1,50 @@ +{-# 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) diff --git a/src/Diagrams/Core/Style.hs b/src/Diagrams/Core/Style.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Style.hs @@ -0,0 +1,239 @@ +{-# 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 . tAttrToStyle diff --git a/src/Diagrams/Core/Trace.hs b/src/Diagrams/Core/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Trace.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Trace +-- Copyright : (c) 2012 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 @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.PosInf +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 + 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 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) + PosInfty -> 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 diff --git a/src/Diagrams/Core/Transform.hs b/src/Diagrams/Core/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Transform.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE TypeOperators + , FlexibleContexts + , FlexibleInstances + , UndecidableInstances + , TypeFamilies + , MultiParamTypeClasses + , GeneralizedNewtypeDeriving + , TypeSynonymInstances + #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + + -- * 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 + +------------------------------------------------------------ +-- 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 + ) + +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 (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 tr (TransInv t) = TransInv (translate (negateV (transl tr)) . transform tr $ 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 diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Types.hs @@ -0,0 +1,885 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE EmptyDataDecls #-} + +----------------------------------------------------------------------------- +-- | +-- 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 + , named + , nameSub + , namePoint + , withName + , withNameAll + , withNames + + -- *** Other + , freeze + , setEnvelope + , setTrace + + -- * Subdiagrams + + , Subdiagram(..), mkSubdiagram + , getSub, rawSub + , location + , subPoint + + -- * Subdiagram maps + + , SubMap(..) + + , fromNames, rememberAs, lookupSub + + -- * Primtives + -- $prim + + , Prim(..), 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 (listToMaybe, fromMaybe) +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) + ::: 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 = 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 diagram. +named :: ( IsName n + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) + => n -> QDiagram b v m -> QDiagram b v m +named = nameSub mkSubdiagram + +-- | Attach an atomic name to a certain point (which may be computed +-- from the given diagram), treated as a subdiagram with no content +-- and a point envelope. +namePoint :: ( IsName n + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) + => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m +namePoint p = nameSub (subPoint . p) + +-- | 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 $ 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 + +-- | 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 *: 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) 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 = (|>) + +-- | Names don't act on anything else. +instance Action Name a + +-- | 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 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 :: Renderable p b => p -> Prim b (V p) + +type instance V (Prim b v) = v + +-- | 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 => 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 (transform (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. +-} diff --git a/src/Diagrams/Core/V.hs b/src/Diagrams/Core/V.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/V.hs @@ -0,0 +1,52 @@ +{-# 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 m diff --git a/src/Graphics/Rendering/Diagrams.hs b/src/Graphics/Rendering/Diagrams.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams.hs +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams --- 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 Graphics.Rendering.Diagrams - ( -- * Associated vector spaces - - V - - -- * Points - - , Point, origin, (*.) - - -- * Vectors - - , withLength - - -- * 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(..), (.>) - , NameMap - , fromNames, fromNamesB - , rememberAs - - , lookupN - - -- * Attributes and styles - - , AttributeClass - , Attribute, mkAttr, mkTAttr, unwrapAttr - - , Style, HasStyle(..) - , getAttr, combineAttr - , applyAttr, applyTAttr - - -- * Envelopes - - , Envelope - , inEnvelope, appEnvelope, onEnvelope, mkEnvelope - , Enveloped(..) - , envelopeV, envelopeP, boundaryFrom - , diameter, radius - - , LocatedEnvelope(..) - , location, locateEnvelope - - -- * Things with local origins - - , HasOrigin(..), moveOriginBy - - -- * Juxtaposable things - - , Juxtaposable(..), juxtaposeDefault - - -- * Queries - - , Query(..) - - -- * Primtives - - , Prim(..), nullPrim - - -- * Diagrams - - , QDiagram, mkQD, Diagram - , prims - , envelope, names, query, sample - , value, resetValue, clearValue - - , named, namePoint - , withName - , withNameAll - , withNames - - , freeze, setEnvelope - - , atop - - -- * Backends - - , Backend(..) - , MultiBackend(..) - , Renderable(..) - - -- ** The null backend - - , NullBackend, D - - -- * Convenience classes - - , HasLinearMap - , OrderedField - , Monoid' - - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Util -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Juxtapose -import Graphics.Rendering.Diagrams.Query -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Names -import Graphics.Rendering.Diagrams.Style -import Graphics.Rendering.Diagrams.Core -import Graphics.Rendering.Diagrams.Monoids (Monoid') diff --git a/src/Graphics/Rendering/Diagrams/Core.hs b/src/Graphics/Rendering/Diagrams/Core.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Core.hs +++ /dev/null @@ -1,632 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , TypeFamilies - , MultiParamTypeClasses - , GADTs - , ExistentialQuantification - , ScopedTypeVariables - , GeneralizedNewtypeDeriving - , DeriveDataTypeable - , TypeOperators - , OverlappingInstances - , UndecidableInstances - , TupleSections - , EmptyDataDecls - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.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. --- --- "Graphics.Rendering.Diagrams.Core" defines types and classes for --- primitives, diagrams, and backends. --- ------------------------------------------------------------------------------ - -{- ~~~~ Note [breaking up Core 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 Graphics.Rendering.Diagrams.Core - ( - -- * Diagrams - - -- ** Annotations - UpAnnots, DownAnnots - , QDiagram(..), mkQD, Diagram - - -- * Operations on diagrams - -- ** Extracting information - , prims - , envelope, 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 - , named - , namePoint - , withName - , withNameAll - , withNames - - -- *** Other - , freeze - , setEnvelope - - -- * Primtives - -- $prim - - , Prim(..), nullPrim - - -- * Backends - - , Backend(..) - , MultiBackend(..) - - -- ** Null backend - - , NullBackend, D - - -- * Renderable - - , Renderable(..) - - ) where - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.MList -import Graphics.Rendering.Diagrams.UDTree - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Query -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Juxtapose -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Names -import Graphics.Rendering.Diagrams.Style - -import Data.VectorSpace -import Data.AffineSpace ((.-.)) - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Semigroup -import qualified Data.Traversable as T -import Control.Arrow (second) -import Control.Applicative ((<$>), (<*>)) - -import Control.Newtype - -import Data.Typeable - --- 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 "Graphics.Rendering.Diagrams.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. --- --- * name/point associations (see "Graphics.Rendering.Diagrams.Names") --- --- * query functions (see "Graphics.Rendering.Diagrams.Query") -type UpAnnots v m = Deletable (Envelope v) ::: NameMap v ::: Query v m ::: Nil - --- | 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 --- "Graphics.Rendering.Diagrams.Transform" --- --- * styles (see "Graphics.Rendering.Diagrams.Style") --- --- * names (see "Graphics.Rendering.Diagrams.Names") -type DownAnnots v = (Split (Transformation v) :+: Style v) ::: AM [] Name ::: Nil - --- | 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 :: UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) } - deriving (Typeable) - -instance Newtype (QDiagram b v m) - (UDTree (UpAnnots v m) (DownAnnots v) (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 that point is occupied or not. --- Transforming a default diagram into one with a more interesting --- query can be done via the 'Functor' instance of @'QDiagram' b@. -type Diagram b v = QDiagram b v Any - --- | Extract a list of primitives from a diagram, together with their --- associated transformations and styles. -prims :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] -prims = (map . second) (untangle . fst . toTuple) . flatten . unQD - --- | Get the envelope of a diagram. -envelope :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap 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 b = over QD ( applyUpre (inj . toDeletable $ b) - . applyUpre (inj (deleteL :: Deletable (Envelope v))) - . applyUpost (inj (deleteR :: Deletable (Envelope v))) - ) - --- | Get the name map of a diagram. -names :: (AdditiveGroup (Scalar v), Floating (Scalar v), InnerSpace v, HasLinearMap v) - => QDiagram b v m -> NameMap v -names = getU' . unQD - --- | Attach an atomic name to (the local origin of) a diagram. -named :: forall v b n m. - ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => n -> QDiagram b v m -> QDiagram b v m -named = namePoint (locateEnvelope <$> const origin <*> envelope) - --- | Attach an atomic name to a certain point and envelope, computed --- from the given diagram. -namePoint :: forall v b n m. - ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => (QDiagram b v m -> LocatedEnvelope v) -> n -> QDiagram b v m -> QDiagram b v m -namePoint p n d = over QD (applyUpre . inj $ fromNamesB [(n,p d)]) d - --- | Given a name and a diagram transformation indexed by a located --- envelope, perform the transformation using the most recent --- located envelope associated with (some qualification of) the --- name, or perform the identity transformation if the name does not --- exist. -withName :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => n -> (LocatedEnvelope v -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withName n f d = maybe id f (lookupN (toName n) (names d) >>= listToMaybe) d - --- | Given a name and a diagram transformation indexed by a list of --- located envelopes, perform the transformation using the --- collection of all such located envelopes associated with (some --- qualification of) the given name. -withNameAll :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => n -> ([LocatedEnvelope v] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withNameAll n f d = f (fromMaybe [] (lookupN (toName n) (names d))) d - --- | Given a list of names and a diagram transformation indexed by a --- list of located envelopes, perform the transformation using the --- list of most recent envelopes associated with (some qualification --- of) each name. Do nothing (the identity transformation) if any --- of the names do not exist. -withNames :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => [n] -> ([LocatedEnvelope v] -> 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) . lookupN . toName) ns)) d - where nd = names d - --- | Get the query function associated with a diagram. -query :: (HasLinearMap v, Monoid m) => QDiagram b v m -> Query v m -query = getU' . unQD - --- | Sample a diagram's query function at a given point. -sample :: (HasLinearMap v, 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, --- name map, and query function. -mkQD :: Prim b v -> Envelope v -> NameMap v -> Query v m -> QDiagram b v m -mkQD p b n a = QD $ leaf (toDeletable b ::: n ::: a ::: Nil) p - ------------------------------------------------------------- --- Instances ------------------------------------------------------------- - ----- Monoid - --- | Diagrams form a monoid since each of their components do: the --- empty diagram has no primitives, an empty envelope, no named --- points, 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), Monoid' m) - => Monoid (QDiagram b v m) where - mempty = QD mempty - (QD d1) `mappend` (QD d2) = QD (d2 `mappend` d1) - -- swap order so that primitives of d2 come first, i.e. will be - -- rendered first, i.e. will be on the bottom. - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Semigroup (QDiagram b v m) where - (<>) = mappend - --- | 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, Monoid' m) - => QDiagram b v m -> QDiagram b v m -> QDiagram b v m -atop = mappend - -infixl 6 `atop` - ----- Functor - --- This is a bit ugly, but it will have to do for now... -instance Functor (QDiagram b v) where - fmap f = over QD (mapU g) - where g (b ::: n ::: a ::: Nil) = b ::: n ::: fmap f a ::: Nil - g _ = error "impossible case in Functor (QDiagram b v) instance (g)" - ----- 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), Monoid m) - => HasStyle (QDiagram b v m) where - applyStyle = over QD . 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), Monoid m) - => QDiagram b v m -> QDiagram b v m -freeze = over QD . applyD . inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - $ split - ----- Juxtaposable - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' 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 - ----- HasOrigin - --- | Every diagram has an intrinsic \"local origin\" which is the --- basis for all combining operations. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' 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, Monoid' m) - => Transformable (QDiagram b v m) where - transform = over QD . applyD . inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - . M - ----- 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), Monoid m) - => Qualifiable (QDiagram b v m) where - (|>) = over QD . applyD . inj . AM . (:[]) . toName - - ------------------------------------------------------------- --- Primitives -------------------------------------------- ------------------------------------------------------------- - --- $prim --- Ultimately, every diagram is essentially a collection 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 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 :: Renderable t b => t -> Prim b (V t) - -type instance V (Prim b v) = v - --- | 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 => 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 (transform (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 a radius-1 circle (this example requires --- @diagrams-lib@): --- --- > ghci> width (circle 1) --- > --- > :1:8: --- > No instances for (Backend b0 R2, --- > Renderable Diagrams.TwoD.Ellipse.Ellipse b0) --- > arising from a use of `circle' --- > Possible fix: --- > add instance declarations for --- > (Backend b0 R2, Renderable Diagrams.TwoD.Ellipse.Ellipse b0) --- > In the first argument of `width', namely `(circle 1)' --- > In the expression: width (circle 1) --- > In an equation for `it': it = width (circle 1) --- --- GHC complains that it cannot find an instance for \"@Backend b0 --- R2@\"; what is really going on is that it does not have enough --- information to decide which backend to use for the circle (hence --- the type variable @b0@). This is annoying because /we/ know that --- the choice of backend cannot possibly affect the width of the --- circle; but there is no way for GHC to know that. --- --- The solution is to annotate @circle 1@ with the type @'D' 'R2'@, --- like so: --- --- > ghci> width (circle 1 :: D R2) --- > 2.0 - -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 :: 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. --} - diff --git a/src/Graphics/Rendering/Diagrams/Envelope.hs b/src/Graphics/Rendering/Diagrams/Envelope.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Envelope.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE TypeFamilies - , FlexibleInstances - , FlexibleContexts - , UndecidableInstances - , GeneralizedNewtypeDeriving - , StandaloneDeriving - , MultiParamTypeClasses - #-} ------------------------------------------------------------------------------ --- | --- 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 Graphics.Rendering.Diagrams.Envelope - ( -- * Envelopes - Envelope(..) - - , inEnvelope - , appEnvelope - , onEnvelope - , mkEnvelope - - , Enveloped(..) - - , LocatedEnvelope(..) - , location - , locateEnvelope - - -- * Utility functions - , diameter - , radius - , envelopeV, envelopeP, boundaryFrom - - -- * Miscellaneous - , OrderedField - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - -import Data.VectorSpace -import Data.AffineSpace ((.+^), (.-^)) - -import Data.Semigroup -import Control.Applicative ((<$>)) - -import qualified Data.Map as M -import qualified Data.Set as S - ------------------------------------------------------------- --- Envelopes --------------------------------------------- ------------------------------------------------------------- - --- | Every diagram comes equipped with an *envelope*. --- Intuitively, the envelope for a diagram tells us the --- minimum distance we have to go in a given direction to get to a --- (hyper)plane entirely containing the diagram on one side of --- it. Formally, given a vector @v@, it returns 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. --- --- This could probably be expressed in terms of a Galois connection; --- this is left as an exercise for the reader. --- --- There is also a special \"empty envelope\". --- --- Essentially, envelopes are a functional representation --- of (a conservative approximation to) convex bounding regions. --- The idea for this representation came from Sebastian Setzer; see --- . -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 b)) = (getMax .) <$> b - -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 .) - --- | Envelopes form a semigroup with pointwise maximum as composition. --- Hence, if @b1@ is the envelope for diagram @d1@, and --- @b2@ is the envelope for @d2@, then @b1 \`mappend\` b2@ --- 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, AdditiveGroup (Scalar 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), AdditiveGroup (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 b), OrderedField (Scalar (V b))) => Enveloped b 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 :: b -> Envelope (V b) - -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 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 - --- XXX rename this? Move it elsewhere? ------------------------------------------------------------- --- Located envelopes ------------------------------------------------------------- - --- | A @LocatedEnvelope@ value represents an envelope with its --- base point at a particular location. -data LocatedEnvelope v = LocatedEnvelope (Point v) (TransInv (Envelope v)) - deriving (Show) - -type instance V (LocatedEnvelope v) = v - -instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (LocatedEnvelope v) where - getEnvelope (LocatedEnvelope _ (TransInv b)) = b - -instance VectorSpace v => HasOrigin (LocatedEnvelope v) where - moveOriginTo (P u) (LocatedEnvelope p b) = LocatedEnvelope (p .-^ u) b - -instance ( HasLinearMap v, InnerSpace v - , Floating (Scalar v), AdditiveGroup (Scalar v) ) - => Transformable (LocatedEnvelope v) where - transform t (LocatedEnvelope p b) = LocatedEnvelope (papply t p) - (transform t b) - --- | Get the location of a located envelope. -location :: LocatedEnvelope v -> Point v -location (LocatedEnvelope p _) = p - --- XXX boundaryFrom really ought to use the 'trace' of a diagram --- instead of the envelope. Leave it here for now, move it when we --- implement traces so it will have a different semantics. - --- | @boundaryFrom v b@ computes the point on the boundary of the --- located envelope @b@ in the direction of @v@ from the --- bounding region's base point. This is most often used to compute --- a point on the boundary of a named subdiagram. -boundaryFrom :: (OrderedField (Scalar v), InnerSpace v) - => LocatedEnvelope v -> v -> Point v -boundaryFrom b v = location b .+^ envelopeV v b - --- | Create a 'LocatedEnvelope' value by specifying a location and an --- envelope. -locateEnvelope :: Point v -> Envelope v -> LocatedEnvelope v -locateEnvelope p b = LocatedEnvelope p (TransInv b) - ------------------------------------------------------------- --- Computing with envelopes ------------------------------------------------------------- - --- | 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 a = maybe zeroV ((*^ v) . ($ v)) $ appEnvelope (getEnvelope a) - --- | 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 a = P $ envelopeV v a - --- | 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 = magnitude (envelopeV v a ^-^ envelopeV (negateV v) a) - --- | 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 a = 0.5 * diameter v a diff --git a/src/Graphics/Rendering/Diagrams/HasOrigin.hs b/src/Graphics/Rendering/Diagrams/HasOrigin.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/HasOrigin.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleInstances - , FlexibleContexts - , TypeFamilies - , UndecidableInstances - #-} - --- The UndecidableInstances flag is needed under 6.12.3 for the --- HasOrigin (a,b) instance. - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.HasOrigin - ( HasOrigin(..), moveOriginBy, moveTo, place - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Points - -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.AffineSpace ((.-^), (.-.)) -import Data.VectorSpace - --- | 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 . moveOriginTo diff --git a/src/Graphics/Rendering/Diagrams/Juxtapose.hs b/src/Graphics/Rendering/Diagrams/Juxtapose.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Juxtapose.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , UndecidableInstances - , TypeFamilies - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.Juxtapose - ( Juxtaposable(..), juxtaposeDefault - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin - -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.VectorSpace - --- | 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'. -juxtaposeDefault :: (Enveloped a, HasOrigin a) => V a -> a -> a -> a -juxtaposeDefault v a1 a2 = moveOriginBy (v1 ^+^ v2) a2 - where v1 = negateV (envelopeV v a1) - v2 = envelopeV (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 = juxtaposeDefault diff --git a/src/Graphics/Rendering/Diagrams/MList.hs b/src/Graphics/Rendering/Diagrams/MList.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/MList.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE TypeOperators - , MultiParamTypeClasses - , FlexibleInstances - , OverlappingInstances - , UndecidableInstances - , TypeFamilies - , GeneralizedNewtypeDeriving - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.MList --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Heterogeneous lists of monoids. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.MList - ( -- * Heterogeneous monoidal lists - - -- $mlist - - Nil(..), (:::)(..) - - , MList(..) - - -- * Converting to tuples - , Tuple, ToTuple(..) - - -- * Accessing embedded values - , (:>:)(..) - - -- * Monoid actions of heterogeneous lists - - -- $mlist-actions - - , SM(..) - ) where - -import Data.Semigroup -import Graphics.Rendering.Diagrams.Monoids - --- $mlist --- --- The idea of /heterogeneous lists/ has been around for a long time. --- Here, we adopt heterogeneous lists where the element types are all --- monoids: this allows us to leave out identity values, so that a --- heterogeneous list containing only a single non-identity value can --- be created without incurring constraints due to all the other --- types, by leaving all the other values out. - -infixr 5 ::: - --- | The empty heterogeneous list. -data Nil = Nil - deriving (Show, Eq, Ord) - --- | Cons for heterogeneous lists. -data a ::: l = Missing l -- ^ The @a@ value is missing, and should be - -- construed as 'mempty'. - | a ::: l -- ^ An @a@ value followed by a heterogeneous - -- list @l@. - deriving (Show, Eq, Ord) - --- MList ----------------------------------- - --- | Type class for heterogeneous monoidal lists, with a single method --- allowing construction of an empty list. -class MList l where - -- | The /empty/ heterogeneous list of type @l@. Of course, @empty - -- == 'mempty'@, but unlike 'mempty', @empty@ does not require - -- 'Monoid' constraints on all the elements of @l@. - empty :: l - -instance MList Nil where - empty = Nil - -instance MList l => MList (a ::: l) where - empty = Missing empty - --- Monoid ---------------------------------- - -instance Semigroup Nil where - _ <> _ = Nil - -instance Monoid Nil where - mempty = Nil - mappend = (<>) - -instance (Semigroup a, Semigroup tl) => Semigroup (a ::: tl) where - (Missing t1) <> (Missing t2) = Missing (t1 <> t2) - (Missing t1) <> (a2 ::: t2) = a2 ::: (t1 <> t2) - (a1 ::: t1) <> (Missing t2) = a1 ::: (t1 <> t2) - (a1 ::: t1) <> (a2 ::: t2) = (a1 <> a2) ::: (t1 <> t2) - --- | Heterogeneous monoidal lists are themselves instances of 'Monoid' --- as long as all their elements are, where 'mappend' is done --- elementwise. -instance (Semigroup a, Semigroup tl, Monoid tl) => Monoid (a ::: tl) where - mempty = Missing mempty - mappend = (<>) - --- ToTuple --------------------------------- - --- | A type function to compute the tuple-based representation for --- instances of 'MList'. -type family Tuple l :: * -type instance Tuple Nil = () -type instance Tuple (a ::: b) = (a, Tuple b) - --- | @toTuple@ can be used to convert a heterogeneous list to its --- tuple-based representation. -class ToTuple l where - toTuple :: l -> Tuple l - -instance ToTuple Nil where - toTuple _ = () - -instance (Monoid a, ToTuple l) => ToTuple (a ::: l) where - toTuple (Missing l) = (mempty, toTuple l) - toTuple (a ::: l) = (a, toTuple l) - --- Embedding ------------------------------------------- - --- | The relation @l :>: a@ holds when @a@ is the type of an element --- in @l@. For example, @(Char ::: Int ::: Bool ::: Nil) :>: Int@. -class l :>: a where - -- | Inject a value into an otherwise empty heterogeneous list. - inj :: a -> l - - -- | Get the value of type @a@ from a heterogeneous list. - get :: l -> a - - -- | Alter the value of type @a@ by applying the given function to it. - alt :: (a -> a) -> l -> l - -instance (MList t, Monoid a) => (:>:) (a ::: t) a where - inj a = a ::: empty - get (Missing _) = mempty - get (a ::: _) = a - alt f (Missing l) = f mempty ::: l - alt f (a ::: l) = f a ::: l - -instance (t :>: a) => (:>:) (b ::: t) a where - inj a = Missing (inj a) - get (Missing l) = get l - get (_ ::: l) = get l - alt f (Missing l) = Missing (alt f l) - alt f (a ::: l) = a ::: alt f l - --- Monoid actions ----------------------------------------- - --- $mlist-actions --- Monoidal heterogeneous lists may act on one another as you would --- expect, with each element in the first list acting on each in the --- second. Unfortunately, coding this up in type class instances is a --- bit fiddly. - --- | @SM@, an abbreviation for \"single monoid\" (as opposed to a --- heterogeneous list of monoids), is only used internally to help --- guide instance selection when defining the action of --- heterogeneous monoidal lists on each other. -newtype SM m = SM m - deriving (Monoid) - -instance Action Nil l where - act _ a = a - -instance (Monoid a, Action (SM a) l2, Action l1 l2) => Action (a ::: l1) l2 where - act (Missing l1) l2 = act l1 l2 - act (a ::: l1) l2 = act (SM a) (act l1 l2) - -instance Monoid a => Action (SM a) Nil where - act _ _ = Nil - -instance (Action a a', Action (SM a) l) => Action (SM a) (a' ::: l) where - act (SM a) (Missing l) = Missing (act (SM a) l) - act (SM a) (a' ::: l) = act a a' ::: act (SM a) l diff --git a/src/Graphics/Rendering/Diagrams/Monoids.hs b/src/Graphics/Rendering/Diagrams/Monoids.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Monoids.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses - , FlexibleInstances - , GeneralizedNewtypeDeriving - , DeriveFunctor - , TypeFamilies - , TypeOperators - , UndecidableInstances - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Monoids --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Various monoid-related definitions (monoid actions, split monoids, --- applicative monoids) used in the core diagrams library. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Monoids - ( -- * Monoids and semigroups - - Monoid' - - -- * Monoid actions - - , Action(..) - - -- * Split monoids - -- $split - - , Split(..), split - - -- * Forgetful monoids - -- $forget - - , Forgetful(..), unForget, forget - - , Deletable(..), unDelete, toDeletable, deleteL, deleteR - - -- * Applicative monoids - - , AM(..), inAM2 - - -- * Coproduct monoid - , (:+:) - , inL, inR - , mappendL, mappendR - , killL, killR - , untangle - ) where - -import Graphics.Rendering.Diagrams.V - -import Data.Semigroup -import Data.Foldable -import Control.Applicative -import Data.Either (lefts, rights) - ------------------------------------------------------------- --- Monoids and semigroups ------------------------------------------------------------- - --- Poor man's constraint synonym. Eventually, once it becomes --- standard, we can make this a real constraint synonym and get rid of --- the UndecidableInstances flag. Better yet, hopefully the Monoid --- class will eventually have a Semigroup superclass. - --- | The @Monoid'@ class is a synonym for things which are instances --- of both 'Semigroup' and 'Monoid'. Ideally, the 'Monoid' class --- itself will eventually include a 'Semigroup' superclass and we --- can get rid of this. -class (Semigroup m, Monoid m) => Monoid' m -instance (Semigroup m, Monoid m) => Monoid' m - ------------------------------------------------------------- --- Monoid actions ------------------------------------------------------------- - --- | Type class for monoid actions, where monoidal values of type @m@ --- \"act\" on values of another type @s@. Instances are required to --- satisfy the laws --- --- * @act mempty = id@ --- --- * @act (m1 ``mappend`` m2) = act m1 . act m2@ --- --- Additionally, if the type @s@ has any algebraic structure, @act --- m@ should be a homomorphism. For example, if @s@ is also a --- monoid we should have @act m mempty = mempty@ and @act m (s1 --- ``mappend`` s2) = (act m s1) ``mappend`` (act m s2)@. --- --- By default, @act = const id@, so for a monoidal type @M@ which --- should have no action on anything, it suffices to write --- --- > instance Action M s --- --- with no method implementations. -class Action m s where - - -- | Convert a monoidal value of type @m@ to an action on @s@ values. - act :: m -> s -> s - act = const id - ------------------------------------------------------------- --- Split monoids ------------------------------------------------------------- - --- $split --- Sometimes we want to accumulate values from some monoid, but have --- the ability to introduce a \"split\" which separates values on --- either side. For example, this is used when accumulating --- transformations to be applied to primitive diagrams: the 'freeze' --- operation introduces a split, since only transformations occurring --- outside the freeze should be applied to attributes. - -infix 5 :| - --- | A value of type @Split m@ is either a single @m@, or a pair of --- @m@'s separated by a divider. -data Split m = M m - | m :| m - --- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which --- combines values on either side of a split, keeping only the --- rightmost split. -instance Semigroup m => Semigroup (Split m) where - (M m1) <> (M m2) = M (m1 <> m2) - (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 - (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' - (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 - -instance (Semigroup m, Monoid m) => Monoid (Split m) where - mempty = M mempty - mappend = (<>) - --- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@. -split :: Monoid m => Split m -split = mempty :| mempty - --- | By default, the action of a split monoid is the same as for --- the underlying monoid, as if the split were removed. -instance Action m n => Action (Split m) n where - act (M m) n = act m n - act (m1 :| m2) n = act m1 (act m2 n) - ------------------------------------------------------------- --- Forgetful monoids ------------------------------------------------------------- - --- $forget --- Sometimes we want to be able to \"forget\" some information. We --- define two monoid transformers that allow forgetting information. --- @Forgetful@ introduces special values which cause anything to their --- right to be forgotten. @Deletable@ introduces special \"left and --- right bracket\" elements which cause everything inside them to be --- forgotten. - - --- | A value of type @Forgetful m@ is either a \"normal\" value of --- type @m@, which combines normally with other normal values, or a --- \"forgetful\" value, which combines normally with other values to --- its left but discards values combined on the right. Also, when --- combining a forgetful value with a normal one the result is --- always forgetful. -data Forgetful m = Normal m - | Forgetful m - deriving Functor - --- | Project the wrapped value out of a `Forgetful` value. -unForget :: Forgetful m -> m -unForget (Normal m) = m -unForget (Forgetful m) = m - --- | If @m@ is a 'Semigroup', then @Forgetful m@ is a semigroup with two --- sorts of values, \"normal\" and \"forgetful\": the normal ones --- combine normally and the forgetful ones discard anything to the --- right. -instance Semigroup m => Semigroup (Forgetful m) where - (Normal m1) <> (Normal m2) = Normal (m1 <> m2) - (Normal m1) <> (Forgetful m2) = Forgetful (m1 <> m2) - (Forgetful m1) <> _ = Forgetful m1 - -instance (Semigroup m, Monoid m) => Monoid (Forgetful m) where - mempty = Normal mempty - mappend = (<>) - - --- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\> --- b == Forgetful a@. -forget :: Monoid m => Forgetful m -forget = Forgetful mempty - -instance Action m n => Action (Forgetful m) n where - act (Normal m) n = act m n - act (Forgetful m) n = act m n - -type instance V (Forgetful m) = V m - --- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking) --- adds two distinguished new elements @[@ and @]@, such that an --- occurrence of [ \"deletes\" everything from it to the next ]. For --- example, --- --- > abc[def]gh == abcgh --- --- This is all you really need to know to /use/ @Deletable m@ --- values; to understand the actual implementation, read on. --- --- To properly deal with nesting and associativity we need to be --- able to assign meanings to things like @[[@, @][@, and so on. (We --- cannot just define, say, @[[ == [@, since then @([[)] == [] == --- id@ but @[([]) == [id == [@.) Formally, elements of @Deletable --- m@ are triples of the form (r, m, l) representing words @]^r m --- [^l@. When combining two triples (r1, m1, l1) and (r2, m2, l2) --- there are three cases: --- --- * If l1 == r2 then the [s from the left and ]s from the right --- exactly cancel, and we are left with (r1, m1 \<\> m2, l2). --- --- * If l1 < r2 then all of the [s cancel with some of the ]s, but --- m1 is still inside the remaining ]s and is deleted, yielding (r1 --- + r2 - l1, m2, l2) --- --- * The remaining case is symmetric with the second. - -data Deletable m = Deletable Int m Int - deriving Functor - -type instance V (Deletable m) = V m - --- | Project the wrapped value out of a `Deletable` value. -unDelete :: Deletable m -> m -unDelete (Deletable _ m _) = m - --- | Inject a value into a `Deletable` wrapper. Satisfies the --- property --- --- > unDelete . toDeletable === id --- -toDeletable :: m -> Deletable m -toDeletable m = Deletable 0 m 0 - -instance Semigroup m => Semigroup (Deletable m) where - (Deletable r1 m1 l1) <> (Deletable r2 m2 l2) - | l1 == r2 = Deletable r1 (m1 <> m2) l2 - | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 - | otherwise = Deletable r1 m1 (l2 + l1 - r2) - -instance (Semigroup m, Monoid m) => Monoid (Deletable m) where - mempty = Deletable 0 mempty 0 - mappend = (<>) - --- | A \"left bracket\", which causes everything between it and the --- next right bracket to be deleted. -deleteL :: Monoid m => Deletable m -deleteL = Deletable 0 mempty 1 - --- | A \"right bracket\", denoting the end of the section that should --- be deleted. -deleteR :: Monoid m => Deletable m -deleteR = Deletable 1 mempty 0 - ------------------------------------------------------------- --- Applicative monoids ------------------------------------------------------------- - --- | A wrapper for an 'Applicative' structure containing a monoid. --- Such structures have a @Monoid@ instance based on \"idiomatic\" --- application of 'mappend' within the @Applicative@ context. --- @instance Monoid m => Monoid (e -> m)@ is one well-known special --- case. (However, the standard @Monoid@ instance for @Maybe@ is --- /not/ an instance of this pattern; nor is the standard instance --- for lists.) -newtype AM f m = AM (f m) - deriving (Functor, Applicative) - --- | Apply a binary function inside an 'AM' newtype wrapper. -inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m -inAM2 g (AM f1) (AM f2) = AM (g f1 f2) - -instance (Applicative f, Semigroup m) => Semigroup (AM f m) where - (<>) = inAM2 (liftA2 (<>)) - --- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@. -instance (Applicative f, Monoid m) => Monoid (AM f m) where - mempty = pure mempty - mappend = inAM2 (liftA2 mappend) - -{- See Applicative laws here: - -http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative --} - -{- left identity: - - AM (pure mempty) `mappend` AM f -= { definition } - AM $ fmap mappend (pure mempty) <*> f -= { naturality of pure, fmap f . pure = pure . f } - AM $ pure (mappend mempty) <*> f -= { monoid law (left identity) } - AM $ pure id <*> f -= { applicative law (identity) } - AM f --} - -{- right identity: - - AM f `mappend` AM (pure mempty) -= { definition } - AM $ fmap mappend f <*> pure mempty -= { applicative law (interchange) } - AM $ pure ($mempty) <*> fmap mappend f -= { applicative/functor law } - AM $ pure ($mempty) <*> (pure mappend <*> f) -= { applicative law (composition) } - AM $ pure (.) <*> pure ($mempty) <*> pure mappend <*> f -= { applicative law (homomorphism) } - AM $ pure ((.) ($mempty)) <*> pure mappend <*> f -= { applicative law (homomorphism) } - AM $ pure (($mempty) . mappend) <*> f -= { monoid law (right identity) } - AM $ pure id <*> f -= { applicative law (identity) } - AM f --} - -{- associativity: - - (AM f1 `mappend` AM f2) `mappend` AM f3 -= { definition } - AM $ fmap mappend (AM f1 `mappend` AM f2) <*> f3 -= { definition } - AM $ fmap mappend (fmap mappend f1 <*> f2) <*> f3 -= { applicative/functor law } - AM $ pure mappend <*> (pure mappend <*> f1 <*> f2) <*> f3 -= { applicative law (composition) } - AM $ pure (.) <*> pure mappend <*> (pure mappend <*> f1) <*> f2 <*> f3 -= { applicative law (homomorphism) } - AM $ pure (mappend .) <*> (pure mappend <*> f1) <*> f2 <*> f3 -= { applicative law (composition) } - AM $ pure (.) <*> pure (mappend .) <*> pure mappend <*> f1 <*> f2 <*> f3 -= { applicative law (homomorphism) } - AM $ pure ((mappend .) . mappend) <*> f1 <*> f2 <*> f3 -= { monoid law (associativity) } - AM $ pure ((. mappend) . (.) . mappend) <*> f1 <*> f2 <*> f3 -= - -- XXX finish this proof (although I have no doubt it goes through) - - -= - AM f1 `mappend` (AM f2 `mappend` AM f3) --} - -{- -\x y z -> (x `mappend` y) `mappend` z -\x y -> mappend (mappend x y) -\x -> mappend . (mappend x) -(mappend .) . mappend --} - -{- -\x y z -> x `mappend` (y `mappend` z) -\x y z -> mappend x (mappend y z) -\x y -> mappend x . mappend y -\x -> ((.) (mappend x)) . mappend -\x -> (.) ((.) (mappend x)) mappend -\x -> (.mappend) ((.) (mappend x)) -(. mappend) . (.) . mappend --} - - --- | An applicative monoid acts on a value of a monoidal type by --- having each element in the structure act on the value --- independently, and then folding the resulting structure. -instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where - act (AM f) n = fold $ fmap (`act` n) f - --- XXX need to prove that this satisfies the laws! There are other --- "obvious" instances too. - ------------------------------------------------------------- --- Monoid coproduct ------------------------------------------------------------- - --- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Values of --- type @m :+: n@ consist of alternating lists of @m@ and @n@ --- values. The empty list is the identity, and composition is list --- concatenation, with appropriate combining of adjacent elements --- when possible. -newtype m :+: n = MCo { unMCo :: [Either m n] } - --- For efficiency and simplicity, we implement it just as [Either m --- n]: of course, this does not preserve the invariant of strictly --- alternating types, but it doesn't really matter as long as we don't --- let anyone inspect the internal representation. - --- | Injection from the left monoid into a coproduct. -inL :: m -> m :+: n -inL m = MCo [Left m] - --- | Injection from the right monoid into a coproduct. -inR :: n -> m :+: n -inR n = MCo [Right n] - --- | Prepend a value from the left monoid. -mappendL :: m -> m :+: n -> m :+: n -mappendL = mappend . inL - --- | Prepend a value from the right monoid. -mappendR :: n -> m :+: n -> m :+: n -mappendR = mappend . inR - -{- -normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n -normalize (MCo es) = MCo (normalize' es) - where normalize' [] = [] - normalize' [e] = [e] - normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es) - normalize' (Left e1:es) = Left e1 : normalize' es - normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es) - normalize' (Right e1:es) = Right e1 : normalize' es --} - -instance Semigroup (m :+: n) where - (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) - --- | The coproduct of two monoids is itself a monoid. -instance Monoid (m :+: n) where - mempty = MCo [] - mappend = (<>) - --- | @killR@ takes a value in a coproduct monoid and sends all the --- values from the right monoid to the identity. -killR :: Monoid m => m :+: n -> m -killR = mconcat . lefts . unMCo - --- | @killL@ takes a value in a coproduct monoid and sends all the --- values from the left monoid to the identity. -killL :: Monoid n => m :+: n -> n -killL = mconcat . rights . unMCo - --- | Take a value from a coproduct monoid where the left monoid has an --- action on the right, and \"untangle\" it into a pair of values. In --- particular, --- --- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ... --- --- is sent to --- --- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...) --- --- That is, before combining @n@ values, every @n@ value is acted on --- by all the @m@ values to its left. -untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n) -untangle (MCo elts) = untangle' mempty elts - where untangle' cur [] = cur - untangle' (curM, curN) (Left m : elts') = untangle' (curM `mappend` m, curN) elts' - untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN `mappend` act curM n) elts' - --- | Coproducts act on other things by having each of the components --- act individually. -instance (Action m r, Action n r) => Action (m :+: n) r where - act = appEndo . mconcat . map (Endo . either act act) . unMCo diff --git a/src/Graphics/Rendering/Diagrams/Names.hs b/src/Graphics/Rendering/Diagrams/Names.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Names.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances - , FlexibleInstances - , FlexibleContexts - , TypeFamilies - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , OverlappingInstances - , TupleSections - , GADTs - , DeriveDataTypeable - , UndecidableInstances - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 locations within diagrams, and related types. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Names - (-- * Names - -- ** Atomic names - AName(..) - - -- ** Names - , Name(..), IsName(..), (.>) - - -- ** Qualifiable - , Qualifiable(..) - - -- * Name maps - - , NameMap(..) - - -- ** Constructing name maps - , fromNames, fromNamesB - , rememberAs - - -- ** Searching within name maps - , lookupN - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.Transform - -import Data.VectorSpace - -import Data.List (intercalate, isSuffixOf) -import qualified Data.Map as M -import Data.Semigroup -import Control.Arrow ((***)) -import Control.Monad (mplus) - -import Control.Newtype - -import Data.Typeable - ------------------------------------------------------------- --- 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 - (|>) = (.>) - -infixr 5 |> -infixr 5 .> - ------------------------------------------------------------- --- Name maps --------------------------------------------- ------------------------------------------------------------- - --- | A 'NameMap' is a map associating names to located envelopes, --- /i.e./ envelopes with concrete locations for their base --- points. There can be multiple associations for any given name. -newtype NameMap v = NameMap (M.Map Name [LocatedEnvelope v]) - deriving (Show) - -instance Newtype (NameMap v) (M.Map Name [LocatedEnvelope v]) where - pack = NameMap - unpack (NameMap m) = m - --- Note, 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 - --- Note also that we wrap the envelope with TransInv. This is because --- the base point of each envelope should be thought of as the paired --- Point, *not* as the origin of the current vector space. In other --- words, the point gets translated "for both of them". - -type instance V (NameMap v) = v - -instance Semigroup (NameMap v) where - NameMap s1 <> NameMap s2 = NameMap $ M.unionWith (++) s1 s2 - --- | 'NameMap'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 (NameMap v) where - mempty = NameMap M.empty - mappend = (<>) - -instance (AdditiveGroup (Scalar v), Fractional (Scalar v), InnerSpace v) - => HasOrigin (NameMap v) where - moveOriginTo = over NameMap . moveOriginTo - -instance (AdditiveGroup (Scalar v), InnerSpace v, Floating (Scalar v), HasLinearMap v) - => Transformable (NameMap v) where - transform = over NameMap . transform - --- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @a |> --- ns@ is the same 'NameMap' except with every name qualified by --- @a@. -instance Qualifiable (NameMap v) where - a |> (NameMap names) = NameMap $ M.mapKeys (a |>) names - --- | Construct a 'NameMap' from a list of (name, point) pairs. -fromNames :: (InnerSpace v, AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v), IsName a) - => [(a, Point v)] -> NameMap v -fromNames = NameMap . M.fromListWith (++) - . map (toName *** ((:[]) . (\p -> locateEnvelope p (getEnvelope p)))) - --- | Construct a 'NameMap' from a list of associations between names --- and located envelopes. -fromNamesB :: IsName a => [(a, LocatedEnvelope v)] -> NameMap v -fromNamesB = NameMap . M.fromListWith (++) . map (toName *** (:[])) - --- | Give a name to a located envelope. -rememberAs :: IsName a => a -> LocatedEnvelope v -> NameMap v -> NameMap v -rememberAs n b = over NameMap $ M.insertWith (++) (toName n) [b] - --- | A name acts on a name map by qualifying every name in it. -instance Action Name (NameMap v) where - act = (|>) - --- | Names don't act on anything else. -instance Action Name a - - --- Searching in name maps. - --- | Look for the given name in a name map, returning a list of --- located envelopes associated with that name. If no names match --- the given name exactly, return all the points associated with --- names of which the given name is a suffix. -lookupN :: IsName n => n -> NameMap v -> Maybe [LocatedEnvelope v] -lookupN a (NameMap 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 diff --git a/src/Graphics/Rendering/Diagrams/Points.hs b/src/Graphics/Rendering/Diagrams/Points.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Points.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeFamilies - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.V - -type instance V (Point v) = v diff --git a/src/Graphics/Rendering/Diagrams/Query.hs b/src/Graphics/Rendering/Diagrams/Query.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Query.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TypeFamilies - , GeneralizedNewtypeDeriving - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.Query - ( Query(..) - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - -import Data.VectorSpace -import Data.AffineSpace - -import Data.Semigroup -import Control.Applicative - ------------------------------------------------------------- --- 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) diff --git a/src/Graphics/Rendering/Diagrams/Style.hs b/src/Graphics/Rendering/Diagrams/Style.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Style.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables - , GADTs - , KindSignatures - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , UndecidableInstances - #-} - --- The UndecidableInstances flag is needed under 6.12.3 for the --- HasStyle (a,b) instance. - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.Style - ( -- * Attributes - -- $attr - - AttributeClass - , Attribute(..) - , mkAttr, mkTAttr, unwrapAttr - , applyAttr, applyTAttr - - -- * Styles - -- $style - - , Style(..) - , attrToStyle, tAttrToStyle - , getAttr, setAttr, addAttr, combineAttr - - , HasStyle(..) - - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Monoids - -import Data.Typeable - -import Control.Arrow ((***)) -import Data.Semigroup -import qualified Data.Map as M -import qualified Data.Set as S - ------------------------------------------------------------- --- 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 . tAttrToStyle diff --git a/src/Graphics/Rendering/Diagrams/Transform.hs b/src/Graphics/Rendering/Diagrams/Transform.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Transform.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE TypeOperators - , FlexibleContexts - , FlexibleInstances - , UndecidableInstances - , TypeFamilies - , MultiParamTypeClasses - , GeneralizedNewtypeDeriving - , TypeSynonymInstances - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Transform --- 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 @Transform@ module defines generic transformations --- parameterized by any vector space. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Transform - ( - -- * Transformations - - -- ** Invertible linear transformations - (:-:)(..), (<->), linv, lapp - - -- ** General transformations - , Transformation(..) - , inv, transp, transl - , apply - , papply - , fromLinear - - -- * 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 Data.AdditiveGroup -import Data.VectorSpace -import Data.AffineSpace ((.-.)) -import Data.LinearMap -import Data.Basis -import Data.MemoTrie - -import Data.Semigroup -import qualified Data.Map as M -import qualified Data.Set as S - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - ------------------------------------------------------------- --- 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 - ------------------------------------------------------------- --- 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 t => Transformable (t,t) where - transform t (x,y) = ( transform t x - , transform t y - ) - -instance Transformable t => Transformable (t,t,t) where - transform t (x,y,z) = ( transform t x - , transform t y - , transform t z - ) - -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 (Forgetful m) where - transform = fmap . transform - -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 (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 tr (TransInv t) = TransInv (translate (negateV (transl tr)) . transform tr $ 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 diff --git a/src/Graphics/Rendering/Diagrams/UDTree.hs b/src/Graphics/Rendering/Diagrams/UDTree.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/UDTree.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveFunctor - , TypeOperators - , FlexibleContexts - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.UDTree --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Rose (n-way) trees with both upwards- and downwards-traveling --- monoidal annotations, used as the basis for representing diagrams. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.UDTree - ( - -- * UD-trees - UDTree(..) - - -- * Constructing UD-trees - , leaf, branchD, branch - - -- * Modifying UD-trees - , applyD, applyUpre, applyUpost, mapU - - -- * Accessors and destructors - , getU, getU', foldUD, flatten - - ) where - -import Data.Semigroup - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.MList - --- | Abstractly, a UDTree is a rose (n-way) tree with data at the --- leaves and two types of monoidal annotations, one (called @u@) --- travelling \"up\" the tree and one (called @d@) traveling --- \"down\". --- --- Specifically, every node (both leaf nodes and internal nodes) --- has two annotations, one of type @d@ and one of type @u@, --- subject to the following constraints: --- --- * The @d@ annotation at a leaf node is equal to the 'mconcat' of --- all the @d@ annotations along the path from the root to the leaf --- node. --- --- * The @u@ annotation at an internal node is equal to @v1 --- ``mappend`` (mconcat us) ``mappend`` v2@ for some values @v1@ --- and @v2@ (possibly 'mempty'), where @us@ is the list (in --- left-right order) of the @u@ annotations on the immediate child --- nodes of the given node. Intuitively, we are \"caching\" the --- @mconcat@ of @u@ annotations from the leaves up, except that at --- any point we may insert \"extra\" information. --- --- In addition, @d@ may have an /action/ on @u@ (see the 'Action' --- type class, defined in "Graphics.Rendering.Diagrams.Monoids"), in --- which case applying a @d@ annotation to a tree will transform all --- the @u@ annotations by acting on them. The constraints on @u@ --- annotations are maintained since the action is required to be a --- monoid homomorphism. - -data UDTree u d a - = Leaf u a - | Branch u [d] [UDTree u d a] - deriving (Functor) - --- XXX need to sort out all the semigroup/monoid stuff in here! - -instance (Action d u, Monoid u, Monoid d) => Semigroup (UDTree u d a) where - t1 <> t2 = branch [t1,t2] - --- | @UDTree@s form a monoid where @mappend@ corresponds to adjoining --- two trees under a common parent root. Note that this technically --- does not satisfy associativity, but it does with respect to --- 'flatten' which is what we really care about. @mconcat@ is --- specialized to put all the trees under a single parent. -instance (Action d u, Monoid u, Monoid d) => Monoid (UDTree u d a) where - mempty = Branch mempty mempty [] - t1 `mappend` t2 = branch [t1,t2] - mconcat = branch - --- | Construct a leaf node from a @u@ annotation and datum. -leaf :: u -> a -> UDTree u d a -leaf = Leaf - --- | Construct a branch node with an explicit @d@ annotation. -branchD :: (Action d u, Monoid u) => d -> [UDTree u d a] -> UDTree u d a -branchD d ts = Branch (mconcat . map getU $ ts) [d] ts - --- | Construct a branch node with a default (identity) @d@ annotation. -branch :: (Action d u, Monoid u, Monoid d) => [UDTree u d a] -> UDTree u d a -branch ts = Branch (mconcat . map getU $ ts) [] ts - --- | Get the @u@ annotation at the root. -getU :: Action d u => UDTree u d a -> u -getU (Leaf u _) = u -getU (Branch u ds _) = foldr act u ds - --- | Get a particular component from a the @u@ annotation at the root. --- This method is provided for convenience, since its context only --- requires an action of @d@ on @u'@, rather than on @u@ in its --- entirety. -getU' :: (Action d (u' ::: Nil), u :>: u') => UDTree u d a -> u' -getU' (Leaf u _) = get u -getU' (Branch u ds _) = hd $ foldr act (get u ::: Nil) ds - where hd (u' ::: Nil) = u' - hd (Missing _) = error "Impossible case in UDTree.getU' (hd)" - --- | Add a @d@ annotation to the root, combining it (on the left) with --- any pre-existing @d@ annotation, and transforming all @u@ --- annotations by the action of @d@. -applyD :: Action d u => d -> UDTree u d a -> UDTree u d a -applyD d l@(Leaf {}) = Branch (getU l) [d] [l] -applyD d (Branch u ds ts) = Branch u (d : ds) ts - --- | Add a @u@ annotation to the root, combining it (on the left) with --- the existing @u@ annotation. -applyUpre :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a -applyUpre u' (Leaf u a) = Leaf (u' <> u) a -applyUpre u' b = Branch (u' <> getU b) [] [b] - --- | Add a @u@ annotation to the root, combining it (on the right) with --- the existing @u@ annotation. -applyUpost :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a -applyUpost u' (Leaf u a) = Leaf (u <> u') a -applyUpost u' b = Branch (getU b <> u') [] [b] - --- | Map a function over all the @u@ annotations. The function must --- be a monoid homomorphism, and must commute with the action of @d@ --- on @u@. That is, to use @mapU f@ safely it must be the case that --- @f (act d u) == act d (f u)@. -mapU :: (u -> u') -> UDTree u d a -> UDTree u' d a -mapU f (Leaf u a) = Leaf (f u) a -mapU f (Branch u ds ts) = Branch (f u) ds (map (mapU f) ts) - --- | A fold for UDTrees. -foldUD :: (Monoid r, Semigroup d, Monoid d, Action d u) - => (u -> d -> a -> r) -- ^ Function for processing leaf nodes. - -- Given the u annotation at this node, the - -- 'mconcat' of all d annotations above, and the - -- leaf value. - -> (u -> d -> r -> r) -- ^ Function for processing internal - -- nodes. Given the u and d - -- annotations at this node and the - -- 'mconcat' of the recursive results. - -> UDTree u d a -> r -foldUD = foldUD' mempty -- Pass along accumulated d value - where foldUD' d l _ (Leaf u a) - = l (act d u) d a - foldUD' d l b (Branch u ds ts) - = b (act (d <> d') u) d' (mconcat $ map (foldUD' (d <> d') l b) ts) - where d' = mconcat ds - --- | A specialized fold provided for convenience: flatten a tree into --- a list of leaves along with their @d@ annotations. -flatten :: (Semigroup d, Monoid d, Action d u) => UDTree u d a -> [(a,d)] -flatten = foldUD (\_ d a -> [(a,d)]) (\_ _ r -> r) diff --git a/src/Graphics/Rendering/Diagrams/Util.hs b/src/Graphics/Rendering/Diagrams/Util.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Util.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Util --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Various internal utilities for the diagrams project. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Util - ( - -- * Vectors - - withLength - - ) where - -import Data.VectorSpace - --- | Produce a vector with the specified length in the same direction --- as the given vector. -withLength :: (InnerSpace v, Floating (Scalar v)) => Scalar v -> v -> v -withLength l v = (l / magnitude v) *^ v diff --git a/src/Graphics/Rendering/Diagrams/V.hs b/src/Graphics/Rendering/Diagrams/V.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/V.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.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 Graphics.Rendering.Diagrams.V - ( V - - ) where - -import Data.Set -import Data.Map - ------------------------------------------------------------- --- Vector spaces ------------------------------------------- ------------------------------------------------------------- - --- | Many sorts of objects have an associated vector space in which --- they live. The type function @V@ maps from objects to their --- 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 (Set a) = V a -type instance V (Map k a) = V a