diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,770 @@ +## [v1.5.1.2](https://github.com/diagrams/diagrams-core/tree/v1.5.1.2) (2026-04-18) + +- Allow `base-4.22`, `containers-0.8`, and test on GHC 9.14 +- Fix some pattern match warnings +- Remove `semigroups` dependency + +## [v1.5.1.1-r4](https://github.com/diagrams/diagrams-core/tree/v1.5.1.1-r4) (2025-05-16) + +- Allow `monoid-extras-0.7` + +## [v1.5.1.1-r3](https://github.com/diagrams/diagrams-core/tree/v1.5.1.1-r3) (2025-01-30) + +- Allow `base-4.21` (GHC 9.12) + +## [v1.5.1.1-r2](https://github.com/diagrams/diagrams-core/tree/v1.5.1.1-r2) (2024-05-20) + +- Allow: + - `base-4.20` (GHC 9.10) + - `lens-5.3` + - `containers-0.7` +- Test on GHC 9.10 + +## [v1.5.1.1-r1](https://github.com/diagrams/diagrams-core/tree/v1.5.1.1-r1) (2024-04-20) + +* Allow `linear-1.23` + +## [v1.5.1.1](https://github.com/diagrams/diagrams-core/tree/v1.5.1.1) (2023-11-15) + +* Allow `base-4.19` and test on GHC 9.8 +* Fix more warnings + +## [v1.5.1](https://github.com/diagrams/diagrams-core/tree/v1.5.1) (2023-05-11) + +* Allow `base-4.18` and test on GHC 9.6 (thanks to @sergv) +* Fix some warnings (thanks to @sergv) +* Fix some documentation typos (thanks to @mchav) + +## [v1.5.0.1-r1](https://github.com/diagrams/diagrams-core/tree/v1.5.0.1-r1) (2022-11-30) + +* Allow `linear-1.22` + +## [v1.5.0.1](https://github.com/diagrams/diagrams-core/tree/v1.5.0.1) (2022-08-27) + +* Test with up to `base-4.17` and GHC 9.4 +* Allow `lens-5.2` +* Fix documentation for `atLeast` and `atMost` (thanks to Igor Moreno) + +## [v1.5.0](https://github.com/diagrams/diagrams-core/tree/v1.5.0) (2021-05-13) + +* Updates for GHC 8.10 and 9.0 +* Drop support for GHC < 8.4 +* Remove deprecated `Option` type in favor of `Maybe`. This is a + breaking API change. + +## [v1.4.2-r1](https://github.com/diagrams/diagrams-core/tree/v1.4.2-r1) (2020-02-10) + +* Allow `lens-4.19` and `linear-1.21` + +## [v1.4.2](https://github.com/diagrams/diagrams-core/tree/v1.4.2) (2019-10-19) + +* New `KeyVal` constructor for `Annotation` ([PR](https://github.com/diagrams/diagrams-core/pull/104)) +* Updates for GHC 8.8 +* Drop support for GHC 7.6 and 7.8 + +## [v1.4.1.1](https://github.com/diagrams/diagrams-core/tree/v1.4.1.1) (2018-06-17) + +* Add some `ConstraintKinds` pragmas to allow compilation on GHC 7.8 and 7.6 + +## [v1.4.1](https://github.com/diagrams/diagrams-core/tree/v1.4.1) (2018-04-10) + +* Allow `base-4.11` +* Allow `lens-4.16` +* Add `Semigroup` instance to build on GHC 8.4 + +## v1.4.0.1 + +* Allow base-4.10 + +## [v1.4](https://github.com/diagrams/diagrams-core/tree/v1.4) (2016-10-26) + +* **New features** + + - New `eachName` traversal, for traversing over parts of a `Name` + that match a given type + + - More documentation explaining `HasOrigin` and `Transformable` + instances for `Envelope` + +* **Dependency/version changes** + + - Allow `lens-4.15` + - Many other upper bounds bumped; see minor release changelogs below. + +* **New instances** + + - `Transformable` instance for `Measured` + + - A bunch more instances for `Query` (`Distributive`, + `Representable`, `Profunctor`, `Coseive`, `Closed`, `Costrong`, + `Corepresentable`) + +* **API changes** + + - Move some `Query`-related functions to `diagrams-lib` (`sample`, + `value`, `resetValue`, `clearValue`) + + - Remove some redundant constraints in type signatures (should not + actually affect API) + +## [v1.3.0.8](https://github.com/diagrams/diagrams-core/tree/v1.3.0.8) (2016-06-05) + +- allow `base-4.9` +- build warning-free on GHC 8.0.1 + +## [v1.3.0.7](https://github.com/diagrams/diagrams-core/tree/v1.3.0.7) (2016-05-01) + +- allow `lens-4.14` + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.6...v1.3.0.7) + +## [v1.3.0.6](https://github.com/diagrams/diagrams-core/tree/v1.3.0.6) (2016-02-19) + + - allow `unordered-containers-0.2.*` + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.5...v1.3.0.6) + +## [v1.3.0.5](https://github.com/diagrams/diagrams-core/tree/v1.3.0.5) (2016-01-14) + + - allow `unordered-containers-0.2.6` + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.4...v1.3.0.5) + +## [v1.3.0.4](https://github.com/diagrams/diagrams-core/tree/v1.3.0.4) (2015-11-10) + + - allow `semigroups-0.18` + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.3...v1.3.0.4) + +## [v1.3.0.3](https://github.com/diagrams/diagrams-core/tree/v1.3.0.3) (2015-09-17) + + - allow `lens-4.13` + - allow `linear-1.20` + - allow `semigroups-0.17` + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.2...v1.3.0.3) + +## [v1.3.0.2](https://github.com/diagrams/diagrams-core/tree/v1.3.0.2) (2015-07-19) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3.0.1...v1.3.0.2) + +## [v1.3.0.1](https://github.com/diagrams/diagrams-core/tree/v1.3.0.1) (2015-05-26) + +[Full Changelog](https://github.com/diagrams/diagrams-core/compare/v1.3...v1.3.0.1) + +## [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,194 +0,0 @@ -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,10 +1,22 @@ -Copyright (c) 2011-2012 diagrams-core team: - +Copyright (c) 2011-2015 diagrams-core team: + + Daniel Bergey + Christopher Chalmers + Tad Doxsee + Conal Elliott + Ben Gamari + Allan Gardner Sam Griffin + Niklas Haas + Chris Mears + Jeffrey Rosenbluth + Carlos Scheidegger + Ryan Scott Vilhelm Sjöberg + Michael Sloan Scott Walck Ryan Yates - Brent Yorgey + Brent Yorgey All rights reserved. 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://github.com/diagrams/diagrams-core/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/diagrams/diagrams-core/actions/workflows/haskell-ci.yml) 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,10 +1,10 @@ Name: diagrams-core -Version: 0.6.0.2 +Version: 1.5.1.2 Synopsis: Core libraries for diagrams EDSL Description: The core modules underlying diagrams, an embedded domain-specific language for compositional, declarative drawing. -Homepage: http://projects.haskell.org/diagrams +Homepage: https://diagrams.github.io License: BSD3 License-file: LICENSE Author: Brent Yorgey @@ -12,37 +12,41 @@ Bug-reports: https://github.com/diagrams/diagrams-core/issues Category: Graphics Build-type: Simple -Cabal-version: >=1.10 -Extra-source-files: CHANGES.markdown, README.markdown -Tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 +Cabal-version: 1.18 +Extra-source-files: diagrams/*.svg +extra-doc-files: diagrams/*.svg, CHANGELOG.md, README.markdown +Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 || ==9.14.1 Source-repository head type: git - location: git://github.com/diagrams/diagrams-core.git + location: https://github.com/diagrams/diagrams-core.git Library Exposed-modules: Diagrams.Core, + Diagrams.Core.Compile, Diagrams.Core.Envelope, Diagrams.Core.HasOrigin, 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 - - Build-depends: base >= 4.2 && < 4.7, - containers >= 0.3 && < 0.6, - semigroups >= 0.3.4 && < 0.10, - vector-space >= 0.8.4 && < 0.9, - vector-space-points >= 0.1 && < 0.2, - MemoTrie >= 0.4.7 && < 0.7, - newtype >= 0.2 && < 0.3, - monoid-extras >= 0.2 && < 0.3, - dual-tree >= 0.1 && < 0.2 + Diagrams.Core.V + Build-depends: base >= 4.11 && < 4.23, + containers >= 0.4.2 && < 0.9, + unordered-containers >= 0.2 && < 0.3, + monoid-extras >= 0.6 && < 0.8, + dual-tree >= 0.2 && < 0.3, + lens >= 4.0 && < 5.4, + linear >= 1.11.3 && < 1.24, + adjunctions >= 4.0 && < 5.0, + distributive >=0.2.2 && < 1.0, + profunctors >= 5.0 && < 6.0, + mtl >= 2.2 && < 2.4 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 new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTracePEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxRayTraceVEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxTracePEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_maxTraceVEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_rayTracePEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_rayTraceVEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_traceEx.svg b/diagrams/src_Diagrams_Core_Trace_traceEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_traceEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_tracePEx.svg b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_tracePEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Core_Trace_traceVEx.svg b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Core_Trace_traceVEx.svg @@ -0,0 +1,1 @@ + 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 -- @@ -9,7 +9,7 @@ -- domain-specific language for describing and rendering diagrams. -- Normal users of the diagrams library should almost never need to -- import anything from this package directly; instead, import modules --- (especially "Diagrams.Prelude") from the diagrams-lib package, +-- (especially @Diagrams.Prelude@) from the diagrams-lib package, -- which re-exports most things of value to users. -- -- For most library code needing access to core internals, it should @@ -19,25 +19,101 @@ -- occasionally find it useful to directly import one of the -- constituent core modules. -- +-- 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'. +-- +-- The best place to start when learning +-- about diagrams\' types is the user manual: +-- +-- The following list shows which types are contained in each module of +-- "Diagrams.Core". +-- +-- * "Diagrams.Core.Types" +-- +-- * @'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 n@, @'Enveloped' a@, +-- * @'OrderedField' s@. +-- +-- * "Diagrams.Core.Juxtapose" +-- +-- * @'Juxtaposable' a@. +-- +-- * "Diagrams.Core.Names" +-- +-- * @'AName'@, @'Name'@, @'IsName' a@, +-- * @'Qualifiable' q@. +-- +-- * "Diagrams.Core.HasOrigin" +-- +-- * @'HasOrigin' t@. +-- +-- * "Diagrams.Core.Query" +-- +-- * @'Query' v n m@. +-- +-- * "Diagrams.Core.Style" +-- +-- * @'AttributeClass' a@, @'Attribute' v n@, +-- * @'Style' v n@, @'HasStyle'@. +-- +-- * "Diagrams.Core.Trace" +-- +-- * @'SortedList' a@, +-- * @'Trace' v n@, @'Traced' a@. +-- +-- * "Diagrams.Core.Transform" +-- +-- * @u ':-:' v@, @'HasLinearMap'@, @'HasBasis'@ +-- * @'Transformation' v n@, @'Transformable' t@, +-- * @'TransInv' t@. +-- +-- * "Diagrams.Core.V" +-- +-- * @'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 -- * Transformations + -- ** Utilities + , basis + , dimension + , determinant + , isReflection + -- ** Invertible linear transformations , (:-:), (<->), linv, lapp -- ** General transformations , Transformation , inv, transp, transl + , dropTransl , apply , papply , fromLinear @@ -45,6 +121,7 @@ -- ** Some specific transformations , translation, translate, moveTo, place , scaling, scale + , avgScale -- ** The Transformable class @@ -52,13 +129,15 @@ -- ** Translational invariance - , TransInv(..) + , TransInv(TransInv) + , eye -- * Names , AName , Name, IsName(..) , Qualifiable(..), (.>) + , eachName -- ** Subdiagram maps @@ -71,27 +150,31 @@ -- * Attributes and styles , AttributeClass - , Attribute, mkAttr, mkTAttr, unwrapAttr + , Attribute (..) , Style, HasStyle(..) - , getAttr, combineAttr - , applyAttr, applyTAttr + , getAttr + , atAttr, atMAttr, atTAttr + , applyAttr, applyMAttr, applyTAttr -- * Envelopes - , Envelope - , inEnvelope, appEnvelope, onEnvelope, mkEnvelope + , Envelope(..) + , appEnvelope, onEnvelope, mkEnvelope , Enveloped(..) , envelopeVMay, envelopeV, envelopePMay, envelopeP - , diameter, radius + , diameter, radius, size -- * Traces - , Trace(..) - , inTrace, mkTrace + , Trace(Trace) + , SortedList, mkSortedList, getSortedList + , appTrace, mkTrace , Traced(..) , traceV, traceP , maxTraceV, maxTraceP + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP -- * Things with local origins @@ -105,24 +188,27 @@ , Query(..) - -- * Primtives + -- * Primitives - , Prim(..), nullPrim + , Prim(..) -- * Diagrams - , QDiagram, mkQD, Diagram - , prims - , envelope, trace, subMap, names, query, sample - , value, resetValue, clearValue + , QDiagram, Diagram, mkQD, pointDiagram + , envelope, trace, subMap, names, query - , named, nameSub, namePoint + , nameSub , withName , withNameAll , withNames + , localize - , freeze, setEnvelope, setTrace + , href + , opacityGroup + , groupOpacity + , setEnvelope, setTrace + , atop -- ** Subdiagrams @@ -132,12 +218,27 @@ , location , subPoint + -- ** Measurements + + , Measured + , Measure + , fromMeasured + , output + , local + , global + , normalized + , scaleLocal + , atLeast + , atMost + -- * Backends , Backend(..) - , MultiBackend(..) , Renderable(..) + , renderDia + , renderDiaT + -- ** The null backend , NullBackend, D @@ -145,21 +246,25 @@ -- * Convenience classes , HasLinearMap + , HasBasis , OrderedField + , TypeableFloat , Monoid' ) where -import Diagrams.Core.Types -import Diagrams.Core.Envelope -import Diagrams.Core.HasOrigin -import Diagrams.Core.Juxtapose -import Diagrams.Core.Names -import Diagrams.Core.Points -import Diagrams.Core.Query -import Diagrams.Core.Style -import Diagrams.Core.Trace -import Diagrams.Core.Transform -import Diagrams.Core.V +import Diagrams.Core.Compile +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 +import Diagrams.Core.Style +import Diagrams.Core.Trace +import Diagrams.Core.Transform +import Diagrams.Core.Types +import Diagrams.Core.V -import Data.Monoid.WithSemigroup (Monoid') +import Data.Monoid.WithSemigroup (Monoid') diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Compile.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Compile +-- Copyright : (c) 2013-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module provides tools for compiling @QDiagrams@ into a more +-- convenient and optimized tree form, suitable for use by backends. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Compile + ( -- * Tools for backends + RNode(..) + , RTree + , toRTree + + -- * Backend API + + , renderDia + , renderDiaT + + -- * Internals + + , toDTree + , fromDTree + ) + where + +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct +import Data.Monoid.MList +import Data.Monoid.WithSemigroup (Monoid') +import Data.Semigroup +import Data.Tree +import Data.Tree.DUAL +import Data.Typeable + +import Diagrams.Core.Envelope (OrderedField, diameter) +import Diagrams.Core.Style +import Diagrams.Core.Transform +import Diagrams.Core.Types + +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, Floating n, Typeable n) + => n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation) +toDTree g n (QD qd) + = foldDUAL + + -- Prims at the leaves. We ignore the accumulated d-annotations + -- for prims (since we instead distribute them incrementally + -- throughout the tree as they occur), or pass them to the + -- continuation in the case of a delayed node. + (\d -> withQDiaLeaf + + -- Prim: make a leaf node + (\p -> Node (DPrim p) []) + + -- Delayed tree: pass the accumulated d-annotations to + -- 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) + ) + + -- u-only leaves --> empty DTree. We don't care about the + -- u-annotations. + emptyDTree + + -- a non-empty list of child trees. + (\ts -> case NEL.toList ts of + [t] -> t + ts' -> Node DEmpty ts' + ) + + -- Internal d-annotations. We untangle the interleaved + -- transformations and style, and carefully place the style + -- /above/ the transform in the tree (since by calling + -- 'untangle' we have already performed the action of the + -- transform on the style). + (\d t -> case get d of + Nothing -> t + Just d' -> + let (tr,sty) = untangle d' + in Node (DStyle sty) [Node (DTransform tr) [t]] + ) + + -- Internal a-annotations. + (\a t -> Node (DAnnot a) [t]) + qd + +-- | Convert a @DTree@ to an @RTree@ which can be used directly 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 :: forall b v n. (Floating n, HasLinearMap v) + => DTree b v n Annotation -> RTree b v n Annotation +fromDTree = fromDTree' mempty + where + fromDTree' :: 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) _) + = Node (RPrim (transform accTr p)) [] + + -- Styles are transformed then stored in their own node + -- and accTr is push down the tree. + fromDTree' accTr (Node (DStyle s) ts) + = Node (RStyle (transform accTr s)) (fmap (fromDTree' accTr) ts) + + -- Transformations are accumulated and pushed down as well. + fromDTree' accTr (Node (DTransform tr) ts) + = Node REmpty (fmap (fromDTree' (accTr <> tr)) ts) + + fromDTree' accTr (Node (DAnnot a) ts) + = Node (RAnnot a) (fmap (fromDTree' accTr) ts) + + -- Drop accumulated transformations upon encountering a DDelay + -- node --- the tree unfolded beneath it already took into account + -- any transformation at this point. + fromDTree' _ (Node DDelay ts) + = Node REmpty (fmap (fromDTree' mempty) ts) + + -- DEmpty nodes become REmpties, again accTr flows through. + fromDTree' accTr (Node _ ts) + = Node REmpty (fmap (fromDTree' accTr) ts) + +-- | Compile a @QDiagram@ into an 'RTree', rewriting styles with the +-- given function along the way. Suitable for use by backends when +-- implementing 'renderData'. The first argument is the +-- transformation used to convert the diagram from local to output +-- units. +toRTree + :: (HasLinearMap v, Metric 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) (unmeasureAttrs gToO nToO) + . fromDTree + . fromMaybe (Node DEmpty []) + . toDTree gToO nToO + $ d + where + gToO = avgScale globalToOutput + + -- Scaling factor from normalized units to output units: nth root + -- 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 (`diameter` d) basis) ** (1 / fromIntegral (dimension d)) + +-- | Apply a style transformation on 'RStyle' nodes; the identity for +-- other 'RNode's. +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 + +-------------------------------------------------- + +-- | Render a diagram, returning also the transformation which was +-- used to convert the diagram from its (\"global\") coordinate +-- system into the output coordinate system. The inverse of this +-- transformation can be used, for example, to convert output/screen +-- coordinates back into diagram coordinates. See also 'adjustDia'. +renderDiaT + :: (Backend b v n , HasLinearMap v, Metric 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 n , HasLinearMap v, Metric 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,26 @@ -{-# LANGUAGE TypeFamilies - , FlexibleInstances - , FlexibleContexts - , UndecidableInstances - , GeneralizedNewtypeDeriving - , StandaloneDeriving - , MultiParamTypeClasses - #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# 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. -- ----------------------------------------------------------------------------- @@ -26,7 +29,6 @@ ( -- * Envelopes Envelope(..) - , inEnvelope , appEnvelope , onEnvelope , mkEnvelope @@ -37,26 +39,39 @@ -- * Utility functions , diameter , radius - , envelopeVMay, envelopeV, envelopePMay, envelopeP, envelopeSMay, envelopeS + , extent + , size + , envelopeVMay + , envelopeV + , envelopePMay + , envelopeP + , envelopeSMay + , envelopeS -- * Miscellaneous , OrderedField ) where -import Control.Applicative ((<$>)) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, + 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.AffineSpace ((.+^), (.-^)) -import Data.VectorSpace +import qualified Data.Set as S import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Metric +import Linear.Vector + + ------------------------------------------------------------ -- Envelopes --------------------------------------------- ------------------------------------------------------------ @@ -94,107 +109,187 @@ -- -- The idea for envelopes came from -- Sebastian Setzer; see --- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . -newtype Envelope v = Envelope { unEnvelope :: Option (v -> Max (Scalar v)) } +-- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . +newtype Envelope v n = Envelope (Maybe (v n -> Max n)) -inEnvelope :: (Option (v -> Max (Scalar v)) -> Option (v -> Max (Scalar v))) - -> Envelope v -> Envelope v -inEnvelope f = Envelope . f . unEnvelope +instance Wrapped (Envelope v n) where + type Unwrapped (Envelope v n) = Maybe (v n -> Max n) + _Wrapped' = iso (\(Envelope e) -> e) Envelope -appEnvelope :: Envelope v -> Maybe (v -> Scalar v) -appEnvelope (Envelope (Option e)) = (getMax .) <$> e +instance Rewrapped (Envelope v n) (Envelope v' n') -onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v -onEnvelope t = (inEnvelope . fmap) ((Max .) . t . (getMax .)) +-- | \"Apply\" an envelope by turning it into a function. @Nothing@ +-- is returned iff the envelope is empty. +appEnvelope :: Envelope v n -> Maybe (v n -> n) +appEnvelope (Envelope e) = (getMax .) <$> e -mkEnvelope :: (v -> Scalar v) -> Envelope v -mkEnvelope = Envelope . Option . Just . (Max .) +-- | A convenient way to transform an envelope, by specifying a +-- transformation on the underlying @v n -> n@ function. The empty +-- envelope is unaffected. +onEnvelope :: ((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n +onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) --- | Create an envelope for the given point. -pointEnvelope :: (Fractional (Scalar v), InnerSpace v) - => Point v -> Envelope v -pointEnvelope p = moveTo p (mkEnvelope (const zeroV)) +-- | Create an envelope from a @v n -> n@ function. +mkEnvelope :: (v n -> n) -> Envelope v n +mkEnvelope = Envelope . Just . (Max .) +-- | Create a point envelope for the given point. A point envelope +-- has distance zero to a bounding hyperplane in every direction. +-- Note this is /not/ the same as the empty envelope. +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) +type instance V (Envelope v n) = v +type instance N (Envelope v n) = n --- XXX add some diagrams here to illustrate! Note that Haddock supports --- inline images, using a \<\\> syntax. +instance Show (Envelope v n) where + show _ = "" -type instance V (Envelope v) = v +------------------------------------------------------------ +-- Transforming envelopes -------------------------------- +------------------------------------------------------------ -- | 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 $ \oldEnv v -> oldEnv v - ((u ^/ (v `dot` v)) `dot` v) + -- For a detailed explanation of this code, see note + -- [Transforming Envelopes] below. -instance Show (Envelope v) where - show _ = "" +instance (Metric v, Floating n) => Transformable (Envelope v n) where + transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g + where ------------------------------------------------------------- --- Transforming envelopes -------------------------------- ------------------------------------------------------------- + -- For a detailed explanation of this code, see note + -- [Transforming Envelopes] below. + g f v = f v' / (v' `dot` vi) + where + v' = signorm $ lapp (transp t) v + vi = apply (inv t) v --- 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 +{- + +Note [Transforming Envelopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are given an envelope for some object, and want to apply an affine +transformation, such that the new envelope will be the envelope for +the transformed object. The HasOrigin instance handles the +translational component; the rest of the code in the Transformable +instance handles the linear component. + +See <>. + +To implement moveOriginTo, we need to move the "base point" from which +envelope queries are made. We are given the old envelope @oldEnv@ (a +function from vectors to scalars), a vector @u@ from the old origin to +the new origin, and a query vector @v@ which we imagine to emanate +from the new origin. If we query the old envelope with v, it will +find the correct perpendicular hyperplane, but the reported distance +may be wrong (it will only be correct if the origin was moved in a +direction perpendicular to v). The part that needs to be subtracted +is just the projection of u onto v, which is given by (u.v)/(v.v) *^ +v. In fact envelopes return not a distance or vector, but a scalar +which is taken to be a multiple of the query vector, so the scalar we +need to subtract is just (u.v)/(v.v). + +We now consider how to apply a linear transformation to an envelope. +Recall that an envelope is a function that takes a vector and returns +a scaling factor s such that scaling the vector by s will produce a +vector to the minimum separating hyperplane. (So if given a unit +vector as input, the output will be simply the distance to the minimum +separating hyperplane.) + +We are given a linear transformation t and must produce a new envelope +function. Given an input vector v, the "obvious" thing to do is to +transform v back into the original coordinate system using the inverse +of t, apply the original envelope, and then adjust the resulting +scalar according to how much the transformation scales v. + +However, this does not work, since linear transformations do not +preserve angles. Thus, in particular, given the query vector v and +the perpendicular separating hyperplane H which we wish to find, t^-1 +v and t^-1 H are not necessarily perpendicular anymore. So if we +query the envelope with t^-1 v we will get information about the +distance to some separating hyperplane, which when mapped forward +through t will no longer be perpendicular to v. + +However, it turns out that if v and w are perpendicular, then t^-1 v +will be perpendicular to t^T w, that is, the *transpose* of t (when +considered as a matrix) applied to w. The proof is simple. Recall +that v and w are perpendicular if and only if v . w = v^T w = 0. Thus, + + (t^-1 v) . (t^T w) = (t^-1 v)^T (t^T w) = v^T t^-T t^T w = v^T w = 0. + +Now to explain this code: + + 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) - ) +In our case, our new envelope function (transformed by t) will be +given a query vector v, and we suppose v is perpendicular to the +separating hyperplane H. Instead of querying the old envelope +function f with t^-1 v, we query it with t^T v (after normalizing), +since that vector will be perpendicular to t^-1 H. + +Finally, to scale the resulting value correctly, we divide by (t^T v +. t^-1 v); I forget why. Perhaps I will come back later and complete +this explanation. + +-} + ------------------------------------------------------------ -- Enveloped class ------------------------------------------------------------ -- | When dealing with envelopes we often want scalars to be an -- ordered field (i.e. support all four arithmetic operations and be --- totally ordered) so we introduce this class as a convenient +-- totally ordered) so we introduce this constraint 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 +type OrderedField s = (Floating s, Ord 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 a, Enveloped b, V a ~ V b) => Enveloped (a,b) where +instance Enveloped t => Enveloped (TransInv t) where + getEnvelope = getEnvelope . op TransInv + +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 ------------------------------------------------------------ @@ -204,57 +299,67 @@ -- | 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) => 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 = case appEnvelope $ getEnvelope a of - (Just env) -> (env v + env (negateV v)) * magnitude v - Nothing -> 0 +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 :: (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 /axis-parallel/ 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,8 +1,10 @@ -{-# LANGUAGE FlexibleInstances - , FlexibleContexts - , TypeFamilies - , UndecidableInstances - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- The UndecidableInstances flag is needed under 6.12.3 for the -- HasOrigin (a,b) instance. @@ -23,15 +25,16 @@ ( HasOrigin(..), moveOriginBy, moveTo, place ) where -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.AffineSpace ((.-^), (.-.)) -import Data.VectorSpace +import qualified Data.Map as M +import qualified Data.Set as S -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,12 +43,14 @@ -- having a separate class for 'HasOrigin'; indeed, for types which -- are instances of both we should have the identity -- --- > moveOriginTo (origin .^+ v) === translate (negateV v) +-- @ +-- 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. -- @@ -53,42 +58,50 @@ -- (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, HasOrigin t) => v n -> t -> t moveOriginBy = moveOriginTo . P -- | Translate the object by the translation that sends the origin to -- the given point. Note that this is dual to 'moveOriginTo', i.e. we -- should have -- --- > moveTo (origin .^+ v) === moveOriginTo (origin .^- v) +-- @ +-- moveTo (origin .^+ v) === moveOriginTo (origin .^- v) +-- @ -- -- For types which are also 'Transformable', this is essentially the -- same as 'translate', i.e. -- --- > moveTo (origin .^+ v) === translate v -moveTo :: HasOrigin t => Point (V t) -> t -> t +-- @ +-- moveTo (origin .^+ v) === translate v +-- @ +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,10 @@ -{-# LANGUAGE FlexibleContexts - , UndecidableInstances - , TypeFamilies - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Juxtapose @@ -18,16 +21,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 +43,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 @@ -66,3 +71,10 @@ instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where juxtapose = juxtaposeDefault + +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,141 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup import, which becomes redundant under GHC 8.4 + +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 :: 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 scaled so that they are interpreted relative to +-- the size of the final rendered diagram. +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 larger of two measures. +atLeast :: Ord n => Measure n -> Measure n -> Measure n +atLeast = liftA2 max + +-- | Calculate the smaller 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 + +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 @@ -1,38 +1,52 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup import, which becomes redundant under GHC 8.4 + ----------------------------------------------------------------------------- -- | -- 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 -- -- This module defines a type of names which can be used for referring --- to locations within diagrams, and related types. +-- to subdiagrams, and related types. -- ----------------------------------------------------------------------------- module Diagrams.Core.Names - (-- * Names - -- ** Atomic names - AName(..) + (-- * Names + -- ** Atomic names + AName(..) + , _AName - -- ** Names - , Name(..), IsName(..), (.>) + -- ** Names + , Name(..) + , IsName(..) + , (.>) + , eachName - -- ** Qualifiable - , Qualifiable(..) + -- ** Qualifiable + , Qualifiable(..) - ) where + ) where -import Data.List ( intercalate ) -import Data.Semigroup -import Data.Typeable +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 ------------------------------------------------- ------------------------------------------------------------ @@ -41,6 +55,26 @@ -- support 'Typeable' (to facilitate extracting them from -- existential wrappers), 'Ord' (for comparison and efficient -- storage) and 'Show'. +-- +-- To make an instance of 'IsName', you need not define any methods, +-- just declare it. +-- +-- WARNING: it is not recommended to use +-- @GeneralizedNewtypeDeriving@ in conjunction with @IsName@, since +-- in that case the underlying type and the @newtype@ will be +-- considered equivalent when comparing names. For example: +-- +-- @ +-- newtype WordN = WordN Int deriving (Show, Ord, Eq, Typeable, IsName) +-- @ +-- +-- is unlikely to work as intended, since @(1 :: Int)@ and @(WordN 1)@ +-- will be considered equal as names. Instead, use +-- +-- @ +-- newtype WordN = WordN Int deriving (Show, Ord, Eq, Typeable, IsName) +-- instance IsName WordN +-- @ class (Typeable a, Ord a, Show a) => IsName a where toName :: a -> Name toName = Name . (:[]) . AName @@ -52,8 +86,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) @@ -61,32 +95,73 @@ -- 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 . (:[]) instance Eq AName where - (AName a1) == (AName a2) = + AName a1 == AName a2 = case cast a2 of Nothing -> False Just a2' -> a1 == a2' instance Ord AName where - (AName a1) `compare` (AName a2) = + 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 Rewrapped Name Name +instance Wrapped Name where + type Unwrapped Name = [AName] + _Wrapped' = iso (\(Name ns) -> ns) Name + +instance Each Name Name AName AName where + each = _Wrapped . traversed + {-# INLINE each #-} + +-- | Traversal over each name in a 'Name' that matches the target type. +-- +-- @ +-- >>> toListOf eachName ('a' .> False .> 'b') :: String +-- "ab" +-- >>> 'a' .> True .> 'b' & eachName %~ not +-- 'a' .> False .> 'b' +-- @ +-- +-- Note that the type of the name is very important. +-- +-- @ +-- >>> sumOf eachName ((1::Int) .> (2 :: Integer) .> (3 :: Int)) :: Int +-- 4 +-- >>> sumOf eachName ((1::Int) .> (2 :: Integer) .> (3 :: Int)) :: Integer +-- 2 +-- @ +eachName :: (Typeable a, Ord a, Show a) => Traversal' Name a +eachName = each . _AName + instance Show Name where - show (Name ns) = intercalate " .> " $ map show ns + showsPrec d (Name xs) = case xs of + [] -> showParen (d > 10) $ showString "toName []" + [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 @@ -101,11 +176,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 - (|>) = (.>) + (.>>) = (.>) -infixr 5 |> +instance Qualifiable a => Qualifiable (TransInv a) where + (.>>) n = over (_Unwrapping' TransInv) (n .>>) + +instance (Qualifiable a, Qualifiable b) => Qualifiable (a,b) where + 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) + +instance Qualifiable a => Qualifiable [a] where + n .>> as = map (n .>>) as + +instance (Ord a, Qualifiable a) => Qualifiable (S.Set a) where + n .>> s = S.map (n .>>) s + +instance Qualifiable a => Qualifiable (M.Map k a) where + n .>> m = fmap (n .>>) m + +instance Qualifiable a => Qualifiable (b -> a) where + n .>> f = (n .>>) . f + +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,6 @@ -{-# LANGUAGE TypeFamilies - #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Points @@ -14,15 +15,42 @@ module Diagrams.Core.Points ( -- * Points - Point(..), origin, (*.) + Point(..), origin, (*.), relative, _Point + , reflectThrough, mirror, relative2, relative3 ) where --- We just import from Data.AffineSpace.Point (defined in the --- vector-space-points package) and re-export. We also define an --- instance of V for Point here. -import Data.AffineSpace.Point +import Control.Lens (over) -import Diagrams.Core.V +import Linear.Affine +import Linear.Vector -type instance V (Point v) = v +import Diagrams.Core.V + +type instance V (Point v n) = v +type instance N (Point v n) = n + +-- | Reflect a point across the origin. +mirror :: (Additive v, Num n) => Point v n -> Point v n +mirror = reflectThrough origin + +-- | 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,10 +1,12 @@ -{-# LANGUAGE TypeFamilies - , GeneralizedNewtypeDeriving - #-} +{-# 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 -- @@ -14,37 +16,84 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Query - ( Query(..) - ) where + ( Query (..) + ) where -import Control.Applicative -import Data.Semigroup +import Control.Applicative +import Control.Lens +import Data.Semigroup +import Data.Distributive +import Data.Functor.Rep +import Data.Profunctor +import Data.Profunctor.Sieve +import Data.Profunctor.Closed +import qualified Data.Profunctor.Rep as P -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 ----------------------------------------------- ------------------------------------------------------------- +------------------------------------------------------------------------ +-- Queries +------------------------------------------------------------------------ -- | A query is a function that maps points in a vector space to -- values in some monoid. Queries naturally form a monoid, with -- two queries being combined pointwise. -- -- The idea for annotating diagrams with monoidal queries came from --- the graphics-drawingcombinators package, . -newtype Query v m = Query { runQuery :: Point v -> m } - deriving (Functor, Applicative, Semigroup, Monoid) +-- the graphics-drawingcombinators package, +-- . +newtype Query v n m = Query { runQuery :: Point v n -> m } + deriving (Functor, Applicative, Monad, Semigroup, Monoid) -type instance V (Query v m) = v +instance Distributive (Query v n) where + distribute a = Query $ \p -> fmap (\(Query q) -> q p) a -instance VectorSpace v => HasOrigin (Query v m) where - moveOriginTo (P u) (Query f) = Query $ \p -> f (p .+^ u) +instance Representable (Query v n) where + type Rep (Query v n) = Point v n + tabulate = Query + index = runQuery -instance HasLinearMap v => Transformable (Query v m) where - transform t (Query f) = Query $ f . papply (inv t) +instance Functor v => Profunctor (Query v) where + lmap f (Query q) = Query $ \p -> q (fmap f p) + rmap = fmap + +instance Functor v => Cosieve (Query v) (Point v) where + cosieve = runQuery + +instance Functor v => Closed (Query v) where + closed (Query fab) = Query $ \fxa x -> fab (fmap ($ x) fxa) + +instance Functor v => Costrong (Query v) where + unfirst (Query f) = Query f' + where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) + unsecond (Query f) = Query f' + where f' fa = b where (d, b) = f ((,) d <$> fa) + +instance Functor v => P.Corepresentable (Query v) where + type Corep (Query v) = Point v + cotabulate = Query + +-- | Setter over the input point of a query. +queryPoint :: Setter (Query v' n' m) (Query v n m) (Point v n) (Point v' n') +queryPoint = sets $ \f (Query q) -> Query $ q . f + +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 a m) (Query v' a' m') + +type instance V (Query v n m) = v +type instance N (Query v n m) = n + +instance (Additive v, Num n) => HasOrigin (Query v n m) where + moveOriginTo (P u) = queryPoint %~ (.+^ u) + +instance (Additive v, Num n) => Transformable (Query v n m) where + transform t = queryPoint %~ 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,19 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables - , GADTs - , KindSignatures - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , UndecidableInstances - #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 -- @@ -23,36 +23,65 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Style - ( -- * Attributes - -- $attr + ( -- * Attributes + -- $attr - AttributeClass - , Attribute(..) - , mkAttr, mkTAttr, unwrapAttr - , applyAttr, applyTAttr + AttributeClass + , Attribute(..) - -- * Styles - -- $style + -- ** Attributes prisms + , _Attribute + , _MAttribute + , _TAttribute - , Style(..) - , attrToStyle, tAttrToStyle - , getAttr, setAttr, addAttr, combineAttr + -- ** Attributes utilities + , unwrapAttribute + , unmeasureAttribute + , attributeType - , HasStyle(..) + -- * Styles + -- $style - ) where + , Style(..) -import Control.Arrow ((***)) -import qualified Data.Map as M + -- ** 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 hiding (transform) +import qualified Data.HashMap.Strict as HM +import Data.Kind (Type) +import qualified Data.Map as M +import Data.Monoid.Action as A import Data.Semigroup -import qualified Data.Set as S +import qualified Data.Set as S import Data.Typeable -import Data.Monoid.Action - +import Diagrams.Core.Measure import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Vector + ------------------------------------------------------------ -- Attributes -------------------------------------------- ------------------------------------------------------------ @@ -77,51 +106,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 affected by transformations and some are not. -data Attribute v :: * where - Attribute :: AttributeClass a => a -> Attribute v - TAttribute :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v +-- are simply inert/static; some are affected by transformations; +-- and some are affected by transformations and can be modified +-- generically. +data Attribute (v :: Type -> Type) n :: Type 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 +-- | Shows the kind of attribute and the type contained in the +-- attribute. +instance 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 +-- +-- 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') +-- | 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) +-- | 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) + => 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 ------------------------------------------------ ------------------------------------------------------------ @@ -134,81 +212,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. - -type instance V (Style v) = v +newtype Style v n = Style (HM.HashMap TypeRep (Attribute v n)) --- | 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) +-- instances ----------------------------------------------------------- --- | 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 V (Style v n) = v +type instance N (Style v n) = 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 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' #-} --- | 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 Each (Style v n) (Style v' n') (Attribute v n) (Attribute v' n') where + each = _Wrapped . each + {-# INLINE each #-} --- | 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) +type instance Index (Style v n) = TypeRep +type instance IxValue (Style v n) = Attribute v n --- | 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 Ixed (Style v n) where + ix k = _Wrapped' . ix k + {-# INLINE ix #-} --- | Add a new attribute to a style that does not already contain an --- attribute of this type, or combine it on the left with an existing --- attribute. -combineAttr :: AttributeClass a => a -> Style v -> Style v -combineAttr a s = - case getAttr s of - Nothing -> setAttr a s - Just a' -> setAttr (a <> a') s +instance At (Style v n) where + at k = _Wrapped' . at k + {-# INLINE at #-} -instance Semigroup (Style v) where - Style s1 <> Style s2 = Style $ M.unionWith (<>) s1 s2 +-- | 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 --- | 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 +-- | The empty style contains no attributes. +instance Typeable n => Monoid (Style v n) where + mempty = Style HM.empty mappend = (<>) - -instance HasLinearMap v => Transformable (Style v) where - transform t = inStyle $ M.map (transform t) +instance (Additive v, Traversable v, Floating n) => Transformable (Style v n) where + transform t = over each (transform t) -- | Styles have no action on other monoids. -instance Action (Style v) m +instance A.Action (Style v n) m +-- | Show the attributes in the style. +instance Show (Style v n) where + showsPrec d sty = showParen (d > 10) $ + showString "Style " . showsPrec d (sty ^.. each) + +-- making styles ------------------------------------------------------- + +-- | 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 ----------------------------------------------- + +-- | 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" + +-- | Replace all 'MAttribute's with 'Attribute's using the 'global' and +-- 'normalized' scales. +unmeasureAttrs :: (Num 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 @@ -223,17 +348,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) => 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 + 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,17 +1,25 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup import, which becomes redundant under GHC 8.4 + ----------------------------------------------------------------------------- -- | -- 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 -- --- "Diagrams" defines the core library of primitives +-- @diagrams-core@ defines the core library of primitives -- forming the basis of an embedded domain-specific language for -- describing and rendering diagrams. -- @@ -22,10 +30,14 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Trace - ( -- * Traces - Trace(..) + ( -- * SortedList + SortedList + , mkSortedList, getSortedList, onSortedList, unsafeOnSortedList - , inTrace + -- * Traces + , Trace(Trace) + + , appTrace , mkTrace -- * Traced class @@ -36,102 +48,166 @@ , traceV, traceP , maxTraceV, maxTraceP + , getRayTrace + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative -import qualified Data.Map as M +#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.Monoid.PosInf -import Data.VectorSpace +import qualified Data.Set as S import Diagrams.Core.HasOrigin -import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V +import Linear.Affine +import Linear.Vector + + ------------------------------------------------------------ +-- SortedList -------------------------------------------- +------------------------------------------------------------ + +-- Traces return sorted lists of intersections, so we define a newtype +-- wrapper to represent sorted lists. + +-- | A newtype wrapper around a list which maintains the invariant +-- that the list is sorted. The constructor is not exported; use +-- the smart constructor 'mkSortedList' (which sorts the given list) +-- instead. +newtype SortedList a = SortedList [a] + +-- | A smart constructor for the 'SortedList' type, which sorts the +-- input to ensure the 'SortedList' invariant. +mkSortedList :: Ord a => [a] -> SortedList a +mkSortedList = SortedList . sort + +-- | Project the (guaranteed sorted) list out of a 'SortedList' +-- wrapper. +getSortedList :: SortedList a -> [a] +getSortedList (SortedList as) = as + +-- | 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 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 f (SortedList as) = SortedList (f as) + +-- | Merge two sorted lists. The result is the sorted list containing +-- all the elements of both input lists (with duplicates). +merge :: Ord a => SortedList a -> SortedList a -> SortedList a +merge (SortedList as) (SortedList bs) = SortedList (merge' as bs) + where + merge' xs [] = xs + merge' [] ys = ys + merge' (x:xs) (y:ys) = + if x <= y + then x : merge' xs (y:ys) + else y : merge' (x:xs) ys + +-- | 'SortedList' forms a semigroup with 'merge' as composition. +instance Ord a => Semigroup (SortedList a) where + (<>) = merge + +-- | 'SortedList' forms a monoid with 'merge' and the empty list. +instance Ord a => Monoid (SortedList a) where + mappend = (<>) + mempty = SortedList [] + +------------------------------------------------------------ -- Trace ------------------------------------------------- ------------------------------------------------------------ --- | Every diagram comes equipped with a *trace*. Intuitively, the +-- > traceEx = mkTraceDia def + +-- | Every diagram comes equipped with a /trace/. Intuitively, the -- trace for a diagram is like a raytracer: given a line --- (represented as a base point + direction), the trace computes the --- distance from the base point along the line to the first --- intersection with the diagram. The distance can be negative if --- the intersection is in the opposite direction from the base --- point, or infinite if the ray never intersects the diagram. --- Note: to obtain the distance to the *furthest* intersection --- instead of the *closest*, just negate the direction vector and --- then negate the result. +-- (represented as a base point and a direction vector), the trace +-- computes a sorted list of signed distances from the base point to +-- all intersections of the line with the boundary of the +-- diagram. -- --- Note that the output should actually be interpreted not as an --- absolute distance, but as a multiplier relative to the input --- vector. That is, if the input vector is @v@ and the returned --- scalar is @s@, the distance from the base point to the --- intersection is given by @s *^ magnitude v@. +-- Note that the outputs are not absolute distances, but multipliers +-- relative to the input vector. That is, if the base point is @p@ +-- and direction vector is @v@, and one of the output scalars is +-- @s@, then there is an intersection at the point @p .+^ (s *^ v)@. +-- +-- <> -newtype Trace v = Trace { appTrace :: Point v -> v -> PosInf (Scalar v) } +newtype Trace v n = Trace { appTrace :: Point v n -> v n -> SortedList n } -inTrace :: ((Point v -> v -> PosInf (Scalar v)) -> (Point v -> v -> PosInf (Scalar v))) - -> Trace v -> Trace v -inTrace f = Trace . f . appTrace +instance Wrapped (Trace v n) where + type Unwrapped (Trace v n) = Point v n -> v n -> SortedList n + _Wrapped' = iso appTrace Trace -mkTrace :: (Point v -> v -> PosInf (Scalar v)) -> Trace v +instance Rewrapped (Trace v n) (Trace v' n') + +mkTrace :: (Point v n -> v n -> SortedList n) -> Trace v n mkTrace = Trace -- | Traces form a semigroup with pointwise minimum as composition. -- Hence, if @t1@ is the trace for diagram @d1@, and -- @e2@ is the trace for @d2@, then @e1 \`mappend\` e2@ -- is the trace for @d1 \`atop\` d2@. -deriving instance Ord (Scalar v) => Semigroup (Trace v) --- | The identity for the 'Monoid' instance is the constantly infinite --- trace. -deriving instance Ord (Scalar v) => Monoid (Trace v) +deriving instance (Ord n) => Semigroup (Trace v n) -type instance V (Trace v) = v +deriving instance (Ord n) => Monoid (Trace v n) -instance (VectorSpace v) => HasOrigin (Trace v) where - moveOriginTo (P u) = inTrace $ \f p -> f (p .+^ u) +type instance V (Trace v n) = v +type instance N (Trace v n) = n -instance Show (Trace v) where +instance (Additive v, Num n) => HasOrigin (Trace v n) where + moveOriginTo (P u) = _Wrapping' Trace %~ \f p -> f (p .+^ u) + +instance Show (Trace v n) where show _ = "" ------------------------------------------------------------ -- Transforming traces ----------------------------------- ------------------------------------------------------------ -instance HasLinearMap v => Transformable (Trace v) where - transform t = inTrace $ \f p v -> f (papply (inv t) p) (apply (inv t) v) +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 --- which returns positive infinity for every query. Arguably it --- should return a finite distance for vectors aimed directly at the --- given point and infinity for everything else, but due to --- floating-point inaccuracy this is problematic. Note that the --- envelope for a single point is *not* the empty envelope (see --- "Diagrams.Core.Envelope"). -instance (Ord (Scalar v), VectorSpace v) => Traced (Point v) where - getTrace p = mempty +-- which returns no intersection points for every query. Arguably +-- it should return a single finite distance for vectors aimed +-- 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 (Additive v, Ord n) => Traced (Point v n) where + getTrace = const mempty -instance (Traced a, Traced b, V a ~ V b) => Traced (a,b) where +instance Traced t => Traced (TransInv t) where + getTrace = getTrace . op TransInv + +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 @@ -147,26 +223,210 @@ -- Computing with traces --------------------------------- ------------------------------------------------------------ --- | Compute the vector from the given point to the boundary of the --- given object in the given direction, or @Nothing@ if there is no --- intersection. -traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) -traceV p v a = case appTrace (getTrace a) p v of - Finite s -> Just (s *^ v) - PosInfty -> Nothing +-- | Compute the vector from the given point @p@ to the \"smallest\" +-- boundary intersection along the given vector @v@. The +-- \"smallest\" boundary intersection is defined as the one given by +-- @p .+^ (s *^ v)@ for the smallest (most negative) value of +-- @s@. Return @Nothing@ if there is no intersection. See also +-- 'traceP'. +-- +-- See also 'rayTraceV' which uses the smallest /positive/ +-- intersection, which is often more intuitive behavior. +-- +-- <> +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 --- | Given a base point and direction, compute the closest point on --- the boundary of the given object, or @Nothing@ if there is no --- intersection in the given direction. -traceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) +-- > traceVEx = mkTraceDiasABC def { drawV = True, sFilter = take 1 } + + +-- | Compute the \"smallest\" boundary point along the line determined +-- by the given point @p@ and vector @v@. The \"smallest\" boundary +-- point is defined as the one given by @p .+^ (s *^ v)@ for +-- the smallest (most negative) value of @s@. Return @Nothing@ if +-- there is no such boundary point. See also 'traceV'. +-- +-- See also 'rayTraceP' which uses the smallest /positive/ +-- intersection, which is often more intuitive behavior. +-- +-- <> +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 --- | Like 'traceV', but computes a vector to the *furthest* point on --- the boundary instead of the closest. -maxTraceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a) -maxTraceV p = traceV p . negateV +-- > tracePEx = mkTraceDiasABC def { sFilter = take 1 } --- | Like 'traceP', but computes the *furthest* point on the boundary --- instead of the closest. -maxTraceP :: Traced a => Point (V a) -> V a -> a -> Maybe (Point (V a)) + +-- | Like 'traceV', but computes a vector to the \"largest\" boundary +-- point instead of the smallest. (Note, however, the \"largest\" +-- boundary point may still be in the opposite direction from the +-- given vector, if all the boundary points are, as in the third +-- example shown below.) +-- +-- <> +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 } + + +-- | Like 'traceP', but computes the \"largest\" boundary point +-- instead of the smallest. (Note, however, the \"largest\" boundary +-- point may still be in the opposite direction from the given +-- vector, if all the boundary points are.) +-- +-- <> +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 } + + +-- | Get a modified 'Trace' for an object which only returns positive +-- 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 :: (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 +-- point of the given object in the given direction, or @Nothing@ if +-- there is no such boundary point (as in the third example +-- below). Note that unlike 'traceV', only /positive/ boundary +-- points are considered, /i.e./ boundary points corresponding to a +-- positive scalar multiple of the direction vector. This is +-- intuitively the \"usual\" behavior of a raytracer, which only +-- considers intersections \"in front of\" the camera. Compare the +-- second example diagram below with the second example shown for +-- 'traceV'. +-- +-- <> +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 + +-- > rayTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = take 1 . filter (>0) } + + +-- | Compute the boundary point on an object which is closest to the +-- given base point in the given direction, or @Nothing@ if there is +-- no such boundary point. Note that unlike 'traceP', only /positive/ +-- boundary points are considered, /i.e./ boundary points +-- corresponding to a positive scalar multiple of the direction +-- vector. This is intuitively the \"usual\" behavior of a raytracer, +-- which only considers intersection points \"in front of\" the +-- camera. +-- +-- <> +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) } + + +-- | Like 'rayTraceV', but computes a vector to the \"largest\" +-- boundary point instead of the smallest. Considers only +-- /positive/ boundary points. +-- +-- <> +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) + +-- > maxRayTraceVEx = mkTraceDiasABC def { drawV = True, sFilter = dropAllBut1 . filter (>0) } + + +-- | Like 'rayTraceP', but computes the \"largest\" boundary point +-- instead of the smallest. Considers only /positive/ boundary +-- points. +-- +-- <> +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) } + + +------------------------------------------------------------ +-- Drawing trace diagrams +------------------------------------------------------------ + +-- > import Data.Default.Class +-- > import Control.Lens ((^.)) +-- > import Data.Maybe (fromMaybe) +-- > +-- > thingyT :: Trail V2 Double +-- > thingyT = +-- > fromOffsets +-- > [ 3 *^ unitX, 3 *^ unitY, 2 *^ unit_X, 1 *^ unit_Y +-- > , 1 *^ unitX, 1 *^ unit_Y, 2 *^ unit_X, 1 *^ unit_Y ] +-- > +-- > thingy = strokeTrail thingyT +-- > +-- > data TraceDiaOpts +-- > = TDO { traceShape :: Diagram B +-- > , basePt :: P2 Double +-- > , dirV :: V2 Double +-- > , sFilter :: [Double] -> [Double] +-- > , drawV :: Bool +-- > } +-- > +-- > instance Default TraceDiaOpts where +-- > def = TDO { traceShape = thingy +-- > , basePt = pointB +-- > , dirV = 0.3 ^& 0.5 +-- > , sFilter = id +-- > , drawV = False +-- > } +-- > +-- > pointA = 1 ^& (-1.5) +-- > pointB = 1 ^& 1.2 +-- > pointC = 2.5 ^& 3.5 +-- > +-- > dot' = circle 0.05 # lw none +-- > +-- > mkTraceDia :: TraceDiaOpts -> Diagram B +-- > mkTraceDia tdo = mconcat +-- > [ 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) +-- > , traceLine (basePt tdo) maxPosPt +-- > , traceLine (basePt tdo) minNegPt +-- > , traceShape tdo +-- > ] +-- > # centerXY # pad 1.1 +-- > where +-- > ss = sFilter tdo . getSortedList +-- > $ appTrace (traceShape tdo ^. trace) (basePt tdo) (dirV tdo) +-- > pts = map mkPt ss +-- > mkPt s = basePt tdo .+^ (s *^ dirV tdo) +-- > maxPosPt = (mkPt <$>) . safeLast $ filter (>0) ss +-- > minNegPt = (mkPt <$>) . safeHead $ filter (<0) ss +-- > minPt = (mkPt <$>) . safeHead $ ss +-- > resultArrow = fromMaybe mempty (arrowBetween (basePt tdo) <$> minPt) +-- > # lc green +-- > +-- > safeLast [] = Nothing +-- > safeLast xs = Just $ last xs +-- > safeHead [] = Nothing +-- > safeHead (x:_) = Just x +-- > dropAllBut1 [] = [] +-- > dropAllBut1 xs = [last xs] +-- > +-- > traceLine _ Nothing = mempty +-- > traceLine p (Just q) = (p ~~ q) # dashingG [0.1,0.1] 0 +-- > +-- > mkTraceDias :: [TraceDiaOpts] -> Diagram B +-- > mkTraceDias = hcat' (with & sep .~ 1) . map mkTraceDia +-- > +-- > 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,17 +1,17 @@ -{-# LANGUAGE TypeOperators - , FlexibleContexts - , FlexibleInstances - , UndecidableInstances - , TypeFamilies - , MultiParamTypeClasses - , GeneralizedNewtypeDeriving - , TypeSynonymInstances - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# 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 -- @@ -34,18 +34,32 @@ -- ** General transformations , Transformation(..) , inv, transp, transl + , dropTransl , apply , papply , fromLinear + , fromOrthogonal + , fromSymmetric + , basis + , dimension + , onBasis + , listRep + , matrixRep + , matrixHomRep + , determinant + , isReflection + , avgScale + , eye -- * The Transformable class , HasLinearMap + , HasBasis , Transformable(..) -- * Translational invariance - , TransInv(..) + , TransInv(TransInv) -- * Vector space independent transformations -- | Most transformations are specific to a particular vector @@ -57,21 +71,24 @@ ) where -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.Measure +import Diagrams.Core.Points () import Diagrams.Core.V ------------------------------------------------------------ @@ -83,21 +100,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. @@ -105,8 +122,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 ---------------------- @@ -126,93 +143,216 @@ -- 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-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 :: (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 +-- | 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. (Additive (V a), Traversable (V a)) => a -> Int +dimension _ = length (basis :: [V a 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 :: (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 | n < 0 = xs +remove n xs = ys ++ drop 1 zs + where + (ys, zs) = splitAt n xs + +-- Minor matrix of cofactor C(i,j) +minor :: Int -> Int -> [[a]] -> [[a]] +minor i j xs = remove j $ map (remove i) xs + +-- The determinant of a square matrix represented as a nonempty list of lists +-- representing column vectors, that is [column]. +det :: Num a => [[a]] -> a +det [] = error "determinant of empty matrix!" +det [a : _] = a +det m@(c1 : _) = sum [(-1) ^ i * (c1 !! i) * det (minor i 0 m) | i <- [0 .. (n - 1)]] + where + n = length m + +-- | Convert a vector v to a list of scalars. +listRep :: Foldable v => v n -> [n] +listRep = toList + +-- | 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 :: (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 (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 +-- +-- @ +-- avgScale (scaling k) == k +-- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 +-- @ +-- +avgScale :: (Additive v, Traversable v, Floating n) => Transformation v n -> n +avgScale t = (abs . determinant) t ** (recip . fromIntegral . dimension) t + +{- + +avgScale is computed as the nth root of the positive determinant. +This works because the determinant is the factor by which a transformation +scales area/volume. See http://en.wikipedia.org/wiki/Determinant. + +Proofs for the specified properties: + +1. |det (scaling k)|^(1/n) = (k^n)^(1/n) = k +2. |det t1|^(1/n) * |det t2|^(1/n) + = (|det t1| * |det t2|)^(1/n) + = |det t1 * det t2|^(1/n) + = |det (t1 <> t2)|^(1/n) + +-} + ------------------------------------------------------------ -- The Transformable class ------------------------------- ------------------------------------------------------------ --- | 'HasLinearMap' is a poor man's class constraint synonym, just to +-- | 'HasLinearMap' is a constraint synonym, just to -- help shorten some of the ridiculously long constraint sets. -class (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v -instance (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v +type HasLinearMap v = (HasBasis v, Traversable v) +-- | An 'Additive' vector space whose representation is made up of basis elements. +type HasBasis v = (Additive v, Representable v, Rep v ~ E 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 ) +-- Transform functions by conjugation. That is, reverse-transform argument and +-- forward-transform result. Intuition: If someone shrinks you, you see your +-- environment enlarged. If you rotate right, you see your environment +-- rotating left. Etc. This technique was used extensively in Pan for modular +-- construction of image filters. Works well for curried functions, since all +-- arguments get inversely transformed. + +instance ( 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 transform = map . transform @@ -222,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 ------------------------------ ------------------------------------------------------------ @@ -242,37 +376,52 @@ -- translationally invariant; the translational component of -- transformations will no longer affect things wrapped in -- @TransInv@. -newtype TransInv t = TransInv { unTransInv :: t } - deriving (Show, Semigroup, Monoid) +newtype TransInv t = TransInv t + deriving (Eq, Ord, Show, Semigroup, Monoid) +instance Wrapped (TransInv t) where + 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 - transform tr (TransInv t) = TransInv (translate (negateV (transl tr)) . transform tr $ t) +instance (Num (N t), Additive (V t), Transformable t) => Transformable (TransInv t) where + transform (Transformation a a' _) (TransInv t) + = TransInv (transform (Transformation a a' zero) t) +instance (InSpace v n t, Transformable t, HasLinearMap v, Floating n) + => Transformable (Measured n t) where + transform t = scaleLocal n . fmap (transform t') + where + t' = t <> scaling (1 / avgScale t) + n = avgScale 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 :: (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,22 +1,26 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE EmptyDataDecls #-} +{-# 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 +-- class there is really no better place to put them. + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Types --- Copyright : (c) 2011-2012 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,33 +45,43 @@ -- * Diagrams -- ** Annotations - UpAnnots, DownAnnots - , QDiagram(..), mkQD, Diagram + -- *** Static annotations + Annotation(Href, OpacityGroup, KeyVal) + , applyAnnotation, href, opacityGroup, groupOpacity, keyVal + + -- *** Dynamic (monoidal) annotations + , UpAnnots, DownAnnots, transfToAnnot, transfFromAnnot + + -- ** Basic type definitions + , QDiaLeaf(..), withQDiaLeaf + , QDiagram(..), Diagram + -- * Operations on diagrams + -- ** Creating diagrams + , mkQD, mkQD', pointDiagram + -- ** Extracting information - , prims - , envelope, trace, subMap, names, query, sample - , value, resetValue, clearValue + , envelope, trace, subMap, names, query -- ** Combining diagrams -- | For many more ways of combining diagrams, see - -- "Diagrams.Combinators" from the diagrams-lib package. + -- "Diagrams.Combinators" and "Diagrams.TwoD.Combinators" + -- from the diagrams-lib package. , atop -- ** Modifying diagrams -- *** Names - , named , nameSub - , namePoint + , lookupName , withName , withNameAll , withNames + , localize -- *** Other - , freeze , setEnvelope , setTrace @@ -87,43 +101,56 @@ -- * Primtives -- $prim - , Prim(..), nullPrim + , Prim(..) + , _Prim -- * Backends , Backend(..) - , MultiBackend(..) + , DTree + , DNode(..) + , RTree + , RNode(..) + , _RStyle + , _RAnnot + , _RPrim + , _REmpty + -- ** Null backend , NullBackend, D + -- ** Number classes + , TypeableFloat + -- * Renderable , Renderable(..) ) where -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (first, second, (***)) -import Control.Monad (mplus) -import Control.Newtype -import Data.AffineSpace ((.-.)) -import Data.List (isSuffixOf) -import qualified Data.Map as M -import Data.Maybe (listToMaybe, fromMaybe) +import Control.Arrow (first, second, (***)) +import Control.Lens (Lens', Prism', Rewrapped, + Wrapped (..), iso, lens, over, + prism', view, (^.), _Wrapped, + _Wrapping) +import Control.Monad (mplus) +import Data.Kind (Type) +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 qualified Data.Traversable as T +import Data.Tree import Data.Typeable -import Data.VectorSpace import Data.Monoid.Action import Data.Monoid.Coproduct import Data.Monoid.Deletable import Data.Monoid.MList -import Data.Monoid.Split import Data.Monoid.WithSemigroup -import qualified Data.Tree.DUAL as D +import qualified Data.Tree.DUAL as D import Diagrams.Core.Envelope import Diagrams.Core.HasOrigin @@ -136,9 +163,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 \<\\>. +-- | Constraint for numeric types that are 'RealFloat' and 'Typeable', +-- which often occur together. This is used to shorten shorten type +-- constraint contexts. +type TypeableFloat n = (Typeable n, RealFloat n) + ------------------------------------------------------------ -- Diagrams ---------------------------------------------- ------------------------------------------------------------ @@ -158,25 +194,22 @@ -- * name/subdiagram associations (see "Diagrams.Core.Names") -- -- * query functions (see "Diagrams.Core.Query") -type UpAnnots b v m = Deletable (Envelope v) - ::: Deletable (Trace v) - ::: SubMap b v m - ::: Query v m - ::: () +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 -- act on the upwards-travelling annotations): -- --- * transformations (split at the innermost freeze): see --- "Diagrams.Core.Transform" --- -- * styles (see "Diagrams.Core.Style") -- -- * names (see "Diagrams.Core.Names") -type DownAnnots v = (Split (Transformation v) :+: Style v) - ::: Name - ::: () +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 @@ -184,175 +217,258 @@ -- | Inject a transformation into a default downwards annotation -- value. -transfToAnnot :: Transformation v -> DownAnnots v +transfToAnnot :: Transformation v n -> DownAnnots v n transfToAnnot = inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - . M + . (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 = option mempty (unsplit . killR) . fst +transfFromAnnot :: (Additive v, Num n) => DownAnnots v n -> Transformation v n +transfFromAnnot = maybe mempty killR . fst --- | The fundamental diagram type is represented by trees of --- primitives with various monoidal annotations. The @Q@ in --- @QDiagram@ stands for \"Queriable\", as distinguished from --- 'Diagram', a synonym for @QDiagram@ with the query type --- specialized to 'Any'. -newtype QDiagram b v m - = QD { unQD :: D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v) } - deriving (Typeable) +-- | A leaf in a 'QDiagram' tree is either a 'Prim', or a \"delayed\" +-- @QDiagram@ which expands to a real @QDiagram@ once it learns the +-- \"final context\" in which it will be rendered. For example, in +-- 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 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 -instance Newtype (QDiagram b v m) - (D.DUALTree (DownAnnots v) (UpAnnots b v m) () (Prim b v)) where - pack = QD - unpack = unQD +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 -type instance V (QDiagram b v m) = v +-- | Static annotations which can be placed at a particular node of a +-- diagram tree. +data Annotation + = Href String -- ^ Hyperlink + | OpacityGroup Double + | KeyVal (String, String) + deriving Show --- | The default sort of diagram is one where querying at a point +-- | Apply a static annotation at the root of a diagram. +applyAnnotation + :: (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 :: (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 + +-- | Apply a general Key-Value annotation +keyVal :: (Metric v, OrderedField n, Semigroup m) + => (String, String) -> QDiagram b v n m -> QDiagram b v n m +keyVal = applyAnnotation . KeyVal + +-- | The fundamental diagram type. The type variables are as follows: +-- +-- * @b@ represents the backend, such as @SVG@ or @Cairo@. Note +-- that each backend also exports a type synonym @B@ for itself, +-- so the type variable @b@ may also typically be instantiated by +-- @B@, meaning \"use whatever backend is in scope\". +-- +-- * @v@ represents the vector space of the diagram. Typical +-- 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 +-- for @m@. Most often, @m@ is simply instantiated to 'Any', +-- associating a simple @Bool@ value to each point indicating +-- whether the point is inside the diagram; 'Diagram' is a synonym +-- for @QDiagram@ with @m@ thus instantiated to @Any@. +-- +-- Diagrams can be combined via their 'Monoid' instance, transformed +-- via their 'Transformable' instance, and assigned attributes via +-- their 'HasStyle' instance. +-- +-- Note that the @Q@ in @QDiagram@ stands for \"Queriable\", as +-- 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 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 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 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 + +instance Rewrapped (QDiagram b v n m) (QDiagram b' v' n' m') + +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) --- | Extract a list of primitives from a diagram, together with their --- associated transformations and styles. -prims :: HasLinearMap v - => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] -prims = (map . second) (untangle . option mempty id . fst) - . D.flatten - . unQD - -- | A useful variant of 'getU' which projects out a certain -- component. getU' :: (Monoid u', u :>: u') => D.DUALTree d u a l -> u' -getU' = maybe mempty (option mempty id . get) . D.getU +getU' = maybe mempty (maybe mempty id . get) . D.getU --- | Get the envelope of a diagram. -envelope :: (Ord (Scalar v)) - => QDiagram b v m -> Envelope v -envelope = unDelete . getU' . unQD +-- | 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 e = over QD ( D.applyUpre (inj . toDeletable $ e) - . D.applyUpre (inj (deleteL :: Deletable (Envelope v))) - . D.applyUpost (inj (deleteR :: Deletable (Envelope v))) - ) +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 n))) + . D.applyUpost (inj (deleteR :: Deletable (Envelope v n))) + ) --- | Get the trace of a diagram. -trace :: (Ord (Scalar v), VectorSpace v, HasLinearMap v) => QDiagram b v m -> Trace v -trace = unDelete . getU' . unQD +-- | 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 t = over QD ( D.applyUpre (inj . toDeletable $ t) - . D.applyUpre (inj (deleteL :: Deletable (Trace v))) - . D.applyUpost (inj (deleteR :: Deletable (Trace v))) - ) +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 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 :: QDiagram b v m -> SubMap b v m -subMap = getU' . unQD +-- | 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 => QDiagram b v m -> [(Name, [Point v])] -names = (map . second . map) location . M.assocs . unpack . subMap - --- | Attach an atomic name to a diagram. -named :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => n -> QDiagram b v m -> QDiagram b v m -named = nameSub mkSubdiagram - --- | Attach an atomic name to a certain point (which may be computed --- from the given diagram), treated as a subdiagram with no content --- and a point envelope. -namePoint :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m -namePoint p = nameSub (subPoint . p) +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 --- given diagram. -nameSub :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => (QDiagram b v m -> Subdiagram b v m) -> n -> QDiagram b v m -> QDiagram b v m -nameSub s n d = over QD (D.applyUpre . inj $ fromNames [(n,s d)]) d +-- given diagram /with the mapping from name to subdiagram +-- 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 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 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 - => n -> (Subdiagram b v m -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withName n f d = maybe id f (lookupSub (toName n) (subMap d) >>= listToMaybe) d +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 - => n -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withNameAll n f d = f (fromMaybe [] (lookupSub (toName n) (subMap d))) d +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 -- list of subdiagrams, perform the transformation using the -- list of most recent subdiagrams associated with (some qualification -- of) each name. Do nothing (the identity transformation) if any -- of the names do not exist. -withNames :: IsName n - => [n] -> ([Subdiagram b v m] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withNames ns f d = maybe id f (T.sequence (map ((listToMaybe=<<) . ($nd) . lookupSub . toName) ns)) d - where nd = subMap d - --- | Get the query function associated with a diagram. -query :: Monoid m => QDiagram b v m -> Query v m -query = getU' . unQD - --- | Sample a diagram's query function at a given point. -sample :: Monoid m => QDiagram b v m -> Point v -> m -sample = runQuery . query - --- | Set the query value for 'True' points in a diagram (/i.e./ points --- \"inside\" the diagram); 'False' points will be set to 'mempty'. -value :: Monoid m => m -> QDiagram b v Any -> QDiagram b v m -value m = fmap fromAny - where fromAny (Any True) = m - fromAny (Any False) = mempty +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) --- | Reset the query values of a diagram to @True@/@False@: any values --- equal to 'mempty' are set to 'False'; any other values are set to --- 'True'. -resetValue :: (Eq m, Monoid m) => QDiagram b v m -> QDiagram b v Any -resetValue = fmap toAny - where toAny m | m == mempty = Any False - | otherwise = Any True +-- | \"Localize\" a diagram by hiding all the names, so they are no +-- longer visible to the outside. +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))) + ) --- | Set all the query values of a diagram to 'False'. -clearValue :: QDiagram b v m -> QDiagram b v Any -clearValue = fmap (const (Any False)) +-- | Get the query function associated with a diagram. +query :: Monoid m => QDiagram b v n m -> Query v n m +query = getU' . view _Wrapped' -- | Create a diagram from a single primitive, along with an envelope, -- trace, subdiagram map, and query function. -mkQD :: Prim b v -> Envelope v -> Trace v -> SubMap b v m -> Query v m -> QDiagram b v m -mkQD p e t n q = QD $ D.leaf (toDeletable e *: toDeletable t *: n *: q *: ()) p +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 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 + ------------------------------------------------------------ -- Instances ------------------------------------------------------------ @@ -371,13 +487,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. @@ -385,19 +501,22 @@ -- | 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 - fmap f = (over QD . D.mapU . second . second) - ( (first . fmap . fmap) f +instance Functor (QDiagram b v n) where + fmap f = over (_Wrapping QD) + ( (D.mapU . second . second) + ( (first . fmap . fmap . fmap) f . (second . first . fmap . fmap) f ) + . (fmap . fmap) f + ) ---- Applicative @@ -409,84 +528,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 - applyStyle = over QD . D.applyD . inj - . (inR :: Style v -> Split (Transformation v) :+: Style v) - --- | By default, diagram attributes are not affected by --- transformations. This means, for example, that @lw 0.01 circle@ --- and @scale 2 (lw 0.01 circle)@ will be drawn with lines of the --- /same/ width, and @scaleY 3 circle@ will be an ellipse drawn with --- a uniform line. Once a diagram is frozen, however, --- transformations do affect attributes, so, for example, @scale 2 --- (freeze (lw 0.01 circle))@ will be drawn with a line twice as --- thick as @lw 0.01 circle@, and @scaleY 3 (freeze circle)@ will be --- drawn with a \"stretched\", variable-width line. --- --- Another way of thinking about it is that pre-@freeze@, we are --- transforming the \"abstract idea\" of a diagram, and the --- transformed version is then drawn; when doing a @freeze@, we --- produce a concrete drawing of the diagram, and it is this visual --- representation itself which is acted upon by subsequent --- transformations. -freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => QDiagram b v m -> QDiagram b v m -freeze = over QD . D.applyD . inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - $ split +instance (Metric v, OrderedField n, Semigroup m) + => HasStyle (QDiagram b v n m) where + applyStyle = over _Wrapped' . D.applyD . inj + . (inR :: Style v n -> Transformation v n :+: Style v n) ---- Juxtaposable -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup 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) ) - => Enveloped (QDiagram b v m) where - getEnvelope = envelope +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)) - => Traced (QDiagram b v m) where - getTrace = trace +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 - transform = over QD . D.applyD . transfToAnnot +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 QD . D.applyD . inj . toName +instance (Metric v, OrderedField n, Semigroup m) + => Qualifiable (QDiagram b v n m) where + (.>>) = over _Wrapped' . D.applyD . inj . toName ------------------------------------------------------------ @@ -498,12 +594,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 @@ -512,36 +609,35 @@ -- @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) + => 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) - => 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 (Ord (Scalar v), VectorSpace v, HasLinearMap v) - => 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 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 @@ -550,16 +646,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 (Subdiagram d a) = over QD (D.applyD a) d +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 ------------------------------------------------------------ @@ -568,24 +661,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 Newtype (SubMap b v m) (M.Map Name [Subdiagram b v m]) where - pack = SubMap - unpack (SubMap m) = m +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 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 - fmap = over SubMap . fmap . map . fmap +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 @@ -593,51 +689,56 @@ -- 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 - moveOriginTo = over SubMap . moveOriginTo +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 - transform = over SubMap . transform +instance 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 n b = over SubMap $ M.insertWith (++) (toName n) [mkSubdiagram b] +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 = (.>>) --- | Names don't act on anything else. -instance Action Name a +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 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` - (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) + (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 - flatten [] = Nothing - flatten xs = Just . concatMap snd $ xs + flattenNames [] = Nothing + flattenNames xs = Just . concatMap snd $ xs n = toName a ------------------------------------------------------------ @@ -645,113 +746,128 @@ ------------------------------------------------------------ -- $prim --- Ultimately, every diagram is essentially a list of /primitives/, +-- Ultimately, every diagram is essentially a tree whose leaves are /primitives/, -- basic building blocks which can be rendered by backends. However, -- not every backend must be able to render every type of primitive; -- the collection of primitives a given backend knows how to render is -- determined by instances of 'Renderable'. --- | A value of type @Prim b v@ is an opaque (existentially quantified) +-- | 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 :: 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 :: (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 --- | The null primitive. -data NullPrim v = NullPrim +------------------------------------------------------------ +-- Backends ----------------------------------------------- +------------------------------------------------------------ -type instance (V (NullPrim v)) = v +-- | 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 n a = Tree (DNode b v n a) -instance HasLinearMap v => Transformable (NullPrim v) where - transform _ _ = NullPrim +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 -instance (HasLinearMap v, Monoid (Render b v)) => Renderable (NullPrim v) b where - render _ _ = mempty +-- | 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 n a = Tree (RNode b v n a) --- | The null primitive, which every backend can render by doing --- nothing. -nullPrim :: (HasLinearMap v, Monoid (Render b v)) => Prim b v -nullPrim = Prim NullPrim +data RNode b v n a = RStyle (Style v n) -- ^ A style node. + | RAnnot a + | RPrim (Prim b v n) -- ^ A primitive. + | REmpty ------------------------------------------------------------- --- Backends ----------------------------------------------- ------------------------------------------------------------- +-- | 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. A minimal complete definition --- consists of the three associated types and implementations for --- 'withStyle' and 'doRender'. +-- instance of the 'Backend' class. -- -class (HasLinearMap v, Monoid (Render b v)) => Backend b v where - -- | The type of rendering operations used by this backend, which - -- must be a monoid. For example, if @Render b v = M ()@ for some - -- monad @M@, a monoid instance can be made with @mempty = return - -- ()@ and @mappend = (>>)@. - data Render b v :: * +-- A minimal complete definition consists of 'Render', 'Result', +-- 'Options', and 'renderRTree'. However, most backends will want to +-- 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 Backend b v n where + -- | An intermediate representation used for rendering primitives. + -- (Typically, this will be some sort of monad, but it need not + -- be.) The 'Renderable' class guarantees that a backend will be + -- 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 n :: Type + -- | The result of running/interpreting a rendering operation. - type Result b v :: * + type Result b v n :: Type -- | Backend-specific rendering options. - data Options b v :: * - - -- | Perform a rendering operation with a local style. - withStyle :: b -- ^ Backend token (needed only for type inference) - -> Style v -- ^ Style to use - -> Transformation v -- ^ Transformation to be applied to the style - -> Render b v -- ^ Rendering operation to run - -> Render b v -- ^ Rendering operation using the style locally - - -- | 'doRender' is used to interpret rendering operations. - doRender :: b -- ^ Backend token (needed only for type inference) - -> Options b v -- ^ Backend-specific collection of rendering options - -> Render b v -- ^ Rendering operation to perform - -> Result b v -- ^ Output of the rendering operation + data Options b v n :: Type -- | 'adjustDia' allows the backend to make adjustments to the final -- diagram (e.g. to adjust the size based on the options) before - -- rendering it. It can also make adjustments to the options - -- record, usually to fill in incompletely specified size - -- information. A default implementation is provided which makes - -- no adjustments. See the diagrams-lib package for other useful - -- implementations. - adjustDia :: Monoid' m => b -> Options b v - -> QDiagram b v m -> (Options b v, QDiagram b v m) - adjustDia _ o d = (o,d) - - -- XXX expand this comment. Explain about freeze, split - -- transformations, etc. - -- | Render a diagram. This has a default implementation in terms - -- of 'adjustDia', 'withStyle', 'doRender', and the 'render' - -- operation from the 'Renderable' class (first 'adjustDia' is - -- used, then 'withStyle' and 'render' are used to render each - -- primitive, the resulting operations are combined with - -- 'mconcat', and the final operation run with 'doRender') but - -- backends may override it if desired. - renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) - => b -> Options b v -> QDiagram b v m -> Result b v - renderDia b opts d = - doRender b opts' . mconcat . map renderOne . prims $ d' - where (opts', d') = adjustDia b opts d - renderOne :: (Prim b v, (Split (Transformation v), Style v)) - -> Render b v - renderOne (p, (M t, s)) - = withStyle b s mempty (render b (transform t p)) + -- rendering it. It returns a modified options record, the + -- transformation applied to the diagram (which can be used to + -- convert attributes whose value is @Measure@, or transform + -- /e.g./ screen coordinates back into local diagram coordinates), + -- and the adjusted diagram itself. + -- + -- See the diagrams-lib package (particularly the + -- @Diagrams.TwoD.Adjust@ module) for some useful implementations. + 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) - renderOne (p, (t1 :| t2, s)) - = withStyle b s t1 (render b (transform (t1 <> t2) p)) + -- | 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 n -> RTree b v n Annotation -> Result b v n -- See Note [backend token] @@ -768,55 +884,70 @@ -- For example, here is the error we get if we try to compute the -- width of an image (this example requires @diagrams-lib@): -- --- > ghci> width (image "foo.png" 200 200) --- > --- > :8:8: --- > No instance for (Renderable Diagrams.TwoD.Image.Image b0) --- > arising from a use of `image' --- > Possible fix: --- > add an instance declaration for --- > (Renderable Diagrams.TwoD.Image.Image b0) --- > In the first argument of `width', namely --- > `(image "foo.png" 200 200)' --- > In the expression: width (image "foo.png" 200 200) --- > In an equation for `it': it = width (image "foo.png" 200 200) +-- @ +-- 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 (DImage n0 External) b0) +-- In the first argument of `width', namely +-- `(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) --- > 200.00000000000006 +-- @ +-- ghci> width (image (uncheckedImageRef \"foo.png\" 200 200) :: D V2 Double) +-- 200.00000000000006 +-- @ -- -- (It turns out the width wasn't 200 after all...) -- -- As another example, here is the error we get if we try to compute -- the width of a radius-1 circle: -- --- > ghci> width (circle 1) --- > --- > :4:1: --- > Couldn't match type `V a0' with `R2' --- > In the expression: width (circle 1) --- > In an equation for `it': it = width (circle 1) +-- @ +-- ghci> width (circle 1) +-- \: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) --- > 1.9999999999999998 +-- @ +-- 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 @@ -832,6 +963,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 -- @@ -840,33 +972,26 @@ -- -- because it overlaps with the Renderable instance for NullPrim. -instance Monoid (Render NullBackend v) where - mempty = NullBackendRender - mappend _ _ = NullBackendRender - -instance HasLinearMap v => Backend NullBackend v where - data Render NullBackend v = NullBackendRender - type Result NullBackend v = () - data Options NullBackend v - - withStyle _ _ _ _ = NullBackendRender - doRender _ _ _ = () - --- | A class for backends which support rendering multiple diagrams, --- e.g. to a multi-page pdf or something similar. -class Backend b v => MultiBackend b v where +instance Semigroup (Render NullBackend v n) where + _ <> _ = NullBackendRender - -- | Render multiple diagrams at once. - renderDias :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) - => b -> Options b v -> [QDiagram b v m] -> Result b v +instance Monoid (Render NullBackend v n) where + mempty = NullBackendRender +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif - -- See Note [backend token] +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,13 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | --- Module : Diagrams.Core.MList --- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- Module : Diagrams.Core.V +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -13,16 +16,19 @@ ----------------------------------------------------------------------------- module Diagrams.Core.V - ( V + ( V , N , Vn + , InSpace, SameSpace + ) where - ) where +import Data.Kind (Type) +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,23 +36,52 @@ -- | 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 :: Type -> Type -- 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 -type instance V (Option a) = V a +type instance V (Maybe a) = V a type instance V (Set a) = V a type instance V (Map k a) = V a type instance V (Deletable m) = V m type instance V (Split m) = V m type instance V (m :+: n) = V m + +-- | The numerical field for the object, the number type used for calculations. +type family N a :: Type + +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 (Maybe 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 + +-- | Convenient 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'. +type InSpace v n a = (V a ~ v, N a ~ n, Additive v, Num n) + +-- | @SameSpace a b@ means the types @a@ and @b@ belong to the same +-- vector space @v n@. +type SameSpace a b = (V a ~ V b, N a ~ N b) +