diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,618 @@ +# Change Log + +## [v1.3](https://github.com/diagrams/diagrams-core/tree/v1.3) (2015-04-19) + +* **New features** + + - Update for ghc-7.10. + + - Switch from `vector-space` to `linear` for linear algebra. + + - `OpacityGroup` annotation for setting the opacity of diagrams as + a group. Opacity groups can be applied with the `opacityGroup` or + `groupOpacity` functions. + + - Added `atAttr`, `atMAttr` and `atTAttr` lenses onto the attributes + of styles. + + - `InSpace` and `SameSpace` synonyms. + + - `size` function for computing the range of an enveloped object in + the basis vectors. + + - "Grouping" for transparent things [\#21](https://github.com/diagrams/diagrams-core/issues/21) + +* **Dependency/version changes** + + - Allow `base-4.8` + - Allow `lens-4.9` + +* **New instances** + + - `Show` instances for `Attribute` and `Style`. + - `Each`, `Ixed` and `At` instances for and `Style`. + +* **API changes** + + - `Measure` has a new internal representation. `Local`, `Global`, + `Normalized`, and `Output` have been renamed to `local`, `global`, + `normalized` and `output` respectivly. `Measure` is now defined in + `Diagrams.Core.Measure`. + + - `GTAttribute` has been removed. `MAttribute` now holds measured + attributes and no longer requires a `Data` instance. + + - `V` is now a `* -> *` kind type family. + + - New type family `N` for the number type of an object, `Scalar` + type family no longer exists. + + - `(|>)` has moved to `(.>>)` to make room for lens's snoc operator. + + - `Style`'s internal representation now uses a hashmap of the + `TypeRep`. + +**Merged pull requests:** + +- Pre 1.3 [\#82](https://github.com/diagrams/diagrams-core/pull/82) ([cchalmers](https://github.com/cchalmers)) + +- update for GHC-7.10, -Wall [\#81](https://github.com/diagrams/diagrams-core/pull/81) ([bergey](https://github.com/bergey)) + +- Style lenses [\#80](https://github.com/diagrams/diagrams-core/pull/80) ([cchalmers](https://github.com/cchalmers)) + +- Add isReflection [\#79](https://github.com/diagrams/diagrams-core/pull/79) ([byorgey](https://github.com/byorgey)) + +- Linear update [\#77](https://github.com/diagrams/diagrams-core/pull/77) ([cchalmers](https://github.com/cchalmers)) + +- Bump lens upper version bounds [\#74](https://github.com/diagrams/diagrams-core/pull/74) ([RyanGlScott](https://github.com/RyanGlScott)) + +- Add Diagram B synonym for Diagram b v n [\#73](https://github.com/diagrams/diagrams-core/pull/73) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- New stuff [\#72](https://github.com/diagrams/diagrams-core/pull/72) ([cchalmers](https://github.com/cchalmers)) + +- Linear [\#71](https://github.com/diagrams/diagrams-core/pull/71) ([cchalmers](https://github.com/cchalmers)) + +- Bump linear upper version bounds [\#75](https://github.com/diagrams/diagrams-core/pull/75) ([RyanGlScott](https://github.com/RyanGlScott)) + +- Change Measure back to not using Scalar v [\#65](https://github.com/diagrams/diagrams-core/pull/65) ([Mathnerd314](https://github.com/Mathnerd314)) + +- Remove gratuitous Data constraints [\#69](https://github.com/diagrams/diagrams-core/pull/69) ([Mathnerd314](https://github.com/Mathnerd314)) + +## [v1.2.0.6](https://github.com/diagrams/diagrams-core/tree/v1.2.0.6) (2015-04-03) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2.0.5...v1.2.0.6) + +**Closed issues:** + +- Please add support for recent versions of vector-space [\#78](https://github.com/diagrams/diagrams-core/issues/78) + +## [v1.2.0.5](https://github.com/diagrams/diagrams-core/tree/v1.2.0.5) (2015-01-13) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2.0.4...v1.2.0.5) + +## [v1.2.0.4](https://github.com/diagrams/diagrams-core/tree/v1.2.0.4) (2014-12-04) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2.0.3...v1.2.0.4) + +## [v1.2.0.3](https://github.com/diagrams/diagrams-core/tree/v1.2.0.3) (2014-11-17) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2.0.2...v1.2.0.3) + +## [v1.2.0.2](https://github.com/diagrams/diagrams-core/tree/v1.2.0.2) (2014-08-22) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2.0.1...v1.2.0.2) + +**Closed issues:** + +- Warn against GND for IsName [\#67](https://github.com/diagrams/diagrams-core/issues/67) + +## [v1.2.0.1](https://github.com/diagrams/diagrams-core/tree/v1.2.0.1) (2014-06-04) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.2...v1.2.0.1) + +**Merged pull requests:** + +- Propogate transformations into the terms of Measure [\#66](https://github.com/diagrams/diagrams-core/pull/66) ([bergey](https://github.com/bergey)) + +## [v1.2](https://github.com/diagrams/diagrams-core/tree/v1.2) (2014-06-02) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.1...v1.2) + +* **New features** + + - New function `matrixHomRep` to convert a transformation to a + homogeneous matrix representation. + + - New function `dropTransl` to drop the translation component + from a transformation. + + - A mini-DSL for Measures. + + - New `extent` function, used in `diameter`. + + - New `dimension` function to return the dimension of a vector space. + + - New `_relative` iso between points and vectors. + + - `avgScale` function (for computing the average scaling factor of + a transformation) has been moved from `diagrams-lib` to + `diagrams-core` and generalized to work over any vector space. + +* **Dependency/version changes** + + - Allow `semigroups-0.15` + - Allow `lens-4.2` + +* **API changes** + + - Major refactoring which removes `freeze` (and hence `Split` transforms, + etc.) and adds units of `Measure`. + + - Refactoring and simplification of the `Backend` class. + + - Remove `Multibackend`. + + - Remove `nullPrim`, `IsPrim` and simplify `RPrim` so that it does not + carry a transformation. + + - Update `adjustDia` to return a transformation, not just a scale factor. + Add `renderDiaT` which returns a transformation (for use by end + users, e.g. to convert output coordinates back into local coordinates). + +**Implemented enhancements:** + +- Extracting things from Prim wrappers [\#42](https://github.com/diagrams/diagrams-core/issues/42) + +**Closed issues:** + +- Incomplete comment on Backend class [\#64](https://github.com/diagrams/diagrams-core/issues/64) + +- Please add support for Lens 4.x [\#56](https://github.com/diagrams/diagrams-core/issues/56) + +**Merged pull requests:** + +- A mini-DSL for Measures. [\#61](https://github.com/diagrams/diagrams-core/pull/61) ([byorgey](https://github.com/byorgey)) + +- Clean-slate redesign/simplification of `Backend` class [\#60](https://github.com/diagrams/diagrams-core/pull/60) ([byorgey](https://github.com/byorgey)) + +- Rework units [\#59](https://github.com/diagrams/diagrams-core/pull/59) ([byorgey](https://github.com/byorgey)) + +- Avg scale [\#58](https://github.com/diagrams/diagrams-core/pull/58) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Preliminary implementation of Measure [\#55](https://github.com/diagrams/diagrams-core/pull/55) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- No mco [\#62](https://github.com/diagrams/diagrams-core/pull/62) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +## [v1.1](https://github.com/diagrams/diagrams-core/tree/v1.1) (2014-03-09) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.0.0.1...v1.1) + +* **New features** + + - New `basis` function + - New `determinant` function for computing the determinant of a + `Transformation` + - Add `Typeable` constraint on `Prim`s, making it possible to + extract things back out of a `Prim` wrapper using `cast` + - Raw `Trace`s now return a *sorted list* of intersections, + instead of only the smallest. This is used to implement a new + family of functions `rayTraceV`, `rayTraceP`, `maxRayTraceV`, + `maxRayTraceP`, which work similarly to the parallel versions + without `Ray`, but return the first intersection in the + *positive* direction from the given point, rather than the + smallest in absolute terms. + - New `Annotation` type and corresponding `applyAnnotation` + function, for attaching uninterpreted annotations at specific + points in a diagram tree. Currently this is used for + hyperlinks; more annotation types will be added in the future. + +* **Dependency/version changes** + + - Require `lens-4.0` + - Allow `vector-space-points-0.2` + +* **Bug fixes** + + - Looking up a subdiagram by name now results in a diagram which + still has that name (#43) + +**Closed issues:** + +- Named subdiagrams lose their names after being looked up [\#43](https://github.com/diagrams/diagrams-core/issues/43) + +**Merged pull requests:** + +- Hyperlinks [\#57](https://github.com/diagrams/diagrams-core/pull/57) ([tdox](https://github.com/tdox)) + +- Added `basis`, simplified `onBasis` [\#54](https://github.com/diagrams/diagrams-core/pull/54) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Determinants [\#53](https://github.com/diagrams/diagrams-core/pull/53) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Introduce Typeable constraint on Prims \(see \#42\) [\#52](https://github.com/diagrams/diagrams-core/pull/52) ([byorgey](https://github.com/byorgey)) + +- Update Wrapped instances for lens-4.0 [\#51](https://github.com/diagrams/diagrams-core/pull/51) ([bergey](https://github.com/bergey)) + +- return list of traces [\#48](https://github.com/diagrams/diagrams-core/pull/48) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Projections rebase [\#50](https://github.com/diagrams/diagrams-core/pull/50) ([bergey](https://github.com/bergey)) + +## [v1.0.0.1](https://github.com/diagrams/diagrams-core/tree/v1.0.0.1) (2013-11-28) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.0...v1.0.0.1) + +## [v1.0](https://github.com/diagrams/diagrams-core/tree/v1.0) (2013-11-25) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.7.0.1...v1.0) + +* **New features** + + * Delayed subtrees: instead of a primitive, one can now also have + a delayed subtree at a leaf, containing a continuation which + generates a `QDiagram` when given the accumulated d-annotation + at that point in the tree. Useful for things which need to know + the final transformation applied to them before deciding what + diagram to generate. The prototypical use case is arrows: see + https://github.com/diagrams/diagrams-lib/issues/112 . However, + this may be useful for other things as well: for example, + diagrams which scale normally until hitting some maximum or + minimum size, at which point they refuse to scale any further + (or more generally diagrams which scale as some non-linear + function of the transformation applied to them). + + The only downside is that the u-annotation must be fixed ahead + of time---doing otherwise requires a more general solution for + constraint solving. + + * New function `lookupName` for doing a simple lookup of a named + subdiagram + + * New module `Diagrams.Core.Compile`, containing a framework for + compiling `QDiagrams` into a simpler tree type `RTree`, which + may be used by backends for rendering. + +* **New instances** + + * `Qualifiable` instances for `(,)`, `(,,)`, `[]`, `Set`, `Map k`, + and `(->) e`. + + * `(->) e` instance for `Juxtaposable` (thanks to Carlos Scheidegger) + +* **API changes** + + * Export `pointDiagram` function, which creates an otherwise empty + diagram with a point (not empty) envelope + + * A bunch of stuff now uses machinery from the `lens` library. + * `envelope`, `trace`, and `subMap` are now `Lens'`es + * `Wrapped` instances for `Trace`, `TransInv`, `QDiagram`, + `SubMap`, `Envelope`, `Style`, `Query`, and `Name` (replaces + `Newtype` instances) + * `Iso`s for `Query`, `Envelope`, `QDiagram`, `SubMap`, `TransInv` + +**Implemented enhancements:** + +- Tree structure in Backends [\#19](https://github.com/diagrams/diagrams-core/issues/19) + +**Merged pull requests:** + +- Delayed subtrees [\#47](https://github.com/diagrams/diagrams-core/pull/47) ([byorgey](https://github.com/byorgey)) + +- Trees for backends [\#46](https://github.com/diagrams/diagrams-core/pull/46) ([byorgey](https://github.com/byorgey)) + +- add b-\>a instance for Juxtaposable [\#45](https://github.com/diagrams/diagrams-core/pull/45) ([cscheid](https://github.com/cscheid)) + +- Lens [\#44](https://github.com/diagrams/diagrams-core/pull/44) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +## [v0.7.0.1](https://github.com/diagrams/diagrams-core/tree/v0.7.0.1) (2013-09-27) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.7...v0.7.0.1) + +**Merged pull requests:** + +- Add lookupName function. [\#41](https://github.com/diagrams/diagrams-core/pull/41) ([cmears](https://github.com/cmears)) + +## [v0.7](https://github.com/diagrams/diagrams-core/tree/v0.7) (2013-08-09) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.6.0.2...v0.7) + +* **New features** + + - new function `onBasis`, to extract the matrix equivalent of a `Transformation` + - `SubMap`s are now `Deletable` + - new function `localize` for hiding/deleting names from scope + - new `IsPrim` class, containing `transformWithFreeze` function. + This is primarily intended to support scale-invariant primitives + (*e.g.* arrowheads) but may be useful for other stuff as well. + The default implementation of `renderDia` now uses + `transformWithFreeze`. + - optimized `Transformable` instance for `TransInv` + +* **New instances** + + - `Eq`, `Ord`, `Enveloped`, `Traced`, and `Qualifiable` instances + for `TransInv` + + - `Transformable` instance for functions, which acts by conjugation + +* **API changes** + + - `named` and `namePoint` have moved to the `diagrams-lib` package. + +* **Dependency/version changes** + + - allow `base-4.7` + - upgrade to `monoid-extras-0.3` + +**Implemented enhancements:** + +- Function to extract matrix coefficients from a Transformation [\#22](https://github.com/diagrams/diagrams-core/issues/22) + +**Closed issues:** + +- Support for monoid-extras-0.3.0.0 [\#38](https://github.com/diagrams/diagrams-core/issues/38) + +**Merged pull requests:** + +- New IsPrim class for supporting ScaleInv [\#37](https://github.com/diagrams/diagrams-core/pull/37) ([byorgey](https://github.com/byorgey)) + +- onBasis gets the matrix equivalent of the Transformation [\#36](https://github.com/diagrams/diagrams-core/pull/36) ([bergey](https://github.com/bergey)) + +## [v0.6.0.2](https://github.com/diagrams/diagrams-core/tree/v0.6.0.2) (2013-03-06) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.6.0.1...v0.6.0.2) + +**Fixed bugs:** + +- radius is wrong [\#35](https://github.com/diagrams/diagrams-core/issues/35) + +**Merged pull requests:** + +- make SubMaps deletable, and add a new function 'localize' for hiding/deleting names [\#34](https://github.com/diagrams/diagrams-core/pull/34) ([byorgey](https://github.com/byorgey)) + +## [v0.6.0.1](https://github.com/diagrams/diagrams-core/tree/v0.6.0.1) (2013-01-07) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.6...v0.6.0.1) + +**Fixed bugs:** + +- "type instance V \(Point v\) = v" is not visible without explicit import. [\#17](https://github.com/diagrams/diagrams-core/issues/17) + +**Merged pull requests:** + +- Transformable instance for functions \(by conjugation\) [\#32](https://github.com/diagrams/diagrams-core/pull/32) ([conal](https://github.com/conal)) + +## [v0.6](https://github.com/diagrams/diagrams-core/tree/v0.6) (2012-12-12) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v0.5...v0.6) + +* **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. + +**Implemented enhancements:** + +- Turn R2 into D2 \(Generalize R2 to any numeric type\) [\#20](https://github.com/diagrams/diagrams-core/issues/20) + +- Terminology: rename "bounding function" -\> "envelope"; "boundary function" -\> "boundary" [\#16](https://github.com/diagrams/diagrams-core/issues/16) + +- Refactor: rename AnnDiagram to QDiagram [\#15](https://github.com/diagrams/diagrams-core/issues/15) + +- Combine \(point, bounds\) pairs stored in NameMap into a single "located bounding function" data structure [\#14](https://github.com/diagrams/diagrams-core/issues/14) + +- Remember more structure when building diagrams [\#12](https://github.com/diagrams/diagrams-core/issues/12) + +- Diagram-building service library + executable [\#7](https://github.com/diagrams/diagrams-core/issues/7) + +**Fixed bugs:** + +- setBounds is incorrect -- throws away bounds of subsequent diagrams too [\#13](https://github.com/diagrams/diagrams-core/issues/13) + +- Start developing test suites [\#10](https://github.com/diagrams/diagrams-core/issues/10) + +- Freezing does not appear to work with the SVG backend [\#9](https://github.com/diagrams/diagrams-core/issues/9) + +- Silent failure on other image types than .png [\#6](https://github.com/diagrams/diagrams-core/issues/6) + +- Tutorial contains links to old version of package [\#5](https://github.com/diagrams/diagrams-core/issues/5) + +- space is not left for empty diagram when using e.g. hcat' with {sep = ... } [\#3](https://github.com/diagrams/diagrams-core/issues/3) + +- Ellipse rotated incorrectly in test file with ellipse next to a square [\#2](https://github.com/diagrams/diagrams-core/issues/2) + +**Closed issues:** + +- Rename core modules to remove Graphics.Rendering prefix. [\#28](https://github.com/diagrams/diagrams-core/issues/28) + +- Improve haddock documentation [\#11](https://github.com/diagrams/diagrams-core/issues/11) + +- Improve description of Envelope in Haddock documentation [\#1](https://github.com/diagrams/diagrams-core/issues/1) + +**Merged pull requests:** + +- Add envelopeS / envelopeSMay for querying scalar displacements from envelopes [\#31](https://github.com/diagrams/diagrams-core/pull/31) ([mgsloan](https://github.com/mgsloan)) + +- Better definition for diameter [\#30](https://github.com/diagrams/diagrams-core/pull/30) ([mgsloan](https://github.com/mgsloan)) + +- Added needed constraints for MultiBackend. [\#29](https://github.com/diagrams/diagrams-core/pull/29) ([fryguybob](https://github.com/fryguybob)) + +- Rename `names` to `subMap`, and add new function `names` [\#26](https://github.com/diagrams/diagrams-core/pull/26) ([byorgey](https://github.com/byorgey)) + +- Fixes to work with rewritten dual-tree [\#25](https://github.com/diagrams/diagrams-core/pull/25) ([byorgey](https://github.com/byorgey)) + +- Fix for juxtaposeDefault to correctly handle empty envelopes [\#24](https://github.com/diagrams/diagrams-core/pull/24) ([byorgey](https://github.com/byorgey)) + +- dep bumps - fixes for GHC7.6 [\#23](https://github.com/diagrams/diagrams-core/pull/23) ([mgsloan](https://github.com/mgsloan)) + +## [v0.5](https://github.com/diagrams/diagrams-core/tree/v0.5) (2012-03-09) + +* 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 + +\* *This Change Log was automatically generated by (and hand edited) [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)* diff --git a/CHANGES.markdown b/CHANGES.markdown deleted file mode 100644 --- a/CHANGES.markdown +++ /dev/null @@ -1,407 +0,0 @@ -1.2.0.6 (2 April 2015) ----------------------- - - - allow `lens-4.9` - - allow `vector-space-0.10` - -1.2.0.5 (13 Jan 2015) ---------------------- - -- Allow `vector-space-0.9` -- Allow `lens-4.7` - -1.2.0.4 (04 Dec 2014) ---------------------- - -- Allow `semigroups-0.16` - -1.2.0.3 (17 November 2014) --------------------------- - -- Allow `lens-4.6` - -1.2.0.2 (22 August 2014) ------------------------- - -- Allow `lens-4.4` - -1.2.0.1 (4 June 2014) ---------------------- - -- Bug fix: `Measure` values using mini-DSL (`atLeast`, `atMost`, - *etc.*) are now properly transformed - -1.2 (27 May 2014) ------------------ - -* **New features** - - - New function `matrixHomRep` to convert a transformation to a - homogeneous matrix representation. - - - New function `dropTransl` to drop the translation component - from a transformation. - - - A mini-DSL for Measures. - - - New `extent` function, used in `diameter`. - - - New `dimension` function to return the dimension of a vector space. - - - New `_relative` iso between points and vectors. - - - `avgScale` function (for computing the average scaling factor of - a transformation) has been moved from `diagrams-lib` to - `diagrams-core` and generalized to work over any vector space. - -* **Dependency/version changes** - - - Allow `semigroups-0.15` - - Allow `lens-4.2` - -* **API changes** - - - Major refactoring which removes `freeze` (and hence `Split` transforms, - etc.) and adds units of `Measure`. - - - Refactoring and simplification of the `Backend` class. - - - Remove `Multibackend`. - - - Remove `nullPrim`, `IsPrim` and simplify `RPrim` so that it does not - carry a transformation. - - - Update `adjustDia` to return a transformation, not just a scale factor. - Add `renderDiaT` which returns a transformation (for use by end - users, e.g. to convert output coordinates back into local coordinates). - -1.1.0.3 (15 May 2014) ----------------------- - - - Allow semigroups-0.14 - -1.1.0.2 (10 April 2014) ----------------------- - - - Allow semigroups-0.13 - -1.1.0.1 (19 March 2014) ----------------------- - - - Allow lens-4.1 - -1.1 (8 March 2014) ------------------- - -* **New features** - - - New `basis` function - - New `determinant` function for computing the determinant of a - `Transformation` - - Add `Typeable` constraint on `Prim`s, making it possible to - extract things back out of a `Prim` wrapper using `cast` - - Raw `Trace`s now return a *sorted list* of intersections, - instead of only the smallest. This is used to implement a new - family of functions `rayTraceV`, `rayTraceP`, `maxRayTraceV`, - `maxRayTraceP`, which work similarly to the parallel versions - without `Ray`, but return the first intersection in the - *positive* direction from the given point, rather than the - smallest in absolute terms. - - New `Annotation` type and corresponding `applyAnnotation` - function, for attaching uninterpreted annotations at specific - points in a diagram tree. Currently this is used for - hyperlinks; more annotation types will be added in the future. - -* **Dependency/version changes** - - - Require `lens-4.0` - - Allow `vector-space-points-0.2` - -* **Bug fixes** - - - Looking up a subdiagram by name now results in a diagram which - still has that name (#43) - -1.0.0.1 (27 November 2013) --------------------------- - - - Allow semigroups-0.12 - -1.0 (25 November 2013) ----------------------- - -* **New features** - - * Delayed subtrees: instead of a primitive, one can now also have - a delayed subtree at a leaf, containing a continuation which - generates a `QDiagram` when given the accumulated d-annotation - at that point in the tree. Useful for things which need to know - the final transformation applied to them before deciding what - diagram to generate. The prototypical use case is arrows: see - https://github.com/diagrams/diagrams-lib/issues/112 . However, - this may be useful for other things as well: for example, - diagrams which scale normally until hitting some maximum or - minimum size, at which point they refuse to scale any further - (or more generally diagrams which scale as some non-linear - function of the transformation applied to them). - - The only downside is that the u-annotation must be fixed ahead - of time---doing otherwise requires a more general solution for - constraint solving. - - * New function `lookupName` for doing a simple lookup of a named - subdiagram - - * New module `Diagrams.Core.Compile`, containing a framework for - compiling `QDiagrams` into a simpler tree type `RTree`, which - may be used by backends for rendering. - -* **New instances** - - * `Qualifiable` instances for `(,)`, `(,,)`, `[]`, `Set`, `Map k`, - and `(->) e`. - - * `(->) e` instance for `Juxtaposable` (thanks to Carlos Scheidegger) - -* **API changes** - - * Export `pointDiagram` function, which creates an otherwise empty - diagram with a point (not empty) envelope - - * A bunch of stuff now uses machinery from the `lens` library. - * `envelope`, `trace`, and `subMap` are now `Lens'`es - * `Wrapped` instances for `Trace`, `TransInv`, `QDiagram`, - `SubMap`, `Envelope`, `Style`, `Query`, and `Name` (replaces - `Newtype` instances) - * `Iso`s for `Query`, `Envelope`, `QDiagram`, `SubMap`, `TransInv` - -0.7.0.1 (26 September 2013) ---------------------------- - - allow semigroups-0.11 - -0.7: 9 August 2013 ------------------- - -* **New features** - - - new function `onBasis`, to extract the matrix equivalent of a `Transformation` - - `SubMap`s are now `Deletable` - - new function `localize` for hiding/deleting names from scope - - new `IsPrim` class, containing `transformWithFreeze` function. - This is primarily intended to support scale-invariant primitives - (*e.g.* arrowheads) but may be useful for other stuff as well. - The default implementation of `renderDia` now uses - `transformWithFreeze`. - - optimized `Transformable` instance for `TransInv` - -* **New instances** - - - `Eq`, `Ord`, `Enveloped`, `Traced`, and `Qualifiable` instances - for `TransInv` - - - `Transformable` instance for functions, which acts by conjugation - -* **API changes** - - - `named` and `namePoint` have moved to the `diagrams-lib` package. - -* **Dependency/version changes** - - - allow `base-4.7` - - upgrade to `monoid-extras-0.3` - -0.6.0.2: 5 March 2013 ---------------------- - -* bug fix: the 'diameter' and 'radius' functions now work correctly. - -0.6.0.1: 7 January 2013 ------------------------ - -* allow `semigroups-0.9` - -0.6: 11 December 2012 ---------------------- - -* **New features** - - - Proper support for subdiagrams: previous versions of - diagrams-core had a mechanism for associating names with a pair - of a location and an envelope. Now, names are associated with - actual subdiagrams (including their location and envelope, along - with all the other information stored by a diagram). - - See - [`Diagrams.Core.Types`](https://github.com/diagrams/diagrams-core/blob/27b275f45cad514caefcd3035e4e261f1b4adf6f/src/Diagrams/Core/Types.hs#L493). - - - Traces: in addition to an envelope, each diagram now stores a - "trace", which is like an embedded raytracer: given any ray - (represented by a base point and a vector), the trace computes - the closest point of intersection with the diagram along the - ray. This is useful for determining points on the boundary of a - diagram, *e.g.* when drawing arrows between diagrams. - - See [`Diagrams.Core.Trace`](https://github.com/diagrams/diagrams-core/blob/2f8727fdfa60cdf46456a23f358c8a771b2cd90d/src/Diagrams/Core/Trace.hs). - -* **API changes** - - - The modules have all been renamed to be more consistent with the - module naming scheme in the rest of the diagrams universe. In - particular: - - `Graphics.Rendering.Diagrams` --> `Diagrams.Core` - `Grahpics.Rendering.Diagrams.Core` --> `Diagrams.Core.Types` - `Graphics.Rendering.Diagrams.*` --> `Diagrams.Core.*` - - - `Graphics.Rendering.Diagrams.UDTree` has been split out into a - separate - [`dual-tree`](http://hackage.haskell.org/package/dual%2Dtree) - package (which has also been substantially rewritten). - - - `Graphics.Rendering.Diagrams.{Monoids,MList}` have been split - out into a separate [`monoid-extras`](http://hackage.haskell.org/package/monoid%2Dextras) package. - - - The `names` function now returns a list of names and their - associated locations, instead of the associated subdiagrams. In - particular the output is suitable to be rendered to a `String` - using `show`. - - - The new `subMap` function fills a similar role that `names` used - to play, returning the entire mapping from names to subdiagrams. - - - New functions `envelope[VP]May` - - `envelopeV` and `envelopeP` return the zero vector and origin, - respectively, when called on an empty envelope. However, - sometimes it's useful to actually know whether the envelope was - empty or not (the zero vector and the origin are legitimate - outputs from non-empty envelopes). The new functions have their - return type wrapped in `Maybe` for this purpose. - - - New functions `envelopeS` and `envelopeSMay` - - Like `envelope[VP](May)`, but returning a scalar multiple of - the input vector. - - - The `Graphics.Rendering.Diagrams.Util` module has been removed, - along with the `withLength` function. Calls to `withLength` can - be replaced using - - `withLength s v = s *^ normalized v` - - - Add needed constraints `(InnerSpace v, OrderedField (Scalar v), - Monoid' m)` to the type of the `renderDias` method in the - `MultiBackend` class. - - - Generalized `Transformable` instances for pairs and tuples - - Previously, the components of the tuples were required to have - the same type; but everything still works as long as they all - share the same vector space. This is actually useful in - practice: say, if we wanted to pair a diagram with a path and - then apply the same transformation to both. - -* **Improvements** - - - More efficient implementation of `diameter` - -* **Dependency/version changes** - - - Tested with GHC 7.6.1 - - allow `base-4.6` - - allow `containers-0.5.*` - - allow `MemoTrie-0.6.1` - -* **Bug fixes** - - - juxtaposeDefault now correctly handles empty envelopes (#37) - - `juxtaposeDefault` is now the identity on the second object if - either one has an empty envelope. In particular this means that - `mempty` is now an identity element for `beside` and friends. - -0.5.0.1: 11 May 2012 --------------------- - -* Update `MemoTrie` upper bound to allow `MemoTrie-0.5` - -0.5: 9 March 2012 ------------------ - -* New features: - - New `Juxtaposable` class - - New `NullBackend` and `D` types, for conveniently giving a - monomorphic type to diagrams when we don't care which one it is. - - [\#27](http://code.google.com/p/diagrams/issues/detail?id=27): Change type of `adjustDia` to return a new options record - (with an explicitly filled-in size) - -* New instances: - - `Enveloped`, `HasOrigin`, `Juxtaposable`, `HasStyle`, and `Transformable` - instances for `Set`s and tuples - - `V Double = Double` - - `Juxtaposable` and `Boundable` instances for `Map` - -* API changes - - `AnnDiagram` renamed to `QDiagram` - - [\#61](http://code.google.com/p/diagrams/issues/detail?id=61): terminology change from "bounds" to "envelope" - + `boundary` -> `envelopeP` - + "bounding region" -> "envelope" - + `Bounds` -> `Envelope` - + `Boundable` -> `Enveloped` - + `getBounds` -> `getEnvelope` - + *etc.* - - Split out definition of `Point` into separate package - ([`vector-space-points`](http://hackage.haskell.org/package/vector%2Dspace%2Dpoints)) - - The `Point` constructor `P` is no longer exported from - `Graphics.Rendering.Diagrams`. See the `Diagrams.TwoD.Types` module - from `diagrams-lib` for new tools for working with abstract 2D - points. If you really need the `P` constructor, import - `Graphics.Rendering.Diagrams.Points`. - - Name-related functions now return "located bounding functions" - instead of pairs of points and bounds, to allow for future - expansion. - -* Dependency/version changes: - - `vector-space` 0.8 is now required. - - Bump base upper bound to allow 4.5; now tested with GHC 7.4.1. - -* Bug fixes: - - Bug fix related to empty envelopes - -0.4: 23 October 2011 --------------------- - -* improved documentation -* a few new instances (Newtype Point, Boundable Point) -* new functions (value, clearValue, resetValue) for working with - alternate query monoids - -0.3: 18 June 2011 ------------------ - -* big overhaul of name maps: - - allow arbitrary types as atomic names - - carry along bounding functions as well as names in NameMaps - - additional functions for querying information associated with names -* fix for issue #34 (fix behavior of setBounds) -* Transformable and HasOrigin instances for Transformations - -0.2: 3 June 2011 ----------------- - -* bounding regions can now be overridden -* new namePoint function for more flexibly assigning names to arbitrary points -* add HasStyle, Boundable, and HasOrigin instances for lists -* add a "trivial backend" -* transformable attributes - -0.1.1: 18 May 2011 ------------------- - -* link to new website - -0.1: 17 May 2011 ----------------- - -* initial preview release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,7 @@ -Copyright (c) 2011-2014 diagrams-core team: +Copyright (c) 2011-2015 diagrams-core team: Daniel Bergey + Christopher Chalmers Tad Doxsee Conal Elliott Sam Griffin diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,4 +1,4 @@ -[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-core.png)](http://travis-ci.org/diagrams/diagrams-core) +[![Build Status](https://travis-ci.org/diagrams/diagrams-core.png?branch=master)](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 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: 1.2.0.6 +Version: 1.3 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language @@ -13,9 +13,9 @@ Category: Graphics Build-type: Simple Cabal-version: >=1.10 -Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg +Extra-source-files: CHANGELOG.md, README.markdown, diagrams/*.svg extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 +Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 Source-repository head type: git location: git://github.com/diagrams/diagrams-core.git @@ -28,23 +28,25 @@ Diagrams.Core.Juxtapose, Diagrams.Core.Names, Diagrams.Core.Points, + Diagrams.Core.Query Diagrams.Core.Style, + Diagrams.Core.Measure, Diagrams.Core.Trace, Diagrams.Core.Transform, Diagrams.Core.Types, - Diagrams.Core.V, - Diagrams.Core.Query + Diagrams.Core.V - Build-depends: base >= 4.2 && < 4.8, + Build-depends: base >= 4.2 && < 4.9, containers >= 0.4.2 && < 0.6, + unordered-containers >= 0.2 && < 0.2.6, semigroups >= 0.8.4 && < 0.17, - vector-space >= 0.8.4 && < 0.11, - vector-space-points >= 0.1 && < 0.3, - MemoTrie >= 0.4.7 && < 0.7, - newtype >= 0.2 && < 0.3, - monoid-extras >= 0.3 && < 0.4, + monoid-extras >= 0.3 && < 0.5, dual-tree >= 0.2 && < 0.3, - lens >= 4.0 && < 4.10 + lens >= 4.0 && < 4.10, + linear >= 1.11.3 && < 1.19, + adjunctions >= 4.0 && < 5.0, + distributive >=0.2.2 && < 1.0, + mtl hs-source-dirs: src Other-extensions: DeriveDataTypeable diff --git a/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg --- a/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg --- a/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg --- a/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg --- a/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg --- a/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg --- a/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_traceEx.svg b/diagrams/src_Diagrams_Core_Trace_traceEx.svg --- a/diagrams/src_Diagrams_Core_Trace_traceEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_traceEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_tracePEx.svg b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg --- a/diagrams/src_Diagrams_Core_Trace_tracePEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/diagrams/src_Diagrams_Core_Trace_traceVEx.svg b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg --- a/diagrams/src_Diagrams_Core_Trace_traceVEx.svg +++ b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg @@ -1,4 +1,3 @@ - + "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -22,7 +22,7 @@ -- The diagrams library relies heavily on custom types and classes. Many -- of the relevant definitions are in the "Diagrams.Core.Types" module. -- Indeed the definition of the diagram type @QDiagram@ is contained in: --- 'Diagrams.Core.Types.QDiagram'. +-- 'Diagrams.Core.Types.QDiagram'. -- -- The best place to start when learning -- about diagrams\' types is the user manual: @@ -32,72 +32,72 @@ -- -- * "Diagrams.Core.Types" -- --- * @Annotation@, --- * @UpAnnots b v m@, @DownAnnots v@, --- * @QDiaLeaf b v m@, @Measure v@, --- * @Subdiagram b v m@, @SubMap b v m@, --- * @Prim b v@, @Backend b v@, --- * @DNode b v a@, @DTree b v a@, --- * @RNode b v a@, @RTree b v a@, --- * @NullBackend@, @Renderable t b@, --- * @D v@. +-- * @'Annotation'@, +-- * @'UpAnnots' b v n m@, @'DownAnnots' v n@, +-- * @'QDiaLeaf' b v n m@, @'Measure' n@, +-- * @'Subdiagram' b v n m@, @'SubMap' b v n m@, +-- * @'Prim' b v n@, @'Backend' b v n@, +-- * @'DNode' b v n a@, @'DTree' b v n a@, +-- * @'RNode' b v n a@, @'RTree' b v n a@, +-- * @'NullBackend'@, @'Renderable' t b@, +-- * @'D' v n@. -- -- * "Diagrams.Core.Envelope" -- --- * @Envelope v@, @Enveloped v@, --- * @OrderedField s@. +-- * @'Envelope' v n@, @'Enveloped' a@, +-- * @'OrderedField' s@. -- -- * "Diagrams.Core.Juxtapose" -- --- * @Juxtaposable a@. +-- * @'Juxtaposable' a@. -- -- * "Diagrams.Core.Names" -- --- * @AName@, @Name@, @IsName a@, --- * @Qualifiable q@. +-- * @'AName'@, @'Name'@, @'IsName' a@, +-- * @'Qualifiable' q@. -- -- * "Diagrams.Core.HasOrigin" -- --- * @HasOrigin t@. --- --- * "Diagrams.Core.Points" --- --- * @Point v@. +-- * @'HasOrigin' t@. -- -- * "Diagrams.Core.Query" -- --- * @Query v m@. +-- * @'Query' v n m@. -- -- * "Diagrams.Core.Style" -- --- * @AttributeClass a@, @Attribute v@, --- * @Style v@, @HasStyle@. +-- * @'AttributeClass' a@, @'Attribute' v n@, +-- * @'Style' v n@, @'HasStyle'@. -- -- * "Diagrams.Core.Trace" -- --- * @SortedList a@, --- * @Trace v@, @Traced a@. +-- * @'SortedList' a@, +-- * @'Trace' v n@, @'Traced' a@. -- -- * "Diagrams.Core.Transform" -- --- * @u :-: v@, @HasLinearMap@, --- * @Transformation v@, @Transformable t@, --- * @TransInv t@. +-- * @u ':-:' v@, @'HasLinearMap'@, @'HasBasis'@ +-- * @'Transformation' v n@, @'Transformable' t@, +-- * @'TransInv' t@. -- -- * "Diagrams.Core.V" -- --- * @V a@. +-- * @'V' a@, +-- * @'N' a@, +-- * @'Vn' a@, +-- * @'InSpace' v n a@, +-- * @'SameSpace' a b@. ----------------------------------------------------------------------------- module Diagrams.Core ( -- * Associated vector spaces - V + V, N, Vn, InSpace, SameSpace -- * Points , Point, origin, (*.) - , _relative + , relative -- * Transformations @@ -105,6 +105,7 @@ , basis , dimension , determinant + , isReflection -- ** Invertible linear transformations , (:-:), (<->), linv, lapp @@ -129,6 +130,7 @@ -- ** Translational invariance , TransInv(TransInv) + , eye -- * Names @@ -147,11 +149,12 @@ -- * Attributes and styles , AttributeClass - , Attribute, mkAttr, mkTAttr, mkGTAttr, unwrapAttr + , Attribute (..) , Style, HasStyle(..) - , getAttr, combineAttr - , applyAttr, applyTAttr, applyGTAttr + , getAttr + , atAttr, atMAttr, atTAttr + , applyAttr, applyMAttr, applyTAttr -- * Envelopes @@ -159,7 +162,7 @@ , appEnvelope, onEnvelope, mkEnvelope , Enveloped(..) , envelopeVMay, envelopeV, envelopePMay, envelopeP - , diameter, radius + , diameter, radius, size -- * Traces @@ -201,6 +204,8 @@ , localize , href + , opacityGroup + , groupOpacity , setEnvelope, setTrace @@ -213,12 +218,18 @@ , location , subPoint - -- * Measurements - , Measure(..) - , fromOutput - , toOutput - , atMost + -- ** Measurements + + , Measured + , Measure + , fromMeasured + , output + , local + , global + , normalized + , scaleLocal , atLeast + , atMost -- * Backends @@ -235,7 +246,9 @@ -- * Convenience classes , HasLinearMap + , HasBasis , OrderedField + , TypeableFloat , Monoid' ) where @@ -244,6 +257,7 @@ import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin import Diagrams.Core.Juxtapose +import Diagrams.Core.Measure import Diagrams.Core.Names import Diagrams.Core.Points import Diagrams.Core.Query diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Compile --- Copyright : (c) 2013 diagrams-core team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -30,12 +31,10 @@ , toDTree , fromDTree - , styleToOutput - , toOutput ) where -import Data.Data +import Data.Typeable import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct @@ -44,21 +43,28 @@ import Data.Semigroup import Data.Tree import Data.Tree.DUAL -import Data.VectorSpace + import Diagrams.Core.Envelope (OrderedField, diameter) -import Diagrams.Core.Style import Diagrams.Core.Transform import Diagrams.Core.Types +import Diagrams.Core.Style -emptyDTree :: Tree (DNode b v a) +import Linear.Metric hiding (qd) + +-- Typeable1 is a depreciated synonym in ghc > 707 +#if __GLASGOW_HASKELL__ >= 707 +#define Typeable1 Typeable +#endif + +emptyDTree :: Tree (DNode b v n a) emptyDTree = Node DEmpty [] uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r uncurry3 f (x, y, z) = f x y z -- | Convert a @QDiagram@ into a raw tree. -toDTree :: HasLinearMap v => Scalar v -> Scalar v -> QDiagram b v m - -> Maybe (DTree b v Annotation) +toDTree :: (HasLinearMap v, Floating n, Typeable n) + => n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation) toDTree g n (QD qd) = foldDUAL @@ -75,8 +81,7 @@ -- the continuation, convert the result to a DTree, and -- splice it in, adding a DDelay node to mark the point -- of the splice. - (Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n - . ($ (d, g, n)) . uncurry3) + (Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n . ($ (d, g, n)) . uncurry3) ) -- u-only leaves --> empty DTree. We don't care about the @@ -108,10 +113,11 @@ -- | Convert a @DTree@ to an @RTree@ which can be used dirctly by backends. -- A @DTree@ includes nodes of type @DTransform (Transformation v)@; -- in the @RTree@ transform is pushed down until it reaches a primitive node. -fromDTree :: HasLinearMap v => DTree b v Annotation -> RTree b v Annotation +fromDTree :: forall b v n. (Floating n, HasLinearMap v) + => DTree b v n Annotation -> RTree b v n Annotation fromDTree = fromDTree' mempty where - fromDTree' :: HasLinearMap v => Transformation v -> DTree b v Annotation -> RTree b v Annotation + fromDTree' :: HasLinearMap v => Transformation v n -> DTree b v n Annotation -> RTree b v n Annotation -- We put the accumulated transformation (accTr) and the prim -- into an RPrim node. fromDTree' accTr (Node (DPrim p) _) @@ -145,10 +151,11 @@ -- transformation used to convert the diagram from local to output -- units. toRTree - :: (HasLinearMap v, InnerSpace v, Data v, Data (Scalar v), OrderedField (Scalar v), Monoid m, Semigroup m) - => Transformation v -> QDiagram b v m -> RTree b v Annotation + :: (HasLinearMap v, Metric v, Typeable1 v, Typeable n, + OrderedField n, Monoid m, Semigroup m) + => Transformation v n -> QDiagram b v n m -> RTree b v n Annotation toRTree globalToOutput d - = (fmap . onRStyle) (styleToOutput gToO nToO) + = (fmap . onRStyle) (unmeasureAttrs gToO nToO) . fromDTree . fromMaybe (Node DEmpty []) . toDTree gToO nToO @@ -160,50 +167,14 @@ -- of product of diameters along each basis direction. Note at -- this point the diagram has already had the globalToOutput -- transformation applied, so output = global = local units. - nToO = product (map (\v -> diameter v d) basis) ** (1 / fromIntegral (dimension d)) + nToO = product (map (`diameter` d) basis) ** (1 / fromIntegral (dimension d)) -- | Apply a style transformation on 'RStyle' nodes; the identity for -- other 'RNode's. -onRStyle :: (Style v -> Style v) -> (RNode b v a -> RNode b v a) +onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a onRStyle f (RStyle s) = RStyle (f s) onRStyle _ n = n --- | Convert all 'Measure' values to 'Output' units. The arguments --- are, respectively, the scaling factor from global units to output --- units, and from normalized units to output units. It is assumed --- that local units are identical to output units (which will be the --- case if all transformations have been fully pushed down and --- applied). Normalized units are based on a logical diagram size of --- 1 x 1. -styleToOutput - :: forall v. (Data v, Data (Scalar v), Num (Scalar v), Ord (Scalar v), Fractional (Scalar v)) - => Scalar v -> Scalar v -> Style v -> Style v -styleToOutput globalToOutput normToOutput = - gmapAttrs (toOutput globalToOutput normToOutput :: Measure v -> Measure v) - --- | Convert an aribrary 'Measure' to 'Output' units. -toOutput :: forall v. (Data v, Data (Scalar v), Num (Scalar v), Ord (Scalar v), Fractional (Scalar v)) - => Scalar v -> Scalar v -> Measure v -> Measure v -toOutput g n m = - case m of - m'@(Output _) -> m' - Local s -> Output s - Global s -> Output (g * s) - Normalized s -> Output (n * s) - - MinM m1 m2 -> outBin min (toOutput g n m1) (toOutput g n m2) - MaxM m1 m2 -> outBin max (toOutput g n m1) (toOutput g n m2) - ZeroM -> Output 0 - NegateM m' -> outUn negate (toOutput g n m') - PlusM m1 m2 -> outBin (+) (toOutput g n m1) (toOutput g n m2) - ScaleM s m' -> outUn (s*) (toOutput g n m') - where - outUn op (Output o1) = Output (op o1) - outUn _ _ = error "outUn: The sky is falling!" - outBin op (Output o1) (Output o2) = Output (o1 `op` o2) - outBin _ _ _ = error "outBin: Both skies are falling!" - - -------------------------------------------------- -- | Render a diagram, returning also the transformation which was @@ -212,21 +183,16 @@ -- transformation can be used, for example, to convert output/screen -- coordinates back into diagram coordinates. See also 'adjustDia'. renderDiaT - :: ( Backend b v - , HasLinearMap v, InnerSpace v, Data v - , OrderedField (Scalar v), Data (Scalar v) - , Monoid' m - ) - => b -> Options b v -> QDiagram b v m -> (Transformation v, Result b v) + :: (Backend b v n , HasLinearMap v, Metric v, Typeable1 v, + Typeable n, OrderedField n, Monoid' m) + => b -> Options b v n -> QDiagram b v n m -> (Transformation v n, Result b v n) renderDiaT b opts d = (g2o, renderRTree b opts' . toRTree g2o $ d') where (opts', g2o, d') = adjustDia b opts d -- | Render a diagram. renderDia - :: ( Backend b v - , InnerSpace v, Data v - , OrderedField (Scalar v), Data (Scalar v) - , Monoid' m - ) - => b -> Options b v -> QDiagram b v m -> Result b v + :: (Backend b v n , HasLinearMap v, Metric v, Typeable1 v, + Typeable n, OrderedField n, Monoid' m) + => b -> Options b v n -> QDiagram b v n m -> Result b v n renderDia b opts d = snd (renderDiaT b opts d) + diff --git a/src/Diagrams/Core/Envelope.hs b/src/Diagrams/Core/Envelope.hs --- a/src/Diagrams/Core/Envelope.hs +++ b/src/Diagrams/Core/Envelope.hs @@ -1,23 +1,24 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | --- Module : Graphics.Rendering.Diagrams.Envelope +-- Module : Diagrams.Core.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. +-- diagrams-core 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 +-- The @Diagrams.Core.Envelope@ module defines a data type and type class for -- \"envelopes\", aka functional bounding regions. -- ----------------------------------------------------------------------------- @@ -37,27 +38,38 @@ , diameter , radius , extent - , envelopeVMay, envelopeV, envelopePMay, envelopeP, envelopeSMay, envelopeS + , size + , envelopeVMay + , envelopeV + , envelopePMay + , envelopeP + , envelopeSMay + , envelopeS -- * Miscellaneous , OrderedField ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) +#endif import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, - op, over, _Wrapping') + op, over, (&), (.~), _Wrapping') +import Data.Functor.Rep import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup import qualified Data.Set as S -import Data.VectorSpace - import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Metric +import Linear.Vector + + ------------------------------------------------------------ -- Envelopes --------------------------------------------- ------------------------------------------------------------ @@ -96,70 +108,65 @@ -- 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 (Option (v -> Max (Scalar v))) +newtype Envelope v n = Envelope (Option (v n -> Max n)) -instance Wrapped (Envelope v) where - type Unwrapped (Envelope v) = Option (v -> Max (Scalar v)) - _Wrapped' = iso (\(Envelope e) -> e) Envelope +instance Wrapped (Envelope v n) where + type Unwrapped (Envelope v n) = Option (v n -> Max n) + _Wrapped' = iso (\(Envelope e) -> e) Envelope -instance Rewrapped (Envelope v) (Envelope v') +instance Rewrapped (Envelope v n) (Envelope v' n') -appEnvelope :: Envelope v -> Maybe (v -> Scalar v) +appEnvelope :: Envelope v n -> Maybe (v n -> n) appEnvelope (Envelope (Option e)) = (getMax .) <$> e -onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v +onEnvelope :: ((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) -mkEnvelope :: (v -> Scalar v) -> Envelope v +mkEnvelope :: (v n -> n) -> Envelope v n 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)) +pointEnvelope :: (Fractional n, Metric v) => Point v n -> Envelope v n +pointEnvelope p = moveTo p (mkEnvelope $ const 0) -- | 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) +deriving instance Ord n => Semigroup (Envelope v n) -- | The special empty envelope is the identity for the -- 'Monoid' instance. -deriving instance Ord (Scalar v) => Monoid (Envelope v) - +deriving instance Ord n => Monoid (Envelope v n) -- XXX add some diagrams here to illustrate! Note that Haddock supports -- inline images, using a \<\\> syntax. -type instance V (Envelope v) = v +type instance V (Envelope v n) = v +type instance N (Envelope v n) = n -- | 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 (Metric v, Fractional n) => HasOrigin (Envelope v n) where + moveOriginTo (P u) = onEnvelope $ \f v -> f v - ((u ^/ (v `dot` v)) `dot` v) -instance Show (Envelope v) where +instance Show (Envelope v n) 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 +instance (Metric v, Floating n) => Transformable (Envelope v n) where + transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g + where + -- XXX add lots of comments explaining this! + g f v = f v' / (v' `dot` vi) + where + v' = signorm $ lapp (transp t) v vi = apply (inv t) v - in f v' / (v' <.> vi) - ) ------------------------------------------------------------ -- Enveloped class @@ -169,38 +176,38 @@ -- 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 +class (Floating s, Ord s) => OrderedField s +instance (Floating s, Ord s) => OrderedField s -- | @Enveloped@ abstracts over things which have an envelope. -class (InnerSpace (V a), OrderedField (Scalar (V a))) => Enveloped a where +class (Metric (V a), OrderedField (N 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) + getEnvelope :: a -> Envelope (V a) (N a) -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Envelope v) where +instance (Metric v, OrderedField n) => Enveloped (Envelope v n) where getEnvelope = id -instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (Point v) where - getEnvelope p = moveTo p . mkEnvelope $ const zeroV +instance (OrderedField n, Metric v) => Enveloped (Point v n) where + getEnvelope p = moveTo p . mkEnvelope $ const 0 instance Enveloped t => Enveloped (TransInv t) where getEnvelope = getEnvelope . op TransInv -instance (Enveloped a, Enveloped b, V a ~ V b) => Enveloped (a,b) where +instance (Enveloped a, Enveloped b, V a ~ V b, N a ~ N b) => Enveloped (a,b) where getEnvelope (x,y) = getEnvelope x <> getEnvelope y -instance (Enveloped b) => Enveloped [b] where +instance Enveloped b => Enveloped [b] where getEnvelope = mconcat . map getEnvelope -instance (Enveloped b) => Enveloped (M.Map k b) where +instance Enveloped b => Enveloped (M.Map k b) where getEnvelope = mconcat . map getEnvelope . M.elems -instance (Enveloped b) => Enveloped (S.Set b) where +instance Enveloped b => Enveloped (S.Set b) where getEnvelope = mconcat . map getEnvelope . S.elems ------------------------------------------------------------ @@ -210,62 +217,66 @@ -- | 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 :: Enveloped a => Vn a -> a -> Maybe (Vn 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 +envelopeV :: Enveloped a => Vn a -> a -> Vn a +envelopeV v = fromMaybe zero . 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 a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (Point v n) 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 a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n envelopeP v = P . envelopeV v --- | Equivalent to the magnitude of 'envelopeVMay': +-- | Equivalent to the norm of 'envelopeVMay': -- --- @ envelopeSMay v x == fmap magnitude (envelopeVMay v x) @ +-- @ envelopeSMay v x == fmap norm (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 +-- preferred, as this requires a call to norm. However, it is more +-- efficient than calling norm on the results of those functions. +envelopeSMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe n +envelopeSMay v = fmap ((* norm v) . ($ v)) . appEnvelope . getEnvelope --- | Equivalent to the magnitude of 'envelopeV': +-- | Equivalent to the norm of 'envelopeV': -- --- @ envelopeS v x == magnitude (envelopeV v x) @ +-- @ envelopeS v x == norm (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) +-- preferred, as this requires a call to norm. However, it is more +-- efficient than calling norm on the results of those functions. +envelopeS :: (V a ~ v, N a ~ n, Enveloped a, Num n) => v n -> a -> n 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 = maybe 0 (\(lo,hi) -> (hi - lo) * magnitude v) (extent v a) +diameter :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n +diameter v a = maybe 0 (\(lo,hi) -> (hi - lo) * norm v) (extent 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 ~ v, N a ~ n, Enveloped a) => v n -> a -> n radius v = (0.5*) . diameter v -- | Compute the range of an enveloped object along a certain -- direction. Returns a pair of scalars @(lo,hi)@ such that the -- object extends from @(lo *^ v)@ to @(hi *^ v)@. Returns @Nothing@ -- for objects with an empty envelope. -extent :: Enveloped a => V a -> a -> Maybe (Scalar (V a), Scalar (V a)) -extent v a = (\f -> (-f (negateV v), f v)) <$> (appEnvelope . getEnvelope $ a) +extent :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (n, n) +extent v a = (\f -> (-f (negated v), f v)) <$> (appEnvelope . getEnvelope $ a) + +-- | The smallest positive vector that bounds the envelope of an object. +size :: (V a ~ v, N a ~ n, Enveloped a, HasBasis v) => a -> v n +size d = tabulate $ \(E l) -> diameter (zero & l .~ 1) d diff --git a/src/Diagrams/Core/HasOrigin.hs b/src/Diagrams/Core/HasOrigin.hs --- a/src/Diagrams/Core/HasOrigin.hs +++ b/src/Diagrams/Core/HasOrigin.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- The UndecidableInstances flag is needed under 6.12.3 for the -- HasOrigin (a,b) instance. @@ -25,12 +26,13 @@ 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.Measure +import Diagrams.Core.Points () import Diagrams.Core.V +import Linear.Affine +import Linear.Vector + -- | 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. @@ -40,13 +42,13 @@ -- are instances of both we should have the identity -- -- @ --- moveOriginTo (origin .^+ v) === translate (negateV v) +-- moveOriginTo (origin .^+ v) === translate (negated 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 +class HasOrigin t where -- | Move the local origin to another point. -- @@ -54,10 +56,10 @@ -- (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 + moveOriginTo :: Point (V t) (N t) -> t -> t -- | Move the local origin by a relative vector. -moveOriginBy :: HasOrigin t => V t -> t -> t +moveOriginBy :: (V t ~ v, N t ~ n, Num n, HasOrigin t) => v n -> t -> t moveOriginBy = moveOriginTo . P -- | Translate the object by the translation that sends the origin to @@ -74,26 +76,30 @@ -- @ -- moveTo (origin .^+ v) === translate v -- @ -moveTo :: HasOrigin t => Point (V t) -> t -> t +moveTo :: (InSpace v n t, HasOrigin t) => Point v n -> 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 :: (InSpace v n t, HasOrigin t) => t -> Point v n -> t place = flip moveTo -instance VectorSpace v => HasOrigin (Point v) where +instance HasOrigin t => HasOrigin (Measured n t) where + moveOriginTo = fmap . moveOriginTo + +instance (Additive v, Num n) => HasOrigin (Point v n) where moveOriginTo (P u) p = p .-^ u -instance (HasOrigin a, HasOrigin b, V a ~ V b) => HasOrigin (a,b) where +instance (HasOrigin t, HasOrigin s, SameSpace s t) => HasOrigin (s, t) where moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) -instance HasOrigin a => HasOrigin [a] where +instance HasOrigin t => HasOrigin [t] where moveOriginTo = map . moveOriginTo -instance (HasOrigin a, Ord a) => HasOrigin (S.Set a) where +instance (HasOrigin t, Ord t) => HasOrigin (S.Set t) where moveOriginTo = S.map . moveOriginTo -instance HasOrigin a => HasOrigin (M.Map k a) where +instance HasOrigin t => HasOrigin (M.Map k t) where moveOriginTo = M.map . moveOriginTo + diff --git a/src/Diagrams/Core/Juxtapose.hs b/src/Diagrams/Core/Juxtapose.hs --- a/src/Diagrams/Core/Juxtapose.hs +++ b/src/Diagrams/Core/Juxtapose.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts - , UndecidableInstances - , TypeFamilies - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Juxtapose @@ -18,16 +19,18 @@ ( Juxtaposable(..), juxtaposeDefault ) where -import Data.Functor ((<$>)) -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.VectorSpace +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Set as S import Diagrams.Core.Envelope +import Diagrams.Core.Measure import Diagrams.Core.HasOrigin import Diagrams.Core.V +import Linear.Metric +import Linear.Vector + -- | Class of things which can be placed \"next to\" other things, for some -- appropriate notion of \"next to\". class Juxtaposable a where @@ -38,23 +41,23 @@ -- @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 + juxtapose :: Vn 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 :: (Enveloped a, HasOrigin a) => Vn 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 + where mv1 = negated <$> envelopeVMay v a1 + mv2 = envelopeVMay (negated v) a2 -instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Envelope v) where +instance (Metric v, OrderedField n) => Juxtaposable (Envelope v n) where juxtapose = juxtaposeDefault -instance (Enveloped a, HasOrigin a, Enveloped b, HasOrigin b, V a ~ V b) +instance (Enveloped a, HasOrigin a, Enveloped b, HasOrigin b, V a ~ V b, N a ~ N b) => Juxtaposable (a,b) where juxtapose = juxtaposeDefault @@ -69,3 +72,7 @@ instance Juxtaposable a => Juxtaposable (b -> a) where juxtapose v f1 f2 b = juxtapose v (f1 b) (f2 b) + +instance Juxtaposable a => Juxtaposable (Measured n a) where + juxtapose v = liftA2 (juxtapose v) + diff --git a/src/Diagrams/Core/Measure.hs b/src/Diagrams/Core/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Measure.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module Diagrams.Core.Measure + ( Measured (..) + , Measure + , fromMeasured + , output + , local + , global + , normalized + , normalised + , scaleLocal + , atLeast + , atMost + ) where + +import Control.Applicative +import Control.Lens +import qualified Control.Monad.Reader as R +import Data.Distributive +import Data.Functor.Rep +import Data.Semigroup +import Data.Typeable + +import Diagrams.Core.V + +import Linear.Vector + +-- | 'Measured n a' is an object that depends on 'local', 'normalized' +-- and 'global' scales. The 'normalized' and 'global' scales are +-- calculated when rendering a diagram. +-- +-- For attributes, the 'local' scale gets multiplied by the average +-- scale of the transform. +newtype Measured n a = Measured { unmeasure :: (n,n,n) -> a } + deriving (Typeable, Functor, Applicative, Monad, Additive, R.MonadReader (n,n,n)) +-- (local, global, normalized) -> output + +type instance V (Measured n a) = V a +type instance N (Measured n a) = N a + +-- | A measure is a 'Measured' number. +type Measure n = Measured n n + +-- | @fromMeasured globalScale normalizedScale measure -> a@ +fromMeasured :: Num n => n -> n -> Measured n a -> a +fromMeasured g n (Measured m) = m (1,g,n) + +-- | Output units don't change. +output :: Num n => n -> Measure n +output = pure + +-- | Local units are scaled by the average scale of a transform. +local :: Num n => n -> Measure n +local x = views _1 (*x) + +-- | Global units are ? +global :: Num n => n -> Measure n +global x = views _2 (*x) + +-- | Normalized units get scaled so that one normalized unit is the size of the +-- final diagram. +normalized :: Num n => n -> Measure n +normalized x = views _3 (*x) + +-- | Just like 'normalized' but spelt properly. +normalised :: Num n => n -> Measure n +normalised x = views _3 (*x) + +-- | Scale the local units of a 'Measured' thing. +scaleLocal :: Num n => n -> Measured n a -> Measured n a +scaleLocal s = R.local (_1 *~ s) + +-- | Calculate the smaller of two measures. +atLeast :: Ord n => Measure n -> Measure n -> Measure n +atLeast = liftA2 max + +-- | Calculate the larger of two measures. +atMost :: Ord n => Measure n -> Measure n -> Measure n +atMost = liftA2 min + +instance Num a => Num (Measured n a) where + (+) = (^+^) + (-) = (^-^) + (*) = liftA2 (*) + + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance Fractional a => Fractional (Measured n a) where + (/) = liftA2 (/) + recip = fmap recip + + fromRational = pure . fromRational + +instance Floating a => Floating (Measured n a) where + pi = pure pi + exp = fmap exp + sqrt = fmap sqrt + log = fmap log + (**) = liftA2 (**) + logBase = liftA2 logBase + sin = fmap sin + tan = fmap tan + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + tanh = fmap tanh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance Semigroup a => Semigroup (Measured n a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Measured n a) where + mempty = pure mempty + mappend = liftA2 mappend + +instance Distributive (Measured n) where + distribute a = Measured $ \x -> fmap (\(Measured m) -> m x) a + +instance Representable (Measured n) where + type Rep (Measured n) = (n,n,n) + tabulate = Measured + index = unmeasure + +instance Profunctor Measured where + lmap f (Measured m) = Measured $ \(l,g,n) -> m (f l, f g, f n) + rmap f (Measured m) = Measured $ f . m + diff --git a/src/Diagrams/Core/Names.hs b/src/Diagrams/Core/Names.hs --- a/src/Diagrams/Core/Names.hs +++ b/src/Diagrams/Core/Names.hs @@ -3,14 +3,13 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Names --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -20,26 +19,27 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Names - (-- * Names - -- ** Atomic names - AName(..) + (-- * Names + -- ** Atomic names + AName(..) + , _AName - -- ** Names - , Name(..), IsName(..), (.>) + -- ** Names + , Name(..), IsName(..), (.>) - -- ** Qualifiable - , Qualifiable(..) + -- ** Qualifiable + , Qualifiable(..) - ) where + ) where -import Control.Lens (over, Wrapped(..), Rewrapped, iso, _Unwrapping') -import Data.List (intercalate) +import Control.Lens hiding ((.>)) import qualified Data.Map as M import Data.Semigroup import qualified Data.Set as S import Data.Typeable import Diagrams.Core.Transform +import Diagrams.Core.Measure ------------------------------------------------------------ -- Names ------------------------------------------------- @@ -80,8 +80,8 @@ instance IsName Float instance IsName Double instance IsName Integer -instance IsName String instance IsName a => IsName [a] +instance IsName a => IsName (Maybe a) instance (IsName a, IsName b) => IsName (a,b) instance (IsName a, IsName b, IsName c) => IsName (a,b,c) @@ -89,7 +89,7 @@ -- things which are 'Typeable', 'Ord' and 'Show'. data AName where AName :: (Typeable a, Ord a, Show a) => a -> AName - deriving (Typeable) + deriving Typeable instance IsName AName where toName = Name . (:[]) @@ -103,24 +103,35 @@ 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' + Nothing -> typeOf a1 `compare` typeOf a2 instance Show AName where - show (AName a) = show a + showsPrec d (AName a) = showParen (d > 10) $ + showString "AName " . showsPrec 11 a +-- | Prism onto 'AName'. +_AName :: (Typeable a, Ord a, Show a) => Prism' AName a +_AName = prism' AName (\(AName a) -> cast a) + -- | A (qualified) name is a (possibly empty) sequence of atomic names. newtype Name = Name [AName] deriving (Eq, Ord, Semigroup, Monoid, Typeable) -instance Wrapped Name where - type Unwrapped Name = [AName] - _Wrapped' = iso (\(Name ans) -> ans) Name - instance Rewrapped Name Name +instance Wrapped Name where + type Unwrapped Name = [AName] + _Wrapped' = iso (\(Name ns) -> ns) Name instance Show Name where - show (Name ns) = intercalate " .> " $ map show ns + showsPrec d (Name xs) = case xs of + [] -> showParen (d > 10) $ showString "Name []" + [n] -> showParen (d > 10) $ showString "toName " . showsName 11 n + (n:ns) -> showParen (d > 5) $ showsName 6 n . go ns + where + go (y:ys) = showString " .> " . showsName 6 y . go ys + go _ = id + where showsName dd (AName a) = showsPrec dd a instance IsName Name where toName = id @@ -135,32 +146,35 @@ -- prefixing them with a name. class Qualifiable q where -- | Qualify with the given name. - (|>) :: IsName a => a -> q -> q + (.>>) :: IsName a => a -> q -> q -- | Of course, names can be qualified using @(.>)@. instance Qualifiable Name where - (|>) = (.>) + (.>>) = (.>) instance Qualifiable a => Qualifiable (TransInv a) where - (|>) n = over (_Unwrapping' TransInv) (n |>) + (.>>) n = over (_Unwrapping' TransInv) (n .>>) instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where - n |> (a,b) = (n |> a, n |> b) + n .>> (a,b) = (n .>> a, n .>> b) instance (Qualifiable a, Qualifiable b, Qualifiable c) => Qualifiable (a,b,c) where - n |> (a,b,c) = (n |> a, n |> b, n |> c) + n .>> (a,b,c) = (n .>> a, n .>> b, n .>> c) instance Qualifiable a => Qualifiable [a] where - n |> as = map (n |>) as + n .>> as = map (n .>>) as instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where - n |> s = S.map (n |>) s + n .>> s = S.map (n .>>) s instance Qualifiable a => Qualifiable (M.Map k a) where - n |> m = fmap (n |>) m + n .>> m = fmap (n .>>) m instance Qualifiable a => Qualifiable (b -> a) where - n |> f = (n |>) . f + n .>> f = (n .>>) . f -infixr 5 |> +instance Qualifiable a => Qualifiable (Measured n a) where + n .>> m = fmap (n .>>) m + +infixr 5 .>> infixr 5 .> diff --git a/src/Diagrams/Core/Points.hs b/src/Diagrams/Core/Points.hs --- a/src/Diagrams/Core/Points.hs +++ b/src/Diagrams/Core/Points.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -16,25 +15,41 @@ module Diagrams.Core.Points ( -- * Points - Point(..), origin, (*.) - , _relative + Point(..), origin, (*.), relative, _Point + , reflectThrough, mirror, relative2, relative3 ) where --- We 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 Control.Lens (over) -import Control.Lens (Iso', iso) +import Linear.Affine +import Linear.Vector -import Data.AffineSpace.Point -import Data.AffineSpace +import Diagrams.Core.V -import Diagrams.Core.V +type instance V (Point v n) = v +type instance N (Point v n) = n -type instance V (Point v) = v +mirror :: (Additive v, Num n) => Point v n -> Point v n +mirror = reflectThrough origin --- | An isomorphism between points and vectors, given a reference --- point. This is provided for defining new lenses on points. -_relative :: AffineSpace (Point v) => Point v -> Iso' (Point v) v -_relative p0 = iso (.-. p0) (p0 .+^) +-- | Scale a point by a scalar. Specialized version of '(*^)'. +(*.) :: (Functor v, Num n) => n -> Point v n -> Point v n +(*.) = (*^) + +-- | Apply a transformation relative to the given point. +relative2 :: (Additive v, Num n) + => Point v n -> (v n -> v n -> v n) + -> Point v n -> Point v n -> Point v n +relative2 p f x y = (p .+^) $ f (inj x) (inj y) where inj = (.-. p) + +-- | Apply a transformation relative to the given point. +relative3 :: (Additive v, Num n) + => Point v n -> (v n -> v n -> v n -> v n) + -> Point v n -> Point v n -> Point v n -> Point v n +relative3 p f x y z = (p .+^) $ f (inj x) (inj y) (inj z) where inj = (.-. p) + +-- | Mirror a point through a given point. +reflectThrough :: (Additive v, Num n) => Point v n -> Point v n -> Point v n +reflectThrough o = over (relative o) negated + diff --git a/src/Diagrams/Core/Query.hs b/src/Diagrams/Core/Query.hs --- a/src/Diagrams/Core/Query.hs +++ b/src/Diagrams/Core/Query.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE FlexibleInstances - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , TemplateHaskell - , TypeFamilies - #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Query --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -17,20 +16,19 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Query - ( Query(Query), runQuery - ) where + ( Query (..) + ) where -import Control.Applicative -import Control.Lens (Wrapped(..), Rewrapped, iso) -import Data.Semigroup +import Control.Applicative +import Control.Lens (Rewrapped, Wrapped (..), iso) +import Data.Semigroup -import Data.AffineSpace -import Data.VectorSpace +import Linear.Affine +import Linear.Vector -import Diagrams.Core.HasOrigin -import Diagrams.Core.Points -import Diagrams.Core.Transform -import Diagrams.Core.V +import Diagrams.Core.HasOrigin +import Diagrams.Core.Transform +import Diagrams.Core.V ------------------------------------------------------------ -- Queries ----------------------------------------------- @@ -42,19 +40,20 @@ -- -- The idea for annotating diagrams with monoidal queries came from -- the graphics-drawingcombinators package, . -newtype Query v m = Query { runQuery :: Point v -> m } +newtype Query v n m = Query { runQuery :: Point v n -> m } deriving (Functor, Applicative, Semigroup, Monoid) -instance Wrapped (Query v m) where - type Unwrapped (Query v m) = (Point v -> m) - _Wrapped' = iso runQuery Query +instance Wrapped (Query v n m) where + type Unwrapped (Query v n m) = Point v n -> m + _Wrapped' = iso runQuery Query -instance Rewrapped (Query v m) (Query v' m') +instance Rewrapped (Query v a m) (Query v' a' m') -type instance V (Query v m) = v +type instance V (Query v n m) = v +type instance N (Query v n m) = n -instance VectorSpace v => HasOrigin (Query v m) where +instance (Additive v, Num n) => HasOrigin (Query v n m) where moveOriginTo (P u) (Query f) = Query $ \p -> f (p .+^ u) -instance HasLinearMap v => Transformable (Query v m) where +instance (Additive v, Num n) => Transformable (Query v n 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 --- a/src/Diagrams/Core/Style.hs +++ b/src/Diagrams/Core/Style.hs @@ -1,21 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} --- The UndecidableInstances flag is needed under 6.12.3 for the --- HasStyle (a,b) instance. +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Style --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -25,40 +23,64 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Style - ( -- * Attributes - -- $attr + ( -- * Attributes + -- $attr - AttributeClass - , Attribute(..) - , mkAttr, mkTAttr, mkGTAttr, unwrapAttr - , applyAttr, applyTAttr, applyGTAttr + AttributeClass + , Attribute(..) - -- * Styles - -- $style + -- ** Attributes prisms + , _Attribute + , _MAttribute + , _TAttribute - , Style(..) - , attrToStyle, tAttrToStyle, gtAttrToStyle - , getAttr, setAttr, addAttr, combineAttr - , gmapAttrs + -- ** Attributes utilities + , unwrapAttribute + , unmeasureAttribute + , attributeType - , HasStyle(..) + -- * Styles + -- $style - ) where + , Style(..) + -- ** Making styles + , attributeToStyle + + -- ** Extracting attibutes from styles + , getAttr + , unmeasureAttrs + + -- ** Attibute lenses + , atAttr + , atMAttr + , atTAttr + + -- ** Applying styles + , applyAttr + , applyMAttr + , applyTAttr + + , HasStyle(..) + + ) where + +import Control.Applicative import Control.Arrow ((***)) -import Control.Lens (Rewrapped, Wrapped (..), iso, (%~), - (&)) -import Data.Data -import Data.Data.Lens (template) +import Control.Lens hiding (transform) +import qualified Data.HashMap.Strict as HM import qualified Data.Map as M +import Data.Monoid.Action as A import Data.Semigroup import qualified Data.Set as S - -import Data.Monoid.Action +import Data.Typeable +import Diagrams.Core.Measure import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Vector + ------------------------------------------------------------ -- Attributes -------------------------------------------- ------------------------------------------------------------ @@ -83,71 +105,100 @@ -- 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 +class (Typeable a, Semigroup a) => AttributeClass a -- | An existential wrapper type to hold attributes. Some attributes -- are simply inert/static; some are affected by transformations; -- and some are affected by transformations and can be modified -- generically. -data Attribute v :: * where - Attribute :: AttributeClass a => a -> Attribute v - TAttribute :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v - GTAttribute :: (AttributeClass a, Data a, Transformable a, V a ~ v) => a -> Attribute v - - -- Note: one could imagine requiring all attributes to be generic, - -- but adding Data instances for everything would be a big pain in - -- the butt, especially for things in other packages which don't - -- export their constructors (e.g. FingerTree). Having three - -- different attribute wrappers is not ideal but it's far less work - -- than the alternative. +data Attribute (v :: * -> *) n :: * where + Attribute :: AttributeClass a => a -> Attribute v n + MAttribute :: AttributeClass a => Measured n a -> Attribute v n + TAttribute :: (AttributeClass a, Transformable a, V a ~ v, N a ~ n) => a -> Attribute v n -type instance V (Attribute v) = v +type instance V (Attribute v n) = v +type instance N (Attribute v n) = n --- | Wrap up an attribute. -mkAttr :: AttributeClass a => a -> Attribute v -mkAttr = Attribute +-- | 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 Typeable n => Semigroup (Attribute v n) where + (Attribute a1) <> (preview _Attribute -> Just a2) = Attribute (a1 <> a2) + (MAttribute a1) <> (preview _MAttribute -> Just a2) = MAttribute (a1 <> a2) + (TAttribute a1) <> (preview _TAttribute -> Just a2) = TAttribute (a1 <> a2) + _ <> a2 = a2 --- | Wrap up a transformable attribute. -mkTAttr :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v -mkTAttr = TAttribute +-- | 'TAttribute's are transformed directly, 'MAttribute's have their +-- local scale multiplied by the average scale of the transform. +-- Plain 'Attribute's are unaffected. +instance (Additive v, Traversable v, Floating n) => Transformable (Attribute v n) where + transform _ (Attribute a) = Attribute a + transform t (MAttribute a) = MAttribute $ scaleLocal (avgScale t) a + transform t (TAttribute a) = TAttribute $ transform t a --- | Wrap up a transformable and generic attribute. -mkGTAttr :: (AttributeClass a, Data a, Transformable a, V a ~ v) => a -> Attribute v -mkGTAttr = GTAttribute +-- | Shows the kind of attribute and the type contained in the +-- attribute. +instance Typeable n => Show (Attribute v n) where + showsPrec d attr = showParen (d > 10) $ case attr of + Attribute a -> showString "Attribute " . showsPrec 11 (typeOf a) + MAttribute a -> showString "MAttribute " . showsPrec 11 (mType a) + TAttribute a -> showString "TAttribute " . showsPrec 11 (typeOf a) -- | Unwrap an unknown 'Attribute' type, performing a dynamic (but --- safe) check on the type of the result. If the required type +-- 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 -unwrapAttr (GTAttribute a) = cast a +-- +-- Measured attributes cannot be extrated from this function until +-- they have been unmeasured with 'unmeasureAttribute'. If you want a +-- measured attibute use the '_MAttribute' prism. +unwrapAttribute :: AttributeClass a => Attribute v n -> Maybe a +unwrapAttribute (Attribute a) = cast a +unwrapAttribute (MAttribute _) = Nothing +unwrapAttribute (TAttribute a) = cast a +{-# INLINE unwrapAttribute #-} --- | 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') - (GTAttribute a1) <> a2 = - case unwrapAttr a2 of - Nothing -> a2 - Just a2' -> GTAttribute (a1 <> a2') +-- | Prism onto an 'Attribute'. +_Attribute :: AttributeClass a => Prism' (Attribute v n) a +_Attribute = prism' Attribute $ \t -> case t of Attribute a -> cast a; _ -> Nothing +{-# INLINE _Attribute #-} -instance HasLinearMap v => Transformable (Attribute v) where - transform _ (Attribute a) = Attribute a - transform t (TAttribute a) = TAttribute (transform t a) - transform t (GTAttribute a) = GTAttribute (transform t a) +-- | Prism onto an 'MAttribute'. +_MAttribute :: (AttributeClass a, Typeable n) => Prism' (Attribute v n) (Measured n a) +_MAttribute = prism' MAttribute $ \t -> case t of MAttribute a -> cast a; _ -> Nothing +{-# INLINE _MAttribute #-} +-- | Prism onto a 'TAttribute'. +_TAttribute :: (V a ~ v, N a ~ n, AttributeClass a, Transformable a) + => Prism' (Attribute v n) a +_TAttribute = prism' TAttribute $ \t -> case t of TAttribute a -> cast a; _ -> Nothing +{-# INLINE _TAttribute #-} + +-- | Turn an 'MAttribute' into an 'Attribute' using the given 'global' +-- and 'normalized' scale. +unmeasureAttribute :: (Num n, Typeable n) + => n -> n -> Attribute v n -> Attribute v n +unmeasureAttribute g n (MAttribute m) = Attribute (fromMeasured g n m) +unmeasureAttribute _ _ a = a + +-- | Type of an attribute that is stored with a style. Measured +-- attributes return the type as if it where unmeasured. +attributeType :: Attribute v n -> TypeRep +attributeType (Attribute a) = typeOf a +attributeType (MAttribute a) = mType a +attributeType (TAttribute a) = typeOf a + +-- Note that we use type 'a' not 'Measured n a' so we don't have to rebuild +-- when unmeasuring the attributes. +mType :: forall n a. Typeable a => Measured n a -> TypeRep +mType _ = typeOf (undefined :: a) + +-- naming convention: "Attribute" deals with the 'AttibuteType' +-- directly and "Attr" is for other things (like styles). Users should +-- rarely (if at all) deal with the 'Attibute' type directly. + ------------------------------------------------------------ -- Styles ------------------------------------------------ ------------------------------------------------------------ @@ -160,102 +211,128 @@ -- | 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. +newtype Style v n = Style (HM.HashMap TypeRep (Attribute v n)) -instance Wrapped (Style v) where - type Unwrapped (Style v) = M.Map String (Attribute v) - _Wrapped' = iso (\(Style m) -> m) Style +-- instances ----------------------------------------------------------- -instance Rewrapped (Style v) (Style v') +type instance V (Style v n) = v +type instance N (Style v n) = n -type instance V (Style v) = v +instance Rewrapped (Style v n) (Style v' n') +instance Wrapped (Style v n) where + type Unwrapped (Style v n) = HM.HashMap TypeRep (Attribute v n) + _Wrapped' = iso (\(Style m) -> m) Style + {-# INLINE _Wrapped' #-} --- | 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) +instance Each (Style v n) (Style v' n') (Attribute v n) (Attribute v' n') where + each = _Wrapped . each + {-# INLINE each #-} --- | 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". +type instance Index (Style v n) = TypeRep +type instance IxValue (Style v n) = Attribute v n --- | 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)) +instance Ixed (Style v n) where + ix k = _Wrapped' . ix k + {-# INLINE ix #-} --- | 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)) +instance At (Style v n) where + at k = _Wrapped' . at k + {-# INLINE at #-} --- | Create a style from a single transformable, generic attribute. -gtAttrToStyle :: forall a v. (AttributeClass a, Data a, Transformable a, V a ~ v) => a -> Style v -gtAttrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkGTAttr a)) +-- | Combine a style by combining the attributes; if the two styles have +-- attributes of the same type they are combined according to their +-- semigroup structure. +instance Typeable n => Semigroup (Style v n) where + Style s1 <> Style s2 = Style $ HM.unionWith (<>) s1 s2 --- | 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) +-- | The empty style contains no attributes. +instance Typeable n => Monoid (Style v n) where + mempty = Style HM.empty + mappend = (<>) --- | 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 +instance (Additive v, Traversable v, Floating n) => Transformable (Style v n) where + transform t = over each (transform t) --- | 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 +-- | Styles have no action on other monoids. +instance A.Action (Style v n) m --- | Map generically over all generic attributes in a style, applying --- the given function to any values with the given type, even deeply --- nested ones. Note that only attributes wrapped in 'GTAttribute' --- are affected. -gmapAttrs :: forall v a. Typeable a => (a -> a) -> Style v -> Style v -gmapAttrs f = (inStyle . M.map) gmapAttr - where - gmapAttr :: Attribute v -> Attribute v - gmapAttr (GTAttribute a) = GTAttribute (a & template %~ f) - gmapAttr a = a +-- | Show the attributes in the style. +instance Typeable n => Show (Style v n) where + showsPrec d sty = showParen (d > 10) $ + showString "Style " . showsPrec d (sty ^.. each) -instance Semigroup (Style v) where - Style s1 <> Style s2 = Style $ M.unionWith (<>) s1 s2 +-- making styles ------------------------------------------------------- --- | 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 = (<>) +-- | Turn an attribute into a style. An easier way to make a style is to +-- use the monoid instance and apply library functions for applying +-- that attribute: +-- +-- @ +-- myStyle = mempty # fc blue :: Style V2 Double +-- @ +attributeToStyle :: Attribute v n -> Style v n +attributeToStyle a = Style $ HM.singleton (attributeType a) a +-- extracting attributes ----------------------------------------------- -instance HasLinearMap v => Transformable (Style v) where - transform t = inStyle $ M.map (transform t) +-- | 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. +-- +-- Trying to extract a measured attibute will fail. It either has to +-- be unmeasured with 'unmeasureAttrs' or use the 'atMAttr' lens. +getAttr :: forall a v n. AttributeClass a => Style v n -> Maybe a +getAttr (Style s) = HM.lookup ty s >>= unwrapAttribute + where ty = typeOf (undefined :: a) + -- unwrapAttribute can fail if someone tries to unwrap a measured + -- attribute before it gets "unmeasured" --- | Styles have no action on other monoids. -instance Action (Style v) m +-- | Replace all 'MAttribute's with 'Attribute's using the 'global' and +-- 'normalized' scales. +unmeasureAttrs :: (Num n, Typeable n) => n -> n -> Style v n -> Style v n +unmeasureAttrs g n = over each (unmeasureAttribute g n) +-- style lenses -------------------------------------------------------- + +mkAttrLens :: forall v n a. Typeable a + => (a -> TypeRep) + -> Prism' (Attribute v n) a + -> Lens' (Style v n) (Maybe a) +mkAttrLens tyF p f sty = + f (sty ^? ix ty . p) <&> \mAtt -> sty & at ty .~ (review p <$> mAtt) + where ty = tyF (undefined :: a) +{-# INLINE mkAttrLens #-} + +-- | Lens onto a plain attribute of a style. +atAttr :: AttributeClass a + => Lens' (Style v n) (Maybe a) +atAttr = mkAttrLens typeOf _Attribute +{-# INLINE atAttr #-} + +-- | Lens onto a measured attribute of a style. +atMAttr :: (AttributeClass a, Typeable n) + => Lens' (Style v n) (Maybe (Measured n a)) +atMAttr = mkAttrLens mType _MAttribute +{-# INLINE atMAttr #-} + +-- | Lens onto a transformable attribute of a style. +atTAttr :: (V a ~ v, N a ~ n, AttributeClass a, Transformable a) + => Lens' (Style v n) (Maybe a) +atTAttr = mkAttrLens typeOf _TAttribute +{-# INLINE atTAttr #-} + +-- applying styles ----------------------------------------------------- + -- | 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 + applyStyle :: Style (V a) (N a) -> a -> a -instance HasStyle (Style v) where +instance Typeable n => HasStyle (Style v n) where applyStyle = mappend -instance (HasStyle a, HasStyle b, V a ~ V b) => HasStyle (a,b) where +instance (HasStyle a, HasStyle b, V a ~ V b, N a ~ N b) => HasStyle (a,b) where applyStyle s = applyStyle s *** applyStyle s instance HasStyle a => HasStyle [a] where @@ -270,20 +347,28 @@ instance (HasStyle a, Ord a) => HasStyle (S.Set a) where applyStyle = S.map . applyStyle +instance HasStyle b => HasStyle (Measured n b) where + applyStyle = fmap . applyStyle + -- | Apply an attribute to an instance of 'HasStyle' (such as a --- diagram or a style). If the object already has an attribute of +-- 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 +applyAttr = applyStyle . attributeToStyle . Attribute +-- | Apply a measured 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. +applyMAttr :: (AttributeClass a, N d ~ n, HasStyle d, Typeable n) => Measured n a -> d -> d +applyMAttr = applyStyle . attributeToStyle . MAttribute + -- | Apply a transformable attribute to an instance of 'HasStyle' --- (such as a diagram or a style). If the object already has an +-- (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 +applyTAttr :: (AttributeClass a, Transformable a, V a ~ V d, N a ~ N d, HasStyle d) => a -> d -> d +applyTAttr = applyStyle . attributeToStyle . TAttribute -applyGTAttr :: (AttributeClass a, Data a, Transformable a, V a ~ V d, HasStyle d) => a -> d -> d -applyGTAttr = applyStyle . gtAttrToStyle diff --git a/src/Diagrams/Core/Trace.hs b/src/Diagrams/Core/Trace.hs --- a/src/Diagrams/Core/Trace.hs +++ b/src/Diagrams/Core/Trace.hs @@ -1,16 +1,16 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Trace --- Copyright : (c) 2012 diagrams-core team (see LICENSE) +-- Copyright : (c) 2012-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -49,21 +49,23 @@ ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative +#endif import Control.Lens import Data.List (sort) import qualified Data.Map as M 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 +import Linear.Affine +import Linear.Vector + + ------------------------------------------------------------ -- SortedList -------------------------------------------- ------------------------------------------------------------ @@ -90,12 +92,12 @@ -- | Apply a list function to a 'SortedList'. The function need not -- result in a sorted list; the result will be sorted before being -- rewrapped as a 'SortedList'. -onSortedList :: Ord b => ([a] -> [b]) -> (SortedList a -> SortedList b) +onSortedList :: Ord b => ([a] -> [b]) -> SortedList a -> SortedList b onSortedList f = unsafeOnSortedList (sort . f) -- | Apply an /order-preserving/ list function to a 'SortedList'. No -- sorts or checks are done. -unsafeOnSortedList :: ([a] -> [b]) -> (SortedList a -> SortedList b) +unsafeOnSortedList :: ([a] -> [b]) -> SortedList a -> SortedList b unsafeOnSortedList f (SortedList as) = SortedList (f as) -- | Merge two sorted lists. The result is the sorted list containing @@ -139,15 +141,15 @@ -- -- <> -newtype Trace v = Trace { appTrace :: Point v -> v -> SortedList (Scalar v) } +newtype Trace v n = Trace { appTrace :: Point v n -> v n -> SortedList n } -instance Wrapped (Trace v) where - type Unwrapped (Trace v) = Point v -> v -> SortedList (Scalar v) - _Wrapped' = iso appTrace Trace +instance Wrapped (Trace v n) where + type Unwrapped (Trace v n) = Point v n -> v n -> SortedList n + _Wrapped' = iso appTrace Trace -instance Rewrapped (Trace v) (Trace v') +instance Rewrapped (Trace v n) (Trace v' n') -mkTrace :: (Point v -> v -> SortedList (Scalar v)) -> Trace v +mkTrace :: (Point v n -> v n -> SortedList n) -> Trace v n mkTrace = Trace -- | Traces form a semigroup with pointwise minimum as composition. @@ -155,36 +157,37 @@ -- @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) +deriving instance (Ord n) => Semigroup (Trace v n) -deriving instance (Ord (Scalar v)) => Monoid (Trace v) +deriving instance (Ord n) => Monoid (Trace v n) -type instance V (Trace v) = v +type instance V (Trace v n) = v +type instance N (Trace v n) = n -instance (VectorSpace v) => HasOrigin (Trace v) where - moveOriginTo (P u) = (_Wrapping' Trace) %~ \f p -> f (p .+^ u) +instance (Additive v, Num n) => HasOrigin (Trace v n) where + moveOriginTo (P u) = _Wrapping' Trace %~ \f p -> f (p .+^ u) -instance Show (Trace v) where +instance Show (Trace v n) where show _ = "" ------------------------------------------------------------ -- Transforming traces ----------------------------------- ------------------------------------------------------------ -instance HasLinearMap v => Transformable (Trace v) where - transform t = _Wrapped' %~ \f p v -> f (papply (inv t) p) (apply (inv t) v) +instance (Additive v, Num n) => Transformable (Trace v n) where + transform t = _Wrapped %~ \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 +class (Additive (V a), Ord (N a)) => Traced a where -- | Compute the trace of an object. - getTrace :: a -> Trace (V a) + getTrace :: a -> Trace (V a) (N a) -instance (Ord (Scalar v), VectorSpace v) => Traced (Trace v) where +instance (Additive v, Ord n) => Traced (Trace v n) where getTrace = id -- | The trace of a single point is the empty trace, /i.e./ the one @@ -193,13 +196,13 @@ -- directly at the given point, 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 +instance (Additive v, Ord n) => Traced (Point v n) where getTrace = const mempty instance Traced t => Traced (TransInv t) where getTrace = getTrace . op TransInv -instance (Traced a, Traced b, V a ~ V b) => Traced (a,b) where +instance (Traced a, Traced b, SameSpace a b) => Traced (a,b) where getTrace (x,y) = getTrace x <> getTrace y instance (Traced b) => Traced [b] where @@ -226,7 +229,7 @@ -- intersection, which is often more intuitive behavior. -- -- <> -traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) +traceV :: (n ~ N a, Num n, Traced a) => Point (V a) n -> V a n -> a -> Maybe (V a n) traceV p v a = case getSortedList $ op Trace (getTrace a) p v of (s:_) -> Just (s *^ v) [] -> Nothing @@ -244,7 +247,7 @@ -- intersection, which is often more intuitive behavior. -- -- <> -traceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) +traceP :: (n ~ N a, Traced a, Num n) => Point (V a) n -> V a n -> a -> Maybe (Point (V a) n) traceP p v a = (p .+^) <$> traceV p v a -- > tracePEx = mkTraceDiasABC def { sFilter = take 1 } @@ -257,8 +260,8 @@ -- example shown below.) -- -- <> -maxTraceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) -maxTraceV p = traceV p . negateV +maxTraceV :: (n ~ N a, Num n, Traced a) => Point (V a) n -> V a n -> a -> Maybe (V a n) +maxTraceV p = traceV p . negated -- > maxTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = dropAllBut1 } @@ -269,7 +272,7 @@ -- vector, if all the boundary points are.) -- -- <> -maxTraceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) +maxTraceP :: (n ~ N a, Num n, Traced a) => Point (V a) n -> V a n -> a -> Maybe (Point (V a) n) maxTraceP p v a = (p .+^) <$> maxTraceV p v a -- > maxTracePEx = mkTraceDiasABC def { sFilter = dropAllBut1 } @@ -279,7 +282,7 @@ -- boundary points, /i.e./ those boundary points given by a positive -- scalar multiple of the direction vector. Note, this property -- will be destroyed if the resulting 'Trace' is translated at all. -getRayTrace :: (Traced a, Num (Scalar (V a))) => a -> Trace (V a) +getRayTrace :: (n ~ N a, Traced a, Num n) => a -> Trace (V a) n getRayTrace a = Trace $ \p v -> unsafeOnSortedList (dropWhile (<0)) $ appTrace (getTrace a) p v -- | Compute the vector from the given point to the closest boundary @@ -294,8 +297,8 @@ -- 'traceV'. -- -- <> -rayTraceV :: (Traced a, Num (Scalar (V a))) - => Point (V a) -> V a -> a -> Maybe (V a) +rayTraceV :: (n ~ N a, Traced a, Num n) + => Point (V a) n -> V a n -> a -> Maybe (V a n) rayTraceV p v a = case getSortedList $ op Trace (getRayTrace a) p v of (s:_) -> Just (s *^ v) [] -> Nothing @@ -313,8 +316,8 @@ -- camera. -- -- <> -rayTraceP :: (Traced a, Num (Scalar (V a))) - => Point (V a) -> V a -> a -> Maybe (Point (V a)) +rayTraceP :: (n ~ N a, Traced a, Num n) + => Point (V a) n -> V a n -> a -> Maybe (Point (V a) n) rayTraceP p v a = (p .+^) <$> rayTraceV p v a -- > rayTracePEx = mkTraceDiasABC def { sFilter = take 1 . filter (>0) } @@ -325,12 +328,12 @@ -- /positive/ boundary points. -- -- <> -maxRayTraceV :: (Traced a, Num (Scalar (V a))) - => Point (V a) -> V a -> a -> Maybe (V a) +maxRayTraceV :: (n ~ N a, Traced a, Num n) + => Point (V a) n -> V a n -> a -> Maybe (V a n) maxRayTraceV p v a = case getSortedList $ op Trace (getRayTrace a) p v of [] -> Nothing - xs -> Just ((last xs) *^ v) + xs -> Just (last xs *^ v) -- > maxRayTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = dropAllBut1 . filter (>0) } @@ -340,8 +343,8 @@ -- points. -- -- <> -maxRayTraceP :: (Traced a, Num (Scalar (V a))) - => Point (V a) -> V a -> a -> Maybe (Point (V a)) +maxRayTraceP :: (n ~ N a, Traced a, Num n) + => Point (V a) n -> V a n -> a -> Maybe (Point (V a) n) maxRayTraceP p v a = (p .+^) <$> maxRayTraceV p v a -- > maxRayTracePEx = mkTraceDiasABC def { sFilter = dropAllBut1 . filter (>0) } @@ -355,7 +358,7 @@ -- > import Control.Lens ((^.)) -- > import Data.Maybe (fromMaybe) -- > --- > thingyT :: Trail R2 +-- > thingyT :: Trail V2 Double -- > thingyT = -- > fromOffsets -- > [ 3 *^ unitX, 3 *^ unitY, 2 *^ unit_X, 1 *^ unit_Y @@ -364,9 +367,9 @@ -- > thingy = strokeTrail thingyT -- > -- > data TraceDiaOpts --- > = TDO { traceShape :: Diagram B R2 --- > , basePt :: P2 --- > , dirV :: R2 +-- > = TDO { traceShape :: Diagram B +-- > , basePt :: P2 Double +-- > , dirV :: V2 Double -- > , sFilter :: [Double] -> [Double] -- > , drawV :: Bool -- > } @@ -383,14 +386,14 @@ -- > pointB = 1 ^& 1.2 -- > pointC = 2.5 ^& 3.5 -- > --- > dot = circle 0.05 # lw none +-- > dot' = circle 0.05 # lw none -- > --- > mkTraceDia :: TraceDiaOpts -> Diagram B R2 +-- > mkTraceDia :: TraceDiaOpts -> Diagram B -- > mkTraceDia tdo = mconcat --- > [ mconcat $ map (place (dot # fc red)) pts +-- > [ mconcat $ map (place (dot' # fc red)) pts -- > , if drawV tdo then resultArrow else mempty -- > , arrowAt (basePt tdo) (dirV tdo) # lc blue --- > , dot # fc blue # moveTo (basePt tdo) +-- > , dot' # fc blue # moveTo (basePt tdo) -- > , traceLine (basePt tdo) maxPosPt -- > , traceLine (basePt tdo) minNegPt -- > , traceShape tdo @@ -417,9 +420,8 @@ -- > traceLine _ Nothing = mempty -- > traceLine p (Just q) = (p ~~ q) # dashingG [0.1,0.1] 0 -- > --- > mkTraceDias :: [TraceDiaOpts] -> Diagram B R2 +-- > mkTraceDias :: [TraceDiaOpts] -> Diagram B -- > mkTraceDias = hcat' (with & sep .~ 1) . map mkTraceDia -- > --- > mkTraceDiasABC :: TraceDiaOpts -> Diagram B R2 +-- > mkTraceDiasABC :: TraceDiaOpts -> Diagram B -- > mkTraceDiasABC tdo = mkTraceDias (map (\p -> tdo { basePt = p }) [pointA, pointB, pointC]) - diff --git a/src/Diagrams/Core/Transform.hs b/src/Diagrams/Core/Transform.hs --- a/src/Diagrams/Core/Transform.hs +++ b/src/Diagrams/Core/Transform.hs @@ -1,20 +1,17 @@ -{-# LANGUAGE TypeOperators - , FlexibleContexts - , FlexibleInstances - , UndecidableInstances - , TypeFamilies - , MultiParamTypeClasses - , GeneralizedNewtypeDeriving - , TemplateHaskell - , TypeFamilies - , TypeSynonymInstances - , ScopedTypeVariables - #-} - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Transform --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -41,6 +38,8 @@ , apply , papply , fromLinear + , fromOrthogonal + , fromSymmetric , basis , dimension , onBasis @@ -48,11 +47,14 @@ , matrixRep , matrixHomRep , determinant + , isReflection , avgScale + , eye -- * The Transformable class , HasLinearMap + , HasBasis , Transformable(..) -- * Translational invariance @@ -69,22 +71,23 @@ ) where -import Control.Lens (Wrapped(..), Rewrapped, iso) -import qualified Data.Map as M +import Control.Lens (Rewrapped, Traversable, Wrapped (..), + iso, (&), (.~)) +import qualified Data.Map as M import Data.Semigroup -import qualified Data.Set as S +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 Linear.Affine +import Linear.Vector + +import Data.Foldable (Foldable, toList) +import Data.Functor.Rep + import Diagrams.Core.HasOrigin -import Diagrams.Core.Points +import Diagrams.Core.Points () import Diagrams.Core.V ------------------------------------------------------------ @@ -96,21 +99,21 @@ ------------------------------------------------------- -- | @(v1 :-: v2)@ is a linear map paired with its inverse. -data (:-:) u v = (u :-* v) :-: (v :-* u) +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 +(<->) :: (u -> v) -> (v -> u) -> (u :-: v) +f <-> g = f :-: g -instance HasLinearMap v => Semigroup (v :-: v) where - (f :-: f') <> (g :-: g') = f *.* g :-: g' *.* f' +instance Semigroup (a :-: a) 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 +instance Monoid (v :-: v) where + mempty = id :-: id mappend = (<>) -- | Invert a linear map. @@ -118,8 +121,8 @@ 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 +lapp :: (u :-: v) -> u -> v +lapp (f :-: _) = f -------------------------------------------------- -- Affine transformations ---------------------- @@ -139,90 +142,95 @@ -- 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. +-- inverse transpose. (For a more detailed explanation and proof, +-- see .) +-- This is exactly what we need when transforming bounding +-- functions, which are defined in terms of /perpendicular/ +-- (i.e. normal) hyperplanes. -- --- For more general, non-invertable transformations, see +-- For more general, non-invertible transformations, see -- @Diagrams.Deform@ (in @diagrams-lib@). -data Transformation v = Transformation (v :-: v) (v :-: v) v +data Transformation v n = Transformation (v n :-: v n) (v n :-: v n) (v n) -type instance V (Transformation v) = v +type instance V (Transformation v n) = v +type instance N (Transformation v n) = n +-- | Identity matrix. +eye :: (HasBasis v, Num n) => v (v n) +eye = tabulate $ \(E e) -> zero & e .~ 1 + -- | Invert a transformation. -inv :: HasLinearMap v => Transformation v -> Transformation v +inv :: (Functor v, Num n) => Transformation v n -> Transformation v n inv (Transformation t t' v) = Transformation (linv t) (linv t') - (negateV (lapp (linv t) v)) + (negated (lapp (linv t) v)) -- | Get the transpose of a transformation (ignoring the translation -- component). -transp :: Transformation v -> (v :-: v) +transp :: Transformation v n -> (v n :-: v n) transp (Transformation _ t' _) = t' -- | Get the translational component of a transformation. -transl :: Transformation v -> v +transl :: Transformation v n -> v n transl (Transformation _ _ v) = v -- | Drop the translational component of a transformation, leaving only -- the linear part. -dropTransl :: AdditiveGroup v => Transformation v -> Transformation v -dropTransl (Transformation a a' _) = Transformation a a' zeroV +dropTransl :: (Additive v, Num n) => Transformation v n -> Transformation v n +dropTransl (Transformation a a' _) = Transformation a a' zero -- | Transformations are closed under composition; @t1 <> t2@ is the -- transformation which performs first @t2@, then @t1@. -instance HasLinearMap v => Semigroup (Transformation v) where +instance (Additive v, Num n) => Semigroup (Transformation v n) 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 +instance (Additive v, Num n) => Monoid (Transformation v n) where + mempty = Transformation mempty mempty zero mappend = (<>) -- | Transformations can act on transformable things. -instance (HasLinearMap v, v ~ (V a), Transformable a) - => Action (Transformation v) a where +instance (Transformable a, V a ~ v, N a ~ n) => Action (Transformation v n) 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 :: Transformation v n -> v n -> v n +apply (Transformation (t :-: _) _ _) = t -- | Apply a transformation to a point. -papply :: HasLinearMap v => Transformation v -> Point v -> Point v +papply :: (Additive v, Num n) => Transformation v n -> Point v n -> Point v n 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 +fromLinear :: (Additive v, Num n) => (v n :-: v n) -> (v n :-: v n) -> Transformation v n +fromLinear l1 l2 = Transformation l1 l2 zero --- | Get the matrix equivalent of the basis of the vector space v as --- a list of columns. -basis :: forall v. HasLinearMap v => [v] -basis = map basisValue b - where b = map fst (decompose (zeroV :: v)) +-- | An orthogonal linear map is one whose inverse is also its transpose. +fromOrthogonal :: (Additive v, Num n) => (v n :-: v n) -> Transformation v n +fromOrthogonal t = fromLinear t (linv t) +-- | A symmetric linear map is one whose transpose is equal to its self. +fromSymmetric :: (Additive v, Num n) => (v n :-: v n) -> Transformation v n +fromSymmetric t = fromLinear t t + -- | Get the dimension of an object whose vector space is an instance of -- @HasLinearMap@, e.g. transformations, paths, diagrams, etc. -dimension :: forall a. HasLinearMap (V a) => a -> Int -dimension _ = length (decompose (zeroV :: V a)) +dimension :: forall a v. (V a ~ v, Additive v, Traversable v) => a -> Int +dimension _ = length (basis :: [v Int]) -- | Get the matrix equivalent of the linear transform, -- (as a list of columns) and the translation vector. This -- is mostly useful for implementing backends. -onBasis :: forall v. HasLinearMap v => Transformation v -> ([v], v) -onBasis t = (vmat, tr) - where - tr = transl t - vmat = map (apply t) basis +onBasis :: (Additive v, Traversable v, Num n) => Transformation v n -> ([v n], v n) +onBasis (Transformation (f :-: _) _ t) = (map f basis, t) -- Remove the nth element from a list remove :: Int -> [a] -> [a] -remove n xs = ys ++ (tail zs) +remove n xs = ys ++ tail zs where (ys, zs) = splitAt n xs @@ -240,29 +248,34 @@ n = length m -- | Convert a vector v to a list of scalars. -listRep :: HasLinearMap v => v -> [Scalar v] -listRep v = map snd (decompose v) +listRep :: Foldable v => v n -> [n] +listRep = toList --- | Convert a `Transformation v` to a matrix representation as a list of --- column vectors which are also lists. -matrixRep :: HasLinearMap v => Transformation v -> [[Scalar v]] -matrixRep t = map listRep (fst . onBasis $ t) +-- | Convert the linear part of a `Transformation` to a matrix +-- representation as a list of column vectors which are also lists. +matrixRep :: (Additive v, Traversable v, Num n) => Transformation v n -> [[n]] +matrixRep (Transformation (f :-: _) _ _) = map (toList . f) basis -- | Convert a `Transformation v` to a homogeneous matrix representation. -- The final list is the translation. -- The representation leaves off the last row of the matrix as it is -- always [0,0, ... 1] and this representation is the defacto standard -- for backends. -matrixHomRep :: HasLinearMap v => Transformation v -> [[Scalar v]] -matrixHomRep t = mr ++ [listRep tl] +matrixHomRep :: (Additive v, Traversable v, Num n) => Transformation v n -> [[n]] +matrixHomRep t = mr ++ [toList tl] where mr = matrixRep t tl = transl t --- | The determinant of a `Transformation`. -determinant :: (HasLinearMap v, Num (Scalar v)) => Transformation v -> Scalar v -determinant t = det . matrixRep $ t +-- | The determinant of (the linear part of) a `Transformation`. +determinant :: (Additive v, Traversable v, Num n) => Transformation v n -> n +determinant = det . matrixRep +-- | Determine whether a `Transformation` includes a reflection +-- component, that is, whether it reverses orientation. +isReflection :: (Additive v, Traversable v, Num n, Ord n) => Transformation v n -> Bool +isReflection = (<0) . determinant + -- | Compute the \"average\" amount of scaling performed by a -- transformation. Satisfies the properties -- @@ -271,8 +284,8 @@ -- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 -- @ -- -avgScale :: (HasLinearMap v, Floating (Scalar v)) => Transformation v -> Scalar v -avgScale t = (abs . determinant $ t) ** (1 / fromIntegral (dimension t)) +avgScale :: (Additive v, Traversable v, Floating n) => Transformation v n -> n +avgScale t = (abs . determinant) t ** (recip . fromIntegral . dimension) t {- @@ -296,29 +309,33 @@ -- | '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 +class (HasBasis v, Traversable v) => HasLinearMap v +instance (HasBasis v, Traversable v) => HasLinearMap v +-- | An 'Additive' vector space whose representation is made up of basis elements. +class (Additive v, Representable v, Rep v ~ E v) => HasBasis v +instance (Additive v, Representable v, Rep v ~ E v) => HasBasis v + -- | Type class for things @t@ which can be transformed. -class HasLinearMap (V t) => Transformable t where +class Transformable t where -- | Apply a transformation to an object. - transform :: Transformation (V t) -> t -> t + transform :: Transformation (V t) (N t) -> t -> t -instance HasLinearMap v => Transformable (Transformation v) where +instance (Additive v, Num n) => Transformable (Transformation v n) where transform t1 t2 = t1 <> t2 -instance HasLinearMap v => HasOrigin (Transformation v) where +instance (Additive v, Num n) => HasOrigin (Transformation v n) where moveOriginTo p = translate (origin .-. p) -instance (Transformable a, Transformable b, V a ~ V b) - => Transformable (a,b) where +instance (Transformable t, Transformable s, V t ~ V s, N t ~ N s) + => Transformable (t, s) 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 +instance (Transformable t, Transformable s, Transformable u, V s ~ V t, N s ~ N t, V s ~ V u, N s ~ N u) + => Transformable (t,s,u) where transform t (x,y,z) = ( transform t x , transform t y , transform t z @@ -331,9 +348,9 @@ -- construction of image filters. Works well for curried functions, since all -- arguments get inversely transformed. -instance ( HasBasis (V b), HasTrie (Basis (V b)) - , Transformable a, Transformable b, V b ~ V a) => - Transformable (a -> b) where +instance ( V t ~ v, N t ~ n, V t ~ V s, N t ~ N s, Functor v, Num n + , Transformable t, Transformable s) + => Transformable (s -> t) where transform tr f = transform tr . f . transform (inv tr) instance Transformable t => Transformable [t] where @@ -345,18 +362,12 @@ instance Transformable t => Transformable (M.Map k t) where transform = M.map . transform -instance HasLinearMap v => Transformable (Point v) where +instance (Additive v, Num n) => Transformable (Point v n) 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 ------------------------------ ------------------------------------------------------------ @@ -369,40 +380,41 @@ deriving (Eq, Ord, Show, Semigroup, Monoid) instance Wrapped (TransInv t) where - type Unwrapped (TransInv t) = t - _Wrapped' = iso (\(TransInv t) -> t) TransInv + type Unwrapped (TransInv t) = t + _Wrapped' = iso (\(TransInv t) -> t) TransInv instance Rewrapped (TransInv t) (TransInv t') type instance V (TransInv t) = V t +type instance N (TransInv t) = N t -instance VectorSpace (V t) => HasOrigin (TransInv t) where +instance HasOrigin (TransInv t) where moveOriginTo = const id -instance Transformable t => Transformable (TransInv t) where +instance (Num (N t), Additive (V t), Transformable t) => Transformable (TransInv t) where transform (Transformation a a' _) (TransInv t) - = TransInv (transform (Transformation a a' zeroV) t) + = TransInv (transform (Transformation a a' zero) t) ------------------------------------------------------------ -- Generic transformations ------------------------------- ------------------------------------------------------------ -- | Create a translation. -translation :: HasLinearMap v => v -> Transformation v +translation :: v n -> Transformation v n translation = Transformation mempty mempty -- | Translate by a vector. -translate :: (Transformable t, HasLinearMap (V t)) => V t -> t -> t +translate :: (Num (N t), Transformable t) => Vn 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 +scaling :: (Additive v, Fractional n) => n -> Transformation v n +scaling s = fromSymmetric lin 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 :: (InSpace v n a, Eq n, Fractional n, Transformable a) + => n -> a -> a 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 --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -1,18 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- We have some orphan Action instances here, but since Action is a multi-param @@ -21,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Types --- Copyright : (c) 2011-2013 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -48,8 +46,8 @@ -- ** Annotations -- *** Static annotations - Annotation(Href) - , applyAnnotation, href + Annotation(Href, OpacityGroup) + , applyAnnotation, href, opacityGroup, groupOpacity -- *** Dynamic (monoidal) annotations , UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot @@ -86,11 +84,6 @@ , setEnvelope , setTrace - -- * Measurements - , Measure(..) - , fromOutput - , atMost, atLeast - -- * Subdiagrams , Subdiagram(..), mkSubdiagram @@ -108,19 +101,28 @@ -- $prim , Prim(..) + , _Prim -- * Backends , Backend(..) - , DNode(..) , DTree - , RNode(..) + , DNode(..) + , RTree + , RNode(..) + , _RStyle + , _RAnnot + , _RPrim + , _REmpty -- ** Null backend , NullBackend, D + -- ** Number classes + , TypeableFloat + -- * Renderable , Renderable(..) @@ -128,19 +130,18 @@ ) where import Control.Arrow (first, second, (***)) -import Control.Lens (Lens', Rewrapped, Wrapped (..), iso, - lens, over, view, (^.), _Wrapped, +import Control.Lens (Lens', Prism', Rewrapped, + Wrapped (..), iso, lens, over, + prism', view, (^.), _Wrapped, _Wrapping) import Control.Monad (mplus) -import Data.AffineSpace ((.-.)) -import Data.Data import Data.List (isSuffixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe, listToMaybe) import Data.Semigroup import qualified Data.Traversable as T import Data.Tree -import Data.VectorSpace +import Data.Typeable import Data.Monoid.Action import Data.Monoid.Coproduct @@ -160,100 +161,18 @@ import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Affine +import Linear.Metric +import Linear.Vector + -- XXX TODO: add lots of actual diagrams to illustrate the -- documentation! Haddock supports \<\\>. ------------------------------------------------------------- --- Measurement Units ------------------------------------- ------------------------------------------------------------- --- | Type of measurement units for attributes. -data Measure v = Output (Scalar v) - | Normalized (Scalar v) - | Local (Scalar v) - | Global (Scalar v) - - | MinM (Measure v) (Measure v) - | MaxM (Measure v) (Measure v) - | ZeroM - | NegateM (Measure v) - | PlusM (Measure v) (Measure v) - | ScaleM (Scalar v) (Measure v) - deriving (Typeable) - -deriving instance (Eq (Scalar v)) => Eq (Measure v) -deriving instance (Ord (Scalar v)) => Ord (Measure v) -deriving instance (Show (Scalar v)) => Show (Measure v) -deriving instance (Typeable v, Data v, Data (Scalar v)) => Data (Measure v) - --- | Compute the larger of two 'Measure's. Useful for setting lower --- bounds. -atLeast :: Measure v -> Measure v -> Measure v -atLeast = MaxM - --- | Compute the smaller of two 'Measure's. Useful for setting upper --- bounds. -atMost :: Measure v -> Measure v -> Measure v -atMost = MinM - -instance AdditiveGroup (Measure v) where - zeroV = ZeroM - negateV (NegateM m) = m - negateV m = NegateM m - ZeroM ^+^ m = m - m ^+^ ZeroM = m - m1 ^+^ m2 = PlusM m1 m2 - -instance VectorSpace (Measure v) where - type Scalar (Measure v) = Scalar v - s *^ m = ScaleM s m - -type instance V (Measure v) = v - -instance (HasLinearMap v, Floating (Scalar v)) => Transformable (Measure v) where - transform tr (Local x) = Local (avgScale tr * x) - transform tr (MinM m1 m2) = MinM (transform tr m1) (transform tr m2) - transform tr (MaxM m1 m2) = MaxM (transform tr m1) (transform tr m2) - transform tr (NegateM m') = NegateM (transform tr m') - transform tr (PlusM m1 m2) = PlusM (transform tr m1) (transform tr m2) - transform tr (ScaleM s m') = ScaleM s (transform tr m') - transform _ y = y - --- | Retrieve the 'Output' value of a 'Measure v' or throw an exception. --- Only 'Ouput' measures should be left in the 'RTree' passed to the backend. -fromOutput :: Measure v -> Scalar v -fromOutput (Output w) = w -fromOutput (Normalized _) = fromOutputErr "Normalized" -fromOutput (Local _) = fromOutputErr "Local" -fromOutput (Global _) = fromOutputErr "Global" -fromOutput (MinM _ _) = fromOutputErr "MinM" -fromOutput (MaxM _ _) = fromOutputErr "MaxM" -fromOutput (ZeroM) = fromOutputErr "ZeroM" -fromOutput (NegateM _) = fromOutputErr "NegateM" -fromOutput (PlusM _ _) = fromOutputErr "PlusM" -fromOutput (ScaleM _ _) = fromOutputErr "ScaleM" - -fromOutputErr :: String -> a -fromOutputErr s = error $ "fromOutput: Cannot pass " ++ s ++ " to backends, must be Output." - --- Eventually we may use a GADT like: --- --- data Measure o v where --- Output :: Scalar v -> Measure O v --- Normalized :: Scalar v -> Measure A v --- Global :: Scalar v -> Measure A v --- Local :: Scale v -> Measure A v --- --- to check this at compile time. But for now we throw a runtime error. --- --- [BAY 4 April 2014] I tried switching to such a GADT. One tricky --- bit is that you have to use Output :: Scalar v -> Measure o v, --- not Measure O v: the reason is that operations like addition have --- to take two values of the same type, so in order to be able to --- add Output to something else, Output must be able to have an A --- annotation. That all works fine. The problem is with gmapAttrs, --- which has to preserve type: so we can't generically convert from --- Measure A to Measure O. - +-- | Class of numbers that are 'RealFloat' and 'Typeable'. This class is used to +-- shorten type constraints. +class (Typeable n, RealFloat n) => TypeableFloat n +instance (Typeable n, RealFloat n) => TypeableFloat n +-- use class instead of type constraint so users don't need constraint kinds pragma ------------------------------------------------------------ -- Diagrams ---------------------------------------------- @@ -274,11 +193,11 @@ -- * name/subdiagram associations (see "Diagrams.Core.Names") -- -- * query functions (see "Diagrams.Core.Query") -type UpAnnots b v m = Deletable (Envelope v) - ::: Deletable (Trace v) - ::: Deletable (SubMap b v m) - ::: Query v m - ::: () +type UpAnnots b v n m = Deletable (Envelope v n) + ::: Deletable (Trace v n) + ::: Deletable (SubMap b v n m) + ::: Query v n m + ::: () -- | Monoidal annotations which travel down the diagram tree, -- /i.e./ which accumulate along each path to a leaf (and which can @@ -287,9 +206,9 @@ -- * styles (see "Diagrams.Core.Style") -- -- * names (see "Diagrams.Core.Names") -type DownAnnots v = (Transformation v :+: Style v) - ::: Name - ::: () +type DownAnnots v n = (Transformation v n :+: Style v n) + ::: Name + ::: () -- Note that we have to put the transformations and styles together -- using a coproduct because the transformations can act on the @@ -297,14 +216,14 @@ -- | Inject a transformation into a default downwards annotation -- value. -transfToAnnot :: Transformation v -> DownAnnots v +transfToAnnot :: Transformation v n -> DownAnnots v n transfToAnnot = inj - . (inL :: Transformation v -> Transformation v :+: Style v) + . (inL :: Transformation v n -> Transformation v n :+: Style v n) -- | Extract the (total) transformation from a downwards annotation -- value. -transfFromAnnot :: HasLinearMap v => DownAnnots v -> Transformation v +transfFromAnnot :: (Additive v, Num n) => DownAnnots v n -> Transformation v n transfFromAnnot = option mempty killR . fst -- | A leaf in a 'QDiagram' tree is either a 'Prim', or a \"delayed\" @@ -313,38 +232,47 @@ -- order to decide how to draw an arrow, we must know the precise -- transformation applied to it (since the arrow head and tail are -- scale-invariant). -data QDiaLeaf b v m - = PrimLeaf (Prim b v) - | DelayedLeaf (DownAnnots v -> Scalar v -> Scalar v -> QDiagram b v m) +data QDiaLeaf b v n m + = PrimLeaf (Prim b v n) + | DelayedLeaf (DownAnnots v n -> n -> n -> QDiagram b v n m) -- ^ The @QDiagram@ produced by a @DelayedLeaf@ function /must/ -- already apply any transformation in the given -- @DownAnnots@ (that is, the transformation will not -- be applied by the context). - deriving (Functor) + deriving Functor -withQDiaLeaf :: (Prim b v -> r) - -> ((DownAnnots v -> Scalar v -> Scalar v -> QDiagram b v m) -> r) - -> (QDiaLeaf b v m -> r) -withQDiaLeaf f _ (PrimLeaf p) = f p +withQDiaLeaf :: (Prim b v n -> r) + -> ((DownAnnots v n -> n -> n -> QDiagram b v n m) -> r) + -> QDiaLeaf b v n m -> r +withQDiaLeaf f _ (PrimLeaf p) = f p withQDiaLeaf _ g (DelayedLeaf dgn) = g dgn -- | Static annotations which can be placed at a particular node of a -- diagram tree. data Annotation = Href String -- ^ Hyperlink + | OpacityGroup Double deriving Show -- | Apply a static annotation at the root of a diagram. applyAnnotation - :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => Annotation -> QDiagram b v m -> QDiagram b v m + :: (Metric v, OrderedField n, Semigroup m) + => Annotation -> QDiagram b v n m -> QDiagram b v n m applyAnnotation an (QD dt) = QD (D.annot an dt) -- | Make a diagram into a hyperlink. Note that only some backends -- will honor hyperlink annotations. -href :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => String -> QDiagram b v m -> QDiagram b v m +href :: (Metric v, OrderedField n, Semigroup m) + => String -> QDiagram b v n m -> QDiagram b v n m href = applyAnnotation . Href +-- | Change the transparency of a 'Diagram' as a group. +opacityGroup, groupOpacity :: (Metric v, OrderedField n, Semigroup m) + => Double -> QDiagram b v n m -> QDiagram b v n m +opacityGroup = applyAnnotation . OpacityGroup +groupOpacity = applyAnnotation . OpacityGroup + + -- | The fundamental diagram type. The type variables are as follows: -- -- * @b@ represents the backend, such as @SVG@ or @Cairo@. Note @@ -353,9 +281,12 @@ -- @B@, meaning \"use whatever backend is in scope\". -- -- * @v@ represents the vector space of the diagram. Typical --- instantiations include @R2@ (for a two-dimensional diagram) or --- @R3@ (for a three-dimensional diagram). +-- instantiations include @V2@ (for a two-dimensional diagram) or +-- @V3@ (for a three-dimensional diagram). -- +-- * @n@ represents the numerical field the diagram uses. Typically +-- this will be a concrete numeric type like @Double@. +-- -- * @m@ is the monoidal type of \"query annotations\": each point -- in the diagram has a value of type @m@ associated to it, and -- these values are combined according to the 'Monoid' instance @@ -372,31 +303,40 @@ -- distinguished from 'Diagram', where @m@ is fixed to @Any@. This -- is not really a very good name, but it's probably not worth -- changing it at this point. -newtype QDiagram b v m - = QD (D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m)) - deriving (Typeable) +newtype QDiagram b v n m + = QD (D.DUALTree (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)) +#if __GLASGOW_HASKELL__ >= 707 + deriving Typeable +#else -instance Wrapped (QDiagram b v m) where - type Unwrapped (QDiagram b v m) = - D.DUALTree (DownAnnots v) (UpAnnots b v m) Annotation (QDiaLeaf b v m) - _Wrapped' = iso (\(QD d) -> d) QD +instance forall b v. (Typeable b, Typeable1 v) => Typeable2 (QDiagram b v) where + typeOf2 _ = mkTyConApp (mkTyCon3 "diagrams-core" "Diagrams.Core.Types" "QDiagram") [] `mkAppTy` + typeOf (undefined :: b) `mkAppTy` + typeOf1 (undefined :: v n) +#endif -instance Rewrapped (QDiagram b v m) (QDiagram b' v' m') +instance Wrapped (QDiagram b v n m) where + type Unwrapped (QDiagram b v n m) = + D.DUALTree (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m) + _Wrapped' = iso (\(QD d) -> d) QD -type instance V (QDiagram b v m) = v +instance Rewrapped (QDiagram b v n m) (QDiagram b' v' n' m') --- | @Diagram b v@ is a synonym for @'QDiagram' b v 'Any'@. That is, +type instance V (QDiagram b v n m) = v +type instance N (QDiagram b v n m) = n + +-- | @Diagram b@ is a synonym for @'QDiagram' b (V b) (N b) 'Any'@. That is, -- 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 +-- query can be done via the 'Functor' instance of @'QDiagram' b v n@ or -- the 'value' function. -type Diagram b v = QDiagram b v Any +type Diagram b = QDiagram b (V b) (N b) 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 :: (Metric v, Fractional n) + => Point v n -> QDiagram b v n m pointDiagram p = QD $ D.leafU (inj . toDeletable $ pointEnvelope p) -- | A useful variant of 'getU' which projects out a certain @@ -404,48 +344,48 @@ 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 :: forall b v m. (OrderedField (Scalar v), InnerSpace v - , HasLinearMap v, Monoid' m) - => Lens' (QDiagram b v m) (Envelope v) +-- | Lens onto the 'Envelope' of a 'QDiagram'. +envelope :: (OrderedField n, Metric v, Monoid' m) + => Lens' (QDiagram b v n m) (Envelope v n) envelope = lens (unDelete . getU' . view _Wrapped') (flip setEnvelope) -- | 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 :: forall b v n m. ( OrderedField n, Metric v + , Monoid' m) + => Envelope v n -> QDiagram b v n m -> QDiagram b v n m setEnvelope e = over _Wrapped' ( D.applyUpre (inj . toDeletable $ e) - . D.applyUpre (inj (deleteL :: Deletable (Envelope v))) - . D.applyUpost (inj (deleteR :: Deletable (Envelope v))) + . D.applyUpre (inj (deleteL :: Deletable (Envelope v n))) + . D.applyUpost (inj (deleteR :: Deletable (Envelope v n))) ) --- | Get the trace of a diagram. -trace :: (InnerSpace v, HasLinearMap v, OrderedField (Scalar v), Semigroup m) => - Lens' (QDiagram b v m) (Trace v) +-- | Lens onto the 'Trace' of a 'QDiagram'. +trace :: (Metric v, OrderedField n, Semigroup m) => + Lens' (QDiagram b v n m) (Trace v n) trace = lens (unDelete . getU' . view _Wrapped') (flip setTrace) -- | 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 :: forall b v n m. ( OrderedField n, Metric v + , Semigroup m) + => Trace v n -> QDiagram b v n m -> QDiagram b v n m setTrace t = over _Wrapped' ( D.applyUpre (inj . toDeletable $ t) - . D.applyUpre (inj (deleteL :: Deletable (Trace v))) - . D.applyUpost (inj (deleteR :: Deletable (Trace v))) - ) + . D.applyUpre (inj (deleteL :: Deletable (Trace v n))) + . D.applyUpost (inj (deleteR :: Deletable (Trace v n))) + ) --- | Get the subdiagram map (/i.e./ an association from names to --- subdiagrams) of a diagram. -subMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) => - Lens' (QDiagram b v m) (SubMap b v m) -subMap = lens (unDelete . getU' . view _Wrapped') (flip setMap) where - setMap :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) => - SubMap b v m -> QDiagram b v m -> QDiagram b v m - setMap m = over _Wrapped' ( D.applyUpre . inj . toDeletable $ m) +-- | Lens onto the 'SubMap' of a 'QDiagram' (/i.e./ an association from +-- names to subdiagrams). +subMap :: (Metric v, Semigroup m, OrderedField n) + => Lens' (QDiagram b v n m) (SubMap b v n m) +subMap = lens (unDelete . getU' . view _Wrapped') (flip setMap) + where + setMap :: (Metric v, Semigroup m, OrderedField n) => + SubMap b v n m -> QDiagram b v n m -> QDiagram b v n m + setMap m = over _Wrapped' ( D.applyUpre . inj . toDeletable $ m) -- | Get a list of names of subdiagrams and their locations. -names :: (HasLinearMap v, InnerSpace v, Semigroup m, OrderedField (Scalar v)) - => QDiagram b v m -> [(Name, [Point v])] +names :: (Metric v, Semigroup m, OrderedField n) + => QDiagram b v n m -> [(Name, [Point v n])] names = (map . second . map) location . M.assocs . view (subMap . _Wrapped') -- | Attach an atomic name to a certain subdiagram, computed from the @@ -453,37 +393,35 @@ -- included/. The upshot of this knot-tying is that if @d' = d # -- named x@, then @lookupName x d' == Just d'@ (instead of @Just -- d@). -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 :: (IsName nm , Metric v, OrderedField n, Semigroup m) + => (QDiagram b v n m -> Subdiagram b v n m) -> nm -> QDiagram b v n m -> QDiagram b v n m nameSub s n d = d' where d' = over _Wrapped' (D.applyUpre . inj . toDeletable $ fromNames [(n,s d')]) d -- | Lookup the most recent diagram associated with (some -- qualification of) the given name. -lookupName :: (IsName n, HasLinearMap v, InnerSpace v - , Semigroup m, OrderedField (Scalar v)) - => n -> QDiagram b v m -> Maybe (Subdiagram b v m) +lookupName :: (IsName nm, Metric v, Semigroup m, OrderedField n) + => nm -> QDiagram b v n m -> Maybe (Subdiagram b v n m) lookupName n d = lookupSub (toName n) (d^.subMap) >>= listToMaybe -- | 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, HasLinearMap v, InnerSpace v - , Semigroup m, OrderedField (Scalar v)) - => n -> (Subdiagram b v m -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m +withName :: (IsName nm, Metric v + , Semigroup m, OrderedField n) + => nm -> (Subdiagram b v n m -> QDiagram b v n m -> QDiagram b v n m) + -> QDiagram b v n m -> QDiagram b v n m withName n f d = maybe id f (lookupName n d) 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, HasLinearMap v, InnerSpace v - , Semigroup m, OrderedField (Scalar v)) - => n -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m +withNameAll :: (IsName nm, Metric v + , Semigroup m, OrderedField n) + => nm -> ([Subdiagram b v n m] -> QDiagram b v n m -> QDiagram b v n m) + -> QDiagram b v n m -> QDiagram b v n m withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (d^.subMap))) d -- | Given a list of names and a diagram transformation indexed by a @@ -491,37 +429,34 @@ -- 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, HasLinearMap v, InnerSpace v - , Semigroup m, OrderedField (Scalar v)) - => [n] -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m +withNames :: (IsName nm, Metric v + , Semigroup m, OrderedField n) + => [nm] -> ([Subdiagram b v n m] -> QDiagram b v n m -> QDiagram b v n m) + -> QDiagram b v n m -> QDiagram b v n m withNames ns f d = maybe id f ns' d where nd = d^.subMap - ns' = T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns) + ns' = T.sequence (map ((listToMaybe=<<) . ($ nd) . lookupSub . toName) ns) -- | \"Localize\" a diagram by hiding all the names, so they are no -- longer visible to the outside. -localize :: forall b v m. ( HasLinearMap v, InnerSpace v - , OrderedField (Scalar v), Semigroup m - ) - => QDiagram b v m -> QDiagram b v m -localize = over _Wrapped' ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v m))) - . D.applyUpost (inj (deleteR :: Deletable (SubMap b v m))) +localize :: forall b v n m. (Metric v, OrderedField n, Semigroup m) + => QDiagram b v n m -> QDiagram b v n m +localize = over _Wrapped' ( D.applyUpre (inj (deleteL :: Deletable (SubMap b v n m))) + . D.applyUpost (inj (deleteR :: Deletable (SubMap b v n m))) ) - -- | Get the query function associated with a diagram. -query :: Monoid m => QDiagram b v m -> Query v m +query :: Monoid m => QDiagram b v n m -> Query v n m query = getU' . view _Wrapped' -- | Sample a diagram's query function at a given point. -sample :: Monoid m => QDiagram b v m -> Point v -> m +sample :: Monoid m => QDiagram b v n m -> Point v n -> 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 :: Monoid m => m -> QDiagram b v n Any -> QDiagram b v n m value m = fmap fromAny where fromAny (Any True) = m fromAny (Any False) = mempty @@ -529,25 +464,25 @@ -- | 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 :: (Eq m, Monoid m) => QDiagram b v n m -> QDiagram b v n 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 :: QDiagram b v n m -> QDiagram b v n 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 :: Prim b v n -> Envelope v n -> Trace v n -> SubMap b v n m -> Query v n m + -> QDiagram b v n m mkQD p = mkQD' (PrimLeaf p) -- | Create a diagram from a generic QDiaLeaf, along with an envelope, -- trace, subdiagram map, and query function. -mkQD' :: QDiaLeaf b v m -> Envelope v -> Trace v -> SubMap b v m -> Query v m - -> QDiagram b v m +mkQD' :: QDiaLeaf b v n m -> Envelope v n -> Trace v n -> SubMap b v n m -> Query v n m + -> QDiagram b v n m mkQD' l e t n q = QD $ D.leaf (toDeletable e *: toDeletable t *: toDeletable n *: q *: ()) l @@ -569,13 +504,13 @@ -- 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 +instance (Metric v, OrderedField n, Semigroup m) + => Monoid (QDiagram b v n m) where mempty = QD D.empty mappend = (<>) -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => Semigroup (QDiagram b v m) where +instance (Metric v, OrderedField n, Semigroup m) + => Semigroup (QDiagram b v n 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. @@ -583,15 +518,15 @@ -- | 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 :: (OrderedField n, Metric v, Semigroup m) + => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m atop = (<>) infixl 6 `atop` ---- Functor -instance Functor (QDiagram b v) where +instance Functor (QDiagram b v n) where fmap f = over (_Wrapping QD) ( (D.mapU . second . second) ( (first . fmap . fmap . fmap) f @@ -610,63 +545,61 @@ -- @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 +-- instance (Backend b v n, Num n, Ord n) +-- => Applicative (QDiagram b v n) 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 +instance (Metric v, OrderedField n, Semigroup m) + => HasStyle (QDiagram b v n m) where applyStyle = over _Wrapped' . D.applyD . inj - . (inR :: Style v -> Transformation v :+: Style v) + . (inR :: Style v n -> Transformation v n :+: Style v n) ---- Juxtaposable -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Juxtaposable (QDiagram b v m) where +instance (Metric v, OrderedField n, Monoid' m) + => Juxtaposable (QDiagram b v n m) where juxtapose = juxtaposeDefault ---- Enveloped -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Enveloped (QDiagram b v m) where +instance (Metric v, OrderedField n, Monoid' m) + => Enveloped (QDiagram b v n m) where getEnvelope = view envelope ---- Traced -instance (HasLinearMap v, VectorSpace v, Ord (Scalar v), InnerSpace v - , Semigroup m, Fractional (Scalar v), Floating (Scalar v)) - => Traced (QDiagram b v m) where +instance (Metric v, OrderedField n, Semigroup m) + => Traced (QDiagram b v n m) where getTrace = view 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 - +instance (Metric v, OrderedField n, Semigroup m) + => HasOrigin (QDiagram b v n 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 +instance (OrderedField n, Metric v, Semigroup m) + => Transformable (QDiagram b v n m) where transform = over _Wrapped' . 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 _Wrapped' . D.applyD . inj . toName +instance (Metric v, OrderedField n, Semigroup m) + => Qualifiable (QDiagram b v n m) where + (.>>) = over _Wrapped' . D.applyD . inj . toName ------------------------------------------------------------ @@ -678,12 +611,13 @@ -- paired with any accumulated information from the larger context -- (transformations, attributes, etc.). -data Subdiagram b v m = Subdiagram (QDiagram b v m) (DownAnnots v) +data Subdiagram b v n m = Subdiagram (QDiagram b v n m) (DownAnnots v n) -type instance V (Subdiagram b v m) = v +type instance V (Subdiagram b v n m) = v +type instance N (Subdiagram b v n m) = n -- | Turn a diagram into a subdiagram with no accumulated context. -mkSubdiagram :: QDiagram b v m -> Subdiagram b v m +mkSubdiagram :: QDiagram b v n m -> Subdiagram b v n m mkSubdiagram d = Subdiagram d empty -- | Create a \"point subdiagram\", that is, a 'pointDiagram' (with no @@ -692,36 +626,36 @@ -- @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 :: (Metric v, OrderedField n, Semigroup m) + => Point v n -> Subdiagram b v n m subPoint p = Subdiagram (pointDiagram origin) (transfToAnnot $ translation (p .-. origin)) -instance Functor (Subdiagram b v) where +instance Functor (Subdiagram b v n) where fmap f (Subdiagram d a) = Subdiagram (fmap f d) a -instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) - => Enveloped (Subdiagram b v m) where +instance (OrderedField n, Metric v, Monoid' m) + => Enveloped (Subdiagram b v n m) where getEnvelope (Subdiagram d a) = transform (transfFromAnnot a) $ getEnvelope d -instance (OrderedField (Scalar v), HasLinearMap v, InnerSpace v, Semigroup m) - => Traced (Subdiagram b v m) where +instance (OrderedField n, Metric v, Semigroup m) + => Traced (Subdiagram b v n 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 +instance (Metric v, OrderedField n) + => HasOrigin (Subdiagram b v n m) where moveOriginTo = translate . (origin .-.) -instance ( HasLinearMap v, InnerSpace v, Floating (Scalar v)) - => Transformable (Subdiagram b v m) where +instance (Metric v, Floating n) + => Transformable (Subdiagram b v n 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 :: (Additive v, Num n) => Subdiagram b v n m -> Point v n location (Subdiagram _ a) = transform (transfFromAnnot a) origin -- | Turn a subdiagram into a normal diagram, including the enclosing @@ -730,16 +664,13 @@ -- 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 :: (Metric v, OrderedField n, Semigroup m) + => Subdiagram b v n m -> QDiagram b v n m getSub (Subdiagram d a) = over _Wrapped' (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 b v n m -> QDiagram b v n m rawSub (Subdiagram d _) = d ------------------------------------------------------------ @@ -748,26 +679,27 @@ -- | 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]) +newtype SubMap b v n m = SubMap (M.Map Name [Subdiagram b v n m]) -- See Note [SubMap Set vs list] -instance Wrapped (SubMap b v m) where - type Unwrapped (SubMap b v m) = M.Map Name [Subdiagram b v m] - _Wrapped' = iso (\(SubMap m) -> m) SubMap +instance Wrapped (SubMap b v n m) where + type Unwrapped (SubMap b v n m) = M.Map Name [Subdiagram b v n m] + _Wrapped' = iso (\(SubMap m) -> m) SubMap -instance Rewrapped (SubMap b v m) (SubMap b' v' m') +instance Rewrapped (SubMap b v n m) (SubMap b' v' n' 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 +type instance V (SubMap b v n m) = v +type instance N (SubMap b v n m) = n -instance Functor (SubMap b v) where +instance Functor (SubMap b v n) where fmap = over _Wrapped . fmap . map . fmap -instance Semigroup (SubMap b v m) where +instance Semigroup (SubMap b v n m) where SubMap s1 <> SubMap s2 = SubMap $ M.unionWith (++) s1 s2 -- | 'SubMap's form a monoid with the empty map as the identity, and @@ -775,51 +707,51 @@ -- 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 +instance Monoid (SubMap b v n m) where mempty = SubMap M.empty mappend = (<>) -instance (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) - => HasOrigin (SubMap b v m) where +instance (OrderedField n, Metric v) + => HasOrigin (SubMap b v n m) where moveOriginTo = over _Wrapped' . moveOriginTo -instance (InnerSpace v, Floating (Scalar v), HasLinearMap v) - => Transformable (SubMap b v m) where +instance (Metric v, Floating n) + => Transformable (SubMap b v n m) where transform = over _Wrapped' . 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 +instance Qualifiable (SubMap b v n 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 :: IsName a => [(a, Subdiagram b v n m)] -> SubMap b v n 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 :: IsName a => a -> QDiagram b v n m -> SubMap b v n m -> SubMap b v n m rememberAs n b = over _Wrapped' $ M.insertWith (++) (toName n) [mkSubdiagram b] -- | A name acts on a name map by qualifying every name in it. -instance Action Name (SubMap b v m) where - act = (|>) +instance Action Name (SubMap b v n m) where + act = (.>>) instance Action Name a => Action Name (Deletable a) where act n (Deletable l a r) = Deletable l (act n a) r -- Names do not act on other things. -instance Action Name (Query v m) -instance Action Name (Envelope v) -instance Action Name (Trace v) +instance Action Name (Query v n m) +instance Action Name (Envelope v n) +instance Action Name (Trace v n) -- | 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 :: IsName nm => nm -> SubMap b v n m -> Maybe [Subdiagram b v n m] lookupSub a (SubMap m) = M.lookup n m `mplus` (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) @@ -839,61 +771,79 @@ -- 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) +-- | A value of type @Prim b v n@ is an opaque (existentially quantified) -- primitive which backend @b@ knows how to render in vector space @v@. -data Prim b v where - Prim :: (Transformable p, Typeable p, Renderable p b) => p -> Prim b (V p) +data Prim b v n where + Prim :: (Transformable p, Typeable p, Renderable p b) => p -> Prim b (V p) (N p) -type instance V (Prim b v) = v +_Prim :: (Transformable p, Typeable p, Renderable p b) => Prism' (Prim b (V p) (N p)) p +_Prim = prism' Prim (\(Prim p) -> cast p) +type instance V (Prim b v n) = v +type instance N (Prim b v n) = n + -- | 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) +instance Transformable (Prim b v n) where + transform t (Prim p) = Prim (transform t 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 +instance Renderable (Prim b v n) b where render b (Prim p) = render b p ------------------------------------------------------------ -- Backends ----------------------------------------------- ------------------------------------------------------------ -data DNode b v a = DStyle (Style v) - | DTransform (Transformation v) - | DAnnot a - | DDelay - -- ^ @DDelay@ marks a point where a delayed subtree - -- was expanded. Such subtrees already take all - -- non-frozen transforms above them into account, - -- so when later processing the tree, upon - -- encountering a @DDelay@ node we must drop any - -- accumulated non-frozen transformation. - | DPrim (Prim b v) - | DEmpty - -- | A 'DTree' is a raw tree representation of a 'QDiagram', with all -- the @u@-annotations removed. It is used as an intermediate type -- by diagrams-core; backends should not need to make use of it. -- Instead, backends can make use of 'RTree', which 'DTree' gets -- compiled and optimized to. -type DTree b v a = Tree (DNode b v a) +type DTree b v n a = Tree (DNode b v n a) -data RNode b v a = RStyle (Style v) - -- ^ A style node. - | RAnnot a - | RPrim (Prim b v) - -- ^ A primitive. - | REmpty +data DNode b v n a = DStyle (Style v n) + | DTransform (Transformation v n) + | DAnnot a + | DDelay + -- ^ @DDelay@ marks a point where a delayed subtree + -- was expanded. Such subtrees already take all + -- non-frozen transforms above them into account, + -- so when later processing the tree, upon + -- encountering a @DDelay@ node we must drop any + -- accumulated non-frozen transformation. + | DPrim (Prim b v n) + | DEmpty -- | An 'RTree' is a compiled and optimized representation of a -- 'QDiagram', which can be used by backends. They have the -- following invariant which backends may rely upon: -- -- * @RPrim@ nodes never have any children. -type RTree b v a = Tree (RNode b v a ) +type RTree b v n a = Tree (RNode b v n a) +data RNode b v n a = RStyle (Style v n) -- ^ A style node. + | RAnnot a + | RPrim (Prim b v n) -- ^ A primitive. + | REmpty + +-- | Prism onto a style of an 'RNode'. +_RStyle :: Prism' (RNode b v n a) (Style v n) +_RStyle = prism' RStyle $ \n -> case n of RStyle s -> Just s; _ -> Nothing + +-- | Prism onto an annotation of an 'RNode'. +_RAnnot :: Prism' (RNode b v n a) a +_RAnnot = prism' RAnnot $ \n -> case n of RAnnot a -> Just a; _ -> Nothing + +-- | Prism onto a 'Prim' of an 'RNode'. +_RPrim :: Prism' (RNode b v n a) (Prim b v n) +_RPrim = prism' RPrim $ \n -> case n of RPrim p -> Just p; _ -> Nothing + +-- | Prism onto an empty 'RNode'. +_REmpty :: Prism' (RNode b v n a) () +_REmpty = prism' (const REmpty) $ \n -> case n of REmpty -> Just (); _ -> Nothing + -- | Abstract diagrams are rendered to particular formats by -- /backends/. Each backend/vector space combination must be an -- instance of the 'Backend' class. @@ -903,7 +853,7 @@ -- implement 'adjustDia' as well; the default definition does -- nothing. Some useful standard definitions are provided in the -- @Diagrams.TwoD.Adjust@ module from the @diagrams-lib@ package. -class HasLinearMap v => Backend b v where +class Backend b v n where -- | An intermediate representation used for rendering primitives. -- (Typically, this will be some sort of monad, but it need not @@ -911,13 +861,13 @@ -- able to convert primitives into this type; how these rendered -- primitives are combined into an ultimate 'Result' is completely -- up to the backend. - data Render b v :: * + data Render b v n :: * -- | The result of running/interpreting a rendering operation. - type Result b v :: * + type Result b v n :: * -- | Backend-specific rendering options. - data Options b v :: * + data Options b v n :: * -- | 'adjustDia' allows the backend to make adjustments to the final -- diagram (e.g. to adjust the size based on the options) before @@ -929,14 +879,14 @@ -- -- See the diagrams-lib package (particularly the -- @Diagrams.TwoD.Adjust@ module) for some useful implementations. - adjustDia :: (Monoid' m, Num (Scalar v)) => b -> Options b v - -> QDiagram b v m -> (Options b v, Transformation v, QDiagram b v m) + adjustDia :: (Additive v, Monoid' m, Num n) => b -> Options b v n + -> QDiagram b v n m -> (Options b v n, Transformation v n, QDiagram b v n m) adjustDia _ o d = (o,mempty,d) -- | Given some options, take a representation of a diagram as a -- tree and render it. The 'RTree' has already been simplified -- and has all measurements converted to @Output@ units. - renderRTree :: b -> Options b v -> RTree b v Annotation -> Result b v + renderRTree :: b -> Options b v n -> RTree b v n Annotation -> Result b v n -- See Note [backend token] @@ -954,32 +904,39 @@ -- 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) +-- ghci> width (image (uncheckedImageRef \"foo.png\" 200 200)) +-- \:11:8: +-- No instance for (Renderable (DImage n0 External) b0) -- arising from a use of `image' +-- The type variables `n0', `b0' are ambiguous +-- Possible fix: add a type signature that fixes these type variable(s) +-- Note: there is a potential instance available: +-- instance Fractional n => Renderable (DImage n a) NullBackend +-- -- Defined in `Diagrams.TwoD.Image' -- Possible fix: -- add an instance declaration for --- (Renderable Diagrams.TwoD.Image.Image b0) +-- (Renderable (DImage n0 External) 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) +-- `(image (uncheckedImageRef \"foo.png\" 200 200))' +-- In the expression: +-- width (image (uncheckedImageRef \"foo.png\" 200 200)) +-- In an equation for `it': +-- it = width (image (uncheckedImageRef \"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 +-- GHC complains that there is no instance for @Renderable (DImage n0 +-- External) 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 +-- uninstantiated @n0@ and @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: +-- @'D' 'V2' 'Double'@, like so: -- -- @ --- ghci> width (image \"foo.png\" 200 200 :: D R2) +-- ghci> width (image (uncheckedImageRef \"foo.png\" 200 200) :: D V2 Double) -- 200.00000000000006 -- @ -- @@ -990,24 +947,26 @@ -- -- @ -- ghci> width (circle 1) --- \:4:1: --- Couldn't match type `V a0' with `R2' +-- \:12:1: +-- Couldn't match expected type `V2' with actual type `V a0' +-- The type variable `a0' is ambiguous +-- Possible fix: add a type signature that fixes these type variable(s) -- 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' +-- a 'Diagram', the 'circle' function can produce any 'TrailLike' -- 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) +-- ghci> width (circle 1 :: D V2 Double) -- 1.9999999999999998 -- @ -type D v = Diagram NullBackend v +type D v n = QDiagram NullBackend v n Any -- | A null backend which does no actual rendering. It is provided @@ -1023,6 +982,7 @@ -- This ensures that the trick with 'D' annotations can be used for -- diagrams containing your primitive. data NullBackend + deriving Typeable -- Note: we can't make a once-and-for-all instance -- @@ -1031,21 +991,21 @@ -- -- because it overlaps with the Renderable instance for NullPrim. -instance Monoid (Render NullBackend v) where +instance Monoid (Render NullBackend v n) 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 +instance Backend NullBackend v n where + data Render NullBackend v n = NullBackendRender + type Result NullBackend v n = () + data Options NullBackend v n renderRTree _ _ _ = () -- | 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) + render :: b -> t -> Render b (V t) (N t) -- ^ Given a token representing the backend and a -- transformable object, render it in the appropriate rendering -- context. diff --git a/src/Diagrams/Core/V.hs b/src/Diagrams/Core/V.hs --- a/src/Diagrams/Core/V.hs +++ b/src/Diagrams/Core/V.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.V --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -13,16 +15,18 @@ ----------------------------------------------------------------------------- module Diagrams.Core.V - ( V + ( V , N , Vn + , InSpace, SameSpace + ) where - ) where +import Data.Map +import Data.Monoid.Coproduct +import Data.Monoid.Deletable +import Data.Monoid.Split +import Data.Semigroup +import Data.Set -import Data.Map -import Data.Monoid.Coproduct -import Data.Monoid.Deletable -import Data.Monoid.Split -import Data.Semigroup -import Data.Set +import Linear.Vector ------------------------------------------------------------ -- Vector spaces ------------------------------------------- @@ -30,16 +34,15 @@ -- | 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 +-- the associated vector space. The resulting vector space has kind @* -> *@ +-- which means it takes another value (a number) and returns a concrete +-- vector. For example 'V2' has kind @* -> *@ and @V2 Double@ is a vector. +type family V a :: * -> * -- 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 a +type instance V (a,b,c) = V a type instance V (a -> b) = V b type instance V [a] = V a @@ -50,3 +53,35 @@ type instance V (Deletable m) = V m type instance V (Split m) = V m type instance V (m :+: n) = V m + +-- | The numerical field for the object, the number type used for calculations. +type family N a :: * + +type instance N (a,b) = N a +type instance N (a,b,c) = N a + +type instance N (a -> b) = N b +type instance N [a] = N a +type instance N (Option a) = N a +type instance N (Set a) = N a +type instance N (Map k a) = N a + +type instance N (Deletable m) = N m +type instance N (Split m) = N m +type instance N (m :+: n) = N m + +-- | Conveient type alias to retrieve the vector type associated with an +-- object's vector space. This is usually used as @Vn a ~ v n@ where @v@ is +-- the vector space and @n@ is the numerical field. +type Vn a = V a (N a) + +-- | @InSpace v n a@ means the type @a@ belongs to the vector space @v n@, +-- where @v@ is 'Additive' and @n@ is a 'Num'. +class (V a ~ v, N a ~ n, Additive v, Num n) => InSpace v n a +instance (V a ~ v, N a ~ n, Additive v, Num n) => InSpace v n a + +-- | @SameSpace a b@ means the types @a@ and @b@ belong to the same +-- vector space @v n@. +class (V a ~ V b, N a ~ N b) => SameSpace a b +instance (V a ~ V b, N a ~ N b) => SameSpace a b +