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 b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,78 +0,0 @@ -* 0.5.0.1: 11 May 2012 - - - Update MemoTrie upper bound to allow MemoTrie-0.5 - -* 0.5: 9 March 2012 - - * New features: - - - New 'Juxtaposable' class - - - New NullBackend and D types, for conveniently giving a - monomorphic type to diagrams when we don't care which one it is. - - - #27: Change type of adjustDia to return a new options record - (with an explicitly filled-in size) - - * New instances: - - Enveloped, HasOrigin, Juxtaposable, HasStyle, and Transformable - instances for Sets and tuples - - V Double = Double - - Juxtaposable and Boundable instances for Map - - * API changes - - - AnnDiagram -> QDiagram - - - #61: terminology change from "bounds" to "envelope" - + boundary -> envelopeP - + "bounding region" -> "envelope" - + Bounds -> Envelope - + Boundable -> Enveloped - + getBounds -> getEnvelope - + etc. - - - Split out definition of Point into separate package - (vector-space-points) - - - The Point constructor P is no longer exported from - Graphics.Rendering.Diagrams. See the Diagrams.TwoD.Types module - from diagrams-lib for new tools for working with abstract 2D - points. If you really need the P constructor, import - Graphics.Rendering.Diagrams.Points. - - - Name-related functions now return "located bounding functions" - instead of pairs of points and bounds, to allow for future - expansion. - - * Dependency/version changes: - - vector-space 0.8 is now required. - - Bump base upper bound to allow 4.5; now tested with GHC 7.4.1. - - * Bug fixes: - - Bug fix related to empty envelopes - -0.4: 23 October 2011 - * improved documentation - * a few new instances (Newtype Point, Boundable Point) - * new functions (value, clearValue, resetValue) for working with - alternate query monoids0.1: 17 May 2011 - * initial preview release - -0.3: 18 June 2011 - * big overhaul of name maps: - - allow arbitrary types as atomic names - - carry along bounding functions as well as names in NameMaps - - additional functions for querying information associated with names - * fix for issue #34 (fix behavior of setBounds) - * Transformable and HasOrigin instances for Transformations - -0.2: 3 June 2011 - * bounding regions can now be overridden - * new namePoint function for more flexibly assigning names to arbitrary points - * add HasStyle, Boundable, and HasOrigin instances for lists - * add a "trivial backend" - * transformable attributes - -0.1.1: 18 May 2011 - * link to new website diff --git a/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 b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,9 +0,0 @@ -The core modules underlying diagrams, a Haskell embedded -domain-specific language for compositional, declarative drawing. See - - http://projects.haskell.org/diagrams/ - -for more information about the project, including installation -instructions, tutorials, a user manual, a gallery of example images, -and links to the mailing list, IRC channel, developer wiki and bug -tracker. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,6 @@ +[![Build Status](https://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 +domain-specific language for compositional, declarative drawing. + diff --git a/diagrams-core.cabal b/diagrams-core.cabal --- a/diagrams-core.cabal +++ b/diagrams-core.cabal @@ -1,46 +1,69 @@ Name: diagrams-core -Version: 0.5.0.1 +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 Maintainer: diagrams-discuss@googlegroups.com +Bug-reports: https://github.com/diagrams/diagrams-core/issues Category: Graphics Build-type: Simple -Cabal-version: >=1.6 -Extra-source-files: CHANGES, README -Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 +Cabal-version: 1.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: darcs - location: http://patch-tag.com/r/byorgey/diagrams-core + type: git + location: https://github.com/diagrams/diagrams-core.git Library - Exposed-modules: Graphics.Rendering.Diagrams, - Graphics.Rendering.Diagrams.Monoids, - Graphics.Rendering.Diagrams.MList, - Graphics.Rendering.Diagrams.UDTree, - Graphics.Rendering.Diagrams.V, - Graphics.Rendering.Diagrams.Query, - Graphics.Rendering.Diagrams.Transform, - Graphics.Rendering.Diagrams.Envelope, - Graphics.Rendering.Diagrams.HasOrigin, - Graphics.Rendering.Diagrams.Juxtapose, - Graphics.Rendering.Diagrams.Points, - Graphics.Rendering.Diagrams.Names, - Graphics.Rendering.Diagrams.Style, - Graphics.Rendering.Diagrams.Util, - Graphics.Rendering.Diagrams.Core - - Build-depends: base >= 4.2 && < 4.6, - containers >= 0.3 && < 0.5, - semigroups >= 0.3.4 && < 0.9, - vector-space >= 0.8 && < 0.9, - vector-space-points >= 0.1 && < 0.2, - MemoTrie >= 0.4.7 && < 0.6, - newtype >= 0.2 && < 0.3 + 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 + 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 + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + MultiParamTypeClasses + OverlappingInstances + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + + Default-language: Haskell2010 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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core.hs @@ -0,0 +1,270 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- The core library of primitives forming the basis of an embedded +-- domain-specific language for describing and rendering diagrams. +-- Normal users of the diagrams library should almost never need to +-- import anything from this package directly; instead, import modules +-- (especially @Diagrams.Prelude@) from the diagrams-lib package, +-- which re-exports most things of value to users. +-- +-- For most library code needing access to core internals, it should +-- be sufficient to import this module, which simply re-exports useful +-- functionality from other modules in the core library. Library +-- writers needing finer-grained access or functionality may +-- occasionally find it useful to directly import one of the +-- constituent core modules. +-- +-- 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, 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 + + -- ** Some specific transformations + , translation, translate, moveTo, place + , scaling, scale + , avgScale + + -- ** The Transformable class + + , Transformable(..) + + -- ** Translational invariance + + , TransInv(TransInv) + , eye + + -- * Names + + , AName + , Name, IsName(..) + , Qualifiable(..), (.>) + , eachName + + -- ** Subdiagram maps + + , SubMap(..) + , fromNames + , rememberAs + + , lookupSub + + -- * Attributes and styles + + , AttributeClass + , Attribute (..) + + , Style, HasStyle(..) + , getAttr + , atAttr, atMAttr, atTAttr + , applyAttr, applyMAttr, applyTAttr + + -- * Envelopes + + , Envelope(..) + , appEnvelope, onEnvelope, mkEnvelope + , Enveloped(..) + , envelopeVMay, envelopeV, envelopePMay, envelopeP + , diameter, radius, size + + -- * Traces + + , Trace(Trace) + , SortedList, mkSortedList, getSortedList + , appTrace, mkTrace + , Traced(..) + , traceV, traceP + , maxTraceV, maxTraceP + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP + + -- * Things with local origins + + , HasOrigin(..), moveOriginBy + + -- * Juxtaposable things + + , Juxtaposable(..), juxtaposeDefault + + -- * Queries + + , Query(..) + + -- * Primitives + + , Prim(..) + + -- * Diagrams + + , QDiagram, Diagram, mkQD, pointDiagram + , envelope, trace, subMap, names, query + + , nameSub + , withName + , withNameAll + , withNames + , localize + + , href + , opacityGroup + , groupOpacity + + , setEnvelope, setTrace + + , atop + + -- ** Subdiagrams + + , Subdiagram(..), mkSubdiagram + , getSub, rawSub + , location + , subPoint + + -- ** Measurements + + , Measured + , Measure + , fromMeasured + , output + , local + , global + , normalized + , scaleLocal + , atLeast + , atMost + + -- * Backends + + , Backend(..) + , Renderable(..) + + , renderDia + , renderDiaT + + -- ** The null backend + + , NullBackend, D + + -- * Convenience classes + + , HasLinearMap + , HasBasis + , OrderedField + , TypeableFloat + , Monoid' + + ) where + +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') 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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Envelope.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Envelope +-- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- diagrams-core defines the core library of primitives forming the +-- basis of an embedded domain-specific language for describing and +-- rendering diagrams. +-- +-- The @Diagrams.Core.Envelope@ module defines a data type and type class for +-- \"envelopes\", aka functional bounding regions. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Envelope + ( -- * Envelopes + Envelope(..) + + , appEnvelope + , onEnvelope + , mkEnvelope + , pointEnvelope + + , Enveloped(..) + + -- * Utility functions + , diameter + , radius + , extent + , size + , envelopeVMay + , envelopeV + , envelopePMay + , envelopeP + , envelopeSMay + , envelopeS + + -- * Miscellaneous + , OrderedField + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, + op, over, (&), (.~), _Wrapping') +import Data.Functor.Rep +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Semigroup +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 --------------------------------------------- +------------------------------------------------------------ + +-- | Every diagram comes equipped with an /envelope/. What is an envelope? +-- +-- Consider first the idea of a /bounding box/. A bounding box +-- expresses the distance to a bounding plane in every direction +-- parallel to an axis. That is, a bounding box can be thought of +-- as the intersection of a collection of half-planes, two +-- perpendicular to each axis. +-- +-- More generally, the intersection of half-planes in /every/ +-- direction would give a tight \"bounding region\", or convex hull. +-- However, representing such a thing intensionally would be +-- impossible; hence bounding boxes are often used as an +-- approximation. +-- +-- An envelope is an /extensional/ representation of such a +-- \"bounding region\". Instead of storing some sort of direct +-- representation, we store a /function/ which takes a direction as +-- input and gives a distance to a bounding half-plane as output. +-- The important point is that envelopes can be composed, and +-- transformed by any affine transformation. +-- +-- Formally, given a vector @v@, the envelope computes a scalar @s@ such +-- that +-- +-- * for every point @u@ inside the diagram, +-- if the projection of @(u - origin)@ onto @v@ is @s' *^ v@, then @s' <= s@. +-- +-- * @s@ is the smallest such scalar. +-- +-- There is also a special \"empty envelope\". +-- +-- The idea for envelopes came from +-- Sebastian Setzer; see +-- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . +newtype Envelope v n = Envelope (Maybe (v n -> Max n)) + +instance Wrapped (Envelope v n) where + type Unwrapped (Envelope v n) = Maybe (v n -> Max n) + _Wrapped' = iso (\(Envelope e) -> e) Envelope + +instance Rewrapped (Envelope v n) (Envelope v' n') + +-- | \"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 + +-- | 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 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 n => Semigroup (Envelope v n) + +-- | The special empty envelope is the identity for the +-- 'Monoid' instance. +deriving instance Ord n => Monoid (Envelope v n) + +type instance V (Envelope v n) = v +type instance N (Envelope v n) = n + +instance Show (Envelope v n) where + show _ = "" + +------------------------------------------------------------ +-- 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 (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 (Metric v, Floating n) => Transformable (Envelope v n) where + transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g + where + + -- 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 + +{- + +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 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 constraint as a convenient +-- shorthand. +type OrderedField s = (Floating s, Ord s) + +-- | @Enveloped@ abstracts over things which have an envelope. +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) (N a) + +instance (Metric v, OrderedField n) => Enveloped (Envelope v n) where + getEnvelope = id + +instance (OrderedField n, Metric v) => Enveloped (Point v n) where + getEnvelope p = moveTo p . mkEnvelope $ const 0 + +instance Enveloped t => Enveloped (TransInv t) where + getEnvelope = getEnvelope . op TransInv + +instance (Enveloped a, Enveloped b, V a ~ V b, N a ~ N b) => Enveloped (a,b) where + getEnvelope (x,y) = getEnvelope x <> getEnvelope y + +instance Enveloped b => Enveloped [b] where + getEnvelope = mconcat . map getEnvelope + +instance Enveloped b => Enveloped (M.Map k b) where + getEnvelope = mconcat . map getEnvelope . M.elems + +instance Enveloped b => Enveloped (S.Set b) where + getEnvelope = mconcat . map getEnvelope . S.elems + +------------------------------------------------------------ +-- Computing with envelopes +------------------------------------------------------------ + +-- | Compute the vector from the local origin to a separating +-- hyperplane in the given direction, or @Nothing@ for the empty +-- envelope. +envelopeVMay :: Enveloped a => 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 => 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 :: (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 :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n +envelopeP v = P . envelopeV v + +-- | Equivalent to the norm of 'envelopeVMay': +-- +-- @ 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 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 norm of 'envelopeV': +-- +-- @ 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 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 :: (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 :: (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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/HasOrigin.hs @@ -0,0 +1,107 @@ +{-# 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. + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.HasOrigin +-- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Types which have an intrinsic notion of a \"local origin\", +-- /i.e./ things which are /not/ invariant under translation. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.HasOrigin + ( HasOrigin(..), moveOriginBy, moveTo, place + ) where + +import qualified Data.Map as M +import qualified Data.Set as S + +import 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. +-- +-- One might wonder why not just use 'Transformable' instead of +-- having a separate class for 'HasOrigin'; indeed, for types which +-- are instances of both we should have the identity +-- +-- @ +-- moveOriginTo (origin .^+ v) === translate (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 HasOrigin t where + + -- | Move the local origin to another point. + -- + -- Note that this function is in some sense dual to 'translate' + -- (for types which are also 'Transformable'); moving the origin + -- itself while leaving the object \"fixed\" is dual to fixing the + -- origin and translating the diagram. + moveOriginTo :: Point (V t) (N t) -> t -> t + +-- | Move the local origin by a relative vector. +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) +-- @ +-- +-- For types which are also 'Transformable', this is essentially the +-- same as 'translate', i.e. +-- +-- @ +-- 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 :: (InSpace v n t, HasOrigin t) => t -> Point v n -> t +place = flip moveTo + +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 t, HasOrigin s, SameSpace s t) => HasOrigin (s, t) where + moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) + +instance HasOrigin t => HasOrigin [t] where + moveOriginTo = map . moveOriginTo + +instance (HasOrigin t, Ord t) => HasOrigin (S.Set t) where + moveOriginTo = S.map . moveOriginTo + +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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Juxtapose.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Juxtapose +-- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Things which can be placed \"next to\" other things, for some +-- appropriate notion of \"next to\". +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Juxtapose + ( Juxtaposable(..), juxtaposeDefault + ) where + +import 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 + + -- | @juxtapose v a1 a2@ positions @a2@ next to @a1@ in the + -- direction of @v@. In particular, place @a2@ so that @v@ points + -- from the local origin of @a1@ towards the old local origin of + -- @a2@; @a1@'s local origin becomes @a2@'s new local origin. The + -- result is just a translated version of @a2@. (In particular, + -- this operation does not /combine/ @a1@ and @a2@ in any way.) + juxtapose :: 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) => Vn a -> a -> a -> a +juxtaposeDefault v a1 a2 = + case (mv1, mv2) of + (Just v1, Just v2) -> moveOriginBy (v1 ^+^ v2) a2 + _ -> a2 + where mv1 = negated <$> envelopeVMay v a1 + mv2 = envelopeVMay (negated v) a2 + +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, N a ~ N b) + => Juxtaposable (a,b) where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b) => Juxtaposable [b] where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b) => Juxtaposable (M.Map k b) where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where + juxtapose = juxtaposeDefault + +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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Names.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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-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 subdiagrams, and related types. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Names + (-- * Names + -- ** Atomic names + AName(..) + , _AName + + -- ** Names + , Name(..) + , IsName(..) + , (.>) + , eachName + + -- ** Qualifiable + , Qualifiable(..) + + ) where + +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 ------------------------------------------------- +------------------------------------------------------------ + +-- | Class for those types which can be used as names. They must +-- support 'Typeable' (to facilitate extracting them from +-- existential wrappers), 'Ord' (for comparison and efficient +-- storage) and 'Show'. +-- +-- 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 + +instance IsName () +instance IsName Bool +instance IsName Char +instance IsName Int +instance IsName Float +instance IsName Double +instance IsName Integer +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) + +-- | Atomic names. @AName@ is just an existential wrapper around +-- things which are 'Typeable', 'Ord' and 'Show'. +data AName where + AName :: (Typeable a, Ord a, Show a) => a -> AName + deriving Typeable + +instance IsName AName where + toName = Name . (:[]) + +instance Eq AName where + AName a1 == AName a2 = + case cast a2 of + Nothing -> False + Just a2' -> a1 == a2' + +instance Ord AName where + AName a1 `compare` AName a2 = + case cast a2 of + Just a2' -> a1 `compare` a2' + Nothing -> typeOf a1 `compare` typeOf a2 + +instance Show AName where + 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 + 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 + +-- | Convenient operator for writing qualified names with atomic +-- components of different types. Instead of writing @toName a1 \<\> +-- toName a2 \<\> toName a3@ you can just write @a1 .> a2 .> a3@. +(.>) :: (IsName a1, IsName a2) => a1 -> a2 -> Name +a1 .> a2 = toName a1 <> toName a2 + +-- | Instances of 'Qualifiable' are things which can be qualified by +-- prefixing them with a name. +class Qualifiable q where + -- | Qualify with the given name. + (.>>) :: IsName a => a -> q -> q + +-- | Of course, names can be qualified using @(.>)@. +instance Qualifiable Name where + (.>>) = (.>) + +instance Qualifiable a => Qualifiable (TransInv a) where + (.>>) n = 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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Points.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Points +-- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A type for /points/ (as distinct from vectors). +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Points + ( -- * Points + + Point(..), origin, (*.), relative, _Point + + , reflectThrough, mirror, relative2, relative3 + ) where + +import Control.Lens (over) + +import Linear.Affine +import Linear.Vector + +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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Query.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Query +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- The @Query@ module defines a type for \"queries\" on diagrams, which +-- are functions from points in a vector space to some monoid. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Query + ( Query (..) + ) where + +import Control.Applicative +import 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 Linear.Affine +import Linear.Vector + +import Diagrams.Core.HasOrigin +import Diagrams.Core.Transform +import Diagrams.Core.V + +------------------------------------------------------------------------ +-- Queries +------------------------------------------------------------------------ + +-- | A query is a function that maps points in a vector space to +-- values in some monoid. Queries naturally form a monoid, with +-- two queries being combined pointwise. +-- +-- The idea for annotating diagrams with monoidal queries came from +-- the graphics-drawingcombinators package, +-- . +newtype Query v n m = Query { runQuery :: Point v n -> m } + deriving (Functor, Applicative, Monad, Semigroup, Monoid) + +instance Distributive (Query v n) where + distribute a = Query $ \p -> fmap (\(Query q) -> q p) a + +instance Representable (Query v n) where + type Rep (Query v n) = Point v n + tabulate = Query + index = runQuery + +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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Style.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Style +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A definition of /styles/ for diagrams as extensible, heterogeneous +-- collections of attributes. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Style + ( -- * Attributes + -- $attr + + AttributeClass + , Attribute(..) + + -- ** Attributes prisms + , _Attribute + , _MAttribute + , _TAttribute + + -- ** Attributes utilities + , unwrapAttribute + , unmeasureAttribute + , attributeType + + -- * Styles + -- $style + + , Style(..) + + -- ** Making styles + , attributeToStyle + + -- ** Extracting attibutes from styles + , getAttr + , unmeasureAttrs + + -- ** Attibute lenses + , atAttr + , atMAttr + , atTAttr + + -- ** Applying styles + , applyAttr + , applyMAttr + , applyTAttr + + , HasStyle(..) + + ) where + +import Control.Applicative +import Control.Arrow ((***)) +import Control.Lens 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 Data.Typeable + +import Diagrams.Core.Measure +import Diagrams.Core.Transform +import Diagrams.Core.V + +import Linear.Vector + +------------------------------------------------------------ +-- Attributes -------------------------------------------- +------------------------------------------------------------ + +-- $attr +-- An /attribute/ is anything that determines some aspect of a +-- diagram's rendering. The standard diagrams library defines several +-- standard attributes (line color, line width, fill color, etc.) but +-- additional attributes may easily be created. Additionally, a given +-- backend need not handle (or even know about) attributes used in +-- diagrams it renders. +-- +-- The attribute code is inspired by xmonad's @Message@ type, which +-- was in turn based on ideas in: +-- +-- Simon Marlow. +-- /An Extensible Dynamically-Typed Hierarchy of Exceptions/. +-- Proceedings of the 2006 ACM SIGPLAN workshop on +-- Haskell. . + +-- | Every attribute must be an instance of @AttributeClass@, which +-- simply guarantees 'Typeable' and 'Semigroup' constraints. The +-- 'Semigroup' instance for an attribute determines how it will combine +-- with other attributes of the same type. +class (Typeable a, Semigroup a) => AttributeClass a + +-- | An existential wrapper type to hold attributes. Some attributes +-- are simply inert/static; some are affected by transformations; +-- and some are affected by transformations and can be modified +-- generically. +data Attribute (v :: 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 n) = v +type instance N (Attribute v n) = n + +-- | 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 + +-- | '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 +-- matches the type of the attribute, the attribute value is +-- returned wrapped in @Just@; if the types do not match, @Nothing@ +-- is returned. +-- +-- 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 #-} + +-- | 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 #-} + +-- | 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 ------------------------------------------------ +------------------------------------------------------------ + +-- $style +-- A 'Style' is a heterogeneous collection of attributes, containing +-- at most one attribute of any given type. This is also based on +-- ideas stolen from xmonad, specifically xmonad's implementation of +-- user-extensible state. + +-- | A @Style@ is a heterogeneous collection of attributes, containing +-- at most one attribute of any given type. +newtype Style v n = Style (HM.HashMap TypeRep (Attribute v n)) + +-- instances ----------------------------------------------------------- + +type instance V (Style v n) = v +type instance N (Style v n) = n + +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' #-} + +instance Each (Style v n) (Style v' n') (Attribute v n) (Attribute v' n') where + each = _Wrapped . each + {-# INLINE each #-} + +type instance Index (Style v n) = TypeRep +type instance IxValue (Style v n) = Attribute v n + +instance Ixed (Style v n) where + ix k = _Wrapped' . ix k + {-# INLINE ix #-} + +instance At (Style v n) where + at k = _Wrapped' . at k + {-# INLINE at #-} + +-- | 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. +instance Typeable n => Monoid (Style v n) where + mempty = Style HM.empty + mappend = (<>) + +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 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) (N a) -> a -> a + +instance Typeable n => HasStyle (Style v n) where + applyStyle = mappend + +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 + applyStyle = fmap . applyStyle + +instance HasStyle b => HasStyle (a -> b) where + applyStyle = fmap . applyStyle + +instance HasStyle a => HasStyle (M.Map k a) where + applyStyle = fmap . applyStyle + +instance (HasStyle a, Ord a) => HasStyle (S.Set a) where + applyStyle = S.map . applyStyle + +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 +-- 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 . 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 +-- 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, 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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Trace.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- @diagrams-core@ defines the core library of primitives +-- forming the basis of an embedded domain-specific language for +-- describing and rendering diagrams. +-- +-- The @Trace@ module defines a data type and type class for +-- \"traces\", aka functional boundaries, essentially corresponding to +-- embedding a raytracer with each diagram. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Trace + ( -- * SortedList + SortedList + , mkSortedList, getSortedList, onSortedList, unsafeOnSortedList + + -- * Traces + , Trace(Trace) + + , appTrace + , mkTrace + + -- * Traced class + + , Traced(..) + + -- * Computing with traces + + , traceV, traceP + , maxTraceV, maxTraceP + , getRayTrace + , rayTraceV, rayTraceP + , maxRayTraceV, maxRayTraceP + + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Lens +import Data.List (sort) +import qualified Data.Map as M +import Data.Semigroup +import qualified Data.Set as S + +import Diagrams.Core.HasOrigin +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 ------------------------------------------------- +------------------------------------------------------------ + +-- > 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 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 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 n = Trace { appTrace :: Point v n -> v n -> SortedList n } + +instance Wrapped (Trace v n) where + type Unwrapped (Trace v n) = Point v n -> v n -> SortedList n + _Wrapped' = iso appTrace Trace + +instance Rewrapped (Trace v 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 n) => Semigroup (Trace v n) + +deriving instance (Ord n) => Monoid (Trace v n) + +type instance V (Trace v n) = v +type instance N (Trace v n) = n + +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 (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 (Additive (V a), Ord (N a)) => Traced a where + + -- | Compute the trace of an object. + getTrace :: a -> Trace (V a) (N a) + +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 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 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 + getTrace = mconcat . map getTrace + +instance (Traced b) => Traced (M.Map k b) where + getTrace = mconcat . map getTrace . M.elems + +instance (Traced b) => Traced (S.Set b) where + getTrace = mconcat . map getTrace . S.elems + +------------------------------------------------------------ +-- Computing with traces --------------------------------- +------------------------------------------------------------ + +-- | Compute the vector from the given point @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 + +-- > 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 + +-- > tracePEx = mkTraceDiasABC def { sFilter = take 1 } + + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Transform.hs @@ -0,0 +1,427 @@ +{-# 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-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- "Diagrams" defines the core library of primitives +-- forming the basis of an embedded domain-specific language for +-- describing and rendering diagrams. +-- +-- The @Transform@ module defines generic transformations +-- parameterized by any vector space. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Transform + ( + -- * Transformations + + -- ** Invertible linear transformations + (:-:)(..), (<->), linv, lapp + + -- ** General transformations + , Transformation(..) + , inv, transp, transl + , 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) + + -- * Vector space independent transformations + -- | Most transformations are specific to a particular vector + -- space, but a few can be defined generically over any + -- vector space. + + , translation, translate + , scaling, scale + + ) where + +import Control.Lens (Rewrapped, Traversable, Wrapped (..), + iso, (&), (.~)) +import qualified Data.Map as M +import Data.Semigroup +import qualified Data.Set as S + +import Data.Monoid.Action +import Data.Monoid.Deletable + +import Linear.Affine +import Linear.Vector + +import Data.Foldable (Foldable, toList) +import Data.Functor.Rep + +import Diagrams.Core.HasOrigin +import Diagrams.Core.Measure +import Diagrams.Core.Points () +import Diagrams.Core.V + +------------------------------------------------------------ +-- Transformations --------------------------------------- +------------------------------------------------------------ + +------------------------------------------------------- +-- Invertible linear transformations ---------------- +------------------------------------------------------- + +-- | @(v1 :-: v2)@ is a linear map paired with its inverse. +data (:-:) u v = (u -> v) :-: (v -> u) +infixr 7 :-: + +-- | Create an invertible linear map from two functions which are +-- assumed to be linear inverses. +(<->) :: (u -> v) -> (v -> u) -> (u :-: v) +f <-> g = f :-: g + +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 Monoid (v :-: v) where + mempty = id :-: id + mappend = (<>) + +-- | Invert a linear map. +linv :: (u :-: v) -> (v :-: u) +linv (f :-: g) = g :-: f + +-- | Apply a linear map to a vector. +lapp :: (u :-: v) -> u -> v +lapp (f :-: _) = f + +-------------------------------------------------- +-- Affine transformations ---------------------- +-------------------------------------------------- + +-- | General (affine) transformations, represented by an invertible +-- linear map, its /transpose/, and a vector representing a +-- translation component. +-- +-- By the /transpose/ of a linear map we mean simply the linear map +-- corresponding to the transpose of the map's matrix +-- representation. For example, any scale is its own transpose, +-- since scales are represented by matrices with zeros everywhere +-- except the diagonal. The transpose of a rotation is the same as +-- its inverse. +-- +-- The reason we need to keep track of transposes is because it +-- turns out that when transforming a shape according to some linear +-- map L, the shape's /normal vectors/ transform according to L's +-- inverse transpose. (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 n = Transformation (v n :-: v n) (v n :-: v n) (v n) + +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 :: (Functor v, Num n) => Transformation v n -> Transformation v n +inv (Transformation t t' v) = Transformation (linv t) (linv t') + (negated (lapp (linv t) v)) + +-- | Get the transpose of a transformation (ignoring the translation +-- component). +transp :: Transformation v n -> (v n :-: v n) +transp (Transformation _ t' _) = t' + +-- | Get the translational component of a transformation. +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 (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 (Additive v, Num n) => Monoid (Transformation v n) where + mempty = Transformation mempty mempty zero + mappend = (<>) + +-- | Transformations can act on transformable things. +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 :: Transformation v n -> v n -> v n +apply (Transformation (t :-: _) _ _) = t + +-- | Apply a transformation to a point. +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 :: (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 constraint synonym, just to +-- help shorten some of the ridiculously long constraint sets. +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 Transformable t where + + -- | Apply a transformation to an object. + transform :: Transformation (V t) (N t) -> t -> t + +instance (Additive v, Num n) => Transformable (Transformation v n) where + transform t1 t2 = t1 <> t2 + +instance (Additive v, Num n) => HasOrigin (Transformation v n) where + moveOriginTo p = translate (origin .-. p) + +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 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 + +instance (Transformable t, Ord t) => Transformable (S.Set t) where + transform = S.map . transform + +instance Transformable t => Transformable (M.Map k t) where + transform = M.map . transform + +instance (Additive v, Num n) => Transformable (Point v n) where + transform = papply + +instance Transformable m => Transformable (Deletable m) where + transform = fmap . transform + +------------------------------------------------------------ +-- Translational invariance ------------------------------ +------------------------------------------------------------ + +-- | @TransInv@ is a wrapper which makes a transformable type +-- translationally invariant; the translational component of +-- transformations will no longer affect things wrapped in +-- @TransInv@. +newtype TransInv t = TransInv 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 HasOrigin (TransInv t) where + moveOriginTo = const id + +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 :: v n -> Transformation v n +translation = Transformation mempty mempty + +-- | Translate by a vector. +translate :: (Transformable t) => Vn t -> t -> t +translate = transform . translation + +-- | Create a uniform scaling transformation. +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 :: (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 new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/Types.hs @@ -0,0 +1,1010 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- We have some orphan Action instances here, but since Action is a multi-param +-- class there is really no better place to put them. + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Types +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- The core library of primitives forming the basis of an embedded +-- domain-specific language for describing and rendering diagrams. +-- +-- "Diagrams.Core.Types" defines types and classes for +-- primitives, diagrams, and backends. +-- +----------------------------------------------------------------------------- + +{- ~~~~ Note [breaking up Types module] + + Although it's not as bad as it used to be, this module has a lot of + stuff in it, and it might seem a good idea in principle to break it up + into smaller modules. However, it's not as easy as it sounds: everything + in this module cyclically depends on everything else. +-} + +module Diagrams.Core.Types + ( + -- * Diagrams + + -- ** Annotations + + -- *** 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 + , envelope, trace, subMap, names, query + + -- ** Combining diagrams + + -- | For many more ways of combining diagrams, see + -- "Diagrams.Combinators" and "Diagrams.TwoD.Combinators" + -- from the diagrams-lib package. + + , atop + + -- ** Modifying diagrams + -- *** Names + , nameSub + , lookupName + , withName + , withNameAll + , withNames + , localize + + -- *** Other + , setEnvelope + , setTrace + + -- * Subdiagrams + + , Subdiagram(..), mkSubdiagram + , getSub, rawSub + , location + , subPoint + + -- * Subdiagram maps + + , SubMap(..) + + , fromNames, rememberAs, lookupSub + + -- * Primtives + -- $prim + + , Prim(..) + , _Prim + + -- * Backends + + , Backend(..) + , DTree + , DNode(..) + + , RTree + , RNode(..) + , _RStyle + , _RAnnot + , _RPrim + , _REmpty + + -- ** Null backend + + , NullBackend, D + + -- ** Number classes + , TypeableFloat + + -- * Renderable + + , Renderable(..) + + ) where + +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 Data.Tree +import Data.Typeable + +import Data.Monoid.Action +import Data.Monoid.Coproduct +import Data.Monoid.Deletable +import Data.Monoid.MList +import Data.Monoid.WithSemigroup +import qualified Data.Tree.DUAL as D + +import Diagrams.Core.Envelope +import Diagrams.Core.HasOrigin +import Diagrams.Core.Juxtapose +import Diagrams.Core.Names +import Diagrams.Core.Points +import Diagrams.Core.Query +import Diagrams.Core.Style +import Diagrams.Core.Trace +import Diagrams.Core.Transform +import Diagrams.Core.V + +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 ---------------------------------------------- +------------------------------------------------------------ + +-- | Monoidal annotations which travel up the diagram tree, /i.e./ which +-- are aggregated from component diagrams to the whole: +-- +-- * envelopes (see "Diagrams.Core.Envelope"). +-- The envelopes are \"deletable\" meaning that at any point we can +-- throw away the existing envelope and replace it with a new one; +-- sometimes we want to consider a diagram as having a different +-- envelope unrelated to its \"natural\" envelope. +-- +-- * traces (see "Diagrams.Core.Trace"), also +-- deletable. +-- +-- * name/subdiagram associations (see "Diagrams.Core.Names") +-- +-- * query functions (see "Diagrams.Core.Query") +type UpAnnots b v 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): +-- +-- * styles (see "Diagrams.Core.Style") +-- +-- * names (see "Diagrams.Core.Names") +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 + -- styles. + +-- | Inject a transformation into a default downwards annotation +-- value. +transfToAnnot :: Transformation v n -> DownAnnots v n +transfToAnnot + = inj + . (inL :: Transformation v n -> Transformation v n :+: Style v n) + +-- | Extract the (total) transformation from a downwards annotation +-- value. +transfFromAnnot :: (Additive v, Num n) => DownAnnots v n -> Transformation v n +transfFromAnnot = maybe mempty killR . fst + +-- | 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 + +withQDiaLeaf :: (Prim b v n -> r) + -> ((DownAnnots v n -> n -> n -> QDiagram b v n m) -> r) + -> QDiaLeaf b v n m -> r +withQDiaLeaf f _ (PrimLeaf p) = f p +withQDiaLeaf _ g (DelayedLeaf dgn) = g dgn + +-- | Static annotations which can be placed at a particular node of a +-- diagram tree. +data Annotation + = Href String -- ^ Hyperlink + | OpacityGroup Double + | KeyVal (String, String) + deriving Show + +-- | 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 v n@ or +-- the 'value' function. +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 :: (Metric v, Fractional n) + => Point v n -> QDiagram b v n m +pointDiagram p = QD $ D.leafU (inj . toDeletable $ pointEnvelope p) + +-- | A useful variant of 'getU' which projects out a certain +-- component. +getU' :: (Monoid u', u :>: u') => D.DUALTree d u a l -> u' +getU' = maybe mempty (maybe mempty id . get) . D.getU + +-- | 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 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))) + ) + +-- | 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 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))) + ) + +-- | 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 :: (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 /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 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 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 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) + +-- | \"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))) + ) + +-- | 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 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 +------------------------------------------------------------ + +---- Monoid + +-- | Diagrams form a monoid since each of their components do: the +-- empty diagram has no primitives, an empty envelope, an empty +-- trace, no named subdiagrams, and a constantly empty query +-- function. +-- +-- Diagrams compose by aligning their respective local origins. The +-- new diagram has all the primitives and all the names from the two +-- diagrams combined, and query functions are combined pointwise. +-- The first diagram goes on top of the second. \"On top of\" +-- probably only makes sense in vector spaces of dimension lower +-- than 3, but in theory it could make sense for, say, 3-dimensional +-- diagrams when viewed by 4-dimensional beings. +instance (Metric v, OrderedField n, Semigroup m) + => Monoid (QDiagram b v n m) where + mempty = QD D.empty + mappend = (<>) + +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. + +-- | 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 :: (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 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 + +-- XXX what to do with this? +-- A diagram with queries of result type @(a -> b)@ can be \"applied\" +-- to a diagram with queries of result type @a@, resulting in a +-- combined diagram with queries of result type @b@. In particular, +-- all components of the two diagrams are combined as in the +-- @Monoid@ instance, except the queries which are combined via +-- @(<*>)@. + +-- instance (Backend b v 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 (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 (Metric v, OrderedField n, Monoid' m) + => Juxtaposable (QDiagram b v n m) where + juxtapose = juxtaposeDefault + +---- Enveloped + +instance (Metric v, OrderedField n, Monoid' m) + => Enveloped (QDiagram b v n m) where + getEnvelope = view envelope + +---- Traced + +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 (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 (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 (Metric v, OrderedField n, Semigroup m) + => Qualifiable (QDiagram b v n m) where + (.>>) = over _Wrapped' . D.applyD . inj . toName + + +------------------------------------------------------------ +-- Subdiagrams +------------------------------------------------------------ + +-- | A @Subdiagram@ represents a diagram embedded within the context +-- of a larger diagram. Essentially, it consists of a diagram +-- paired with any accumulated information from the larger context +-- (transformations, attributes, etc.). + +data Subdiagram b v n m = Subdiagram (QDiagram b v n m) (DownAnnots v n) + +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 n m -> Subdiagram b v n m +mkSubdiagram d = Subdiagram d empty + +-- | Create a \"point subdiagram\", that is, a 'pointDiagram' (with no +-- content and a point envelope) treated as a subdiagram with local +-- origin at the given point. Note this is not the same as +-- @mkSubdiagram . pointDiagram@, which would result in a subdiagram +-- with local origin at the parent origin, rather than at the given +-- point. +subPoint :: (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 n) where + fmap f (Subdiagram d a) = Subdiagram (fmap f d) a + +instance (OrderedField n, Metric v, Monoid' m) + => Enveloped (Subdiagram b v n m) where + getEnvelope (Subdiagram d a) = transform (transfFromAnnot a) $ getEnvelope d + +instance (OrderedField n, Metric v, Semigroup m) + => Traced (Subdiagram b v n m) where + getTrace (Subdiagram d a) = transform (transfFromAnnot a) $ getTrace d + +instance (Metric v, OrderedField n) + => HasOrigin (Subdiagram b v n m) where + moveOriginTo = translate . (origin .-.) + +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 :: (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 +-- context. Concretely, a subdiagram is a pair of (1) a diagram and +-- (2) a \"context\" consisting of an extra transformation and +-- attributes. @getSub@ simply applies the transformation and +-- attributes to the diagram to get the corresponding \"top-level\" +-- diagram. +getSub :: (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 n m -> QDiagram b v n m +rawSub (Subdiagram d _) = d + +------------------------------------------------------------ +-- Subdiagram maps --------------------------------------- +------------------------------------------------------------ + +-- | A 'SubMap' is a map associating names to subdiagrams. There can +-- be multiple associations for any given name. +newtype SubMap b v n m = SubMap (M.Map Name [Subdiagram b v n m]) + -- See Note [SubMap Set vs list] + +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 n m) = v +type instance N (SubMap b v n m) = n + +instance Functor (SubMap b v n) where + fmap = over _Wrapped . fmap . map . fmap + +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 +-- map union as the binary operation. No information is ever lost: +-- if two maps have the same name in their domain, the resulting map +-- will associate that name to the concatenation of the information +-- associated with that name. +instance Monoid (SubMap b v n m) where + mempty = SubMap M.empty + mappend = (<>) + +instance (OrderedField n, Metric v) + => HasOrigin (SubMap b v n m) where + moveOriginTo = over _Wrapped' . moveOriginTo + +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 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 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 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 n m) where + act = (.>>) + +instance Action Name a => Action Name (Deletable a) where + act n (Deletable l a r) = Deletable l (act n a) r + +-- Names do not act on other things. + +instance Action Name (Query v 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 nm => nm -> SubMap b v n m -> Maybe [Subdiagram b v n m] +lookupSub a (SubMap m) + = M.lookup n m `mplus` + (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) + where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 + flattenNames [] = Nothing + flattenNames xs = Just . concatMap snd $ xs + n = toName a + +------------------------------------------------------------ +-- Primitives -------------------------------------------- +------------------------------------------------------------ + +-- $prim +-- 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 n@ is an opaque (existentially quantified) +-- primitive which backend @b@ knows how to render in vector space @v@. +data Prim b v n where + Prim :: (Transformable p, Typeable p, Renderable p b) => p -> Prim b (V p) (N p) + +_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 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 Renderable (Prim b v n) b where + render b (Prim p) = render b p + +------------------------------------------------------------ +-- Backends ----------------------------------------------- +------------------------------------------------------------ + +-- | 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) + +data DNode b v n a = DStyle (Style v n) + | DTransform (Transformation v n) + | DAnnot a + | DDelay + -- ^ @DDelay@ marks a point where a delayed subtree + -- was expanded. Such subtrees already take all + -- non-frozen transforms above them into account, + -- so when later processing the tree, upon + -- encountering a @DDelay@ node we must drop any + -- accumulated non-frozen transformation. + | DPrim (Prim b v n) + | DEmpty + +-- | An 'RTree' is a compiled and optimized representation of a +-- 'QDiagram', which can be used by backends. They have the +-- following invariant which backends may rely upon: +-- +-- * @RPrim@ nodes never have any children. +type RTree b v n a = Tree (RNode b v n a) + +data RNode b v n a = RStyle (Style v n) -- ^ A style node. + | RAnnot a + | RPrim (Prim b v n) -- ^ A primitive. + | REmpty + +-- | Prism onto a style of an 'RNode'. +_RStyle :: Prism' (RNode b v n a) (Style v n) +_RStyle = prism' RStyle $ \n -> case n of RStyle s -> Just s; _ -> Nothing + +-- | Prism onto an annotation of an 'RNode'. +_RAnnot :: Prism' (RNode b v n a) a +_RAnnot = prism' RAnnot $ \n -> case n of RAnnot a -> Just a; _ -> Nothing + +-- | Prism onto a 'Prim' of an 'RNode'. +_RPrim :: Prism' (RNode b v n a) (Prim b v n) +_RPrim = prism' RPrim $ \n -> case n of RPrim p -> Just p; _ -> Nothing + +-- | Prism onto an empty 'RNode'. +_REmpty :: Prism' (RNode b v n a) () +_REmpty = prism' (const REmpty) $ \n -> case n of REmpty -> Just (); _ -> Nothing + +-- | Abstract diagrams are rendered to particular formats by +-- /backends/. Each backend/vector space combination must be an +-- instance of the 'Backend' class. +-- +-- 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 n :: Type + + -- | Backend-specific rendering options. + 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 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) + + -- | 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] + +-- | The @D@ type is provided for convenience in situations where you +-- must give a diagram a concrete, monomorphic type, but don't care +-- which one. Such situations arise when you pass a diagram to a +-- function which is polymorphic in its input but monomorphic in its +-- output, such as 'width', 'height', 'phantom', or 'names'. Such +-- functions compute some property of the diagram, or use it to +-- accomplish some other purpose, but do not result in the diagram +-- being rendered. If the diagram does not have a monomorphic type, +-- GHC complains that it cannot determine the diagram's type. +-- +-- For example, here is the error we get if we try to compute the +-- width of an image (this example requires @diagrams-lib@): +-- +-- @ +-- ghci> width (image (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 (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 @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' 'V2' 'Double'@, like so: +-- +-- @ +-- 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) +-- \: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 '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 V2 Double) +-- 1.9999999999999998 +-- @ + +type D v n = QDiagram NullBackend v n Any + + +-- | A null backend which does no actual rendering. It is provided +-- mainly for convenience in situations where you must give a +-- diagram a concrete, monomorphic type, but don't actually care +-- which one. See 'D' for more explanation and examples. +-- +-- It is courteous, when defining a new primitive @P@, to make an instance +-- +-- > instance Renderable P NullBackend where +-- > render _ _ = mempty +-- +-- This ensures that the trick with 'D' annotations can be used for +-- diagrams containing your primitive. +data NullBackend + deriving Typeable + +-- Note: we can't make a once-and-for-all instance +-- +-- > instance Renderable a NullBackend where +-- > render _ _ = mempty +-- +-- because it overlaps with the Renderable instance for NullPrim. + +instance Semigroup (Render NullBackend v n) where + _ <> _ = NullBackendRender + +instance Monoid (Render NullBackend v n) where + mempty = NullBackendRender +#if !MIN_VERSION_base(4,11,0) + mappend = (<>) +#endif + +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) (N t) + -- ^ Given a token representing the backend and a + -- transformable object, render it in the appropriate rendering + -- context. + + -- See Note [backend token] + +{- +~~~~ Note [backend token] + +A bunch of methods here take a "backend token" as an argument. The +backend token is expected to carry no actual information; it is solely +to help out the type system. The problem is that all these methods +return some associated type applied to b (e.g. Render b) and unifying +them with something else will never work, since type families are not +necessarily injective. +-} diff --git a/src/Diagrams/Core/V.hs b/src/Diagrams/Core/V.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Core/V.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.V +-- Copyright : (c) 2011-2015 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type family for identifying associated vector spaces. +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.V + ( V , N , Vn + , InSpace, SameSpace + ) 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 Linear.Vector + +------------------------------------------------------------ +-- Vector spaces ------------------------------------------- +------------------------------------------------------------ + +-- | Many sorts of objects have an associated vector space in which +-- they \"live\". The type function @V@ maps from object types to +-- the associated vector space. 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 b +type instance V [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) + diff --git a/src/Graphics/Rendering/Diagrams.hs b/src/Graphics/Rendering/Diagrams.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams.hs +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- The core library of primitives forming the basis of an embedded --- domain-specific language for describing and rendering diagrams. --- Normal users of the diagrams library should almost never need to --- import anything from this package directly; instead, import modules --- (especially "Diagrams.Prelude") from the diagrams-lib package, --- which re-exports most things of value to users. --- --- For most library code needing access to core internals, it should --- be sufficient to import this module, which simply re-exports useful --- functionality from other modules in the core library. Library --- writers needing finer-grained access or functionality may --- occasionally find it useful to directly import one of the --- constituent core modules. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams - ( -- * Associated vector spaces - - V - - -- * Points - - , Point, origin, (*.) - - -- * Vectors - - , withLength - - -- * Transformations - - -- ** Invertible linear transformations - , (:-:), (<->), linv, lapp - - -- ** General transformations - , Transformation - , inv, transp, transl - , apply - , papply - , fromLinear - - -- ** Some specific transformations - , translation, translate, moveTo, place - , scaling, scale - - -- ** The Transformable class - - , Transformable(..) - - -- ** Translational invariance - - , TransInv(..) - - -- * Names - - , AName - , Name, IsName(..) - , Qualifiable(..), (.>) - , NameMap - , fromNames, fromNamesB - , rememberAs - - , lookupN - - -- * Attributes and styles - - , AttributeClass - , Attribute, mkAttr, mkTAttr, unwrapAttr - - , Style, HasStyle(..) - , getAttr, combineAttr - , applyAttr, applyTAttr - - -- * Envelopes - - , Envelope - , inEnvelope, appEnvelope, onEnvelope, mkEnvelope - , Enveloped(..) - , envelopeV, envelopeP, boundaryFrom - , diameter, radius - - , LocatedEnvelope(..) - , location, locateEnvelope - - -- * Things with local origins - - , HasOrigin(..), moveOriginBy - - -- * Juxtaposable things - - , Juxtaposable(..), juxtaposeDefault - - -- * Queries - - , Query(..) - - -- * Primtives - - , Prim(..), nullPrim - - -- * Diagrams - - , QDiagram, mkQD, Diagram - , prims - , envelope, names, query, sample - , value, resetValue, clearValue - - , named, namePoint - , withName - , withNameAll - , withNames - - , freeze, setEnvelope - - , atop - - -- * Backends - - , Backend(..) - , MultiBackend(..) - , Renderable(..) - - -- ** The null backend - - , NullBackend, D - - -- * Convenience classes - - , HasLinearMap - , OrderedField - , Monoid' - - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Util -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Juxtapose -import Graphics.Rendering.Diagrams.Query -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Names -import Graphics.Rendering.Diagrams.Style -import Graphics.Rendering.Diagrams.Core -import Graphics.Rendering.Diagrams.Monoids (Monoid') diff --git a/src/Graphics/Rendering/Diagrams/Core.hs b/src/Graphics/Rendering/Diagrams/Core.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Core.hs +++ /dev/null @@ -1,632 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , TypeFamilies - , MultiParamTypeClasses - , GADTs - , ExistentialQuantification - , ScopedTypeVariables - , GeneralizedNewtypeDeriving - , DeriveDataTypeable - , TypeOperators - , OverlappingInstances - , UndecidableInstances - , TupleSections - , EmptyDataDecls - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Core --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- The core library of primitives forming the basis of an embedded --- domain-specific language for describing and rendering diagrams. --- --- "Graphics.Rendering.Diagrams.Core" defines types and classes for --- primitives, diagrams, and backends. --- ------------------------------------------------------------------------------ - -{- ~~~~ Note [breaking up Core module] - - Although it's not as bad as it used to be, this module has a lot of - stuff in it, and it might seem a good idea in principle to break it up - into smaller modules. However, it's not as easy as it sounds: everything - in this module cyclically depends on everything else. --} - -module Graphics.Rendering.Diagrams.Core - ( - -- * Diagrams - - -- ** Annotations - UpAnnots, DownAnnots - , QDiagram(..), mkQD, Diagram - - -- * Operations on diagrams - -- ** Extracting information - , prims - , envelope, names, query, sample - , value, resetValue, clearValue - - -- ** Combining diagrams - - -- | For many more ways of combining diagrams, see - -- "Diagrams.Combinators" from the diagrams-lib package. - - , atop - - -- ** Modifying diagrams - -- *** Names - , named - , namePoint - , withName - , withNameAll - , withNames - - -- *** Other - , freeze - , setEnvelope - - -- * Primtives - -- $prim - - , Prim(..), nullPrim - - -- * Backends - - , Backend(..) - , MultiBackend(..) - - -- ** Null backend - - , NullBackend, D - - -- * Renderable - - , Renderable(..) - - ) where - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.MList -import Graphics.Rendering.Diagrams.UDTree - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Query -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Juxtapose -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Names -import Graphics.Rendering.Diagrams.Style - -import Data.VectorSpace -import Data.AffineSpace ((.-.)) - -import Data.Maybe (listToMaybe, fromMaybe) -import Data.Semigroup -import qualified Data.Traversable as T -import Control.Arrow (second) -import Control.Applicative ((<$>), (<*>)) - -import Control.Newtype - -import Data.Typeable - --- XXX TODO: add lots of actual diagrams to illustrate the --- documentation! Haddock supports \<\\>. - ------------------------------------------------------------- --- Diagrams ---------------------------------------------- ------------------------------------------------------------- - --- | Monoidal annotations which travel up the diagram tree, i.e. which --- are aggregated from component diagrams to the whole: --- --- * envelopes (see "Graphics.Rendering.Diagrams.Envelope"). --- The envelopes are \"deletable\" meaning that at any point we can --- throw away the existing envelope and replace it with a new one; --- sometimes we want to consider a diagram as having a different --- envelope unrelated to its \"natural\" envelope. --- --- * name/point associations (see "Graphics.Rendering.Diagrams.Names") --- --- * query functions (see "Graphics.Rendering.Diagrams.Query") -type UpAnnots v m = Deletable (Envelope v) ::: NameMap v ::: Query v m ::: Nil - --- | Monoidal annotations which travel down the diagram tree, --- i.e. which accumulate along each path to a leaf (and which can --- act on the upwards-travelling annotations): --- --- * transformations (split at the innermost freeze): see --- "Graphics.Rendering.Diagrams.Transform" --- --- * styles (see "Graphics.Rendering.Diagrams.Style") --- --- * names (see "Graphics.Rendering.Diagrams.Names") -type DownAnnots v = (Split (Transformation v) :+: Style v) ::: AM [] Name ::: Nil - --- | The fundamental diagram type is represented by trees of --- primitives with various monoidal annotations. The @Q@ in --- @QDiagram@ stands for \"Queriable\", as distinguished from --- 'Diagram', a synonym for @QDiagram@ with the query type --- specialized to 'Any'. -newtype QDiagram b v m - = QD { unQD :: UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) } - deriving (Typeable) - -instance Newtype (QDiagram b v m) - (UDTree (UpAnnots v m) (DownAnnots v) (Prim b v)) where - pack = QD - unpack = unQD - -type instance V (QDiagram b v m) = v - --- | The default sort of diagram is one where querying at a point --- simply tells you whether that point is occupied or not. --- Transforming a default diagram into one with a more interesting --- query can be done via the 'Functor' instance of @'QDiagram' b@. -type Diagram b v = QDiagram b v Any - --- | Extract a list of primitives from a diagram, together with their --- associated transformations and styles. -prims :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] -prims = (map . second) (untangle . fst . toTuple) . flatten . unQD - --- | Get the envelope of a diagram. -envelope :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) - => QDiagram b v m -> Envelope v -envelope = unDelete . getU' . unQD - --- | Replace the envelope of a diagram. -setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) - => Envelope v -> QDiagram b v m -> QDiagram b v m -setEnvelope b = over QD ( applyUpre (inj . toDeletable $ b) - . applyUpre (inj (deleteL :: Deletable (Envelope v))) - . applyUpost (inj (deleteR :: Deletable (Envelope v))) - ) - --- | Get the name map of a diagram. -names :: (AdditiveGroup (Scalar v), Floating (Scalar v), InnerSpace v, HasLinearMap v) - => QDiagram b v m -> NameMap v -names = getU' . unQD - --- | Attach an atomic name to (the local origin of) a diagram. -named :: forall v b n m. - ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => n -> QDiagram b v m -> QDiagram b v m -named = namePoint (locateEnvelope <$> const origin <*> envelope) - --- | Attach an atomic name to a certain point and envelope, computed --- from the given diagram. -namePoint :: forall v b n m. - ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => (QDiagram b v m -> LocatedEnvelope v) -> n -> QDiagram b v m -> QDiagram b v m -namePoint p n d = over QD (applyUpre . inj $ fromNamesB [(n,p d)]) d - --- | Given a name and a diagram transformation indexed by a located --- envelope, perform the transformation using the most recent --- located envelope associated with (some qualification of) the --- name, or perform the identity transformation if the name does not --- exist. -withName :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => n -> (LocatedEnvelope v -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withName n f d = maybe id f (lookupN (toName n) (names d) >>= listToMaybe) d - --- | Given a name and a diagram transformation indexed by a list of --- located envelopes, perform the transformation using the --- collection of all such located envelopes associated with (some --- qualification of) the given name. -withNameAll :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => n -> ([LocatedEnvelope v] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withNameAll n f d = f (fromMaybe [] (lookupN (toName n) (names d))) d - --- | Given a list of names and a diagram transformation indexed by a --- list of located envelopes, perform the transformation using the --- list of most recent envelopes associated with (some qualification --- of) each name. Do nothing (the identity transformation) if any --- of the names do not exist. -withNames :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) - , InnerSpace v, HasLinearMap v) - => [n] -> ([LocatedEnvelope v] -> QDiagram b v m -> QDiagram b v m) - -> QDiagram b v m -> QDiagram b v m -withNames ns f d = maybe id f (T.sequence (map ((listToMaybe=<<) . ($nd) . lookupN . toName) ns)) d - where nd = names d - --- | Get the query function associated with a diagram. -query :: (HasLinearMap v, Monoid m) => QDiagram b v m -> Query v m -query = getU' . unQD - --- | Sample a diagram's query function at a given point. -sample :: (HasLinearMap v, Monoid m) => QDiagram b v m -> Point v -> m -sample = runQuery . query - --- | Set the query value for 'True' points in a diagram (/i.e./ points --- "inside" the diagram); 'False' points will be set to 'mempty'. -value :: Monoid m => m -> QDiagram b v Any -> QDiagram b v m -value m = fmap fromAny - where fromAny (Any True) = m - fromAny (Any False) = mempty - --- | Reset the query values of a diagram to True/False: any values --- equal to 'mempty' are set to 'False'; any other values are set to --- 'True'. -resetValue :: (Eq m, Monoid m) => QDiagram b v m -> QDiagram b v Any -resetValue = fmap toAny - where toAny m | m == mempty = Any False - | otherwise = Any True - --- | Set all the query values of a diagram to 'False'. -clearValue :: QDiagram b v m -> QDiagram b v Any -clearValue = fmap (const (Any False)) - --- | Create a diagram from a single primitive, along with an envelope, --- name map, and query function. -mkQD :: Prim b v -> Envelope v -> NameMap v -> Query v m -> QDiagram b v m -mkQD p b n a = QD $ leaf (toDeletable b ::: n ::: a ::: Nil) p - ------------------------------------------------------------- --- Instances ------------------------------------------------------------- - ----- Monoid - --- | Diagrams form a monoid since each of their components do: the --- empty diagram has no primitives, an empty envelope, no named --- points, and a constantly empty query function. --- --- Diagrams compose by aligning their respective local origins. The --- new diagram has all the primitives and all the names from the two --- diagrams combined, and query functions are combined pointwise. --- The first diagram goes on top of the second. \"On top of\" --- probably only makes sense in vector spaces of dimension lower --- than 3, but in theory it could make sense for, say, 3-dimensional --- diagrams when viewed by 4-dimensional beings. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Monoid (QDiagram b v m) where - mempty = QD mempty - (QD d1) `mappend` (QD d2) = QD (d2 `mappend` d1) - -- swap order so that primitives of d2 come first, i.e. will be - -- rendered first, i.e. will be on the bottom. - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Semigroup (QDiagram b v m) where - (<>) = mappend - --- | A convenient synonym for 'mappend' on diagrams, designed to be --- used infix (to help remember which diagram goes on top of which --- when combining them, namely, the first on top of the second). -atop :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => QDiagram b v m -> QDiagram b v m -> QDiagram b v m -atop = mappend - -infixl 6 `atop` - ----- Functor - --- This is a bit ugly, but it will have to do for now... -instance Functor (QDiagram b v) where - fmap f = over QD (mapU g) - where g (b ::: n ::: a ::: Nil) = b ::: n ::: fmap f a ::: Nil - g _ = error "impossible case in Functor (QDiagram b v) instance (g)" - ----- Applicative - --- XXX what to do with this? --- A diagram with queries of result type @(a -> b)@ can be \"applied\" --- to a diagram with queries of result type @a@, resulting in a --- combined diagram with queries of result type @b@. In particular, --- all components of the two diagrams are combined as in the --- @Monoid@ instance, except the queries which are combined via --- @(<*>)@. - --- instance (Backend b v, s ~ Scalar v, AdditiveGroup s, Ord s) --- => Applicative (QDiagram b v) where --- pure a = Diagram mempty mempty mempty (Query $ const a) - --- (Diagram ps1 bs1 ns1 smp1) <*> (Diagram ps2 bs2 ns2 smp2) --- = Diagram (ps1 <> ps2) (bs1 <> bs2) (ns1 <> ns2) (smp1 <*> smp2) - ----- HasStyle - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => HasStyle (QDiagram b v m) where - applyStyle = over QD . applyD . inj - . (inR :: Style v -> Split (Transformation v) :+: Style v) - --- | By default, diagram attributes are not affected by --- transformations. This means, for example, that @lw 0.01 circle@ --- and @scale 2 (lw 0.01 circle)@ will be drawn with lines of the --- /same/ width, and @scaleY 3 circle@ will be an ellipse drawn with --- a uniform line. Once a diagram is frozen, however, --- transformations do affect attributes, so, for example, @scale 2 --- (freeze (lw 0.01 circle))@ will be drawn with a line twice as --- thick as @lw 0.01 circle@, and @scaleY 3 (freeze circle)@ will be --- drawn with a \"stretched\", variable-width line. --- --- Another way of thinking about it is that pre-@freeze@, we are --- transforming the \"abstract idea\" of a diagram, and the --- transformed version is then drawn; when doing a @freeze@, we --- produce a concrete drawing of the diagram, and it is this visual --- representation itself which is acted upon by subsequent --- transformations. -freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => QDiagram b v m -> QDiagram b v m -freeze = over QD . applyD . inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - $ split - ----- Juxtaposable - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => Juxtaposable (QDiagram b v m) where - juxtapose = juxtaposeDefault - ----- Enveloped - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v) ) - => Enveloped (QDiagram b v m) where - getEnvelope = envelope - ----- HasOrigin - --- | Every diagram has an intrinsic \"local origin\" which is the --- basis for all combining operations. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) - => HasOrigin (QDiagram b v m) where - - moveOriginTo = translate . (origin .-.) - ----- Transformable - --- | Diagrams can be transformed by transforming each of their --- components appropriately. -instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => Transformable (QDiagram b v m) where - transform = over QD . applyD . inj - . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) - . M - ----- Qualifiable - --- | Diagrams can be qualified so that all their named points can --- now be referred to using the qualification prefix. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => Qualifiable (QDiagram b v m) where - (|>) = over QD . applyD . inj . AM . (:[]) . toName - - ------------------------------------------------------------- --- Primitives -------------------------------------------- ------------------------------------------------------------- - --- $prim --- Ultimately, every diagram is essentially a collection of --- /primitives/, basic building blocks which can be rendered by --- backends. However, not every backend must be able to render every --- type of primitive; the collection of primitives a given backend --- knows how to render is determined by instances of 'Renderable'. - --- | A value of type @Prim b v@ is an opaque (existentially quantified) --- primitive which backend @b@ knows how to render in vector space @v@. -data Prim b v where - Prim :: Renderable t b => t -> Prim b (V t) - -type instance V (Prim b v) = v - --- | The 'Transformable' instance for 'Prim' just pushes calls to --- 'transform' down through the 'Prim' constructor. -instance HasLinearMap v => Transformable (Prim b v) where - transform v (Prim p) = Prim (transform v p) - --- | The 'Renderable' instance for 'Prim' just pushes calls to --- 'render' down through the 'Prim' constructor. -instance HasLinearMap v => Renderable (Prim b v) b where - render b (Prim p) = render b p - --- | The null primitive. -data NullPrim v = NullPrim - -type instance (V (NullPrim v)) = v - -instance HasLinearMap v => Transformable (NullPrim v) where - transform _ _ = NullPrim - -instance (HasLinearMap v, Monoid (Render b v)) => Renderable (NullPrim v) b where - render _ _ = mempty - --- | The null primitive, which every backend can render by doing --- nothing. -nullPrim :: (HasLinearMap v, Monoid (Render b v)) => Prim b v -nullPrim = Prim NullPrim - - ------------------------------------------------------------- --- Backends ----------------------------------------------- ------------------------------------------------------------- - --- | Abstract diagrams are rendered to particular formats by --- /backends/. Each backend/vector space combination must be an --- instance of the 'Backend' class. A minimal complete definition --- consists of the three associated types and implementations for --- 'withStyle' and 'doRender'. --- -class (HasLinearMap v, Monoid (Render b v)) => Backend b v where - -- | The type of rendering operations used by this backend, which - -- must be a monoid. For example, if @Render b v = M ()@ for some - -- monad @M@, a monoid instance can be made with @mempty = return - -- ()@ and @mappend = (>>)@. - data Render b v :: * - - -- | The result of running/interpreting a rendering operation. - type Result b v :: * - - -- | Backend-specific rendering options. - data Options b v :: * - - -- | Perform a rendering operation with a local style. - withStyle :: b -- ^ Backend token (needed only for type inference) - -> Style v -- ^ Style to use - -> Transformation v -- ^ Transformation to be applied to the style - -> Render b v -- ^ Rendering operation to run - -> Render b v -- ^ Rendering operation using the style locally - - -- | 'doRender' is used to interpret rendering operations. - doRender :: b -- ^ Backend token (needed only for type inference) - -> Options b v -- ^ Backend-specific collection of rendering options - -> Render b v -- ^ Rendering operation to perform - -> Result b v -- ^ Output of the rendering operation - - -- | 'adjustDia' allows the backend to make adjustments to the final - -- diagram (e.g. to adjust the size based on the options) before - -- rendering it. It can also make adjustments to the options - -- record, usually to fill in incompletely specified size - -- information. A default implementation is provided which makes - -- no adjustments. See the diagrams-lib package for other useful - -- implementations. - adjustDia :: Monoid' m => b -> Options b v - -> QDiagram b v m -> (Options b v, QDiagram b v m) - adjustDia _ o d = (o,d) - - -- XXX expand this comment. Explain about freeze, split - -- transformations, etc. - -- | Render a diagram. This has a default implementation in terms - -- of 'adjustDia', 'withStyle', 'doRender', and the 'render' - -- operation from the 'Renderable' class (first 'adjustDia' is - -- used, then 'withStyle' and 'render' are used to render each - -- primitive, the resulting operations are combined with - -- 'mconcat', and the final operation run with 'doRender') but - -- backends may override it if desired. - renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) - => b -> Options b v -> QDiagram b v m -> Result b v - renderDia b opts d = - doRender b opts' . mconcat . map renderOne . prims $ d' - where (opts', d') = adjustDia b opts d - renderOne :: (Prim b v, (Split (Transformation v), Style v)) - -> Render b v - renderOne (p, (M t, s)) - = withStyle b s mempty (render b (transform t p)) - - renderOne (p, (t1 :| t2, s)) - = withStyle b s t1 (render b (transform (t1 <> t2) p)) - - -- See Note [backend token] - --- | The @D@ type is provided for convenience in situations where you --- must give a diagram a concrete, monomorphic type, but don't care --- which one. Such situations arise when you pass a diagram to a --- function which is polymorphic in its input but monomorphic in its --- output, such as 'width', 'height', 'phantom', or 'names'. Such --- functions compute some property of the diagram, or use it to --- accomplish some other purpose, but do not result in the diagram --- being rendered. If the diagram does not have a monomorphic type, --- GHC complains that it cannot determine the diagram's type. --- --- For example, here is the error we get if we try to compute the --- width of a radius-1 circle (this example requires --- @diagrams-lib@): --- --- > ghci> width (circle 1) --- > --- > :1:8: --- > No instances for (Backend b0 R2, --- > Renderable Diagrams.TwoD.Ellipse.Ellipse b0) --- > arising from a use of `circle' --- > Possible fix: --- > add instance declarations for --- > (Backend b0 R2, Renderable Diagrams.TwoD.Ellipse.Ellipse b0) --- > In the first argument of `width', namely `(circle 1)' --- > In the expression: width (circle 1) --- > In an equation for `it': it = width (circle 1) --- --- GHC complains that it cannot find an instance for \"@Backend b0 --- R2@\"; what is really going on is that it does not have enough --- information to decide which backend to use for the circle (hence --- the type variable @b0@). This is annoying because /we/ know that --- the choice of backend cannot possibly affect the width of the --- circle; but there is no way for GHC to know that. --- --- The solution is to annotate @circle 1@ with the type @'D' 'R2'@, --- like so: --- --- > ghci> width (circle 1 :: D R2) --- > 2.0 - -type D v = Diagram NullBackend v - - --- | A null backend which does no actual rendering. It is provided --- mainly for convenience in situations where you must give a --- diagram a concrete, monomorphic type, but don't actually care --- which one. See 'D' for more explanation and examples. --- --- It is courteous, when defining a new primitive @P@, to make an instance --- --- > instance Renderable P NullBackend where --- > render _ _ = mempty --- --- This ensures that the trick with 'D' annotations can be used for --- diagrams containing your primitive. -data NullBackend - --- Note: we can't make a once-and-for-all instance --- --- > instance Renderable a NullBackend where --- > render _ _ = mempty --- --- because it overlaps with the Renderable instance for NullPrim. - -instance Monoid (Render NullBackend v) where - mempty = NullBackendRender - mappend _ _ = NullBackendRender - -instance HasLinearMap v => Backend NullBackend v where - data Render NullBackend v = NullBackendRender - type Result NullBackend v = () - data Options NullBackend v - - withStyle _ _ _ _ = NullBackendRender - doRender _ _ _ = () - --- | A class for backends which support rendering multiple diagrams, --- e.g. to a multi-page pdf or something similar. -class Backend b v => MultiBackend b v where - - -- | Render multiple diagrams at once. - renderDias :: b -> Options b v -> [QDiagram b v m] -> Result b v - - -- See Note [backend token] - - --- | The Renderable type class connects backends to primitives which --- they know how to render. -class Transformable t => Renderable t b where - render :: b -> t -> Render b (V t) - -- ^ Given a token representing the backend and a - -- transformable object, render it in the appropriate rendering - -- context. - - -- See Note [backend token] - -{- -~~~~ Note [backend token] - -A bunch of methods here take a "backend token" as an argument. The -backend token is expected to carry no actual information; it is solely -to help out the type system. The problem is that all these methods -return some associated type applied to b (e.g. Render b) and unifying -them with something else will never work, since type families are not -necessarily injective. --} - diff --git a/src/Graphics/Rendering/Diagrams/Envelope.hs b/src/Graphics/Rendering/Diagrams/Envelope.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Envelope.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE TypeFamilies - , FlexibleInstances - , FlexibleContexts - , UndecidableInstances - , GeneralizedNewtypeDeriving - , StandaloneDeriving - , MultiParamTypeClasses - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Envelope --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- "Graphics.Rendering.Diagrams" defines the core library of primitives --- forming the basis of an embedded domain-specific language for --- describing and rendering diagrams. --- --- The @Envelope@ module defines a data type and type class for --- \"envelopes\", aka functional bounding regions. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Envelope - ( -- * Envelopes - Envelope(..) - - , inEnvelope - , appEnvelope - , onEnvelope - , mkEnvelope - - , Enveloped(..) - - , LocatedEnvelope(..) - , location - , locateEnvelope - - -- * Utility functions - , diameter - , radius - , envelopeV, envelopeP, boundaryFrom - - -- * Miscellaneous - , OrderedField - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - -import Data.VectorSpace -import Data.AffineSpace ((.+^), (.-^)) - -import Data.Semigroup -import Control.Applicative ((<$>)) - -import qualified Data.Map as M -import qualified Data.Set as S - ------------------------------------------------------------- --- Envelopes --------------------------------------------- ------------------------------------------------------------- - --- | Every diagram comes equipped with an *envelope*. --- Intuitively, the envelope for a diagram tells us the --- minimum distance we have to go in a given direction to get to a --- (hyper)plane entirely containing the diagram on one side of --- it. Formally, given a vector @v@, it returns a scalar @s@ such --- that --- --- * for every point @u@ inside the diagram, --- if the projection of @(u - origin)@ onto @v@ is @s' *^ v@, then @s' <= s@. --- --- * @s@ is the smallest such scalar. --- --- This could probably be expressed in terms of a Galois connection; --- this is left as an exercise for the reader. --- --- There is also a special \"empty envelope\". --- --- Essentially, envelopes are a functional representation --- of (a conservative approximation to) convex bounding regions. --- The idea for this representation came from Sebastian Setzer; see --- . -newtype Envelope v = Envelope { unEnvelope :: Option (v -> Max (Scalar v)) } - -inEnvelope :: (Option (v -> Max (Scalar v)) -> Option (v -> Max (Scalar v))) - -> Envelope v -> Envelope v -inEnvelope f = Envelope . f . unEnvelope - -appEnvelope :: Envelope v -> Maybe (v -> Scalar v) -appEnvelope (Envelope (Option b)) = (getMax .) <$> b - -onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v -onEnvelope t = (inEnvelope . fmap) ((Max .) . t . (getMax .)) - -mkEnvelope :: (v -> Scalar v) -> Envelope v -mkEnvelope = Envelope . Option . Just . (Max .) - --- | Envelopes form a semigroup with pointwise maximum as composition. --- Hence, if @b1@ is the envelope for diagram @d1@, and --- @b2@ is the envelope for @d2@, then @b1 \`mappend\` b2@ --- is the envelope for @d1 \`atop\` d2@. -deriving instance Ord (Scalar v) => Semigroup (Envelope v) - --- | The special empty envelope is the identity for the --- 'Monoid' instance. -deriving instance Ord (Scalar v) => Monoid (Envelope v) - - - --- XXX add some diagrams here to illustrate! Note that Haddock supports --- inline images, using a \<\\> syntax. - -type instance V (Envelope v) = v - --- | The local origin of an envelope is the point with respect to --- which bounding queries are made, /i.e./ the point from which the --- input vectors are taken to originate. -instance (InnerSpace v, AdditiveGroup (Scalar v), Fractional (Scalar v)) - => HasOrigin (Envelope v) where - moveOriginTo (P u) = onEnvelope $ \f v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) - -instance Show (Envelope v) where - show _ = "" - ------------------------------------------------------------- --- Transforming envelopes -------------------------------- ------------------------------------------------------------- - --- XXX can we get away with removing this Floating constraint? It's the --- call to normalized here which is the culprit. -instance ( HasLinearMap v, InnerSpace v - , Floating (Scalar v), AdditiveGroup (Scalar v) ) - => Transformable (Envelope v) where - transform t = -- XXX add lots of comments explaining this! - moveOriginTo (P . negateV . transl $ t) . - (onEnvelope $ \f v -> - let v' = normalized $ lapp (transp t) v - vi = apply (inv t) v - in f v' / (v' <.> vi) - ) - ------------------------------------------------------------- --- Enveloped class ------------------------------------------------------------- - --- | When dealing with envelopes we often want scalars to be an --- ordered field (i.e. support all four arithmetic operations and be --- totally ordered) so we introduce this class as a convenient --- shorthand. -class (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s -instance (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s - --- | @Enveloped@ abstracts over things which have an envelope. -class (InnerSpace (V b), OrderedField (Scalar (V b))) => Enveloped b where - - -- | Compute the envelope of an object. For types with an intrinsic - -- notion of \"local origin\", the envelope will be based there. - -- Other types (e.g. 'Trail') may have some other default - -- reference point at which the envelope will be based; their - -- instances should document what it is. - getEnvelope :: b -> Envelope (V b) - -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Envelope v) where - getEnvelope = id - -instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (Point v) where - getEnvelope p = moveTo p . mkEnvelope $ const zeroV - -instance (Enveloped a, Enveloped b, V a ~ V b) => Enveloped (a,b) where - getEnvelope (x,y) = getEnvelope x <> getEnvelope y - -instance (Enveloped b) => Enveloped [b] where - getEnvelope = mconcat . map getEnvelope - -instance (Enveloped b) => Enveloped (M.Map k b) where - getEnvelope = mconcat . map getEnvelope . M.elems - -instance (Enveloped b) => Enveloped (S.Set b) where - getEnvelope = mconcat . map getEnvelope . S.elems - --- XXX rename this? Move it elsewhere? ------------------------------------------------------------- --- Located envelopes ------------------------------------------------------------- - --- | A @LocatedEnvelope@ value represents an envelope with its --- base point at a particular location. -data LocatedEnvelope v = LocatedEnvelope (Point v) (TransInv (Envelope v)) - deriving (Show) - -type instance V (LocatedEnvelope v) = v - -instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (LocatedEnvelope v) where - getEnvelope (LocatedEnvelope _ (TransInv b)) = b - -instance VectorSpace v => HasOrigin (LocatedEnvelope v) where - moveOriginTo (P u) (LocatedEnvelope p b) = LocatedEnvelope (p .-^ u) b - -instance ( HasLinearMap v, InnerSpace v - , Floating (Scalar v), AdditiveGroup (Scalar v) ) - => Transformable (LocatedEnvelope v) where - transform t (LocatedEnvelope p b) = LocatedEnvelope (papply t p) - (transform t b) - --- | Get the location of a located envelope. -location :: LocatedEnvelope v -> Point v -location (LocatedEnvelope p _) = p - --- XXX boundaryFrom really ought to use the 'trace' of a diagram --- instead of the envelope. Leave it here for now, move it when we --- implement traces so it will have a different semantics. - --- | @boundaryFrom v b@ computes the point on the boundary of the --- located envelope @b@ in the direction of @v@ from the --- bounding region's base point. This is most often used to compute --- a point on the boundary of a named subdiagram. -boundaryFrom :: (OrderedField (Scalar v), InnerSpace v) - => LocatedEnvelope v -> v -> Point v -boundaryFrom b v = location b .+^ envelopeV v b - --- | Create a 'LocatedEnvelope' value by specifying a location and an --- envelope. -locateEnvelope :: Point v -> Envelope v -> LocatedEnvelope v -locateEnvelope p b = LocatedEnvelope p (TransInv b) - ------------------------------------------------------------- --- Computing with envelopes ------------------------------------------------------------- - --- | Compute the vector from the local origin to a separating --- hyperplane in the given direction. Returns the zero vector for --- the empty envelope. -envelopeV :: Enveloped a => V a -> a -> V a -envelopeV v a = maybe zeroV ((*^ v) . ($ v)) $ appEnvelope (getEnvelope a) - --- | Compute the point on a separating hyperplane in the given --- direction. Returns the origin for the empty envelope. -envelopeP :: Enveloped a => V a -> a -> Point (V a) -envelopeP v a = P $ envelopeV v a - --- | Compute the diameter of a enveloped object along a particular --- vector. Returns zero for the empty envelope. -diameter :: Enveloped a => V a -> a -> Scalar (V a) -diameter v a = magnitude (envelopeV v a ^-^ envelopeV (negateV v) a) - --- | Compute the \"radius\" (1\/2 the diameter) of an enveloped object --- along a particular vector. -radius :: Enveloped a => V a -> a -> Scalar (V a) -radius v a = 0.5 * diameter v a diff --git a/src/Graphics/Rendering/Diagrams/HasOrigin.hs b/src/Graphics/Rendering/Diagrams/HasOrigin.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/HasOrigin.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleInstances - , FlexibleContexts - , TypeFamilies - , UndecidableInstances - #-} - --- The UndecidableInstances flag is needed under 6.12.3 for the --- HasOrigin (a,b) instance. - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.HasOrigin --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Types which have an intrinsic notion of a \"local origin\", --- /i.e./ things which are /not/ invariant under translation. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.HasOrigin - ( HasOrigin(..), moveOriginBy, moveTo, place - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Points - -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.AffineSpace ((.-^), (.-.)) -import Data.VectorSpace - --- | Class of types which have an intrinsic notion of a \"local --- origin\", i.e. things which are not invariant under translation, --- and which allow the origin to be moved. --- --- One might wonder why not just use 'Transformable' instead of --- having a separate class for 'HasOrigin'; indeed, for types which --- are instances of both we should have the identity --- --- > moveOriginTo (origin .^+ v) === translate (negateV v) --- --- The reason is that some things (e.g. vectors, 'Trail's) are --- transformable but are translationally invariant, i.e. have no --- origin. -class VectorSpace (V t) => HasOrigin t where - - -- | Move the local origin to another point. - -- - -- Note that this function is in some sense dual to 'translate' - -- (for types which are also 'Transformable'); moving the origin - -- itself while leaving the object \"fixed\" is dual to fixing the - -- origin and translating the diagram. - moveOriginTo :: Point (V t) -> t -> t - --- | Move the local origin by a relative vector. -moveOriginBy :: HasOrigin t => V t -> t -> t -moveOriginBy = moveOriginTo . P - --- | Translate the object by the translation that sends the origin to --- the given point. Note that this is dual to 'moveOriginTo', i.e. we --- should have --- --- > moveTo (origin .^+ v) === moveOriginTo (origin .^- v) --- --- For types which are also 'Transformable', this is essentially the --- same as 'translate', i.e. --- --- > moveTo (origin .^+ v) === translate v -moveTo :: HasOrigin t => Point (V t) -> t -> t -moveTo = moveOriginBy . (origin .-.) - --- | A flipped variant of 'moveTo', provided for convenience. Useful --- when writing a function which takes a point as an argument, such --- as when using 'withName' and friends. -place :: HasOrigin t => t -> Point (V t) -> t -place = flip moveTo - -instance VectorSpace v => HasOrigin (Point v) where - moveOriginTo (P u) p = p .-^ u - -instance (HasOrigin a, HasOrigin b, V a ~ V b) => HasOrigin (a,b) where - moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) - -instance HasOrigin a => HasOrigin [a] where - moveOriginTo = map . moveOriginTo - -instance (HasOrigin a, Ord a) => HasOrigin (S.Set a) where - moveOriginTo = S.map . moveOriginTo - -instance HasOrigin a => HasOrigin (M.Map k a) where - moveOriginTo = M.map . moveOriginTo diff --git a/src/Graphics/Rendering/Diagrams/Juxtapose.hs b/src/Graphics/Rendering/Diagrams/Juxtapose.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Juxtapose.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , UndecidableInstances - , TypeFamilies - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Juxtapose --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Things which can be placed \"next to\" other things, for some --- appropriate notion of \"next to\". --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Juxtapose - ( Juxtaposable(..), juxtaposeDefault - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.HasOrigin - -import qualified Data.Map as M -import qualified Data.Set as S - -import Data.VectorSpace - --- | Class of things which can be placed \"next to\" other things, for some --- appropriate notion of \"next to\". -class Juxtaposable a where - - -- | @juxtapose v a1 a2@ positions @a2@ next to @a1@ in the - -- direction of @v@. In particular, place @a2@ so that @v@ points - -- from the local origin of @a1@ towards the old local origin of - -- @a2@; @a1@'s local origin becomes @a2@'s new local origin. The - -- result is just a translated version of @a2@. (In particular, - -- this operation does not /combine/ @a1@ and @a2@ in any way.) - juxtapose :: V a -> a -> a -> a - --- | Default implementation of 'juxtapose' for things which are --- instances of 'Enveloped' and 'HasOrigin'. -juxtaposeDefault :: (Enveloped a, HasOrigin a) => V a -> a -> a -> a -juxtaposeDefault v a1 a2 = moveOriginBy (v1 ^+^ v2) a2 - where v1 = negateV (envelopeV v a1) - v2 = envelopeV (negateV v) a2 - -instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Envelope v) where - juxtapose = juxtaposeDefault - -instance (Enveloped a, HasOrigin a, Enveloped b, HasOrigin b, V a ~ V b) - => Juxtaposable (a,b) where - juxtapose = juxtaposeDefault - -instance (Enveloped b, HasOrigin b) => Juxtaposable [b] where - juxtapose = juxtaposeDefault - -instance (Enveloped b, HasOrigin b) => Juxtaposable (M.Map k b) where - juxtapose = juxtaposeDefault - -instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where - juxtapose = juxtaposeDefault diff --git a/src/Graphics/Rendering/Diagrams/MList.hs b/src/Graphics/Rendering/Diagrams/MList.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/MList.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE TypeOperators - , MultiParamTypeClasses - , FlexibleInstances - , OverlappingInstances - , UndecidableInstances - , TypeFamilies - , GeneralizedNewtypeDeriving - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.MList --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Heterogeneous lists of monoids. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.MList - ( -- * Heterogeneous monoidal lists - - -- $mlist - - Nil(..), (:::)(..) - - , MList(..) - - -- * Converting to tuples - , Tuple, ToTuple(..) - - -- * Accessing embedded values - , (:>:)(..) - - -- * Monoid actions of heterogeneous lists - - -- $mlist-actions - - , SM(..) - ) where - -import Data.Semigroup -import Graphics.Rendering.Diagrams.Monoids - --- $mlist --- --- The idea of /heterogeneous lists/ has been around for a long time. --- Here, we adopt heterogeneous lists where the element types are all --- monoids: this allows us to leave out identity values, so that a --- heterogeneous list containing only a single non-identity value can --- be created without incurring constraints due to all the other --- types, by leaving all the other values out. - -infixr 5 ::: - --- | The empty heterogeneous list. -data Nil = Nil - deriving (Show, Eq, Ord) - --- | Cons for heterogeneous lists. -data a ::: l = Missing l -- ^ The @a@ value is missing, and should be - -- construed as 'mempty'. - | a ::: l -- ^ An @a@ value followed by a heterogeneous - -- list @l@. - deriving (Show, Eq, Ord) - --- MList ----------------------------------- - --- | Type class for heterogeneous monoidal lists, with a single method --- allowing construction of an empty list. -class MList l where - -- | The /empty/ heterogeneous list of type @l@. Of course, @empty - -- == 'mempty'@, but unlike 'mempty', @empty@ does not require - -- 'Monoid' constraints on all the elements of @l@. - empty :: l - -instance MList Nil where - empty = Nil - -instance MList l => MList (a ::: l) where - empty = Missing empty - --- Monoid ---------------------------------- - -instance Semigroup Nil where - _ <> _ = Nil - -instance Monoid Nil where - mempty = Nil - mappend = (<>) - -instance (Semigroup a, Semigroup tl) => Semigroup (a ::: tl) where - (Missing t1) <> (Missing t2) = Missing (t1 <> t2) - (Missing t1) <> (a2 ::: t2) = a2 ::: (t1 <> t2) - (a1 ::: t1) <> (Missing t2) = a1 ::: (t1 <> t2) - (a1 ::: t1) <> (a2 ::: t2) = (a1 <> a2) ::: (t1 <> t2) - --- | Heterogeneous monoidal lists are themselves instances of 'Monoid' --- as long as all their elements are, where 'mappend' is done --- elementwise. -instance (Semigroup a, Semigroup tl, Monoid tl) => Monoid (a ::: tl) where - mempty = Missing mempty - mappend = (<>) - --- ToTuple --------------------------------- - --- | A type function to compute the tuple-based representation for --- instances of 'MList'. -type family Tuple l :: * -type instance Tuple Nil = () -type instance Tuple (a ::: b) = (a, Tuple b) - --- | @toTuple@ can be used to convert a heterogeneous list to its --- tuple-based representation. -class ToTuple l where - toTuple :: l -> Tuple l - -instance ToTuple Nil where - toTuple _ = () - -instance (Monoid a, ToTuple l) => ToTuple (a ::: l) where - toTuple (Missing l) = (mempty, toTuple l) - toTuple (a ::: l) = (a, toTuple l) - --- Embedding ------------------------------------------- - --- | The relation @l :>: a@ holds when @a@ is the type of an element --- in @l@. For example, @(Char ::: Int ::: Bool ::: Nil) :>: Int@. -class l :>: a where - -- | Inject a value into an otherwise empty heterogeneous list. - inj :: a -> l - - -- | Get the value of type @a@ from a heterogeneous list. - get :: l -> a - - -- | Alter the value of type @a@ by applying the given function to it. - alt :: (a -> a) -> l -> l - -instance (MList t, Monoid a) => (:>:) (a ::: t) a where - inj a = a ::: empty - get (Missing _) = mempty - get (a ::: _) = a - alt f (Missing l) = f mempty ::: l - alt f (a ::: l) = f a ::: l - -instance (t :>: a) => (:>:) (b ::: t) a where - inj a = Missing (inj a) - get (Missing l) = get l - get (_ ::: l) = get l - alt f (Missing l) = Missing (alt f l) - alt f (a ::: l) = a ::: alt f l - --- Monoid actions ----------------------------------------- - --- $mlist-actions --- Monoidal heterogeneous lists may act on one another as you would --- expect, with each element in the first list acting on each in the --- second. Unfortunately, coding this up in type class instances is a --- bit fiddly. - --- | @SM@, an abbreviation for \"single monoid\" (as opposed to a --- heterogeneous list of monoids), is only used internally to help --- guide instance selection when defining the action of --- heterogeneous monoidal lists on each other. -newtype SM m = SM m - deriving (Monoid) - -instance Action Nil l where - act _ a = a - -instance (Monoid a, Action (SM a) l2, Action l1 l2) => Action (a ::: l1) l2 where - act (Missing l1) l2 = act l1 l2 - act (a ::: l1) l2 = act (SM a) (act l1 l2) - -instance Monoid a => Action (SM a) Nil where - act _ _ = Nil - -instance (Action a a', Action (SM a) l) => Action (SM a) (a' ::: l) where - act (SM a) (Missing l) = Missing (act (SM a) l) - act (SM a) (a' ::: l) = act a a' ::: act (SM a) l diff --git a/src/Graphics/Rendering/Diagrams/Monoids.hs b/src/Graphics/Rendering/Diagrams/Monoids.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Monoids.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses - , FlexibleInstances - , GeneralizedNewtypeDeriving - , DeriveFunctor - , TypeFamilies - , TypeOperators - , UndecidableInstances - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Monoids --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Various monoid-related definitions (monoid actions, split monoids, --- applicative monoids) used in the core diagrams library. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Monoids - ( -- * Monoids and semigroups - - Monoid' - - -- * Monoid actions - - , Action(..) - - -- * Split monoids - -- $split - - , Split(..), split - - -- * Forgetful monoids - -- $forget - - , Forgetful(..), unForget, forget - - , Deletable(..), unDelete, toDeletable, deleteL, deleteR - - -- * Applicative monoids - - , AM(..), inAM2 - - -- * Coproduct monoid - , (:+:) - , inL, inR - , mappendL, mappendR - , killL, killR - , untangle - ) where - -import Graphics.Rendering.Diagrams.V - -import Data.Semigroup -import Data.Foldable -import Control.Applicative -import Data.Either (lefts, rights) - ------------------------------------------------------------- --- Monoids and semigroups ------------------------------------------------------------- - --- Poor man's constraint synonym. Eventually, once it becomes --- standard, we can make this a real constraint synonym and get rid of --- the UndecidableInstances flag. Better yet, hopefully the Monoid --- class will eventually have a Semigroup superclass. - --- | The @Monoid'@ class is a synonym for things which are instances --- of both 'Semigroup' and 'Monoid'. Ideally, the 'Monoid' class --- itself will eventually include a 'Semigroup' superclass and we --- can get rid of this. -class (Semigroup m, Monoid m) => Monoid' m -instance (Semigroup m, Monoid m) => Monoid' m - ------------------------------------------------------------- --- Monoid actions ------------------------------------------------------------- - --- | Type class for monoid actions, where monoidal values of type @m@ --- \"act\" on values of another type @s@. Instances are required to --- satisfy the laws --- --- * @act mempty = id@ --- --- * @act (m1 ``mappend`` m2) = act m1 . act m2@ --- --- Additionally, if the type @s@ has any algebraic structure, @act --- m@ should be a homomorphism. For example, if @s@ is also a --- monoid we should have @act m mempty = mempty@ and @act m (s1 --- ``mappend`` s2) = (act m s1) ``mappend`` (act m s2)@. --- --- By default, @act = const id@, so for a monoidal type @M@ which --- should have no action on anything, it suffices to write --- --- > instance Action M s --- --- with no method implementations. -class Action m s where - - -- | Convert a monoidal value of type @m@ to an action on @s@ values. - act :: m -> s -> s - act = const id - ------------------------------------------------------------- --- Split monoids ------------------------------------------------------------- - --- $split --- Sometimes we want to accumulate values from some monoid, but have --- the ability to introduce a \"split\" which separates values on --- either side. For example, this is used when accumulating --- transformations to be applied to primitive diagrams: the 'freeze' --- operation introduces a split, since only transformations occurring --- outside the freeze should be applied to attributes. - -infix 5 :| - --- | A value of type @Split m@ is either a single @m@, or a pair of --- @m@'s separated by a divider. -data Split m = M m - | m :| m - --- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which --- combines values on either side of a split, keeping only the --- rightmost split. -instance Semigroup m => Semigroup (Split m) where - (M m1) <> (M m2) = M (m1 <> m2) - (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 - (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' - (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 - -instance (Semigroup m, Monoid m) => Monoid (Split m) where - mempty = M mempty - mappend = (<>) - --- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@. -split :: Monoid m => Split m -split = mempty :| mempty - --- | By default, the action of a split monoid is the same as for --- the underlying monoid, as if the split were removed. -instance Action m n => Action (Split m) n where - act (M m) n = act m n - act (m1 :| m2) n = act m1 (act m2 n) - ------------------------------------------------------------- --- Forgetful monoids ------------------------------------------------------------- - --- $forget --- Sometimes we want to be able to \"forget\" some information. We --- define two monoid transformers that allow forgetting information. --- @Forgetful@ introduces special values which cause anything to their --- right to be forgotten. @Deletable@ introduces special \"left and --- right bracket\" elements which cause everything inside them to be --- forgotten. - - --- | A value of type @Forgetful m@ is either a \"normal\" value of --- type @m@, which combines normally with other normal values, or a --- \"forgetful\" value, which combines normally with other values to --- its left but discards values combined on the right. Also, when --- combining a forgetful value with a normal one the result is --- always forgetful. -data Forgetful m = Normal m - | Forgetful m - deriving Functor - --- | Project the wrapped value out of a `Forgetful` value. -unForget :: Forgetful m -> m -unForget (Normal m) = m -unForget (Forgetful m) = m - --- | If @m@ is a 'Semigroup', then @Forgetful m@ is a semigroup with two --- sorts of values, \"normal\" and \"forgetful\": the normal ones --- combine normally and the forgetful ones discard anything to the --- right. -instance Semigroup m => Semigroup (Forgetful m) where - (Normal m1) <> (Normal m2) = Normal (m1 <> m2) - (Normal m1) <> (Forgetful m2) = Forgetful (m1 <> m2) - (Forgetful m1) <> _ = Forgetful m1 - -instance (Semigroup m, Monoid m) => Monoid (Forgetful m) where - mempty = Normal mempty - mappend = (<>) - - --- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\> --- b == Forgetful a@. -forget :: Monoid m => Forgetful m -forget = Forgetful mempty - -instance Action m n => Action (Forgetful m) n where - act (Normal m) n = act m n - act (Forgetful m) n = act m n - -type instance V (Forgetful m) = V m - --- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking) --- adds two distinguished new elements @[@ and @]@, such that an --- occurrence of [ \"deletes\" everything from it to the next ]. For --- example, --- --- > abc[def]gh == abcgh --- --- This is all you really need to know to /use/ @Deletable m@ --- values; to understand the actual implementation, read on. --- --- To properly deal with nesting and associativity we need to be --- able to assign meanings to things like @[[@, @][@, and so on. (We --- cannot just define, say, @[[ == [@, since then @([[)] == [] == --- id@ but @[([]) == [id == [@.) Formally, elements of @Deletable --- m@ are triples of the form (r, m, l) representing words @]^r m --- [^l@. When combining two triples (r1, m1, l1) and (r2, m2, l2) --- there are three cases: --- --- * If l1 == r2 then the [s from the left and ]s from the right --- exactly cancel, and we are left with (r1, m1 \<\> m2, l2). --- --- * If l1 < r2 then all of the [s cancel with some of the ]s, but --- m1 is still inside the remaining ]s and is deleted, yielding (r1 --- + r2 - l1, m2, l2) --- --- * The remaining case is symmetric with the second. - -data Deletable m = Deletable Int m Int - deriving Functor - -type instance V (Deletable m) = V m - --- | Project the wrapped value out of a `Deletable` value. -unDelete :: Deletable m -> m -unDelete (Deletable _ m _) = m - --- | Inject a value into a `Deletable` wrapper. Satisfies the --- property --- --- > unDelete . toDeletable === id --- -toDeletable :: m -> Deletable m -toDeletable m = Deletable 0 m 0 - -instance Semigroup m => Semigroup (Deletable m) where - (Deletable r1 m1 l1) <> (Deletable r2 m2 l2) - | l1 == r2 = Deletable r1 (m1 <> m2) l2 - | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 - | otherwise = Deletable r1 m1 (l2 + l1 - r2) - -instance (Semigroup m, Monoid m) => Monoid (Deletable m) where - mempty = Deletable 0 mempty 0 - mappend = (<>) - --- | A \"left bracket\", which causes everything between it and the --- next right bracket to be deleted. -deleteL :: Monoid m => Deletable m -deleteL = Deletable 0 mempty 1 - --- | A \"right bracket\", denoting the end of the section that should --- be deleted. -deleteR :: Monoid m => Deletable m -deleteR = Deletable 1 mempty 0 - ------------------------------------------------------------- --- Applicative monoids ------------------------------------------------------------- - --- | A wrapper for an 'Applicative' structure containing a monoid. --- Such structures have a @Monoid@ instance based on \"idiomatic\" --- application of 'mappend' within the @Applicative@ context. --- @instance Monoid m => Monoid (e -> m)@ is one well-known special --- case. (However, the standard @Monoid@ instance for @Maybe@ is --- /not/ an instance of this pattern; nor is the standard instance --- for lists.) -newtype AM f m = AM (f m) - deriving (Functor, Applicative) - --- | Apply a binary function inside an 'AM' newtype wrapper. -inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m -inAM2 g (AM f1) (AM f2) = AM (g f1 f2) - -instance (Applicative f, Semigroup m) => Semigroup (AM f m) where - (<>) = inAM2 (liftA2 (<>)) - --- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@. -instance (Applicative f, Monoid m) => Monoid (AM f m) where - mempty = pure mempty - mappend = inAM2 (liftA2 mappend) - -{- See Applicative laws here: - -http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative --} - -{- left identity: - - AM (pure mempty) `mappend` AM f -= { definition } - AM $ fmap mappend (pure mempty) <*> f -= { naturality of pure, fmap f . pure = pure . f } - AM $ pure (mappend mempty) <*> f -= { monoid law (left identity) } - AM $ pure id <*> f -= { applicative law (identity) } - AM f --} - -{- right identity: - - AM f `mappend` AM (pure mempty) -= { definition } - AM $ fmap mappend f <*> pure mempty -= { applicative law (interchange) } - AM $ pure ($mempty) <*> fmap mappend f -= { applicative/functor law } - AM $ pure ($mempty) <*> (pure mappend <*> f) -= { applicative law (composition) } - AM $ pure (.) <*> pure ($mempty) <*> pure mappend <*> f -= { applicative law (homomorphism) } - AM $ pure ((.) ($mempty)) <*> pure mappend <*> f -= { applicative law (homomorphism) } - AM $ pure (($mempty) . mappend) <*> f -= { monoid law (right identity) } - AM $ pure id <*> f -= { applicative law (identity) } - AM f --} - -{- associativity: - - (AM f1 `mappend` AM f2) `mappend` AM f3 -= { definition } - AM $ fmap mappend (AM f1 `mappend` AM f2) <*> f3 -= { definition } - AM $ fmap mappend (fmap mappend f1 <*> f2) <*> f3 -= { applicative/functor law } - AM $ pure mappend <*> (pure mappend <*> f1 <*> f2) <*> f3 -= { applicative law (composition) } - AM $ pure (.) <*> pure mappend <*> (pure mappend <*> f1) <*> f2 <*> f3 -= { applicative law (homomorphism) } - AM $ pure (mappend .) <*> (pure mappend <*> f1) <*> f2 <*> f3 -= { applicative law (composition) } - AM $ pure (.) <*> pure (mappend .) <*> pure mappend <*> f1 <*> f2 <*> f3 -= { applicative law (homomorphism) } - AM $ pure ((mappend .) . mappend) <*> f1 <*> f2 <*> f3 -= { monoid law (associativity) } - AM $ pure ((. mappend) . (.) . mappend) <*> f1 <*> f2 <*> f3 -= - -- XXX finish this proof (although I have no doubt it goes through) - - -= - AM f1 `mappend` (AM f2 `mappend` AM f3) --} - -{- -\x y z -> (x `mappend` y) `mappend` z -\x y -> mappend (mappend x y) -\x -> mappend . (mappend x) -(mappend .) . mappend --} - -{- -\x y z -> x `mappend` (y `mappend` z) -\x y z -> mappend x (mappend y z) -\x y -> mappend x . mappend y -\x -> ((.) (mappend x)) . mappend -\x -> (.) ((.) (mappend x)) mappend -\x -> (.mappend) ((.) (mappend x)) -(. mappend) . (.) . mappend --} - - --- | An applicative monoid acts on a value of a monoidal type by --- having each element in the structure act on the value --- independently, and then folding the resulting structure. -instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where - act (AM f) n = fold $ fmap (`act` n) f - --- XXX need to prove that this satisfies the laws! There are other --- "obvious" instances too. - ------------------------------------------------------------- --- Monoid coproduct ------------------------------------------------------------- - --- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Values of --- type @m :+: n@ consist of alternating lists of @m@ and @n@ --- values. The empty list is the identity, and composition is list --- concatenation, with appropriate combining of adjacent elements --- when possible. -newtype m :+: n = MCo { unMCo :: [Either m n] } - --- For efficiency and simplicity, we implement it just as [Either m --- n]: of course, this does not preserve the invariant of strictly --- alternating types, but it doesn't really matter as long as we don't --- let anyone inspect the internal representation. - --- | Injection from the left monoid into a coproduct. -inL :: m -> m :+: n -inL m = MCo [Left m] - --- | Injection from the right monoid into a coproduct. -inR :: n -> m :+: n -inR n = MCo [Right n] - --- | Prepend a value from the left monoid. -mappendL :: m -> m :+: n -> m :+: n -mappendL = mappend . inL - --- | Prepend a value from the right monoid. -mappendR :: n -> m :+: n -> m :+: n -mappendR = mappend . inR - -{- -normalize :: (Monoid m, Monoid n) => m :+: n -> m :+: n -normalize (MCo es) = MCo (normalize' es) - where normalize' [] = [] - normalize' [e] = [e] - normalize' (Left e1:Left e2 : es) = normalize' (Left (e1 <> e2) : es) - normalize' (Left e1:es) = Left e1 : normalize' es - normalize' (Right e1:Right e2:es) = normalize' (Right (e1 <> e2) : es) - normalize' (Right e1:es) = Right e1 : normalize' es --} - -instance Semigroup (m :+: n) where - (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) - --- | The coproduct of two monoids is itself a monoid. -instance Monoid (m :+: n) where - mempty = MCo [] - mappend = (<>) - --- | @killR@ takes a value in a coproduct monoid and sends all the --- values from the right monoid to the identity. -killR :: Monoid m => m :+: n -> m -killR = mconcat . lefts . unMCo - --- | @killL@ takes a value in a coproduct monoid and sends all the --- values from the left monoid to the identity. -killL :: Monoid n => m :+: n -> n -killL = mconcat . rights . unMCo - --- | Take a value from a coproduct monoid where the left monoid has an --- action on the right, and \"untangle\" it into a pair of values. In --- particular, --- --- > m1 <> n1 <> m2 <> n2 <> m3 <> n3 <> ... --- --- is sent to --- --- > (m1 <> m2 <> m3 <> ..., (act m1 n1) <> (act (m1 <> m2) n2) <> (act (m1 <> m2 <> m3) n3) <> ...) --- --- That is, before combining @n@ values, every @n@ value is acted on --- by all the @m@ values to its left. -untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n) -untangle (MCo elts) = untangle' mempty elts - where untangle' cur [] = cur - untangle' (curM, curN) (Left m : elts') = untangle' (curM `mappend` m, curN) elts' - untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN `mappend` act curM n) elts' - --- | Coproducts act on other things by having each of the components --- act individually. -instance (Action m r, Action n r) => Action (m :+: n) r where - act = appEndo . mconcat . map (Endo . either act act) . unMCo diff --git a/src/Graphics/Rendering/Diagrams/Names.hs b/src/Graphics/Rendering/Diagrams/Names.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Names.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances - , FlexibleInstances - , FlexibleContexts - , TypeFamilies - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , OverlappingInstances - , TupleSections - , GADTs - , DeriveDataTypeable - , UndecidableInstances - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Names --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- This module defines a type of names which can be used for referring --- to locations within diagrams, and related types. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Names - (-- * Names - -- ** Atomic names - AName(..) - - -- ** Names - , Name(..), IsName(..), (.>) - - -- ** Qualifiable - , Qualifiable(..) - - -- * Name maps - - , NameMap(..) - - -- ** Constructing name maps - , fromNames, fromNamesB - , rememberAs - - -- ** Searching within name maps - , lookupN - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.HasOrigin -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Envelope -import Graphics.Rendering.Diagrams.Transform - -import Data.VectorSpace - -import Data.List (intercalate, isSuffixOf) -import qualified Data.Map as M -import Data.Semigroup -import Control.Arrow ((***)) -import Control.Monad (mplus) - -import Control.Newtype - -import Data.Typeable - ------------------------------------------------------------- --- Names ------------------------------------------------- ------------------------------------------------------------- - --- | Class for those types which can be used as names. They must --- support 'Typeable' (to facilitate extracting them from --- existential wrappers), 'Ord' (for comparison and efficient --- storage) and 'Show'. -class (Typeable a, Ord a, Show a) => IsName a where - toName :: a -> Name - toName = Name . (:[]) . AName - -instance IsName () -instance IsName Bool -instance IsName Char -instance IsName Int -instance IsName Float -instance IsName Double -instance IsName Integer -instance IsName String -instance IsName a => IsName [a] -instance (IsName a, IsName b) => IsName (a,b) -instance (IsName a, IsName b, IsName c) => IsName (a,b,c) - --- | Atomic names. @AName@ is just an existential wrapper around --- things which are 'Typeable', 'Ord' and 'Show'. -data AName where - AName :: (Typeable a, Ord a, Show a) => a -> AName - deriving (Typeable) - -instance IsName AName where - toName = Name . (:[]) - -instance Eq AName where - (AName a1) == (AName a2) = - case cast a2 of - Nothing -> False - Just a2' -> a1 == a2' - -instance Ord AName where - (AName a1) `compare` (AName a2) = - case cast a2 of - Nothing -> show (typeOf a1) `compare` show (typeOf a2) - Just a2' -> a1 `compare` a2' - -instance Show AName where - show (AName a) = show a - --- | A (qualified) name is a (possibly empty) sequence of atomic names. -newtype Name = Name [AName] - deriving (Eq, Ord, Semigroup, Monoid, Typeable) - -instance Show Name where - show (Name ns) = intercalate " .> " $ map show ns - -instance IsName Name where - toName = id - --- | Convenient operator for writing qualified names with atomic --- components of different types. Instead of writing @toName a1 \<\> --- toName a2 \<\> toName a3@ you can just write @a1 .> a2 .> a3@. -(.>) :: (IsName a1, IsName a2) => a1 -> a2 -> Name -a1 .> a2 = toName a1 <> toName a2 - --- | Instances of 'Qualifiable' are things which can be qualified by --- prefixing them with a name. -class Qualifiable q where - -- | Qualify with the given name. - (|>) :: IsName a => a -> q -> q - --- | Of course, names can be qualified using @(.>)@. -instance Qualifiable Name where - (|>) = (.>) - -infixr 5 |> -infixr 5 .> - ------------------------------------------------------------- --- Name maps --------------------------------------------- ------------------------------------------------------------- - --- | A 'NameMap' is a map associating names to located envelopes, --- /i.e./ envelopes with concrete locations for their base --- points. There can be multiple associations for any given name. -newtype NameMap v = NameMap (M.Map Name [LocatedEnvelope v]) - deriving (Show) - -instance Newtype (NameMap v) (M.Map Name [LocatedEnvelope v]) where - pack = NameMap - unpack (NameMap m) = m - --- Note, in some sense it would be nicer to use Sets instead of a --- list, but then we would have to put Ord constraints on v --- everywhere. =P - --- Note also that we wrap the envelope with TransInv. This is because --- the base point of each envelope should be thought of as the paired --- Point, *not* as the origin of the current vector space. In other --- words, the point gets translated "for both of them". - -type instance V (NameMap v) = v - -instance Semigroup (NameMap v) where - NameMap s1 <> NameMap s2 = NameMap $ M.unionWith (++) s1 s2 - --- | 'NameMap's form a monoid with the empty map as the identity, and --- map union as the binary operation. No information is ever lost: --- if two maps have the same name in their domain, the resulting map --- will associate that name to the concatenation of the information --- associated with that name. -instance Monoid (NameMap v) where - mempty = NameMap M.empty - mappend = (<>) - -instance (AdditiveGroup (Scalar v), Fractional (Scalar v), InnerSpace v) - => HasOrigin (NameMap v) where - moveOriginTo = over NameMap . moveOriginTo - -instance (AdditiveGroup (Scalar v), InnerSpace v, Floating (Scalar v), HasLinearMap v) - => Transformable (NameMap v) where - transform = over NameMap . transform - --- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @a |> --- ns@ is the same 'NameMap' except with every name qualified by --- @a@. -instance Qualifiable (NameMap v) where - a |> (NameMap names) = NameMap $ M.mapKeys (a |>) names - --- | Construct a 'NameMap' from a list of (name, point) pairs. -fromNames :: (InnerSpace v, AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v), IsName a) - => [(a, Point v)] -> NameMap v -fromNames = NameMap . M.fromListWith (++) - . map (toName *** ((:[]) . (\p -> locateEnvelope p (getEnvelope p)))) - --- | Construct a 'NameMap' from a list of associations between names --- and located envelopes. -fromNamesB :: IsName a => [(a, LocatedEnvelope v)] -> NameMap v -fromNamesB = NameMap . M.fromListWith (++) . map (toName *** (:[])) - --- | Give a name to a located envelope. -rememberAs :: IsName a => a -> LocatedEnvelope v -> NameMap v -> NameMap v -rememberAs n b = over NameMap $ M.insertWith (++) (toName n) [b] - --- | A name acts on a name map by qualifying every name in it. -instance Action Name (NameMap v) where - act = (|>) - --- | Names don't act on anything else. -instance Action Name a - - --- Searching in name maps. - --- | Look for the given name in a name map, returning a list of --- located envelopes associated with that name. If no names match --- the given name exactly, return all the points associated with --- names of which the given name is a suffix. -lookupN :: IsName n => n -> NameMap v -> Maybe [LocatedEnvelope v] -lookupN a (NameMap m) - = M.lookup n m `mplus` - (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) - where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 - flatten [] = Nothing - flatten xs = Just . concatMap snd $ xs - n = toName a diff --git a/src/Graphics/Rendering/Diagrams/Points.hs b/src/Graphics/Rendering/Diagrams/Points.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Points.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeFamilies - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Points --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A type for /points/ (as distinct from vectors). --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Points - ( -- * Points - - Point(..), origin, (*.) - - ) where - --- We just import from Data.AffineSpace.Point (defined in the --- vector-space-points package) and re-export. We also define an --- instance of V for Point here. -import Data.AffineSpace.Point - -import Graphics.Rendering.Diagrams.V - -type instance V (Point v) = v diff --git a/src/Graphics/Rendering/Diagrams/Query.hs b/src/Graphics/Rendering/Diagrams/Query.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Query.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TypeFamilies - , GeneralizedNewtypeDeriving - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Query --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- The @Query@ module defines a type for \"queries\" on diagrams, which --- are functions from points in a vector space to some monoid. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Query - ( Query(..) - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - -import Data.VectorSpace -import Data.AffineSpace - -import Data.Semigroup -import Control.Applicative - ------------------------------------------------------------- --- Queries ----------------------------------------------- ------------------------------------------------------------- - --- | A query is a function that maps points in a vector space to --- values in some monoid. Queries naturally form a monoid, with --- two queries being combined pointwise. --- --- The idea for annotating diagrams with monoidal queries came from --- the graphics-drawingcombinators package, . -newtype Query v m = Query { runQuery :: Point v -> m } - deriving (Functor, Applicative, Semigroup, Monoid) - -type instance V (Query v m) = v - -instance VectorSpace v => HasOrigin (Query v m) where - moveOriginTo (P u) (Query f) = Query $ \p -> f (p .+^ u) - -instance HasLinearMap v => Transformable (Query v m) where - transform t (Query f) = Query $ f . papply (inv t) diff --git a/src/Graphics/Rendering/Diagrams/Style.hs b/src/Graphics/Rendering/Diagrams/Style.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Style.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables - , GADTs - , KindSignatures - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , UndecidableInstances - #-} - --- The UndecidableInstances flag is needed under 6.12.3 for the --- HasStyle (a,b) instance. - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Style --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A definition of /styles/ for diagrams as extensible, heterogeneous --- collections of attributes. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Style - ( -- * Attributes - -- $attr - - AttributeClass - , Attribute(..) - , mkAttr, mkTAttr, unwrapAttr - , applyAttr, applyTAttr - - -- * Styles - -- $style - - , Style(..) - , attrToStyle, tAttrToStyle - , getAttr, setAttr, addAttr, combineAttr - - , HasStyle(..) - - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Monoids - -import Data.Typeable - -import Control.Arrow ((***)) -import Data.Semigroup -import qualified Data.Map as M -import qualified Data.Set as S - ------------------------------------------------------------- --- Attributes -------------------------------------------- ------------------------------------------------------------- - --- $attr --- An /attribute/ is anything that determines some aspect of a --- diagram's rendering. The standard diagrams library defines several --- standard attributes (line color, line width, fill color, etc.) but --- additional attributes may easily be created. Additionally, a given --- backend need not handle (or even know about) attributes used in --- diagrams it renders. --- --- The attribute code is inspired by xmonad's @Message@ type, which --- was in turn based on ideas in: --- --- Simon Marlow. --- /An Extensible Dynamically-Typed Hierarchy of Exceptions/. --- Proceedings of the 2006 ACM SIGPLAN workshop on --- Haskell. . - --- | Every attribute must be an instance of @AttributeClass@, which --- simply guarantees 'Typeable' and 'Semigroup' constraints. The --- 'Semigroup' instance for an attribute determines how it will combine --- with other attributes of the same type. -class (Typeable a, Semigroup a) => AttributeClass a where - --- | An existential wrapper type to hold attributes. Some attributes --- are affected by transformations and some are not. -data Attribute v :: * where - Attribute :: AttributeClass a => a -> Attribute v - TAttribute :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v - -type instance V (Attribute v) = v - --- | Wrap up an attribute. -mkAttr :: AttributeClass a => a -> Attribute v -mkAttr = Attribute - --- | Wrap up a transformable attribute. -mkTAttr :: (AttributeClass a, Transformable a, V a ~ v) => a -> Attribute v -mkTAttr = TAttribute - --- | Unwrap an unknown 'Attribute' type, performing a dynamic (but --- safe) check on the type of the result. If the required type --- matches the type of the attribute, the attribute value is --- returned wrapped in @Just@; if the types do not match, @Nothing@ --- is returned. -unwrapAttr :: AttributeClass a => Attribute v -> Maybe a -unwrapAttr (Attribute a) = cast a -unwrapAttr (TAttribute a) = cast a - --- | Attributes form a semigroup, where the semigroup operation simply --- returns the right-hand attribute when the types do not match, and --- otherwise uses the semigroup operation specific to the (matching) --- types. -instance Semigroup (Attribute v) where - (Attribute a1) <> a2 = - case unwrapAttr a2 of - Nothing -> a2 - Just a2' -> Attribute (a1 <> a2') - (TAttribute a1) <> a2 = - case unwrapAttr a2 of - Nothing -> a2 - Just a2' -> TAttribute (a1 <> a2') - -instance HasLinearMap v => Transformable (Attribute v) where - transform _ (Attribute a) = Attribute a - transform t (TAttribute a) = TAttribute (transform t a) - ------------------------------------------------------------- --- Styles ------------------------------------------------ ------------------------------------------------------------- - --- $style --- A 'Style' is a heterogeneous collection of attributes, containing --- at most one attribute of any given type. This is also based on --- ideas stolen from xmonad, specifically xmonad's implementation of --- user-extensible state. - --- | A @Style@ is a heterogeneous collection of attributes, containing --- at most one attribute of any given type. -newtype Style v = Style (M.Map String (Attribute v)) - -- The String keys are serialized TypeRep values, corresponding to - -- the type of the stored attribute. - -type instance V (Style v) = v - --- | Helper function for operating on styles. -inStyle :: (M.Map String (Attribute v) -> M.Map String (Attribute v)) - -> Style v -> Style v -inStyle f (Style s) = Style (f s) - --- | Extract an attribute from a style of a particular type. If the --- style contains an attribute of the requested type, it will be --- returned wrapped in @Just@; otherwise, @Nothing@ is returned. -getAttr :: forall a v. AttributeClass a => Style v -> Maybe a -getAttr (Style s) = M.lookup ty s >>= unwrapAttr - where ty = show . typeOf $ (undefined :: a) - -- the unwrapAttr should never fail, since we maintain the invariant - -- that attributes of type T are always stored with the key "T". - --- | Create a style from a single attribute. -attrToStyle :: forall a v. AttributeClass a => a -> Style v -attrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkAttr a)) - --- | Create a style from a single transformable attribute. -tAttrToStyle :: forall a v. (AttributeClass a, Transformable a, V a ~ v) => a -> Style v -tAttrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkTAttr a)) - --- | Add a new attribute to a style, or replace the old attribute of --- the same type if one exists. -setAttr :: forall a v. AttributeClass a => a -> Style v -> Style v -setAttr a = inStyle $ M.insert (show . typeOf $ (undefined :: a)) (mkAttr a) - --- | Attempt to add a new attribute to a style, but if an attribute of --- the same type already exists, do not replace it. -addAttr :: AttributeClass a => a -> Style v -> Style v -addAttr a s = attrToStyle a <> s - --- | Add a new attribute to a style that does not already contain an --- attribute of this type, or combine it on the left with an existing --- attribute. -combineAttr :: AttributeClass a => a -> Style v -> Style v -combineAttr a s = - case getAttr s of - Nothing -> setAttr a s - Just a' -> setAttr (a <> a') s - -instance Semigroup (Style v) where - Style s1 <> Style s2 = Style $ M.unionWith (<>) s1 s2 - --- | The empty style contains no attributes; composition of styles is --- a union of attributes; if the two styles have attributes of the --- same type they are combined according to their semigroup --- structure. -instance Monoid (Style v) where - mempty = Style M.empty - mappend = (<>) - - -instance HasLinearMap v => Transformable (Style v) where - transform t = inStyle $ M.map (transform t) - --- | Styles have no action on other monoids. -instance Action (Style v) m - --- | Type class for things which have a style. -class HasStyle a where - -- | /Apply/ a style by combining it (on the left) with the - -- existing style. - applyStyle :: Style (V a) -> a -> a - -instance HasStyle (Style v) where - applyStyle = mappend - -instance (HasStyle a, HasStyle b, V a ~ V b) => HasStyle (a,b) where - applyStyle s = applyStyle s *** applyStyle s - -instance HasStyle a => HasStyle [a] where - applyStyle = fmap . applyStyle - -instance HasStyle b => HasStyle (a -> b) where - applyStyle = fmap . applyStyle - -instance HasStyle a => HasStyle (M.Map k a) where - applyStyle = fmap . applyStyle - -instance (HasStyle a, Ord a) => HasStyle (S.Set a) where - applyStyle = S.map . applyStyle - --- | Apply an attribute to an instance of 'HasStyle' (such as a --- diagram or a style). If the object already has an attribute of --- the same type, the new attribute is combined on the left with the --- existing attribute, according to their semigroup structure. -applyAttr :: (AttributeClass a, HasStyle d) => a -> d -> d -applyAttr = applyStyle . attrToStyle - --- | Apply a transformable attribute to an instance of 'HasStyle' --- (such as a diagram or a style). If the object already has an --- attribute of the same type, the new attribute is combined on the --- left with the existing attribute, according to their semigroup --- structure. -applyTAttr :: (AttributeClass a, Transformable a, V a ~ V d, HasStyle d) => a -> d -> d -applyTAttr = applyStyle . tAttrToStyle diff --git a/src/Graphics/Rendering/Diagrams/Transform.hs b/src/Graphics/Rendering/Diagrams/Transform.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Transform.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE TypeOperators - , FlexibleContexts - , FlexibleInstances - , UndecidableInstances - , TypeFamilies - , MultiParamTypeClasses - , GeneralizedNewtypeDeriving - , TypeSynonymInstances - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Transform --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- "Graphics.Rendering.Diagrams" defines the core library of primitives --- forming the basis of an embedded domain-specific language for --- describing and rendering diagrams. --- --- The @Transform@ module defines generic transformations --- parameterized by any vector space. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Transform - ( - -- * Transformations - - -- ** Invertible linear transformations - (:-:)(..), (<->), linv, lapp - - -- ** General transformations - , Transformation(..) - , inv, transp, transl - , apply - , papply - , fromLinear - - -- * The Transformable class - - , HasLinearMap - , Transformable(..) - - -- * Translational invariance - - , TransInv(..) - - -- * Vector space independent transformations - -- | Most transformations are specific to a particular vector - -- space, but a few can be defined generically over any - -- vector space. - - , translation, translate - , scaling, scale - - ) where - -import Data.AdditiveGroup -import Data.VectorSpace -import Data.AffineSpace ((.-.)) -import Data.LinearMap -import Data.Basis -import Data.MemoTrie - -import Data.Semigroup -import qualified Data.Map as M -import qualified Data.Set as S - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - ------------------------------------------------------------- --- Transformations --------------------------------------- ------------------------------------------------------------- - -------------------------------------------------------- --- Invertible linear transformations ---------------- -------------------------------------------------------- - --- | @(v1 :-: v2)@ is a linear map paired with its inverse. -data (:-:) u v = (u :-* v) :-: (v :-* u) -infixr 7 :-: - --- | Create an invertible linear map from two functions which are --- assumed to be linear inverses. -(<->) :: (HasLinearMap u, HasLinearMap v) => (u -> v) -> (v -> u) -> (u :-: v) -f <-> g = linear f :-: linear g - -instance HasLinearMap v => Semigroup (v :-: v) where - (f :-: f') <> (g :-: g') = f *.* g :-: g' *.* f' - --- | Invertible linear maps from a vector space to itself form a --- monoid under composition. -instance HasLinearMap v => Monoid (v :-: v) where - mempty = idL :-: idL - mappend = (<>) - --- | Invert a linear map. -linv :: (u :-: v) -> (v :-: u) -linv (f :-: g) = g :-: f - --- | Apply a linear map to a vector. -lapp :: (VectorSpace v, Scalar u ~ Scalar v, HasLinearMap u) => (u :-: v) -> u -> v -lapp (f :-: _) = lapply f - --------------------------------------------------- --- Affine transformations ---------------------- --------------------------------------------------- - --- | General (affine) transformations, represented by an invertible --- linear map, its /transpose/, and a vector representing a --- translation component. --- --- By the /transpose/ of a linear map we mean simply the linear map --- corresponding to the transpose of the map's matrix --- representation. For example, any scale is its own transpose, --- since scales are represented by matrices with zeros everywhere --- except the diagonal. The transpose of a rotation is the same as --- its inverse. --- --- The reason we need to keep track of transposes is because it --- turns out that when transforming a shape according to some linear --- map L, the shape's /normal vectors/ transform according to L's --- inverse transpose. This is exactly what we need when --- transforming bounding functions, which are defined in terms of --- /perpendicular/ (i.e. normal) hyperplanes. - -data Transformation v = Transformation (v :-: v) (v :-: v) v - -type instance V (Transformation v) = v - --- | Invert a transformation. -inv :: HasLinearMap v => Transformation v -> Transformation v -inv (Transformation t t' v) = Transformation (linv t) (linv t') - (negateV (lapp (linv t) v)) - --- | Get the transpose of a transformation (ignoring the translation --- component). -transp :: Transformation v -> (v :-: v) -transp (Transformation _ t' _) = t' - --- | Get the translational component of a transformation. -transl :: Transformation v -> v -transl (Transformation _ _ v) = v - --- | Transformations are closed under composition; @t1 <> t2@ is the --- transformation which performs first @t2@, then @t1@. -instance HasLinearMap v => Semigroup (Transformation v) where - Transformation t1 t1' v1 <> Transformation t2 t2' v2 - = Transformation (t1 <> t2) (t2' <> t1') (v1 ^+^ lapp t1 v2) - -instance HasLinearMap v => Monoid (Transformation v) where - mempty = Transformation mempty mempty zeroV - mappend = (<>) - --- | Transformations can act on transformable things. -instance (HasLinearMap v, v ~ (V a), Transformable a) - => Action (Transformation v) a where - act = transform - --- | Apply a transformation to a vector. Note that any translational --- component of the transformation will not affect the vector, since --- vectors are invariant under translation. -apply :: HasLinearMap v => Transformation v -> v -> v -apply (Transformation t _ _) = lapp t - --- | Apply a transformation to a point. -papply :: HasLinearMap v => Transformation v -> Point v -> Point v -papply (Transformation t _ v) (P p) = P $ lapp t p ^+^ v - --- | Create a general affine transformation from an invertible linear --- transformation and its transpose. The translational component is --- assumed to be zero. -fromLinear :: AdditiveGroup v => (v :-: v) -> (v :-: v) -> Transformation v -fromLinear l1 l2 = Transformation l1 l2 zeroV - ------------------------------------------------------------- --- The Transformable class ------------------------------- ------------------------------------------------------------- - --- | 'HasLinearMap' is a poor man's class constraint synonym, just to --- help shorten some of the ridiculously long constraint sets. -class (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v -instance (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v - --- | Type class for things @t@ which can be transformed. -class HasLinearMap (V t) => Transformable t where - - -- | Apply a transformation to an object. - transform :: Transformation (V t) -> t -> t - -instance HasLinearMap v => Transformable (Transformation v) where - transform t1 t2 = t1 <> t2 - -instance HasLinearMap v => HasOrigin (Transformation v) where - moveOriginTo p = translate (origin .-. p) - -instance Transformable t => Transformable (t,t) where - transform t (x,y) = ( transform t x - , transform t y - ) - -instance Transformable t => Transformable (t,t,t) where - transform t (x,y,z) = ( transform t x - , transform t y - , transform t z - ) - -instance Transformable t => Transformable [t] where - transform = map . transform - -instance (Transformable t, Ord t) => Transformable (S.Set t) where - transform = S.map . transform - -instance Transformable t => Transformable (M.Map k t) where - transform = M.map . transform - -instance HasLinearMap v => Transformable (Point v) where - transform = papply - -instance Transformable m => Transformable (Forgetful m) where - transform = fmap . transform - -instance Transformable m => Transformable (Deletable m) where - transform = fmap . transform - -instance Transformable Double where - transform = apply - -instance Transformable Rational where - transform = apply - ------------------------------------------------------------- --- Translational invariance ------------------------------ ------------------------------------------------------------- - --- | @TransInv@ is a wrapper which makes a transformable type --- translationally invariant; the translational component of --- transformations will no longer affect things wrapped in --- @TransInv@. -newtype TransInv t = TransInv { unTransInv :: t } - deriving (Show, Semigroup, Monoid) - -type instance V (TransInv t) = V t - -instance VectorSpace (V t) => HasOrigin (TransInv t) where - moveOriginTo = const id - -instance Transformable t => Transformable (TransInv t) where - transform tr (TransInv t) = TransInv (translate (negateV (transl tr)) . transform tr $ t) - ------------------------------------------------------------- --- Generic transformations ------------------------------- ------------------------------------------------------------- - --- | Create a translation. -translation :: HasLinearMap v => v -> Transformation v -translation = Transformation mempty mempty - --- | Translate by a vector. -translate :: (Transformable t, HasLinearMap (V t)) => V t -> t -> t -translate = transform . translation - --- | Create a uniform scaling transformation. -scaling :: (HasLinearMap v, Fractional (Scalar v)) - => Scalar v -> Transformation v -scaling s = fromLinear lin lin -- scaling is its own transpose - where lin = (s *^) <-> (^/ s) - --- | Scale uniformly in every dimension by the given scalar. -scale :: (Transformable t, Fractional (Scalar (V t)), Eq (Scalar (V t))) - => Scalar (V t) -> t -> t -scale 0 = error "scale by zero! Halp!" -- XXX what should be done here? -scale s = transform $ scaling s diff --git a/src/Graphics/Rendering/Diagrams/UDTree.hs b/src/Graphics/Rendering/Diagrams/UDTree.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/UDTree.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveFunctor - , TypeOperators - , FlexibleContexts - #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.UDTree --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Rose (n-way) trees with both upwards- and downwards-traveling --- monoidal annotations, used as the basis for representing diagrams. --- ------------------------------------------------------------------------------ -module Graphics.Rendering.Diagrams.UDTree - ( - -- * UD-trees - UDTree(..) - - -- * Constructing UD-trees - , leaf, branchD, branch - - -- * Modifying UD-trees - , applyD, applyUpre, applyUpost, mapU - - -- * Accessors and destructors - , getU, getU', foldUD, flatten - - ) where - -import Data.Semigroup - -import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.MList - --- | Abstractly, a UDTree is a rose (n-way) tree with data at the --- leaves and two types of monoidal annotations, one (called @u@) --- travelling \"up\" the tree and one (called @d@) traveling --- \"down\". --- --- Specifically, every node (both leaf nodes and internal nodes) --- has two annotations, one of type @d@ and one of type @u@, --- subject to the following constraints: --- --- * The @d@ annotation at a leaf node is equal to the 'mconcat' of --- all the @d@ annotations along the path from the root to the leaf --- node. --- --- * The @u@ annotation at an internal node is equal to @v1 --- ``mappend`` (mconcat us) ``mappend`` v2@ for some values @v1@ --- and @v2@ (possibly 'mempty'), where @us@ is the list (in --- left-right order) of the @u@ annotations on the immediate child --- nodes of the given node. Intuitively, we are \"caching\" the --- @mconcat@ of @u@ annotations from the leaves up, except that at --- any point we may insert \"extra\" information. --- --- In addition, @d@ may have an /action/ on @u@ (see the 'Action' --- type class, defined in "Graphics.Rendering.Diagrams.Monoids"), in --- which case applying a @d@ annotation to a tree will transform all --- the @u@ annotations by acting on them. The constraints on @u@ --- annotations are maintained since the action is required to be a --- monoid homomorphism. - -data UDTree u d a - = Leaf u a - | Branch u [d] [UDTree u d a] - deriving (Functor) - --- XXX need to sort out all the semigroup/monoid stuff in here! - -instance (Action d u, Monoid u, Monoid d) => Semigroup (UDTree u d a) where - t1 <> t2 = branch [t1,t2] - --- | @UDTree@s form a monoid where @mappend@ corresponds to adjoining --- two trees under a common parent root. Note that this technically --- does not satisfy associativity, but it does with respect to --- 'flatten' which is what we really care about. @mconcat@ is --- specialized to put all the trees under a single parent. -instance (Action d u, Monoid u, Monoid d) => Monoid (UDTree u d a) where - mempty = Branch mempty mempty [] - t1 `mappend` t2 = branch [t1,t2] - mconcat = branch - --- | Construct a leaf node from a @u@ annotation and datum. -leaf :: u -> a -> UDTree u d a -leaf = Leaf - --- | Construct a branch node with an explicit @d@ annotation. -branchD :: (Action d u, Monoid u) => d -> [UDTree u d a] -> UDTree u d a -branchD d ts = Branch (mconcat . map getU $ ts) [d] ts - --- | Construct a branch node with a default (identity) @d@ annotation. -branch :: (Action d u, Monoid u, Monoid d) => [UDTree u d a] -> UDTree u d a -branch ts = Branch (mconcat . map getU $ ts) [] ts - --- | Get the @u@ annotation at the root. -getU :: Action d u => UDTree u d a -> u -getU (Leaf u _) = u -getU (Branch u ds _) = foldr act u ds - --- | Get a particular component from a the @u@ annotation at the root. --- This method is provided for convenience, since its context only --- requires an action of @d@ on @u'@, rather than on @u@ in its --- entirety. -getU' :: (Action d (u' ::: Nil), u :>: u') => UDTree u d a -> u' -getU' (Leaf u _) = get u -getU' (Branch u ds _) = hd $ foldr act (get u ::: Nil) ds - where hd (u' ::: Nil) = u' - hd (Missing _) = error "Impossible case in UDTree.getU' (hd)" - --- | Add a @d@ annotation to the root, combining it (on the left) with --- any pre-existing @d@ annotation, and transforming all @u@ --- annotations by the action of @d@. -applyD :: Action d u => d -> UDTree u d a -> UDTree u d a -applyD d l@(Leaf {}) = Branch (getU l) [d] [l] -applyD d (Branch u ds ts) = Branch u (d : ds) ts - --- | Add a @u@ annotation to the root, combining it (on the left) with --- the existing @u@ annotation. -applyUpre :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a -applyUpre u' (Leaf u a) = Leaf (u' <> u) a -applyUpre u' b = Branch (u' <> getU b) [] [b] - --- | Add a @u@ annotation to the root, combining it (on the right) with --- the existing @u@ annotation. -applyUpost :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a -applyUpost u' (Leaf u a) = Leaf (u <> u') a -applyUpost u' b = Branch (getU b <> u') [] [b] - --- | Map a function over all the @u@ annotations. The function must --- be a monoid homomorphism, and must commute with the action of @d@ --- on @u@. That is, to use @mapU f@ safely it must be the case that --- @f (act d u) == act d (f u)@. -mapU :: (u -> u') -> UDTree u d a -> UDTree u' d a -mapU f (Leaf u a) = Leaf (f u) a -mapU f (Branch u ds ts) = Branch (f u) ds (map (mapU f) ts) - --- | A fold for UDTrees. -foldUD :: (Monoid r, Semigroup d, Monoid d, Action d u) - => (u -> d -> a -> r) -- ^ Function for processing leaf nodes. - -- Given the u annotation at this node, the - -- 'mconcat' of all d annotations above, and the - -- leaf value. - -> (u -> d -> r -> r) -- ^ Function for processing internal - -- nodes. Given the u and d - -- annotations at this node and the - -- 'mconcat' of the recursive results. - -> UDTree u d a -> r -foldUD = foldUD' mempty -- Pass along accumulated d value - where foldUD' d l _ (Leaf u a) - = l (act d u) d a - foldUD' d l b (Branch u ds ts) - = b (act (d <> d') u) d' (mconcat $ map (foldUD' (d <> d') l b) ts) - where d' = mconcat ds - --- | A specialized fold provided for convenience: flatten a tree into --- a list of leaves along with their @d@ annotations. -flatten :: (Semigroup d, Monoid d, Action d u) => UDTree u d a -> [(a,d)] -flatten = foldUD (\_ d a -> [(a,d)]) (\_ _ r -> r) diff --git a/src/Graphics/Rendering/Diagrams/Util.hs b/src/Graphics/Rendering/Diagrams/Util.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Util.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Util --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Various internal utilities for the diagrams project. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Util - ( - -- * Vectors - - withLength - - ) where - -import Data.VectorSpace - --- | Produce a vector with the specified length in the same direction --- as the given vector. -withLength :: (InnerSpace v, Floating (Scalar v)) => Scalar v -> v -> v -withLength l v = (l / magnitude v) *^ v diff --git a/src/Graphics/Rendering/Diagrams/V.hs b/src/Graphics/Rendering/Diagrams/V.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/V.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.MList --- Copyright : (c) 2011 diagrams-core team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Type family for identifying associated vector spaces. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.V - ( V - - ) where - -import Data.Set -import Data.Map - ------------------------------------------------------------- --- Vector spaces ------------------------------------------- ------------------------------------------------------------- - --- | Many sorts of objects have an associated vector space in which --- they live. The type function @V@ maps from objects to their --- associated vector space. -type family V a :: * - -type instance V Double = Double -type instance V Rational = Rational - --- Note, to use these instances one often needs a constraint of the form --- V a ~ V b, etc. -type instance V (a,b) = V a -type instance V (a,b,c) = V a - -type instance V (a -> b) = V b -type instance V [a] = V a -type instance V (Set a) = V a -type instance V (Map k a) = V a