diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,1837 @@ +## [v1.5.1](https://github.com/diagrams/diagrams-lib/tree/v1.5.1) (2025-12-02) + +- New `Semigroup` instance for located lines (i.e. `Located (Trail' + Line v n)`), which adds an extra segment from the end of the first + to the start of the second. + +## [v1.5.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.5.0.1) (2025-08-25) + +- Fix bug in `bezierFindRoot` that caused diagrams to hang when + computing the trace of certain degenerate Bezier curves. See + https://github.com/diagrams/diagrams-contrib/issues/91 . + +## [v1.5-r2](https://github.com/diagrams/diagrams-lib/tree/v1.5-r2) (2025-06-12) + +- Allow `optparse-applicative-0.19` + +## [v1.5-r1](https://github.com/diagrams/diagrams-lib/tree/v1.5-r1) (2025-05-17) + +- Allow `monoid-extras-0.7` + +## [v1.5](https://github.com/diagrams/diagrams-lib/tree/v1.5) (2025-02-13) + +- Allow `base-4.21` and test on GHC 9.12 +- Remove looped compilation mode options ([#372](https://github.com/diagrams/diagrams-lib/pull/372)) + - This allows us to remove the `fsnotify` dependency, which in + turn allows compiling diagrams to Wasm. + - To recover similar functionality (automatically recompiling + every time a source file changes), try an external tool like + `ghcid` or `ghciwatch`, or, more generically, `entr`. + +## [v1.4.7](https://github.com/diagrams/diagrams-lib/tree/v1.4.7) (2024-10-26) + +- Switch to `data-default-0.8` instead of `data-default-class` + +## [v1.4.6.2-r3](https://github.com/diagrams/diagrams-lib/tree/v1.4.6.2-r3) (2024-08-23) + +- Allow `hashable-1.5` + +## [v1.4.6.2-r2](https://github.com/diagrams/diagrams-lib/tree/v1.4.6.2-r2) (2024-07-01) + +- Allow `tasty-quickcheck-0.11` + +## [v1.4.6.2-r1](https://github.com/diagrams/diagrams-lib/tree/v1.4.6.2-r1) (2024-05-01) + +- Allow `base-4.21` (GHC 9.10), `containers-0.7`, `lens-5.3`, and `filepath-1.5` + +## [v1.4.6.2](https://github.com/diagrams/diagrams-lib/tree/v1.4.6.2) (2024-05-01) + +- Support for `linear-1.23`. This version of `linear` introduces a + breaking change, so add an internal compatibility module that allows + diagrams to work with any version of `linear` both before and after + the change. + +## [v1.4.6.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.6.1) (2024-02-26) + +- Fix compilation on BSD ([#367](https://github.com/diagrams/diagrams-lib/pull/367), thanks to Finn Espen Gundersen) + +## [v1.4.6-r4](https://github.com/diagrams/diagrams-lib/tree/v1.4.6-r4) (2024-01-11) + +- Allow `base-4.19` and test with GHC 9.8 +- Allow `text-2.1` + +## [v1.4.6-r3](https://github.com/diagrams/diagrams-lib/tree/v1.4.6-r3) (2023-09-14) + +- Allow `tasty-1.5` + +## [v1.4.6-r2](https://github.com/diagrams/diagrams-lib/tree/v1.4.6-r2) (2023-08-16) + +- Allow `bytestring-0.12` and `deepseq-1.5` + +## [v1.4.6-r1](https://github.com/diagrams/diagrams-lib/tree/v1.4.6-r1) (2023-05-25) + +- Allow `optparse-applicative-0.18` + +## [v1.4.6](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.3) (2023-05-15) + +- Allow `base-4.18`; test with GHC 9.6 (thanks to @sergv) +- Fix some warnings (thanks to @sergv) + +## [v1.4.5.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.3) (2022-09-19) + +- Update to `fsnotify-0.4` + +- Revisions: + - r1: require `lens-5.1` + - r2: allow `mtl-2.3` + - r3 (3 Dec 2022): allow `linear-1.22` + +## [v1.4.5.2](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.2) (2022-09-14) + +- Fix build with `transformers-0.6` +- Fix some deprecation warnings + +## [v1.4.5.1-r3](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.1-r3) (2022-08-27) + +- Allow `base-4.17` and `lens-5.2`; test with GHC 9.4 + +## [v1.4.5.1-r2](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.1-r2) (2022-02-01) + +- Allow `optparse-applicative-0.17` + +## [v1.4.5.1-r1](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.1-r1) (2022-01-08) + +- Allow `text-2.0` + +## [v1.4.5.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.5.1) (2021-12-17) + +- Bug fix: make things compile again under versions of `lens` before 5.1. + +## [v1.4.5](https://github.com/diagrams/diagrams-lib/tree/v1.4.5) (2021-12-16) + +- Allow `base-4.16` (tested with GHC 9.2.1) +- Allow `semigroups-0.20`, `lens-5.1`, `hashable-1.4`, + `transformers-0.6` +- Add `Eq` instance for `SizeSpec` + +## [v1.4.4-r1](https://github.com/diagrams/diagrams-lib/tree/v1.4.4-r1) (2021-06-05) + +- Bumps to dependency upper bounds: + - Allow `tasty-1.4` + - Allow `bytestring-0.11` + +## [v1.4.4](https://github.com/diagrams/diagrams-lib/tree/v1.4.4) (2021-05-24) + +- Bumps to upper bounds, to allow building with: + - `base-4.15` (tested with GHC 9.0.1) + - `optparse-applicative` (tested with GHC 8.8.4 & 8.10.2) + +- Updated use of Kinds thoughout the package + +- Drop support for GHC 8.2 or earlier + +## [v1.4.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.3) (2019-11-06) + +- Bumps to upper bounds, to allow building with: + - `base-4.13` (tested with GHC 8.8.1) + - `intervals-0.9` + - `semigroups-0.19` + - `hashable-1.3` +- Many bug fixes, including + - [#313](https://github.com/diagrams/diagrams-lib/issues/313) (`combineBoundaries`) + - [#322](https://github.com/diagrams/diagrams-lib/issues/322), [#329](https://github.com/diagrams/diagrams-lib/issues/329) (`section`) + - [#325](https://github.com/diagrams/diagrams-lib/pull/325) + (Bezier/Bezier intersection) + - [#339](https://github.com/diagrams/diagrams-lib/pull/339) (`perspectiveZ1`) +- Added derived `Eq` and `Ord` instances for `FixedSegment` + +## [v1.4.2.3](https://github.com/diagrams/diagrams-lib/tree/v1.4.2.3) (2018-06-11) + +- Bug fix for `extrudeEnvelope` and friends ([#316](https://github.com/diagrams/diagrams-lib/issues/316)) + +## [v1.4.2.2](https://github.com/diagrams/diagrams-lib/tree/v1.4.2.2) (2018-05-08) + +- Fixes for GHC < 8.0 + +## [v1.4.2.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.2.1) (2018-04-13) + +- Allow `base-4.11` (GHC 8.4) +- Allow `tasty-quickcheck-0.10` +- Bug fix for `Diagrams.TwoD.Offset.capArc` ([#310](https://github.com/diagrams/diagrams-lib/pull/310)) + +## [v1.4.2-r1](https://github.com/diagrams/diagrams-lib/tree/v1.4.2-r1) (2017-12-20) + +Hackage revision to allow `tasty-1.0` in the test suite. + +## [v1.4.2](https://github.com/diagrams/diagrams-lib/tree/v1.4.2) (2017-12-20) + +- New functions: + - `boxGrid`, for computing a grid of regularly spaced points. + - `scalingRotationTo` and `scaleRotateTo`, for affine conformal 2D + transformations. +- Documentation fixes: + - `dirBetween` + - `PolyOrientation` +- Upper bound updates: allow `tasty-0.12`, `tasty-quickcheck-0.9`, + `tasty-hunit-0.10`, `optparse-applicative-0.14` +- Test with GHC 8.2.2 + +## [v1.4.1.2](https://github.com/diagrams/diagrams-lib/tree/v1.4.1.2) (2017-06-10) + +- Fix test suite compilation failure [#299](https://github.com/diagrams/diagrams-lib/issues/299). + +## [v1.4.1.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.1.1) (2017-06-06) + +- Fix `Diagrams.Points.centroid` to make it total. +- Fix bug in `Diagrams.Transform.Matrix.fromMatWithInv` (and hence + also related functions which called it, such as `fromMat22` and + `fromMat33`). + +## [v1.4.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.1) (2017-05-28) + +- New functions `embeddedImage` and `loadImageEmbBS` for loading + images. +- Fix [#289](https://github.com/diagrams/diagrams-lib/issues/289) + which could have caused strange behavior in looped compilation mode + on 32-bit platforms. +- Allow `intervals-0.8` and `directory-1.3`. +- Minor fixes to compile with GHC 8.2. + +## [v1.4.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.4.0.1) (2016-11-07) + +- Fix test suite compilation problem ([#286](https://github.com/diagrams/diagrams-lib/issues/286)) + +## [v1.4](https://github.com/diagrams/diagrams-lib/tree/v1.4) (2016-10-26) + +* **New features** + + - New `mkText'` function, which allows making a text primitive + without recommending a fill colour or font size so users can + recommend their own (*e.g.* using the `recommendFontSize` + function). + + - New functions `reflectXY` and `reflectionXY` + + - New `composeAligned` combinator for doing composition under an + alignment while leaving the local origin unaffected. + + - Add `_LocLoop` and `_LocLine` prisms + + - New `bspline` function for creating uniform cubic B-splines + + - New 3D features: + - New `Skinned` class + - Improved handling of 3D primitives + - CSG + + - New standard attributes for separate fill and stroke opacity + (see + [#248](https://github.com/diagrams/diagrams-lib/issues/248)). + + - New `HasQuery` class for things which can be spatially queried + for values from some monoid. + + - New function `inquire` for testing whether a given point is + inside a diagram. + + - New font weights: `bolder`, `lighter`, `thinWeight`, + `ultraLight`, `light`, `mediumWeight`, `heavy`, `semiBold`, + `ultraBold`. Note that currently only the SVG backend deals + with the new weights. + + - Export `GetSegmentCodomain` and update documentation + + - Improved performance of 2D rotations + +* **New instances** + + - `Alignable` instance for `Located` + + - `ToPath` instances for lines and loops + + - `Serialize` instances for `Trail`, `Path`, `Located`, `SegTree`, + `Segment` + + - `Generic` instances for `Path`, `Located` + + - `Action` instance for `Angle`: angles act by rotation. + +* **API changes** + + - `snugBL`, `snugBR`, `snugTR` and `snugBR` are deprecated. + These functions were unintuitive, ad-hoc, and not particularly useful, + especially since e.g. `snugL` and `snugB` do not commute. You + can use something like `snugB . snugL` directly, or use `snug` + with a direction vector. See + [#250](https://github.com/diagrams/diagrams-lib/issues/250) for + more details. + +* **Dependency/version changes** + + - upgrade `fsnotify` and drop dependency on deprecated + `system-filepath` + - Allow `lens-4.15` + - Many other bumped upper bounds, see release notes for minor releases + below + +* **Bug fixes** + + - fix `orientPoints` function, which was previously generating NaN + values with lists of only one or two + points. ([#210](https://github.com/diagrams/diagrams-lib/issues/210)) + + - Broken offset joins with non-vertices in loops ([#263](https://github.com/diagrams/diagrams-lib/issues/263)) + + - Properly transform arrow shaft styles ([#274](https://github.com/diagrams/diagrams-lib/issues/274)) + + - Fix sign error in `reflectionAbout` + +## [v1.3.1.4](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.4) (2016-08-16) (16 August 2016) + +- allow `optparse-applicative-0.13` + +## [v1.3.1.3](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.3) (2016-06-05) + +- allow `base-4.9` +- allow `data-default-class-0.1` +- test with GHC 8.0.1 + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.2...v1.3.1.3) + +## [v1.3.1.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.2) (2016-05-01) + +- allow `lens-4.14` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.1...v1.3.1.2) + +## [v1.3.1.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.2) (2016-02-19) + + - allow `unordered-containers-0.2.*` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.0...v1.3.1.1) + +## [v1.3.1.0](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.0) (2016-02-14) + +- improve path offset calculations + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.9...v1.3.1.0) + +## [v1.3.0.9](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.9) (2016-01-14) + +- allow `unordered-containers-0.2.6` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.8...v1.3.0.9) + +## [v1.3.0.8](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.8) (2015-11-10) + +- allow `semigroups-0.18` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.7...v1.3.0.8) + +## [v1.3.0.7](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.7) (2015-10-08) ## + +- Add `LambdaCase` extension to `.cabal` file, so `cabal` correctly + reports that `diagrams-lib` does not build on `GHC-7.4`. + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.6...v1.3.0.7) + +## [v1.3.0.6](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.6) (2015-09-29) ## + +- Allow `optparse-applicative-0.12` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.5...v1.3.0.6) + +## [v1.3.0.5](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.5) (2015-09-18) ## + +- Fix compilation problem with `lens-4.13` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.4...v1.3.0.5) + +## [v1.3.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.4) (2015-09-17) ## + +**Dependency/version changes** + +- Allow `lens-1.13` +- Allow `semigroups-0.17` +- Require `linear-1.20` + +## [v1.3.0.3](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.3) (2015-08-10) + +**Dependency/version changes** + +- Drop dependency on deprecated `system-filepath` package +- Require `fsnotify-0.2.1` + +## [v1.3.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.2) (2015-07-19) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.1...v1.3.0.2) + +## [v1.3.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.1) (2015-05-26) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3...v1.3.0.1) + +## [v1.3](https://github.com/diagrams/diagrams-lib/tree/v1.3) (2015-04-19) + +**New features** + +- Native image type that backends can specify. + +- Affine maps between spaces for path-like objects. A new + `Diagrams.ThreeD.Projections` has some helper functions for + orthographic and perspective projections. + +- Intersections for path-like objects using Bézier clipping. + +- Helper functions in `Diagrams.Matrix` for converting between + transforms and matrices. + +- New `Diagrams` module that only exports functions defined in + diagrams. + +- New `Direction` type. `Direction` is a vector that's forgot it's + magnitude. Some functions have changed their type from `R2` to + `Direction V2 n` to make it clear that magnitude has no effect. + +- Use the [`fsnotify`](https://hackage.haskell.org/package/fsnotify) + package for command line looping. Command line looping now works + on Windows. + +- `groupOpacity` function added for lowering the opacity of a + diagram as a whole. + +- New `ToPath` class for converting path-like things to a `Path`. + +**New instances** + +- `Each` instances for `BoundingBox`, `Offset`, `Segment`, + `FixedSegment` and `Path`. + +- `Reversing` instances for `Offset`, `Segment`, `FixedSegment`, + `Trail` and `Path`. + +- `AsEmpty` instances for `BoundingBox`, `Trail` and `Path`. + +- `Cons` and `Snoc` instances for `Path` and `Line`. + +- New `Show` instances for `Angle`, `Segment`, `SomeColor`, `Trail'` + and `at`. + +- `Tangent` instance for `(FixedSegment v n)`. + +- `Ord` instances for `LineMiterLimit`, `LineJoin` and `LineCap`. + +**New helper functions** + +- `_Line` and `_Loop` prisms. + +- Style lenses: `_fontSize`, `_lineWidth`, `_fillTexture`, + `_lineTexture`, `_opacity`, `_font`, `_lineCap`, `_lineJoin` + `_dashing`. + +- `_SomeColor` iso and `_AC` prism onto an `AlphaColour`. + +- `atPoints` function to zip points with diagrams. + +**API changes** + +- `Diagram` type synonym now only takes a backend token: `Diagram B` + +- Types that previously had a `v` variable now have `v` and `n`. + +- `Control.Lens` and `Data.Default.Class` are now exported from from + `Diagrams.Prelude` + +- `Measure` has a new internal representation. `Local`, `Global`, + `Normalized`, and `Output` have been renamed to `local`, `global`, + `normalized` and `output` respectivly. + +- `SizeSpec2D` has moved to `SizeSpec v n` in `Diagrams.SizeSpec`. + `Dims, Height, Width and `Absolute` have moved to `dims2D`, + `mkHeight`, `mkWidth` and `absolute` respectively. + +- `Color` instances for `Colour` and `AlphaColour` are limited to + `Double` for better type inference. + +- `under` has been renamed to `underT`. New `transformed`, + `translated`, `movedTo`, `movedFrom` and `rotated` isomorphisms to + use with lens's `under` function. + +- `stroke` is now polymorphic. Use `strokePath` or `strokeP` to get + old `stroke` behaviour. + +- `angleBetween` now works for any vector space, which means the + angle is always positive. The old behaviour can be retrieved from + `signedAngleBetween` + +- `arc` now takes a starting `Direction` and a sweep `Angle`. + `arcCW` and `arcCCW` take a start and finish `Direction`. + +**Dependency/version changes** + +- use `linear` instead of `vector-space` + +**Closed issues:** + +- Perspective deformation of square vertices yields extra point [\#244](https://github.com/diagrams/diagrams-lib/issues/244) + +- Local fontsize renders inconsistentl on diffrent backends [\#243](https://github.com/diagrams/diagrams-lib/issues/243) + +- Factor out Diagrams.Solve into a package? [\#235](https://github.com/diagrams/diagrams-lib/issues/235) + +**Merged pull requests:** + +- add pathPoints and pathVertices' functions [\#245](https://github.com/diagrams/diagrams-lib/pull/245) ([byorgey](https://github.com/byorgey)) + +- New loop [\#242](https://github.com/diagrams/diagrams-lib/pull/242) ([cchalmers](https://github.com/cchalmers)) + +- Pre 1.3 [\#241](https://github.com/diagrams/diagrams-lib/pull/241) ([cchalmers](https://github.com/cchalmers)) + +- Update CubicSpline.hs [\#240](https://github.com/diagrams/diagrams-lib/pull/240) ([fryguybob](https://github.com/fryguybob)) + +- updated changes for GHC-7.10 [\#239](https://github.com/diagrams/diagrams-lib/pull/239) ([bergey](https://github.com/bergey)) + +- split out new package diagrams-solve [\#237](https://github.com/diagrams/diagrams-lib/pull/237) ([byorgey](https://github.com/byorgey)) + +- Lens style [\#236](https://github.com/diagrams/diagrams-lib/pull/236) ([cchalmers](https://github.com/cchalmers)) + +- Half-dart arrowheads [\#234](https://github.com/diagrams/diagrams-lib/pull/234) ([byorgey](https://github.com/byorgey)) + +- TwoD.Points: Needs TypeFamilies [\#233](https://github.com/diagrams/diagrams-lib/pull/233) ([bgamari](https://github.com/bgamari)) + +- Projections [\#229](https://github.com/diagrams/diagrams-lib/pull/229) ([cchalmers](https://github.com/cchalmers)) + +## [1.2.0.9]() (2 April 2015) + + - allow `lens-4.9` + + - allow `vector-space-0.10` + +## [v1.2.0.8](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.8) (2015-01-13) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.7...v1.2.0.8) + +**Merged pull requests:** + +- typo in haddocks [\#232](https://github.com/diagrams/diagrams-lib/pull/232) ([ggreif](https://github.com/ggreif)) + +- Update diagrams-lib.cabal : bumping JuicyPixels dependency [\#230](https://github.com/diagrams/diagrams-lib/pull/230) ([Twinside](https://github.com/Twinside)) + +## [v1.2.0.7](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.7) (2014-12-07) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.6...v1.2.0.7) + +## [v1.2.0.6](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.6) (2014-12-04) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.5...v1.2.0.6) + +**Merged pull requests:** + +- Minor changes in documentation about Polygons. [\#228](https://github.com/diagrams/diagrams-lib/pull/228) ([alexDarcy](https://github.com/alexDarcy)) + +## [v1.2.0.5](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.5) (2014-11-17) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.4...v1.2.0.5) + +**Implemented enhancements:** + +- Path/trail intersection [\#209](https://github.com/diagrams/diagrams-lib/issues/209) + +- Turn R2 into D2 \(Generalize R2 to any numeric type\) [\#50](https://github.com/diagrams/diagrams-lib/issues/50) + +**Fixed bugs:** + +- `Sectionable` instance for `SegTree` is not a linear reparameterization. [\#217](https://github.com/diagrams/diagrams-lib/issues/217) + +**Closed issues:** + +- bezierFromSweep very slow? [\#227](https://github.com/diagrams/diagrams-lib/issues/227) + +- All lines render at same width [\#222](https://github.com/diagrams/diagrams-lib/issues/222) + +- numerically stable cubic rootfinder [\#204](https://github.com/diagrams/diagrams-lib/issues/204) + +**Merged pull requests:** + +- Intersections [\#226](https://github.com/diagrams/diagrams-lib/pull/226) ([cchalmers](https://github.com/cchalmers)) + +- Linear update [\#225](https://github.com/diagrams/diagrams-lib/pull/225) ([cchalmers](https://github.com/cchalmers)) + +- Add arcCCW and friends. Fix offset joins. [\#221](https://github.com/diagrams/diagrams-lib/pull/221) ([fryguybob](https://github.com/fryguybob)) + +- Reparameterize section [\#220](https://github.com/diagrams/diagrams-lib/pull/220) ([fryguybob](https://github.com/fryguybob)) + +- Diagram b v n to QDiagram b v n Any [\#219](https://github.com/diagrams/diagrams-lib/pull/219) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- New stuff [\#218](https://github.com/diagrams/diagrams-lib/pull/218) ([cchalmers](https://github.com/cchalmers)) + +- Linear [\#215](https://github.com/diagrams/diagrams-lib/pull/215) ([cchalmers](https://github.com/cchalmers)) + +## [v1.2.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.4) (2014-10-08) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.3...v1.2.0.4) + +**Merged pull requests:** + +- add semi-portable looping using fsnotify [\#213](https://github.com/diagrams/diagrams-lib/pull/213) ([bergey](https://github.com/bergey)) + +## [v1.2.0.3](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.3) (2014-09-07) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.2...v1.2.0.3) + +**Closed issues:** + +- arrowFromLocatedTrail function [\#205](https://github.com/diagrams/diagrams-lib/issues/205) + +**Merged pull requests:** + +- Added `arrowFromLocatedTrail` [\#206](https://github.com/diagrams/diagrams-lib/pull/206) ([pnutus](https://github.com/pnutus)) + +## [v1.2.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.2) (2014-08-22) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.1...v1.2.0.2) + +**Implemented enhancements:** + +- Generalize Angle class? [\#38](https://github.com/diagrams/diagrams-lib/issues/38) + +**Fixed bugs:** + +- --selection and --src both use -s abbreviation [\#172](https://github.com/diagrams/diagrams-lib/issues/172) + +**Closed issues:** + +- Spike arrowhead and tail render with oversized joint [\#203](https://github.com/diagrams/diagrams-lib/issues/203) + +**Merged pull requests:** + +- Enable compilation with GHC HEAD \(v7.9\) [\#211](https://github.com/diagrams/diagrams-lib/pull/211) ([ggreif](https://github.com/ggreif)) + +- cli-options [\#200](https://github.com/diagrams/diagrams-lib/pull/200) ([bergey](https://github.com/bergey)) + +- Add Native images to Diagrams.TwoD.Image [\#199](https://github.com/diagrams/diagrams-lib/pull/199) ([taruti](https://github.com/taruti)) + +- add atPoints, deprecate decorateFoo [\#198](https://github.com/diagrams/diagrams-lib/pull/198) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Add bg' [\#197](https://github.com/diagrams/diagrams-lib/pull/197) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- add convenience synonyms \[hv\]sep for \[hv\]cat' \(with & sep .~ x\) [\#196](https://github.com/diagrams/diagrams-lib/pull/196) ([byorgey](https://github.com/byorgey)) + +- Vertices [\#192](https://github.com/diagrams/diagrams-lib/pull/192) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Direction type [\#186](https://github.com/diagrams/diagrams-lib/pull/186) ([bergey](https://github.com/bergey)) + +## [v1.2.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.1) (2014-06-04) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2...v1.2.0.1) + +**Closed issues:** + +- Local headLength / headGaps act like Output [\#193](https://github.com/diagrams/diagrams-lib/issues/193) + +**Merged pull requests:** + +- transform Local Measure in arrow styles [\#194](https://github.com/diagrams/diagrams-lib/pull/194) ([bergey](https://github.com/bergey)) + +## [v1.2](https://github.com/diagrams/diagrams-lib/tree/v1.2) (2014-06-02) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.4...v1.2) + +**New features** + +- Several attributes (such as line width, dashing size, arrowhead + size, and font size) that formerly had a value of type `Double` + now have the more general type `Measure R2`. This allows the + attributes to be specified relative to one of four measurement + frames: `Local`, `Global`, `Normalized`, and `Output`. + +- New DSL for specifying measurements. + +- New synonyms for specifying measurements, *e.g.* `thin`, + `thick`, and `medium`, `large`. + +- Support for radial and linear gradients for fills and strokes. + +- New `DImage` type that supports both embedded and external images in + Backends that support them. + +- New `lengths` Traversal for setting `headLength` and `tailLength` + simultaneously. + +- `Frustrum` and `Box` shapes added to `Diagrams.ThreeD.Shapes`. + +- New function `quartForm` to find roots of quartic polynomials. + +- New Lenses for polar coordinates. + +- New trig functions, `sinA`, `atanA`, etc. which take `Angle` as + input or output. + +**New instances** + +- `Transformable` instances for `LineWidth`, `Dashing`, + `LineTexture`, and `FillTexture`. + +**API changes** + +- `FillColor` and `LineColor` attributes have been replaced with + the more general `FillTexture` and `LineTexture`. Use the `solid` + function to convert a color to a texture. + +- The size of arrow heads and tails is now specified in terms of + length instead of the radius of their circumcircle. + +- Gaps at the ends of arrows are now specified using `Measure R2`. + +- The `gap` traversal has been replaced by `gaps` for consistency + in naming, though `gap` is still provided for backwards compatibility. + +- `fontSize` now takes a value of type `Measure R2`. + +- Get rid of (bitrotted) `Show` backend. + +- Functions in `TwoD.Adjust` now return the adjustment + transformation itself in addition to the resized `Diagram` and + `Options` record; this can be used, *e.g.* to convert screen + coordinates back into diagram coordinates. + +- Export `pathLocSegments`. + +- The `avgScale` function has been moved to `Diagrams.Core`. + +- The `Angle` definition and related functions (*e.g.* + `angleBetween`) have moved to a separate module, `Diagrams.Angle`. + +- A separate `Diagrams.TwoD.Attributes` module now contains most + of the attributes that require 2D transformation instances. + +- The `splitColorFills` function has been replaced by `splitTextureFills`. + +**Dependency/version changes** + +- Allow `semigroups-0.15` + +- Allow `opt-parse-applicative-0.9.0 + +- Allow `lens-4.2` + +**Implemented enhancements:** + +- 'image' should be in IO [\#29](https://github.com/diagrams/diagrams-lib/issues/29) + +- Add gradient support [\#9](https://github.com/diagrams/diagrams-lib/issues/9) + +**Closed issues:** + +- fails to build against HP [\#190](https://github.com/diagrams/diagrams-lib/issues/190) + +- text does not scale [\#179](https://github.com/diagrams/diagrams-lib/issues/179) + +- Please add support for latest version of intervals library [\#170](https://github.com/diagrams/diagrams-lib/issues/170) + +- presence of arrowHead can tilt connection sideways [\#162](https://github.com/diagrams/diagrams-lib/issues/162) + +**Merged pull requests:** + +- Quartic formula, no obvious bugs [\#187](https://github.com/diagrams/diagrams-lib/pull/187) ([Mathnerd314](https://github.com/Mathnerd314)) + +- Arrow length [\#185](https://github.com/diagrams/diagrams-lib/pull/185) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- fix handling of text scaling [\#182](https://github.com/diagrams/diagrams-lib/pull/182) ([byorgey](https://github.com/byorgey)) + +- Texture [\#181](https://github.com/diagrams/diagrams-lib/pull/181) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- arrow envelopes [\#180](https://github.com/diagrams/diagrams-lib/pull/180) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- make headSize and tailSize back into ArrowOpts fields [\#177](https://github.com/diagrams/diagrams-lib/pull/177) ([byorgey](https://github.com/byorgey)) + +- updated the upper bounds of the .cabal constraints for 'semigroups' package [\#176](https://github.com/diagrams/diagrams-lib/pull/176) ([zgredzik](https://github.com/zgredzik)) + +- Image2 [\#174](https://github.com/diagrams/diagrams-lib/pull/174) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Image [\#173](https://github.com/diagrams/diagrams-lib/pull/173) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Preliminary implementation of Measure [\#159](https://github.com/diagrams/diagrams-lib/pull/159) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Gradient [\#136](https://github.com/diagrams/diagrams-lib/pull/136) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +## [v1.1.0.7]() (2014-05-15) + +- Allow `semigroups-0.14` + +## [v1.1.0.6]() (2014-04-10) + +- Allow `semigroups-0.13` + +## [v1.1.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.4) (2014-04-04) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.2...v1.1.0.4) + +**Merged pull requests:** + +- Updates to work with `Backend` redesign [\#171](https://github.com/diagrams/diagrams-lib/pull/171) ([byorgey](https://github.com/byorgey)) + +- Rework of units [\#169](https://github.com/diagrams/diagrams-lib/pull/169) ([byorgey](https://github.com/byorgey)) + +- Make Diagrams.Transform.under more polymorphic [\#168](https://github.com/diagrams/diagrams-lib/pull/168) ([FlorentBecker](https://github.com/FlorentBecker)) + +## [v1.1.0.3]() (2014-03-19) + +- Allow `lens-4.1` + +## [v1.1.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.2) (2014-03-19) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.1...v1.1.0.2) + +**Merged pull requests:** + +- move avgScale to core [\#167](https://github.com/diagrams/diagrams-lib/pull/167) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- 3d color & lighting, more solids, Angle utilities [\#166](https://github.com/diagrams/diagrams-lib/pull/166) ([bergey](https://github.com/bergey)) + +- Added bothSize function, lineHead and lineTail [\#165](https://github.com/diagrams/diagrams-lib/pull/165) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +## [v1.1.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.1) (2014-03-09) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1...v1.1.0.1) + +- Depend on `hashable` package, and add `Hashable` instance for + `SizeSpec2D`. + + Technically, the PVP specifies that adding a new instance + requires a major version bump. However, I highly doubt anyone + was making their own orphan `Hashable` instances before. Feel + free to yell at Brent if this breaks your build. + +## [v1.1](https://github.com/diagrams/diagrams-lib/tree/v1.1) (2014-03-09) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0.1...v1.1) + +**New features** + +- Support for `Deformation`s, arbitrary (non-affine) + transformations on objects such as points, paths, and located + trails (though not on diagrams). + +- New functions `clipTo`, which clips a diagram's envelope and + trace along with its visual representation, and `clipped`, which + clips the diagram's visual representation but replaces its + envelope and trace with those of the clipping path. + +- New `arrowV` function, for creating an arrow with the direction + and magnitude of a given vector. + +- `gap` traversal, for setting the head and tail gaps of an arrow + simultaneously. + +- Generalized types for `centerXY` and `snugXY`, based on new + `basis` function from `diagrams-core + +- New 3D `Transform`s, alignment, and 3D-specific `Prelude`. + +- New `frame` function similar to `pad`, but increases the envelope + of a diagram by an amount specified in local units in every direction + irrespective of the local origin. + +- New `splitFills` function for pushing fill attributes down to + subtrees containing only loops (mostly of relevance only to + backend implementors). + +**New instances** + +- `Typeable` instances for all data types that are used as diagram + primitives. + +- `Sectionable` instance for `FixedSegment`. + +**API changes** + +- `Angle` is now a type, rather than a class. It uses a single + internal representation for angles, and lenses `turn`, `rad,` + and `deg` are supplied for constructing (using `@@`) and viewing + (using `^.`) `Angle`s in various units. In addition, the `Num` + instance for `Angle` has been removed, eliminating a class of + errors where a bare number is interpreted in units other than + what you expect. + +- Removed `Num` instance for angles. + +**Dependency/version changes** + +- Require `lens >= 4.0`. + +- Allow `array-0.5`. + +- Allow `hashable-1.1`. + +- Remove `NumInstances` dependency. + +**Bug fixes** + +- Exclude joins in offsets on close segments (#160). + +- Exclude extra segment when joining loops in offset (#155). + +**Performance improvements** + +- `colorToSRGBA` function now avoids expensive matrix operations, + offering dramatic speedups in rendering diagrams with many color + attributes. + +**Implemented enhancements:** + +- Better color model in 3D [\#121](https://github.com/diagrams/diagrams-lib/issues/121) + +- Projective/perspective transforms for points and paths [\#108](https://github.com/diagrams/diagrams-lib/issues/108) + +- clipTo function [\#35](https://github.com/diagrams/diagrams-lib/issues/35) + +**Fixed bugs:** + +- Offset Bug [\#155](https://github.com/diagrams/diagrams-lib/issues/155) + +**Closed issues:** + +- Expand of an expand [\#160](https://github.com/diagrams/diagrams-lib/issues/160) + +**Merged pull requests:** + +- fix doc for === and ||| [\#164](https://github.com/diagrams/diagrams-lib/pull/164) ([denys-duchier](https://github.com/denys-duchier)) + +- Split fills [\#161](https://github.com/diagrams/diagrams-lib/pull/161) ([byorgey](https://github.com/byorgey)) + +- Exclude extra segment when joining loops in offset. Fixes \#155. [\#158](https://github.com/diagrams/diagrams-lib/pull/158) ([fryguybob](https://github.com/fryguybob)) + +- added basis, generalized `centerXY` and `snugXY` [\#157](https://github.com/diagrams/diagrams-lib/pull/157) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- derive Typeable for all data types used in Prims [\#156](https://github.com/diagrams/diagrams-lib/pull/156) ([byorgey](https://github.com/byorgey)) + +- Lens4 [\#154](https://github.com/diagrams/diagrams-lib/pull/154) ([bergey](https://github.com/bergey)) + +- removed NumInstances dependency [\#153](https://github.com/diagrams/diagrams-lib/pull/153) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Remove Num instance for Angle [\#150](https://github.com/diagrams/diagrams-lib/pull/150) ([bergey](https://github.com/bergey)) + +- Change internal color representation to SRGBA [\#149](https://github.com/diagrams/diagrams-lib/pull/149) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Projections - non-affine transformations [\#148](https://github.com/diagrams/diagrams-lib/pull/148) ([bergey](https://github.com/bergey)) + +## [v1.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.0.1) (2014-01-26) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0.0.1...v1.0.1) + +**Implemented enhancements:** + +- Module for generating nice colors/color schemes [\#77](https://github.com/diagrams/diagrams-lib/issues/77) + +**Closed issues:** + +- "Maybe.fromJust: Nothing" error when connecting translated small diagram [\#147](https://github.com/diagrams/diagrams-lib/issues/147) + +**Merged pull requests:** + +- Add Hashable instance for SizeSpec2D [\#146](https://github.com/diagrams/diagrams-lib/pull/146) ([byorgey](https://github.com/byorgey)) + +- return list of traces [\#145](https://github.com/diagrams/diagrams-lib/pull/145) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- added clipTo [\#144](https://github.com/diagrams/diagrams-lib/pull/144) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- Unified angle type [\#140](https://github.com/diagrams/diagrams-lib/pull/140) ([bergey](https://github.com/bergey)) + +## [v1.0.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.0.0.1) (2013-11-28) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0...v1.0.0.1) + +## [v1.0](https://github.com/diagrams/diagrams-lib/tree/v1.0) (2013-11-25) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7.1.1...v1.0) + +**New features** + +- New modules `Diagrams.TwoD.Arrow` and `Diagrams.TwoD.Arrowheads` + for creating arrows. + +- New module `Diagrams.Backend.CmdLine`, providing a flexible + framework for creating command-line-driven diagram rendering executables. + +- New functions in `Diagrams.Offset`: `offsetTrail` and + `offsetPath` for one-sided offsets of trails and paths; + `expandTrail` and `expandPath` for "stroking" trails and paths, + computing a path whose fill corresponds to the stroke of the + given trail or path. + +- New module `Diagrams.Tangent` for computing tangent and normal + vectors of segments, trails, and paths. + +- New functions in `Diagrams.Align` to allow diagrams to be aligned by `Trace` + called `snug`, `snugBy` and `snugCenter` + and the ability to define other boundary functions for alignment. Functions + `snugL`, `snugR`, etc. are included in `TwoD.Align`. + +- Lenses from `Control.Lens` are now used consistently for record fields + throughout the library. + +- New function `angleRatio` for calculating the ratio between two angles. + +- Restricted identity functions `asTurn`, `asRad`, and `asDeg` for + resolving type ambiguity + +- New miter limit attribute. + +- New function `annularWedge` in `TwoD.Arc` + +- New `avgScale` utility in `TwoD.Transform`, for backends which + cannot fully implement freezing of line width + +- New function `heptagon`, a vast improvement over the linguistic + frankenstein `septagon`. + +- New function `lookupName` (re-exported from `diagrams-core`) for + simple lookups of named subdiagrams + +- New function `angleBetween` to calculate the angle between two + vectors. + +- New function `arcBetween` to draw an arc between two given + points. + +- A bunch of new modules containing types, primitives and + utilities for constructing 3D diagrams: `Diagrams.ThreeD.Align`, + `.Camera`, `.Light`, `.Shapes`, `.Transform`, `.Types`, and + `.Vector`. This is still a "feature preview" (in particular, + appropriate 3D backends are still under construction). + +**New instances** + +- `AdditiveGroup` and `VectorSpace` instances for `Turn`, `Rad`, `Deg` + +- `Alignable` instance for `(->) e` + +- `Default` instances for `FillRule`, `FillRuleA`, `LineJoin`, + `LineCap`, `FillColor` + +- `Show` instances for `FillRule`, `FillRuleA` + +**API changes** + +- `e` no longer exported from `Diagrams.Prelude`. + +- `Diagrams.BoundingBox` is no longer exported from `Diagrams.Prelude`. + +- Re-export `Diagrams.Core.pointDiagram` from `Diagrams.Prelude`. + +- Added `fromAlphaColour` method to `Color` class. + +- `&` renamed to `^&` + +- Stop re-exporting `tan`, `over`, and `both` from `Data.Colour`. + +- New coordinate lenses `_x`, `_y`, and `_z` for `R2`, `P2`, `R3`, `P3` + +- Export `fullTurn` from `Diagrams.Prelude`. + +- `Codomain (Located a)` is now `Point (Codomain a)` instead of + `Located (Codomain a)`. + +- Export `domainBounds` from `Diagrams.Parametric`. + +- Adjusting functionality moved from `Diagrams.Parametric` to its + own module, `Diagrams.Parametric.Adjust`. + +- Rename `strokeT` (and primed variant) to `strokeTrail`; rename + `strokeLocT` to `strokeLocTrail`. + +- `ScaleInv` is now in its own module, `Diagrams.TwoD.Transform.ScaleInv`. + +- Re-export `Image` type (but not constructor) from `Diagrams.TwoD` + +- Removed `Floating` and `RealFloat` instances for `Turn` and `Deg` + +- `offsetSegment` now returns a `Located` instead of a tuple. + +- Removed `Num` and `Fractional` instances for `R2`. + +**Dependency/version changes** + +- Remove `newtype` dependency + +- New dependencies on `lens`, `tagged`, `optparse-applicative`, + `filepath`, `safe`, `vector-space-points`, `MemoTrie` + +- Depend on `intervals >= 0.3 && < 0.5`. + +**Bug fixes** + +- Depend on `intervals 0.3`, which allows diagrams to build on + Windows, by evading a GHCi linker bug which affects the FFI use in + previous versions of intervals ([diagrams-contrib#14](https://github.com/diagrams/diagrams-contrib/issues/14)) + +- Use point envelope at the origin for text objects instead of an + empty envelope + ([#115](https://github.com/diagrams/diagrams-lib/issues/115), + [#116](https://github.com/diagrams/diagrams-lib/issues/116)). + +- Adjusting the end of a trail now works correctly ([#95](https://github.com/diagrams/diagrams-lib/issues/95)). + +- Only look for miter join on corners in `Diagrams.TwoD.Offset` ([#118](https://github.com/diagrams/diagrams-lib/issues/118)). + +- `wedge` from `Diagrams.TwoD.Arc` is now a Loop ([#99](https://github.com/diagrams/diagrams-lib/issues/99)) + +- Arrows do not behave correctly under scaling [\#112](https://github.com/diagrams/diagrams-lib/issues/112) + +**Performance improvements** + +- `R2` is now strict and `UNPACK`ed + +- Add strictness to `Offset`, `Segment`, `OffsetEnvelope`, and `SizeSpec2D`. + +- Make `getEnvelope` calculation for `Segment` more efficient by + floating divisions out of the inner calculation. + +- Use a specialized `HasTrie` instance for `R2`. + + +**Closed issues:** + +- diagrams-lib-0.7.1.1 fails to build with ghc-7.7 \(-HEAD\) [\#128](https://github.com/diagrams/diagrams-lib/issues/128) + +- Arrow misses target [\#126](https://github.com/diagrams/diagrams-lib/issues/126) + +**Merged pull requests:** + +- Lenses for setting arrow head, tail, and shaft colors [\#138](https://github.com/diagrams/diagrams-lib/pull/138) ([byorgey](https://github.com/byorgey)) + +- Delayed subtrees [\#137](https://github.com/diagrams/diagrams-lib/pull/137) ([byorgey](https://github.com/byorgey)) + +- Add helpers for common optparse-applicative backend command line. [\#135](https://github.com/diagrams/diagrams-lib/pull/135) ([fryguybob](https://github.com/fryguybob)) + +- add located lens for access into Located things [\#134](https://github.com/diagrams/diagrams-lib/pull/134) ([byorgey](https://github.com/byorgey)) + +- add b-\>a instance for Alignable [\#133](https://github.com/diagrams/diagrams-lib/pull/133) ([cscheid](https://github.com/cscheid)) + +- Strictness optimizations [\#132](https://github.com/diagrams/diagrams-lib/pull/132) ([JohnLato](https://github.com/JohnLato)) + +- Lens [\#131](https://github.com/diagrams/diagrams-lib/pull/131) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- 3D scaling, alignment, coordinate lenses [\#129](https://github.com/diagrams/diagrams-lib/pull/129) ([bergey](https://github.com/bergey)) + +- correctly \(?\) compute shaftScale by solving a quadratic [\#127](https://github.com/diagrams/diagrams-lib/pull/127) ([byorgey](https://github.com/byorgey)) + +- calculate arrow shaftScale using projection of ends onto shaft offset [\#125](https://github.com/diagrams/diagrams-lib/pull/125) ([bergey](https://github.com/bergey)) + +- Convert from newtype to lens [\#124](https://github.com/diagrams/diagrams-lib/pull/124) ([byorgey](https://github.com/byorgey)) + +- Version bump on lens [\#123](https://github.com/diagrams/diagrams-lib/pull/123) ([haasn](https://github.com/haasn)) + +## [v0.7.1.1](https://github.com/diagrams/diagrams-lib/tree/v0.7.1.1) (2013-09-27) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7.1...v0.7.1.1) + +**Implemented enhancements:** + +- Use a point envelope for built-in text objects [\#116](https://github.com/diagrams/diagrams-lib/issues/116) + +- implement rotations in 3D [\#86](https://github.com/diagrams/diagrams-lib/issues/86) + +- Control over boundary conditions on cubic splines. [\#32](https://github.com/diagrams/diagrams-lib/issues/32) + +**Fixed bugs:** + +- diagrams with empty envelopes are not properly separated by struts [\#115](https://github.com/diagrams/diagrams-lib/issues/115) + +**Closed issues:** + +- calculate ratio between two angles [\#109](https://github.com/diagrams/diagrams-lib/issues/109) + +- Add primitives for arrows [\#73](https://github.com/diagrams/diagrams-lib/issues/73) + +**Merged pull requests:** + +- Three d render [\#114](https://github.com/diagrams/diagrams-lib/pull/114) ([bergey](https://github.com/bergey)) + +- API for computing tangent and normal vectors to segments and trails [\#113](https://github.com/diagrams/diagrams-lib/pull/113) ([byorgey](https://github.com/byorgey)) + +- change default styles for arrows [\#111](https://github.com/diagrams/diagrams-lib/pull/111) ([byorgey](https://github.com/byorgey)) + +- 3D utility functions [\#107](https://github.com/diagrams/diagrams-lib/pull/107) ([bergey](https://github.com/bergey)) + +## [v0.7.1](https://github.com/diagrams/diagrams-lib/tree/v0.7.1) (2013-09-11) + +**New features** + +- New standard miter limit attribute + +- New functions `lineColorA`, `lineWidthA`, `lineMiterLimitA`, + `fontSizeA` for directly applying attribute values + +- `setDefault2DAttributes` now sets default line cap (butt), line + join (miter), and miter limit (10) attributes + +**New instances** + +- `Data.Default` instances for + +- `LineCap` + +- `LineJoin` + +- `LineMiterLimit` + +- `LineWidth` + +- `LineColor` + +- `FontSize` + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7...v0.7.1) + +**Implemented enhancements:** + +- Path expansion. [\#55](https://github.com/diagrams/diagrams-lib/issues/55) + +- way to move diagrams closer together [\#18](https://github.com/diagrams/diagrams-lib/issues/18) + +**Fixed bugs:** + +- wedge should be closed [\#99](https://github.com/diagrams/diagrams-lib/issues/99) + +- Adjusting trail from the end has no effect [\#95](https://github.com/diagrams/diagrams-lib/issues/95) + +**Merged pull requests:** + +- Add offsetTrail and expandTrail. [\#103](https://github.com/diagrams/diagrams-lib/pull/103) ([fryguybob](https://github.com/fryguybob)) + +- change Codomain of Located to Point \(Codomain a\) [\#102](https://github.com/diagrams/diagrams-lib/pull/102) ([byorgey](https://github.com/byorgey)) + +- Default and Show instances for FillRule and FillRuleA [\#100](https://github.com/diagrams/diagrams-lib/pull/100) ([jbracker](https://github.com/jbracker)) + +- Changes required due to the introduction of Roles in GHC [\#98](https://github.com/diagrams/diagrams-lib/pull/98) ([co-dan](https://github.com/co-dan)) + +- removed default implementation of reverseDomain [\#97](https://github.com/diagrams/diagrams-lib/pull/97) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +- fixed issue \#95 [\#96](https://github.com/diagrams/diagrams-lib/pull/96) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) + +## [v0.7](https://github.com/diagrams/diagrams-lib/tree/v0.7) (2013-08-09) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.3...v0.7) + +**New features** + +- New module `Diagrams.TwoD.Curvature`, for computing the + curvature of 2D segments at any given point. + +- New module `Diagrams.Offset`, containing an `offsetSegment` + function that builds a trail a fixed distance from the original + segment. This is a precursor to planned functions `offsetTrail` + and `offsetPath`. + +- New function `Diagrams.TwoD.Transform.onBasis`, for extracting a + matrix representation of a 2D transformation + +- New functions `extrudeEnvelope` and `intrudeEnvelope`, for + extending or shrinking an envelope only in a certain direction. + +- Generalize the `Color` class to absolute colors. + This addresses concerns raised in issue #66 by letting the backend + choose which color space to render `Color` instances to. Functions are + provided for backwards compatibility with the old semantics. + +- New function `scaleInvPrim` for creating a diagram from a single + scale-invariant primitive. + +- New module `Diagrams.Parametric`, containing a collection of + classes abstracting over "parametric" things: `Parametric`, + `DomainBounds`, `EndValues`, `Sectionable`, and `HasArcLength`, + with instances for segments, trails, and related things. + +- A big refactoring of segments and trails: + + - Segments can now be either "closed" or "open". + + - There are now two types of trails: "lines" (which travel + from point A to point B) or "loops" (closed curves which end + where they started). `Trail` is now a wrapper type which can + contain both loops and lines. + + - There is a new `Located` wrapper type for adding locations to + translation-invariant things. `Path`s now consist of a + collection of `Located Trail`s. + + - The `PathLike` class is now renamed to `TrailLike`; the + `trailLike` function takes a `Located Trail` as input. + +- New convenience functions `boundaryFrom` and `boundaryFromMay`, + for computing boundaries of subdiagrams. + +- Re-export from `diagrams-lib` a lot of things defined in + `diagrams-core`, to make them easier for users to find. Several + new modules have been created as a result: `Diagrams.Query`, + `Diagrams.Envelope`, `Diagrams.Trace`, and `Diagrams.Names`. + +- Export the `centroid` function from `Diagrams.Prelude`. + +- `triangle` is now a synonym for `eqTriangle`. + +**New instances** + +- `IsPrim` instances for `Path`, `Ellipsoid`, `Image`, `Text`, and + `ScaleInv` + +- `Eq`, `Ord`, and `Show` instances for `SizeSpec2D` + +**API changes** + +- `CircleFrac` has been renamed `Turn` (though `CircleFrac` is + retained as a deprecated synonym). + +- `Diagrams.Coordinates` is no longer exported from + `Diagrams.Prelude`. This is for compatibility with `lens`, as `(&)` + is a rather important lens operator and clashes with + `Diagrams.Coordinates`. Users who want the `Coordinates` stuff can import + `Diagrams.Coordinates` explicitly. + +**Dependency/version changes** + +- allow `base-4.7` + +- upgrade to `monoid-extras-0.3` + +- depend on `data-default-class` instead of `data-default` + +- Tested with GHC 7.7. + +**Bug fixes** + +- Added a special case that was a not handled properly by the + quadratic solver, resulting in bogus envelopes in certain cases + (#88). + +- Import only `Data.NumInstances.Tuple` instead of + `Data.NumInstances`. Previously, `Diagrams.Prelude` exported + `Eq`, `Show`, and `Num` instances for functions and tuples; now + it only exports tuple instances. Users wishing to use + `Diagrams.CubicSpline` with a vector space built over functions (!?) + can import `Data.NumInstances.Function` themselves. (#48) + +- Do scaling on a `Path` *before* constructing a `TrailLike` in + `rect` (#43) + +**Implemented enhancements:** + +- Split PathLike, Trail, and Path into separate modules [\#25](https://github.com/diagrams/diagrams-lib/issues/25) + +- Add support for path-oriented diagrams. [\#13](https://github.com/diagrams/diagrams-lib/issues/13) + +**Fixed bugs:** + +- Wrong envelope for cubic segment [\#88](https://github.com/diagrams/diagrams-lib/issues/88) + +- Fix documentation of beside, \(===\), and \(|||\) re: monoidal semantics [\#83](https://github.com/diagrams/diagrams-lib/issues/83) + +- reverseTrail should not generate extra segments for closed trails [\#24](https://github.com/diagrams/diagrams-lib/issues/24) + +**Closed issues:** + +- Test issue [\#91](https://github.com/diagrams/diagrams-lib/issues/91) + +**Merged pull requests:** + +- Add parametric generalizations for segments, trails, Located, etc. [\#92](https://github.com/diagrams/diagrams-lib/pull/92) ([byorgey](https://github.com/byorgey)) + +- Adding type signature so it compiles with GHC7.7 [\#90](https://github.com/diagrams/diagrams-lib/pull/90) ([co-dan](https://github.com/co-dan)) + +- bug fix: add special case for b==0 to quadform solver [\#89](https://github.com/diagrams/diagrams-lib/pull/89) ([byorgey](https://github.com/byorgey)) + +- Big refactoring of segments and trails. [\#87](https://github.com/diagrams/diagrams-lib/pull/87) ([byorgey](https://github.com/byorgey)) + +- Stop exporting Diagrams.Coordinates from Diagrams.Prelude [\#82](https://github.com/diagrams/diagrams-lib/pull/82) ([byorgey](https://github.com/byorgey)) + +- Generalization of R2 to D2 a [\#65](https://github.com/diagrams/diagrams-lib/pull/65) ([jbracker](https://github.com/jbracker)) + +## [v0.6.0.3](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.3) (2013-05-04) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.2...v0.6.0.3) + +**Closed issues:** + +- Offset [\#80](https://github.com/diagrams/diagrams-lib/issues/80) + +**Merged pull requests:** + +- Added offsetSegment function [\#79](https://github.com/diagrams/diagrams-lib/pull/79) ([fryguybob](https://github.com/fryguybob)) + +- Working on adding curvature. [\#74](https://github.com/diagrams/diagrams-lib/pull/74) ([fryguybob](https://github.com/fryguybob)) + +- New `scaleInvPrim` function [\#71](https://github.com/diagrams/diagrams-lib/pull/71) ([byorgey](https://github.com/byorgey)) + +## [v0.6.0.2](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.2) (2013-03-29) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/types-generalized...v0.6.0.2) + +**Implemented enhancements:** + +- Don't export Eq and Show instances for functions from Diagrams.Prelude [\#48](https://github.com/diagrams/diagrams-lib/issues/48) + +**Closed issues:** + +- radius is wrong [\#75](https://github.com/diagrams/diagrams-lib/issues/75) + +**Merged pull requests:** + +- Matrix basis rep [\#78](https://github.com/diagrams/diagrams-lib/pull/78) ([bergey](https://github.com/bergey)) + +## [types-generalized](https://github.com/diagrams/diagrams-lib/tree/types-generalized) (2013-02-13) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.1...types-generalized) + +## [v0.6.0.1](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.1) (2013-01-07) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6...v0.6.0.1) + +**Fixed bugs:** + +- text on zero width rect leads to nans [\#51](https://github.com/diagrams/diagrams-lib/issues/51) + +- wrong result when using `beside` with circle and vector \(1 & \(-1\)\) [\#46](https://github.com/diagrams/diagrams-lib/issues/46) + +- Handle `rect` with zero arguments. [\#43](https://github.com/diagrams/diagrams-lib/issues/43) + +**Closed issues:** + +- Generalization of color space used in rendering [\#66](https://github.com/diagrams/diagrams-lib/issues/66) + +**Merged pull requests:** + +- do scaling on a Path before constructing PathLike in 'rect' \(fixes \#43\) [\#70](https://github.com/diagrams/diagrams-lib/pull/70) ([byorgey](https://github.com/byorgey)) + +## [v0.6](https://github.com/diagrams/diagrams-lib/tree/v0.6) (2012-12-12) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_5_0_1...v0.6) + +**New features** + +- `boundingRect` function for constructing a bounding rectangle + +- `bg` function for "setting the background color" (*i.e.* placing + atop a colored bounding rectangle) + +- New functions `setDefault2DAttributes` and `adjustDiaSize2D`. + `adjustDia2D` does both --- so the behavior of `adjustDia2D` has + not changed, but it is now possible to apply just one of the two + adjustments using the new functions. + +- `Diagrams.TwoD.Transform` now exports a `ScaleInv` type for creating + scale-invariant objects, which are only affected by rotational + and translational components of transformations. + +- The new `Diagrams.Coordinates` module provides nicer syntax for + constructing and pattern-matching point and vector literals. + +- New `fromFixedSeg` function in `Diagrams.Segment`, which + decomposes a `FixedSegment` into a starting point and a `Segment`. + +- New `withTrace` function for setting the `Trace` of a diagram. + +- Three new size-related functions: + + - New `sized` function for scaling an object to a particular size. + One particularly nice use of this is to obviate the need to keep + fiddling with the line width to get diagrams to "look right"; + just set the line width relative to some arbitrary scale + (*e.g.* assuming the final diagram will fit into a 1x1 box) and + then apply `sized` to the final diagram to make it that given + arbitrary size. It can also be used for easily making something + (a diagram, path, trail, ...) the same size as something else, + with the help of the new `sizeSpec2D` function. + + - New `sizedAs` function, for setting the size of some object to + be "the same as" some other object. + + - New `sizeSpec2D` function for conveniently calculating the size + of an object as a `SizeSpec2D` value (for use with the new `sized` + funtion). + +- New `extrudeEnvelope` and `intrudeEnvelope` functions for + modifying envelopes in a single direction only, as well as new + functions `extrude{Left,Right,Bottom,Top}` specializing + `extrudeEnvelope` to 2D. + +- `arcCW` draws clockwise arcs; `arc'` draws arcs counterclockwise + or clockwise as the radius is positive or negative, + respectively. + +- fill color attribute is generalized to support "recommended" and + "committed" colors; text objects use a recommended fill color of + black. + +**New instances** + +- The `Show` instance for `R2` now produces something like `2 & 6` + instead of `R2 { unR2 = (2,6) }`. The `Read` instance has also + been changed to match, so `read . show = id`. + +- `Enveloped` instance for `FixedSegment` + +- `Traced` instances for `Segment`, `FixedSegment`, `Trail`, and `Path` + +- New derived `Eq` instances for `LineCapA`, `LineJoinA`, `Dashing`, + `DashingA`, `FillRule`, `Font`, `FontSize`, `FontSlant`, `FontSlantA`, + `FontWeight`, and `FontWeightA` + +- `Renderable Ellipsoid NullBackend` instance + +**API changes** + +- `Data.Colour` (minus `atop` and `AffineSpace`) is now re-exported + from Diagrams.Prelude for convenience. + +- The `beneath` function is now infixl 6. + +- The `BoundingBox` module has had a complete overhaul. There is + now a special empty bounding box, and bounding boxes are an + instance of `Monoid`. + +- The type of `withEnvelope` has been slightly generalized. + +- `Diagrams.TwoD.Adjust.adjustSize` is now deprecated; it has been + renamed and moved to `Diagrams.TwoD.Size.requiredScaleT`. + +- `expandPath` has been renamed to `scalePath`. + +**Dependency/version changes** + +- Allow `data-default` 0.4 and 0.5 + +- Allow `base`-4.6 + +- Allow `containers`-0.5 + +**Bug fixes** + +- `arc` and `arcT` functions now always produce counterclockwise arcs, + as claimed. + +**Implemented enhancements:** + +- Enhancements for `arc`s. [\#54](https://github.com/diagrams/diagrams-lib/issues/54) + +- align and friends should be in terms of a new 'Alignable' class instead of 'Boundable' [\#31](https://github.com/diagrams/diagrams-lib/issues/31) + +- Tools for more accurate boundary calculations in common cases [\#30](https://github.com/diagrams/diagrams-lib/issues/30) + +- Reimplement Diagrams.TwoD.Ellipse in terms of Diagrams.TwoD.Arc [\#27](https://github.com/diagrams/diagrams-lib/issues/27) + +- Function to convert angles into 2D unit vectors [\#23](https://github.com/diagrams/diagrams-lib/issues/23) + +- 2D specialization of 'beside' which takes an angle instead of a vector [\#22](https://github.com/diagrams/diagrams-lib/issues/22) + +- Generalize showOrigin function [\#21](https://github.com/diagrams/diagrams-lib/issues/21) + +- Add generic 'extent' and 'breadth' ? functions [\#20](https://github.com/diagrams/diagrams-lib/issues/20) + +- Add shearing transformations to standard library [\#19](https://github.com/diagrams/diagrams-lib/issues/19) + +- Add support for text [\#15](https://github.com/diagrams/diagrams-lib/issues/15) + +- Allow the user to choose the fill rule used for paths when stroking [\#14](https://github.com/diagrams/diagrams-lib/issues/14) + +- Image primitives [\#10](https://github.com/diagrams/diagrams-lib/issues/10) + +- Merge polygon code from Dmitry Olshansky [\#4](https://github.com/diagrams/diagrams-lib/issues/4) + +**Fixed bugs:** + +- Enhancements for `arc`s. [\#54](https://github.com/diagrams/diagrams-lib/issues/54) + +- boundingBox computes incorrect bounding box for transformed diagrams [\#39](https://github.com/diagrams/diagrams-lib/issues/39) + +- hcat is really \*terrible\* performance-wise [\#28](https://github.com/diagrams/diagrams-lib/issues/28) + +- stroke sets the fill rule attribute to a default value, so it can't be changed later [\#26](https://github.com/diagrams/diagrams-lib/issues/26) + +- Text alignment should be with respect to descent and ascent lines rather than text bounding box [\#17](https://github.com/diagrams/diagrams-lib/issues/17) + +- incorrect bounds for Bezier segments [\#11](https://github.com/diagrams/diagrams-lib/issues/11) + +- More combinators in D.Combinators [\#5](https://github.com/diagrams/diagrams-lib/issues/5) + +**Merged pull requests:** + +- clean up and fix bugs with ScaleInv wrapper [\#69](https://github.com/diagrams/diagrams-lib/pull/69) ([byorgey](https://github.com/byorgey)) + +- Patch proposal for generalized Color [\#67](https://github.com/diagrams/diagrams-lib/pull/67) ([haasn](https://github.com/haasn)) + +- Renamed `expandPath` to `scalePath` to make room [\#61](https://github.com/diagrams/diagrams-lib/pull/61) ([fryguybob](https://github.com/fryguybob)) + +- Envelope deformation [\#60](https://github.com/diagrams/diagrams-lib/pull/60) ([mgsloan](https://github.com/mgsloan)) + +- Added `Eq` instances for some data structures. [\#59](https://github.com/diagrams/diagrams-lib/pull/59) ([fryguybob](https://github.com/fryguybob)) + +- More involved diameter benchmark + better implementation [\#58](https://github.com/diagrams/diagrams-lib/pull/58) ([mgsloan](https://github.com/mgsloan)) + +- Add NullBackend for Ellipsoid [\#57](https://github.com/diagrams/diagrams-lib/pull/57) ([mgsloan](https://github.com/mgsloan)) + +- Fixed `arc` and `arcT` so they are always CCW. [\#56](https://github.com/diagrams/diagrams-lib/pull/56) ([fryguybob](https://github.com/fryguybob)) + +- new sized, sizedAs, and sizeSpec2D functions [\#52](https://github.com/diagrams/diagrams-lib/pull/52) ([byorgey](https://github.com/byorgey)) + +- Update to track with diagrams-core renaming, and a better Show instance for R2 [\#47](https://github.com/diagrams/diagrams-lib/pull/47) ([byorgey](https://github.com/byorgey)) + +- Minor tweaks due to monoid-extra and dual-tree changes [\#45](https://github.com/diagrams/diagrams-lib/pull/45) ([byorgey](https://github.com/byorgey)) + +- split out default attribute setting and size adjustment into separate functions [\#42](https://github.com/diagrams/diagrams-lib/pull/42) ([byorgey](https://github.com/byorgey)) + +- make beneath infixl 6 [\#41](https://github.com/diagrams/diagrams-lib/pull/41) ([byorgey](https://github.com/byorgey)) + +- scale invariant [\#3](https://github.com/diagrams/diagrams-lib/pull/3) ([ludflu](https://github.com/ludflu)) + +- BoundingBox is now Monoidal [\#2](https://github.com/diagrams/diagrams-lib/pull/2) ([mgsloan](https://github.com/mgsloan)) + +- New module enabling nice syntax for constructing and pattern-matching literal points and vectors [\#1](https://github.com/diagrams/diagrams-lib/pull/1) ([byorgey](https://github.com/byorgey)) + +## [v0.5.0.1](https://github.com/diagrams/diagrams-lib/tree/0_5_0_1) (2012-07-24) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_5...0_5_0_1) + +## [v0.5](https://github.com/diagrams/diagrams-lib/tree/0_5) (2012-03-09) + +[Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_4...0_5) + +**New features** +- `mkSizeSpec` function for constructing a `SizeSpec2D` from two `Maybe Double`s + +- `beneath` as convenient synonym for `flip atop` + +- Improvements and extensions to rounded rectangles by Peter Hall: + + + `roundedRect'` allows rounded rectangles with a different radius + specified for each corner + + + both `roundedRect'` and `roundedRect` now allow negative radii, + resulting in "inverted" circular corners + +- [\#64](http://code.google.com/p/diagrams/issues/detail?id=64): New `Alignable` class for things that can be aligned. + +- `explodeTrail` and `explodePath` have been generalized to return any + `PathLike` type. + +- New path functions `pathCentroid` (compute the centroid of a + path's vertices) and `expandPath` (scale a path about its centroid). + +- Generalized `centroid` function now exported from new module + `Diagrams.Points`. + +- Initial (experimental) support for animation: + + + `Animation` and `QAnimation` defined as synonyms for `Active` + diagrams (see `active` package) + + + Instances for `Active`: `V`, `HasOrigin`, `Transformable`, + `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` + + + `animEnvelope` and `animRect` functions for automatic bounding of + animations + +- `addClosingSegment` function for making the implicit closing + segment of a closed trail explicit + +- Improvements to `BoundingBox` module from Michael Sloan: querying + of `BoundingBox` bounds, corners, extents, and transformation of + objects to fit within a given box. + +- Text alignment options from Michael Sloan + +- `view` function for restricting a diagram's envelope to a + rectangular region. + +- `iterateN` function for iterating a finite number of times + +- `atAngle` for placing two diagrams next to each other along a + specified angle. + +- `padX` and `padY` functions for padding in the X- and Y-directions + independently. + + +- generalized `showOrigin` function from Ian Ross + +- [\#40](http://code.google.com/p/diagrams/issues/detail?id=40): add shears to `Diagrams.TwoD.Transform` + +**Performance improvements** + +- Use a balanced folding scheme for `cat'`, reducing time in some + cases from \\(O(n^2)\\) to \\(O(n \\log n)\\) + +- More efficient implementation of `beside` + +**New instances** + +- `Alignable` instances for `QDiagram`, `Path`, `Envelope`, `Active`, `Set`, + `Map`, `[]` + +- `Renderable` instances for `NullBackend` (`Trail`, `Path`, `Segment`, + `Image`, `Text`) + +- Instances for `Active`: `V`, `HasOrigin`, `Transformable`, + `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` + +**API changes** + +- `R2` used to be a synonym for `(Double, Double)` but is now + abstract. To convert between pairs of `Doubles` and `R2`, use the + new functions `r2` and `unr2`. There are two reasons for this + change: + 1. to allow for future changes to the implementation of `R2`; + 2. `(Double, Double)` was an awkward special case getting in the + way of useful tuple instances for classes like `HasOrigin`, + `Enveloped`, and so on. + +- `circlePath` has been removed; its functionality has been + subsumed by `circle`. + +- `adjustSegment` now takes an extra tolerance option. + +- Ellipses are now represented using Bezier approximations rather + than a separate special type. + +- `BoundingBox` no longer has a `Transformable` instance; the old + instance was misleading at best. + +- Change semantics of `beside` (hence also `(|||)` and `(===)`) so the + result's origin is the same as that of the first argument. + +- `adjustDia2D` now takes a `SizeSpec2D`. + +- `beside` and related functions are now implemented in terms of + `juxtapose`. + +- Instead of taking an `R2`, `roundedRect` now takes a pair of + `Double`s, to be more consistent with `rect`. + +**Dependency/version changes** + +- Support for GHC 7.4.1: + + + depend on `colour` >= 2.3.2 + + + update `base` and `array` upper bounds + +- bump `vector-space` upper bound + +**Bug fixes** + +- Avoid scale by zero error in `showOrigin`. +- Base `adjustDia2D` translation on output size rather than diagram size. + +## [v0.4.0.1] () (30 October 2011) +------------------------ + +- bump `data-default` dependency to allow version 0.3 + +## [v0.4]() (23 October 2011) +-------------------- + +**documentation fixes** + +**New functions and primitives** + ++ `wedge` shape primitive + ++ `fromDirection` function for converting angles to 2D unit vectors; + + inverse function `direction` generalized to return any Angle type ++ New functions for computing and adjusting segment lengths + ++ `scaleUToX` and `scaleUToY` for doing uniform scales + resulting in a desired width or height. + ++ `circlePath`, `reversePath`, `decoratePath` + + +**New features** + ++ Completely new and improved polygon generation API + ++ Cubic splines + ++ User-controllable path fill rules + +**Bug fixes** + ++ fix incorrect corner case in arc generation + ++ fix incorrect `reverseTrail` function + +## [v0.3]() (18 June 2011) +----------------- + +**New features** + ++ new customizable `stroke'` function which lets you assign names to + path vertices + ++ `circle` and `square` functions now take a size argument + ++ function for adjusting 2D diagrams to requested size abstracted + from cairo backend + ++ generalize `PathLike` class to include an instance for diagrams, + and collapse things like `polygon`/`polygonPath` into a single + polymorphic function + ++ basic text support + ++ basic support for external images + ++ very sketchy initial proof-of-concept library of 3D primitives. + See also diagrams-povray package. + +**Bug fixes** + ++ Issue 32 (`mempty` not behaving correctly within concatenations) + +## [v0.2]() (3 June 2011) +---------------- + +**New functions and primitives** + ++ `scaleToX` and `scaleToY` for scaling to an absolute width/height + ++ `reverseTrail` + ++ new `Angle` class and ability to use radians, degrees, or circle fractions + for specifying angles + ++ `rotateAbout` and `reflectAbout` transformations based on new conjugation functions + ++ `rect` and `roundedRect` primitives + ++ `explodeTrail`/`Path` for breaking trails and paths into individual segments + +**New features** + ++ opacity attribute + ++ support for path clipping + +* **New modules** + + `Diagrams.BoundingBox` + +**Fixes and updates** + + ++ `withBounds` now properly uses the new bounds instead of just combining + them with the old + +## [v0.1.1]() (18 May 2011) +------------------ + +* minor documentation fixes + +* link to new website + +## [v0.1]() [17 May 2011] +---------------- + +* initial preview release + +\* *This Change Log was automatically generated by (and then edited by hand) [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)* diff --git a/CHANGES.markdown b/CHANGES.markdown deleted file mode 100644 --- a/CHANGES.markdown +++ /dev/null @@ -1,405 +0,0 @@ -0.7.1.1 (27 September 2013) ---------------------------- - -* allow semigroups-0.11 - -0.7.1 (11 September 2013) -------------------------- - -* **New features** - - - New standard miter limit attribute - - New functions `lineColorA`, `lineWidthA`, `lineMiterLimitA`, - `fontSizeA` for directly applying attribute values - - `setDefault2DAttributes` now sets default line cap (butt), line - join (miter), and miter limit (10) attributes - -* **New instances** - - - `Data.Default` instances for - - `LineCap` - - `LineJoin` - - `LineMiterLimit` - - `LineWidth` - - `LineColor` - - `FontSize` - -0.7 (9 August 2013) -------------------- - -* **New features** - - - New module `Diagrams.TwoD.Curvature`, for computing the - curvature of 2D segments at any given point. - - New module `Diagrams.Offset`, containing an `offsetSegment` - function that builds a trail a fixed distance from the original - segment. This is a precursor to planned functions `offsetTrail` - and `offsetPath`. - - New function `Diagrams.TwoD.Transform.onBasis`, for extracting a - matrix representation of a 2D transformation - - New functions `extrudeEnvelope` and `intrudeEnvelope`, for - extending or shrinking an envelope only in a certain direction. - - Generalize the `Color` class to absolute colors. - This addresses concerns raised in issue #66 by letting the backend - choose which color space to render `Color` instances to. Functions are - provided for backwards compatibility with the old semantics. - - New function `scaleInvPrim` for creating a diagram from a single - scale-invariant primitive. - - New module `Diagrams.Parametric`, containing a collection of - classes abstracting over "parametric" things: `Parametric`, - `DomainBounds`, `EndValues`, `Sectionable`, and `HasArcLength`, - with instances for segments, trails, and related things. - - A big refactoring of segments and trails: - - Segments can now be either "closed" or "open". - - There are now two types of trails: "lines" (which travel - from point A to point B) or "loops" (closed curves which end - where they started). `Trail` is now a wrapper type which can - contain both loops and lines. - - There is a new `Located` wrapper type for adding locations to - translation-invariant things. `Path`s now consist of a - collection of `Located Trail`s. - - The `PathLike` class is now renamed to `TrailLike`; the - `trailLike` function takes a `Located Trail` as input. - - New convenience functions `boundaryFrom` and `boundaryFromMay`, - for computing boundaries of subdiagrams. - - Re-export from `diagrams-lib` a lot of things defined in - `diagrams-core`, to make them easier for users to find. Several - new modules have been created as a result: `Diagrams.Query`, - `Diagrams.Envelope`, `Diagrams.Trace`, and `Diagrams.Names`. - - Export the `centroid` function from `Diagrams.Prelude`. - - `triangle` is now a synonym for `eqTriangle`. - -* **New instances** - - - `IsPrim` instances for `Path`, `Ellipsoid`, `Image`, `Text`, and - `ScaleInv` - - `Eq`, `Ord`, and `Show` instances for `SizeSpec2D` - -* **API changes** - - - `CircleFrac` has been renamed `Turn` (though `CircleFrac` is - retained as a deprecated synonym). - - `Diagrams.Coordinates` is no longer exported from - `Diagrams.Prelude`. This is for compatibility with `lens`, as `(&)` - is a rather important lens operator and clashes with - `Diagrams.Coordinates`. Users who want the `Coordinates` stuff can import - `Diagrams.Coordinates` explicitly. - -* **Dependency/version changes** - - - allow `base-4.7` - - upgrade to `monoid-extras-0.3` - - depend on `data-default-class` instead of `data-default` - - Tested with GHC 7.7. - -* **Bug fixes** - - - Added a special case that was a not handled properly by the - quadratic solver, resulting in bogus envelopes in certain cases - (#88). - - Import only `Data.NumInstances.Tuple` instead of - `Data.NumInstances`. Previously, `Diagrams.Prelude` exported - `Eq`, `Show`, and `Num` instances for functions and tuples; now - it only exports tuple instances. Users wishing to use - `Diagrams.CubicSpline` with a vector space built over functions (!?) - can import `Data.NumInstances.Function` themselves. (#48) - - Do scaling on a `Path` *before* constructing a `TrailLike` in - `rect` (#43) - -0.6.0.3 (4 May 2013) --------------------- - -* bump upper bound to allow `NumInstances-1.3` - -0.6.0.2 (28 March 2013) ------------------------ - -* bump upper bound to allow `NumInstances-1.2` - -* Quadratic solver is now more numerically stable, getting rid of some - incorrect behavior of `juxtapose` - ([\#46](https://github.com/diagrams/diagrams-lib/issues/46)) - -0.6.0.1: 7 January 2013 ------------------------ - -* allow `semigroups-0.9` - -0.6: 11 December 2012 ---------------------- - -* **New features** - - - `boundingRect` function for constructing a bounding rectangle - - - `bg` function for "setting the background color" (*i.e.* placing - atop a colored bounding rectangle) - - - New functions `setDefault2DAttributes` and `adjustDiaSize2D`. - `adjustDia2D` does both --- so the behavior of `adjustDia2D` has - not changed, but it is now possible to apply just one of the two - adjustments using the new functions. - - - `Diagrams.TwoD.Transform` now exports a `ScaleInv` type for creating - scale-invariant objects, which are only affected by rotational - and translational components of transformations. - - - The new `Diagrams.Coordinates` module provides nicer syntax for - constructing and pattern-matching point and vector literals. - - - New `fromFixedSeg` function in `Diagrams.Segment`, which - decomposes a `FixedSegment` into a starting point and a `Segment`. - - - New `withTrace` function for setting the `Trace` of a diagram. - - - Three new size-related functions: - - - New `sized` function for scaling an object to a particular size. - One particularly nice use of this is to obviate the need to keep - fiddling with the line width to get diagrams to "look right"; - just set the line width relative to some arbitrary scale - (*e.g.* assuming the final diagram will fit into a 1x1 box) and - then apply `sized` to the final diagram to make it that given - arbitrary size. It can also be used for easily making something - (a diagram, path, trail, ...) the same size as something else, - with the help of the new `sizeSpec2D` function. - - - New `sizedAs` function, for setting the size of some object to - be "the same as" some other object. - - - New `sizeSpec2D` function for conveniently calculating the size - of an object as a `SizeSpec2D` value (for use with the new `sized` - funtion). - - - New `extrudeEnvelope` and `intrudeEnvelope` functions for - modifying envelopes in a single direction only, as well as new - functions `extrude{Left,Right,Bottom,Top}` specializing - `extrudeEnvelope` to 2D. - - - `arcCW` draws clockwise arcs; `arc'` draws arcs counterclockwise - or clockwise as the radius is positive or negative, - respectively. - - - fill color attribute is generalized to support "recommended" and - "committed" colors; text objects use a recommended fill color of - black. - -* **New instances** - - - The `Show` instance for `R2` now produces something like `2 & 6` - instead of `R2 { unR2 = (2,6) }`. The `Read` instance has also - been changed to match, so `read . show = id`. - - - `Enveloped` instance for `FixedSegment` - - - `Traced` instances for `Segment`, `FixedSegment`, `Trail`, and `Path` - - - New derived `Eq` instances for `LineCapA`, `LineJoinA`, `Dashing`, - `DashingA`, `FillRule`, `Font`, `FontSize`, `FontSlant`, `FontSlantA`, - `FontWeight`, and `FontWeightA` - - - `Renderable Ellipsoid NullBackend` instance - -* **API changes** - - - `Data.Colour` (minus `atop` and `AffineSpace`) is now re-exported - from Diagrams.Prelude for convenience. - - - The `beneath` function is now infixl 6. - - - The `BoundingBox` module has had a complete overhaul. There is - now a special empty bounding box, and bounding boxes are an - instance of `Monoid`. - - - The type of `withEnvelope` has been slightly generalized. - - - `Diagrams.TwoD.Adjust.adjustSize` is now deprecated; it has been - renamed and moved to `Diagrams.TwoD.Size.requiredScaleT`. - - - `expandPath` has been renamed to `scalePath`. - -* **Dependency/version changes** - - - Allow `data-default` 0.4 and 0.5 - - Allow `base`-4.6 - - Allow `containers`-0.5 - -* **Bug fixes** - - - `arc` and `arcT` functions now always produce counterclockwise arcs, - as claimed. - -0.5: 9 March 2012 ------------------ - -* **New features** - - `mkSizeSpec` function for constructing a `SizeSpec2D` from two `Maybe Double`s - - `beneath` as convenient synonym for `flip atop` - - Improvements and extensions to rounded rectangles by Peter Hall: - + `roundedRect'` allows rounded rectangles with a different radius - specified for each corner - + both `roundedRect'` and `roundedRect` now allow negative radii, - resulting in "inverted" circular corners - - [\#64](http://code.google.com/p/diagrams/issues/detail?id=64): New `Alignable` class for things that can be aligned. - - `explodeTrail` and `explodePath` have been generalized to return any - `PathLike` type. - - New path functions `pathCentroid` (compute the centroid of a - path's vertices) and `expandPath` (scale a path about its centroid). - - Generalized `centroid` function now exported from new module - `Diagrams.Points`. - - Initial (experimental) support for animation: - + `Animation` and `QAnimation` defined as synonyms for `Active` - diagrams (see `active` package) - + Instances for `Active`: `V`, `HasOrigin`, `Transformable`, - `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` - + `animEnvelope` and `animRect` functions for automatic bounding of - animations - - `addClosingSegment` function for making the implicit closing - segment of a closed trail explicit - - Improvements to `BoundingBox` module from Michael Sloan: querying - of `BoundingBox` bounds, corners, extents, and transformation of - objects to fit within a given box. - - Text alignment options from Michael Sloan - - `view` function for restricting a diagram's envelope to a - rectangular region. - - `iterateN` function for iterating a finite number of times - - `atAngle` for placing two diagrams next to each other along a - specified angle. - - `padX` and `padY` functions for padding in the X- and Y-directions - independently. - - generalized `showOrigin` function from Ian Ross - - [\#40](http://code.google.com/p/diagrams/issues/detail?id=40): add shears to `Diagrams.TwoD.Transform` - -* **Performance improvements** - - Use a balanced folding scheme for `cat'`, reducing time in some - cases from \\(O(n^2)\\) to \\(O(n \\log n)\\) - - More efficient implementation of `beside` - -* **New instances** - - `Alignable` instances for `QDiagram`, `Path`, `Envelope`, `Active`, `Set`, - `Map`, `[]` - - `Renderable` instances for `NullBackend` (`Trail`, `Path`, `Segment`, - `Image`, `Text`) - - Instances for `Active`: `V`, `HasOrigin`, `Transformable`, - `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` - -* **API changes** - - `R2` used to be a synonym for `(Double, Double)` but is now - abstract. To convert between pairs of `Doubles` and `R2`, use the - new functions `r2` and `unr2`. There are two reasons for this - change: - 1. to allow for future changes to the implementation of `R2`; - 2. `(Double, Double)` was an awkward special case getting in the - way of useful tuple instances for classes like `HasOrigin`, - `Enveloped`, and so on. - - `circlePath` has been removed; its functionality has been - subsumed by `circle`. - - `adjustSegment` now takes an extra tolerance option. - - Ellipses are now represented using Bezier approximations rather - than a separate special type. - - `BoundingBox` no longer has a `Transformable` instance; the old - instance was misleading at best. - - Change semantics of `beside` (hence also `(|||)` and `(===)`) so the - result's origin is the same as that of the first argument. - - `adjustDia2D` now takes a `SizeSpec2D`. - - `beside` and related functions are now implemented in terms of - `juxtapose`. - - Instead of taking an `R2`, `roundedRect` now takes a pair of - `Double`s, to be more consistent with `rect`. - -* **Dependency/version changes** - - Support for GHC 7.4.1: - + depend on `colour` >= 2.3.2 - + update `base` and `array` upper bounds - - bump `vector-space` upper bound - -* **Bug fixes** - - Avoid scale by zero error in `showOrigin`. - - Base `adjustDia2D` translation on output size rather than diagram size. - -0.4.0.1: 30 October 2011 ------------------------- - -* bump `data-default` dependency to allow version 0.3 - -0.4: 23 October 2011 --------------------- - -* **documentation fixes** - -* **New functions and primitives** - - + `wedge` shape primitive - + `fromDirection` function for converting angles to 2D unit vectors; - inverse function `direction` generalized to return any Angle type - + New functions for computing and adjusting segment lengths - + `scaleUToX` and `scaleUToY` for doing uniform scales - resulting in a desired width or height. - + `circlePath`, `reversePath`, `decoratePath` - -* **New features** - - + Completely new and improved polygon generation API - + Cubic splines - + User-controllable path fill rules - -* **Bug fixes** - - + fix incorrect corner case in arc generation - + fix incorrect `reverseTrail` function - -0.3: 18 June 2011 ------------------ - -* **New features** - + new customizable `stroke'` function which lets you assign names to - path vertices - + `circle` and `square` functions now take a size argument - + function for adjusting 2D diagrams to requested size abstracted - from cairo backend - + generalize `PathLike` class to include an instance for diagrams, - and collapse things like `polygon`/`polygonPath` into a single - polymorphic function - + basic text support - + basic support for external images - + very sketchy initial proof-of-concept library of 3D primitives. - See also diagrams-povray package. - -* **Bug fixes** - + Issue 32 (`mempty` not behaving correctly within concatenations) - -0.2: 3 June 2011 ----------------- - -* **documentation fixes** - -* **New functions and primitives** - + `scaleToX` and `scaleToY` for scaling to an absolute width/height - + `reverseTrail` - + new `Angle` class and ability to use radians, degrees, or circle fractions - for specifying angles - + `rotateAbout` and `reflectAbout` transformations based on new conjugation functions - + `rect` and `roundedRect` primitives - + `explodeTrail`/`Path` for breaking trails and paths into individual segments - -* **New features** - + opacity attribute - + support for path clipping - -* **New modules** - + `Diagrams.BoundingBox` - -* **Fixes and updates** - + `withBounds` now properly uses the new bounds instead of just combining - them with the old - -0.1.1: 18 May 2011 ------------------- - -* minor documentation fixes -* link to new website - -0.1: 17 May 2011 ----------------- - -* initial preview release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,15 +1,35 @@ -Copyright (c) 2011-2013 diagrams-lib team: +Copyright (c) 2011-2016 diagrams-lib team: + Florent Becker + Jan Bracker Daniel Bergey + Vincent Berthoux + Christopher Chalmers + Michael Chavinda + Denys Duchier Daniil Frumin + Ben Gamari + Allan Gardner + Pontus Granström + Gabor Greif Niklas Haas Peter Hall + Dashiell Halpern Claude Heiland-Allen Deepak Jois + Sidharth Kapur + Taru Karttunen + John Lato + Konrad Madej + Chris Mears + Alexis Praga + Jeffrey Rosenbluth Ian Ross + Carlos Scheidegger Michael Sloan Jim Snavely Kanchalai Suveepattananont + Robert Vollmert Scott Walck Ryan Yates Brent Yorgey diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,4 +1,4 @@ -[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-lib.png)](http://travis-ci.org/diagrams/diagrams-lib) +[![Build Status](https://github.com/diagrams/diagrams-lib/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/diagrams/diagrams-lib/actions/workflows/haskell-ci.yml) The standard library for [diagrams](http://projects.haskell.org/diagrams/), a Haskell embedded diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,29 +1,2 @@ -import Data.List (isSuffixOf) import Distribution.Simple -import Distribution.Simple.Setup (Flag (..), HaddockFlags, - haddockDistPref) -import Distribution.Simple.Utils (copyFiles) -import Distribution.Text (display) -import Distribution.Verbosity (normal) -import System.Directory (getDirectoryContents) -import System.FilePath (()) - --- Ugly hack, logic copied from Distribution.Simple.Haddock -haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath -haddockOutputDir flags pkg = destDir - where - baseDir = case haddockDistPref flags of - NoFlag -> "." - Flag x -> x - destDir = baseDir "doc" "html" display (packageName pkg) - -diagramsDir = "diagrams" - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { postHaddock = \args flags pkg lbi -> do - dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents diagramsDir - copyFiles normal (haddockOutputDir flags pkg) - (map (\d -> ("", diagramsDir d)) dias) - postHaddock simpleUserHooks args flags pkg lbi - } +main = defaultMain diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 0.7.1.1 +Version: 1.5.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created @@ -7,83 +7,176 @@ multiple backends. diagrams-lib provides a standard library of primitives and operations for creating diagrams. To get started using it, see - "Diagrams.Prelude". -Homepage: http://projects.haskell.org/diagrams + the "Diagrams" module, and refer to the tutorials and + documentation on the diagrams website, + . +Homepage: http://diagrams.github.io License: BSD3 License-file: LICENSE Author: Brent Yorgey Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics -Build-type: Custom -Cabal-version: >=1.10 -Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Build-type: Simple +Cabal-version: 1.18 +Extra-source-files: diagrams/*.svg +Extra-doc-files: CHANGELOG.md, README.markdown, diagrams/*.svg +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 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git Library - Exposed-modules: Diagrams.Prelude, + Exposed-modules: Diagrams, + Diagrams.Prelude, Diagrams.Align, + Diagrams.Angle, + Diagrams.Animation, + Diagrams.Animation.Active, + Diagrams.Attributes, + Diagrams.Attributes.Compile, + Diagrams.Backend.CmdLine, + Diagrams.BoundingBox, Diagrams.Combinators, Diagrams.Coordinates, - Diagrams.Attributes, - Diagrams.Points, + Diagrams.CubicSpline, + Diagrams.CubicSpline.Boehm, + Diagrams.CubicSpline.Internal, + Diagrams.Deform + Diagrams.Direction, + Diagrams.Envelope, + Diagrams.LinearMap, Diagrams.Located, + Diagrams.Names, Diagrams.Parametric, + Diagrams.Parametric.Adjust, + Diagrams.Path, + Diagrams.Points, + Diagrams.Query, Diagrams.Segment, + Diagrams.Size, + Diagrams.Tangent, + Diagrams.ThreeD, + Diagrams.ThreeD.Align, + Diagrams.ThreeD.Attributes, + Diagrams.ThreeD.Camera, + Diagrams.ThreeD.Deform, + Diagrams.ThreeD.Light, + Diagrams.ThreeD.Shapes, + Diagrams.ThreeD.Size, + Diagrams.ThreeD.Transform, + Diagrams.ThreeD.Projection, + Diagrams.ThreeD.Types, + Diagrams.ThreeD.Vector, + Diagrams.Trace, Diagrams.Trail, Diagrams.TrailLike, - Diagrams.Path, - Diagrams.CubicSpline, - Diagrams.CubicSpline.Internal, - Diagrams.Solve, Diagrams.Transform, - Diagrams.BoundingBox, - Diagrams.Names, - Diagrams.Envelope, - Diagrams.Trace, - Diagrams.Query, + Diagrams.Transform.ScaleInv, + Diagrams.Transform.Matrix, Diagrams.TwoD, - Diagrams.TwoD.Types, + Diagrams.TwoD.Adjust, Diagrams.TwoD.Align, - Diagrams.TwoD.Combinators, - Diagrams.TwoD.Transform, - Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, - Diagrams.TwoD.Segment, + Diagrams.TwoD.Arrow, + Diagrams.TwoD.Arrowheads, + Diagrams.TwoD.Attributes, + Diagrams.TwoD.Combinators, Diagrams.TwoD.Curvature, + Diagrams.TwoD.Deform, + Diagrams.TwoD.Ellipse, + Diagrams.TwoD.Image, + Diagrams.TwoD.Model, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, + Diagrams.TwoD.Points, Diagrams.TwoD.Polygons, - Diagrams.TwoD.Shapes, - Diagrams.TwoD.Vector, + Diagrams.TwoD.Segment, + Diagrams.TwoD.Segment.Bernstein, Diagrams.TwoD.Size, - Diagrams.TwoD.Model, + Diagrams.TwoD.Shapes, Diagrams.TwoD.Text, - Diagrams.TwoD.Image, - Diagrams.TwoD.Adjust, - Diagrams.ThreeD.Types, - Diagrams.ThreeD.Shapes, - Diagrams.Animation, - Diagrams.Animation.Active, - Diagrams.Util, - Diagrams.Backend.Show - Build-depends: base >= 4.2 && < 4.8, - containers >= 0.3 && < 0.6, - array >= 0.3 && < 0.5, - semigroups >= 0.3.4 && < 0.12, - monoid-extras >= 0.3 && < 0.4, - diagrams-core >= 0.7 && < 0.8, - active >= 0.1 && < 0.2, - vector-space >= 0.7.7 && < 0.9, - NumInstances >= 1.2 && < 1.4, + Diagrams.TwoD.Transform, + Diagrams.TwoD.Types, + Diagrams.TwoD.Vector, + Diagrams.Util + other-modules: Linear.Vector.Compat + Build-depends: base >= 4.9 && < 4.22, + containers >= 0.3 && < 0.8, + array >= 0.3 && < 0.6, + semigroups >= 0.3.4 && < 0.21, + monoid-extras >= 0.6 && < 0.8, + dual-tree >= 0.2 && < 0.3, + diagrams-core >= 1.4 && < 1.6, + diagrams-solve >= 0.1 && < 0.2, + active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, - data-default-class < 0.1, - pretty >= 1.0.1.2 && < 1.2, - newtype >= 0.2 && < 0.3, + data-default >= 0.8 && < 0.9, fingertree >= 0.1 && < 0.2, - intervals >= 0.2.2 && < 0.3 + intervals >= 0.7 && < 0.10, + lens >= 5.1 && < 5.4, + tagged >= 0.7 && < 0.9, + optparse-applicative >= 0.11 && < 0.20, + filepath >= 1.4 && < 1.6, + JuicyPixels >= 3.3.4 && < 3.4, + hashable >= 1.1 && < 1.6, + linear >= 1.20.1 && < 1.24, + adjunctions >= 4.0 && < 5.0, + distributive >=0.2.2 && < 1.0, + process >= 1.1 && < 1.7, + directory >= 1.2 && < 1.4, + unordered-containers >= 0.2 && < 0.3, + text >= 0.7.1 && < 2.2, + mtl >= 2.0 && < 2.3 || >= 2.3.1 && < 2.4, + transformers >= 0.3.0 && < 0.7.0, + profunctors >= 5.0 && < 6.0, + exceptions >= 0.6 && < 1.0, + cereal >=0.4.1.1 && <0.6, + bytestring >=0.9 && <0.13, + fail >= 4.9.0.0 && <4.10 Hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 + other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, + DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, + GADTs, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, + RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, + TypeOperators, TypeSynonymInstances, UndecidableInstances, ViewPatterns, + LambdaCase + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: Diagrams.Test.Direction + , Diagrams.Test.Trail + , Diagrams.Test.Transform + , Diagrams.Test.Transform.Matrix + , Diagrams.Test.TwoD.Offset + , Diagrams.Test.TwoD.Segment + , Diagrams.Test.TwoD + , Diagrams.Test.Angle + , Instances + hs-source-dirs: test + build-depends: base, + tasty >= 0.10 && < 1.6, + tasty-hunit >= 0.9.2 && < 0.11, + tasty-quickcheck >= 0.8 && < 0.12, + QuickCheck >= 2.7, + deepseq >= 1.3 && < 1.6, + diagrams-lib, + lens, + distributive, + numeric-extras, + diagrams-solve + default-language: Haskell2010 + +benchmark benchmarks + type: exitcode-stdio-1.0 + main-is:Speed.hs + hs-source-dirs:test + default-language: Haskell2010 + build-depends: + base < 5, + criterion, + diagrams-core, + diagrams-lib diff --git a/diagrams/besideEx.svg b/diagrams/besideEx.svg deleted file mode 100644 --- a/diagrams/besideEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/closeLineEx.svg b/diagrams/closeLineEx.svg deleted file mode 100644 --- a/diagrams/closeLineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/cubicOffsetExample.svg b/diagrams/cubicOffsetExample.svg deleted file mode 100644 --- a/diagrams/cubicOffsetExample.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/cubicSplineEx.svg b/diagrams/cubicSplineEx.svg deleted file mode 100644 --- a/diagrams/cubicSplineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/decagonEx.svg b/diagrams/decagonEx.svg deleted file mode 100644 --- a/diagrams/decagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramA.svg b/diagrams/diagramA.svg deleted file mode 100644 --- a/diagrams/diagramA.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramNeg.svg b/diagrams/diagramNeg.svg deleted file mode 100644 --- a/diagrams/diagramNeg.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramPos.svg b/diagrams/diagramPos.svg deleted file mode 100644 --- a/diagrams/diagramPos.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramZero.svg b/diagrams/diagramZero.svg deleted file mode 100644 --- a/diagrams/diagramZero.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/dodecagonEx.svg b/diagrams/dodecagonEx.svg deleted file mode 100644 --- a/diagrams/dodecagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/glueLineEx.svg b/diagrams/glueLineEx.svg deleted file mode 100644 --- a/diagrams/glueLineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hendecagonEx.svg b/diagrams/hendecagonEx.svg deleted file mode 100644 --- a/diagrams/hendecagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hexagonEx.svg b/diagrams/hexagonEx.svg deleted file mode 100644 --- a/diagrams/hexagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hruleEx.svg b/diagrams/hruleEx.svg deleted file mode 100644 --- a/diagrams/hruleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/lineFromOffsetsEx.svg b/diagrams/lineFromOffsetsEx.svg deleted file mode 100644 --- a/diagrams/lineFromOffsetsEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/lineFromVerticesEx.svg b/diagrams/lineFromVerticesEx.svg deleted file mode 100644 --- a/diagrams/lineFromVerticesEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/nonagonEx.svg b/diagrams/nonagonEx.svg deleted file mode 100644 --- a/diagrams/nonagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/octagonEx.svg b/diagrams/octagonEx.svg deleted file mode 100644 --- a/diagrams/octagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/pentagonEx.svg b/diagrams/pentagonEx.svg deleted file mode 100644 --- a/diagrams/pentagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/rectEx.svg b/diagrams/rectEx.svg deleted file mode 100644 --- a/diagrams/rectEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/roundedRectEx.svg b/diagrams/roundedRectEx.svg deleted file mode 100644 --- a/diagrams/roundedRectEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/septagonEx.svg b/diagrams/septagonEx.svg deleted file mode 100644 --- a/diagrams/septagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/squareEx.svg b/diagrams/squareEx.svg deleted file mode 100644 --- a/diagrams/squareEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/src_Diagrams_Combinators_alignedEx1.svg b/diagrams/src_Diagrams_Combinators_alignedEx1.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_alignedEx1.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_alignedEx2.svg b/diagrams/src_Diagrams_Combinators_alignedEx2.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_alignedEx2.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_appendsEx.svg b/diagrams/src_Diagrams_Combinators_appendsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_appendsEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_besideEx.svg b/diagrams/src_Diagrams_Combinators_besideEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_besideEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_positionEx.svg b/diagrams/src_Diagrams_Combinators_positionEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_positionEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_strutEx.svg b/diagrams/src_Diagrams_Combinators_strutEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_strutEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_CubicSpline_Boehm_bsplineEx.svg b/diagrams/src_Diagrams_CubicSpline_Boehm_bsplineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_CubicSpline_Boehm_bsplineEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg b/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TrailLike_twiddleEx.svg b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Trail_closeLineEx.svg b/diagrams/src_Diagrams_Trail_closeLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_closeLineEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Trail_glueLineEx.svg b/diagrams/src_Diagrams_Trail_glueLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_glueLineEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_Trail_trailOffsetEx.svg b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example1.svg b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example2.svg b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg @@ -0,0 +1,1 @@ +LineCapSquareLineCapRoundLineCapButt diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg @@ -0,0 +1,1 @@ +LineJoinBevelLineJoinRoundLineJoinMiter diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg @@ -0,0 +1,1 @@ + diff --git a/diagrams/trailOffsetEx.svg b/diagrams/trailOffsetEx.svg deleted file mode 100644 --- a/diagrams/trailOffsetEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/triangleEx.svg b/diagrams/triangleEx.svg deleted file mode 100644 --- a/diagrams/triangleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/unitSquareEx.svg b/diagrams/unitSquareEx.svg deleted file mode 100644 --- a/diagrams/unitSquareEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/vruleEx.svg b/diagrams/vruleEx.svg deleted file mode 100644 --- a/diagrams/vruleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/src/Diagrams.hs b/src/Diagrams.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams +-- Copyright : (c) 2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module only contains exports defined in @diagrams-lib@ or +-- @diagrams-core@. This module can be used if you want to avoid some +-- potential conflicts with other modules, but importing +-- "Diagrams.Prelude" (which includes re-exports from other packages) +-- is often more convenient. +-- +----------------------------------------------------------------------------- + +module Diagrams + ( + -- * Core library + -- | The core definitions of transformations, diagrams, + -- backends, and so on. + module Diagrams.Core + + -- * Standard library + + -- | Attributes (color, line style, etc.) and styles. + , module Diagrams.Attributes + + -- | Alignment of diagrams relative to their envelopes. + , module Diagrams.Align + + -- | Creating and using bounding boxes. + , module Diagrams.BoundingBox + + -- | Combining multiple diagrams into one. + , module Diagrams.Combinators + + -- | Giving concrete locations to translation-invariant things. + , module Diagrams.Located + + -- | Linear and cubic bezier segments. + , module Diagrams.Segment + + -- | Trails. + , module Diagrams.Trail + + -- | Parametrization of segments and trails. + , module Diagrams.Parametric + + -- | Adjusting the length of parameterized objects. + , module Diagrams.Parametric.Adjust + + -- | Computing tangent and normal vectors of segments and + -- trails. + , module Diagrams.Tangent + + -- | Trail-like things. + , module Diagrams.TrailLike + + -- | Paths. + , module Diagrams.Path + + -- | Cubic splines. + , module Diagrams.CubicSpline + + -- | Some additional transformation-related functions, like + -- conjugation of transformations. + , module Diagrams.Transform + + -- | Projective transformations and other deformations + -- lacking an inverse. + , module Diagrams.Deform + + -- | Giving names to subdiagrams and later retrieving + -- subdiagrams by name. + , module Diagrams.Names + + -- | Envelopes, aka functional bounding regions. + , module Diagrams.Envelope + + -- | Traces, aka embedded raytracers, for finding points on + -- the boundary of a diagram. + , module Diagrams.Trace + + -- | A query is a function that maps points in a vector space + -- to values in some monoid; they can be used to annotate + -- the points of a diagram with some values. + , module Diagrams.Query + + -- | Utilities for working with points. + , module Diagrams.Points + + -- | Utilities for working with size. + , module Diagrams.Size + + -- | Angles + , module Diagrams.Angle + + -- | Convenience infix operators for working with coordinates. + , module Diagrams.Coordinates + + -- | Directions, distinguished from angles or vectors + , module Diagrams.Direction + + -- | A wide range of things (shapes, transformations, + -- combinators) specific to creating two-dimensional + -- diagrams. + , module Diagrams.TwoD + + -- | Extra things for three-dimensional diagrams. + , module Diagrams.ThreeD + + -- | Tools for making animations. + , module Diagrams.Animation + + -- | Various utility definitions. + , module Diagrams.Util + + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.Angle +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.BoundingBox hiding (contains, inside, + intersection, outside, union) +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Deform +import Diagrams.Direction hiding (dir) +import Diagrams.Envelope +import Diagrams.Located +import Diagrams.Names +import Diagrams.Parametric +import Diagrams.Parametric.Adjust +import Diagrams.Path hiding (pathPoints) +import Diagrams.Points +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Size +import Diagrams.Tangent +import Diagrams.ThreeD +import Diagrams.Trace +import Diagrams.Trail hiding (linePoints, loopPoints, + trailPoints) +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.TwoD +import Diagrams.Util + diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -21,69 +24,151 @@ ( -- * Alignable class Alignable(..) - , alignByDefault + , alignBy'Default + , envelopeBoundary + , traceBoundary -- * General alignment functions , align - , center + , snug + , centerV, center + , snugBy + , snugCenterV, snugCenter ) where import Diagrams.Core +import Diagrams.Util (applyAll) -import Data.AffineSpace (alerp) -import Data.VectorSpace +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Traversable +import Prelude +import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S +import Linear.Affine +import Linear.Metric +import Linear.Vector (negated) +import Linear.Vector.Compat (lerp) + -- | Class of things which can be aligned. class Alignable a where -- | @alignBy v d a@ moves the origin of @a@ along the vector -- @v@. If @d = 1@, the origin is moved to the edge of the - -- envelope in the direction of @v@; if @d = -1@, it moves to the - -- edge of the envelope in the direction of the negation of @v@. + -- boundary in the direction of @v@; if @d = -1@, it moves to the + -- edge of the boundary in the direction of the negation of @v@. -- Other values of @d@ interpolate linearly (so for example, @d = -- 0@ centers the origin along the direction of @v@). - alignBy :: V a -> Scalar (V a) -> a -> a + alignBy' :: (InSpace v n a, Fractional n, HasOrigin a) + => (v n -> a -> Point v n) -> v n -> n -> a -> a + alignBy' = alignBy'Default + defaultBoundary :: (V a ~ v, N a ~ n) => v n -> a -> Point v n + + alignBy :: (InSpace v n a, Fractional n, HasOrigin a) + => v n -> n -> a -> a + alignBy = alignBy' defaultBoundary + -- | Default implementation of 'alignBy' for types with 'HasOrigin' --- and 'Enveloped' instances. -alignByDefault :: (HasOrigin a, Enveloped a, Num (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a -alignByDefault v d a = moveOriginTo (alerp (envelopeP (negateV v) a) - (envelopeP v a) - ((d + 1) / 2)) - a +-- and 'AdditiveGroup' instances. +alignBy'Default :: (InSpace v n a, Fractional n, HasOrigin a) + => (v n -> a -> Point v n) -> v n -> n -> a -> a +alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) + (boundary (negated v) a) + (boundary v a) + ) a +{-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-} -instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Envelope v) where - alignBy = alignByDefault -instance (Enveloped b, HasOrigin b) => Alignable [b] where - alignBy = alignByDefault +-- | Some standard functions which can be used as the `boundary` argument to +-- `alignBy'`. +envelopeBoundary :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n +envelopeBoundary = envelopeP -instance (Enveloped b, HasOrigin b, Ord b) => Alignable (S.Set b) where - alignBy = alignByDefault +traceBoundary :: (V a ~ v, N a ~ n, Num n, Traced a) => v n -> a -> Point v n +traceBoundary v a = fromMaybe origin (maxTraceP origin v a) -instance (Enveloped b, HasOrigin b) => Alignable (M.Map k b) where - alignBy = alignByDefault +combineBoundaries + :: (InSpace v n a, Metric v, Ord n, F.Foldable f) + => (v n -> a -> Point v n) -> v n -> f a -> Point v n +combineBoundaries b v fa + = b v $ F.maximumBy (comparing (dot v . (.-.origin) . b v)) fa -instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) - , Monoid' m - ) => Alignable (QDiagram b v m) where - alignBy = alignByDefault +instance (Metric v, OrderedField n) => Alignable (Envelope v n) where + defaultBoundary = envelopeBoundary +instance (Metric v, OrderedField n) => Alignable (Trace v n) where + defaultBoundary = traceBoundary + +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable [b] where + defaultBoundary = combineBoundaries defaultBoundary + +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) + => Alignable (S.Set b) where + defaultBoundary = combineBoundaries defaultBoundary + +instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) + => Alignable (M.Map k b) where + defaultBoundary = combineBoundaries defaultBoundary + +instance (Metric v, OrderedField n, Monoid' m) + => Alignable (QDiagram b v n m) where + defaultBoundary = envelopeBoundary + +-- | Although the 'alignBy' method for the @(b -> a)@ instance is +-- sensible, there is no good implementation for +-- 'defaultBoundary'. Instead, we provide a total method, but one that +-- is not sensible. This should not present a serious problem as long +-- as your use of 'Alignable' happens through 'alignBy'. +instance (InSpace v n a, HasOrigin a, Alignable a) => Alignable (b -> a) where + alignBy v d f b = alignBy v d (f b) + defaultBoundary _ _ = origin + -- | @align v@ aligns an enveloped object along the edge in the -- direction of @v@. That is, it moves the local origin in the -- direction of @v@ until it is on the edge of the envelope. (Note -- that if the local origin is outside the envelope to begin with, -- it may have to move \"backwards\".) -align :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a +align :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a align v = alignBy v 1 --- | @center v@ centers an enveloped object along the direction of +-- | Version of @alignBy@ specialized to use @traceBoundary@ +snugBy :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) + => v n -> n -> a -> a +snugBy = alignBy' traceBoundary + +-- | Like align but uses trace. +snug :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) + => v n -> a -> a +snug v = snugBy v 1 + +-- | @centerV v@ centers an enveloped object along the direction of -- @v@. -center :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a -center v = alignBy v 0 +centerV :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a +centerV v = alignBy v 0 + +-- | @center@ centers an enveloped object along all of its basis vectors. +center :: (InSpace v n a, Fractional n, Traversable v, Alignable a, HasOrigin a) => a -> a +center = applyAll fs + where + fs = map centerV basis + +-- | Like @centerV@ using trace. +snugCenterV + :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) + => v n -> a -> a +snugCenterV v = alignBy' traceBoundary v 0 + +-- | Like @center@ using trace. +snugCenter :: (InSpace v n a, Traversable v, Fractional n, Alignable a, HasOrigin a, Traced a) + => a -> a +snugCenter = applyAll fs + where + fs = map snugCenterV basis + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Angle.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Angle +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing angles. +-- +----------------------------------------------------------------------------- + +module Diagrams.Angle + ( -- * Angle type + Angle + + -- ** Using angles + , (@@), rad, turn, deg + + -- ** Common angles + , fullTurn, halfTurn, quarterTurn + + -- ** Trigonometric functions + , sinA, cosA, tanA + , asinA, acosA, atanA, atan2A, atan2A' + + -- ** Angle utilities + , angleBetween, angleRatio, normalizeAngle + + -- ** Classes + , HasTheta(..) + , HasPhi(..) + + -- * Rotation + , rotation, rotate + ) where + +import Control.Applicative +import Control.Lens (AReview, Iso', Lens', iso, over, + review, (^.)) +import Data.Fixed +import Data.Monoid hiding ((<>)) +import Data.Monoid.Action +import Data.Semigroup +import Prelude +import Text.Read + +import Diagrams.Core (OrderedField) +import Diagrams.Core.Transform +import Diagrams.Core.V +import Diagrams.Points +import Linear.V2 (V2 (..)) + +import Linear.Metric +import Linear.Vector + +-- | Angles can be expressed in a variety of units. Internally, +-- they are represented in radians. +newtype Angle n = Radians n + deriving (Eq, Ord, Enum, Functor) + +instance Show n => Show (Angle n) where + showsPrec d (Radians a) = showParen (d > 5) $ + showsPrec 6 a . showString " @@ rad" + +instance Read n => Read (Angle n) where + readPrec = parens . prec 5 $ do + x <- readPrec + Symbol "@@" <- lexP + Ident "rad" <- lexP + pure (Radians x) + +type instance N (Angle n) = n + +instance Applicative Angle where + pure = Radians + {-# INLINE pure #-} + Radians f <*> Radians x = Radians (f x) + {-# INLINE (<*>) #-} + +instance Additive Angle where + zero = pure 0 + {-# INLINE zero #-} + +instance Num n => Semigroup (Angle n) where + (<>) = (^+^) + {-# INLINE (<>) #-} + +instance Num n => Monoid (Angle n) where + mappend = (<>) + mempty = Radians 0 + +-- | The radian measure of an 'Angle' @a@ can be accessed as @a '^.' +-- rad@. A new 'Angle' can be defined in radians as @pi \@\@ +-- rad@. +rad :: Iso' (Angle n) n +rad = iso (\(Radians r) -> r) Radians +{-# INLINE rad #-} + +-- | The measure of an 'Angle' @a@ in full circles can be accessed as +-- @a '^.' turn@. A new 'Angle' of one-half circle can be defined in as +-- @1/2 \@\@ turn@. +turn :: Floating n => Iso' (Angle n) n +turn = iso (\(Radians r) -> r / (2*pi)) (Radians . (*(2*pi))) +{-# INLINE turn #-} + +-- | The degree measure of an 'Angle' @a@ can be accessed as @a +-- '^.' deg@. A new 'Angle' can be defined in degrees as @180 \@\@ +-- deg@. +deg :: Floating n => Iso' (Angle n) n +deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) +{-# INLINE deg #-} + +-- | An angle representing one full turn. +fullTurn :: Floating v => Angle v +fullTurn = 1 @@ turn + +-- | An angle representing a half turn. +halfTurn :: Floating v => Angle v +halfTurn = 0.5 @@ turn + +-- | An angle representing a quarter turn. +quarterTurn :: Floating v => Angle v +quarterTurn = 0.25 @@ turn + +-- | Calculate ratio between two angles. +angleRatio :: Floating n => Angle n -> Angle n -> n +angleRatio a b = (a ^. rad) / (b ^. rad) + +-- | The sine of the given @Angle@. +sinA :: Floating n => Angle n -> n +sinA (Radians r) = sin r + +-- | The cosine of the given @Angle@. +cosA :: Floating n => Angle n -> n +cosA (Radians r) = cos r + +-- | The tangent function of the given @Angle@. +tanA :: Floating n => Angle n -> n +tanA (Radians r) = tan r + +-- | The @Angle@ with the given sine. +asinA :: Floating n => n -> Angle n +asinA = Radians . asin + +-- | The @Angle@ with the given cosine. +acosA :: Floating n => n -> Angle n +acosA = Radians . acos + +-- | The @Angle@ with the given tangent. +atanA :: Floating n => n -> Angle n +atanA = Radians . atan + +-- | @atan2A y x@ is the angle between the positive x-axis and the vector given +-- by the coordinates (x, y). The 'Angle' returned is in the [-pi,pi] range. +atan2A :: RealFloat n => n -> n -> Angle n +atan2A y x = Radians $ atan2 y x + +-- | Similar to 'atan2A' but without the 'RealFloat' constraint. This means it +-- doesn't handle negative zero cases. However, for most geometric purposes, +-- the outcome will be the same. +atan2A' :: OrderedField n => n -> n -> Angle n +atan2A' y x = atan2' y x @@ rad + +-- atan2 without negative zero tests +atan2' :: OrderedField n => n -> n -> n +atan2' y x + | x > 0 = atan (y/x) + | x == 0 && y > 0 = pi/2 + | x < 0 && y > 0 = pi + atan (y/x) + | x <= 0 && y < 0 = -atan2' (-y) x + | y == 0 && x < 0 = pi -- must be after the previous test on zero y + | x==0 && y==0 = y -- must be after the other double zero tests + | otherwise = x + y -- x or y is a NaN, return a NaN (via +) + +-- | @30 \@\@ deg@ is an 'Angle' of the given measure and units. +-- +-- >>> pi @@ rad +-- 3.141592653589793 @@ rad +-- +-- >>> 1 @@ turn +-- 6.283185307179586 @@ rad +-- +-- >>> 30 @@ deg +-- 0.5235987755982988 @@ rad +-- +-- For 'Iso''s, ('@@') reverses the 'Iso'' on its right, and applies +-- the 'Iso'' to the value on the left. 'Angle's are the motivating +-- example where this order improves readability. +-- +-- This is the same as a flipped 'review'. +-- +-- @ +-- ('@@') :: a -> 'Iso'' s a -> s +-- ('@@') :: a -> 'Prism'' s a -> s +-- ('@@') :: a -> 'Review' s a -> s +-- ('@@') :: a -> 'Equality'' s a -> s +-- @ +(@@) :: b -> AReview a b -> a +a @@ i = review i a + +infixl 5 @@ + +-- | Compute the positive angle between the two vectors in their common +-- plane in the [0,pi] range. For a signed angle see +-- 'Diagrams.TwoD.Vector.signedAngleBetween'. +-- +-- Returns NaN if either of the vectors are zero. +angleBetween :: (Metric v, Floating n, Ord n) => v n -> v n -> Angle n +angleBetween v1 v2 = acosA (min 1 . max (-1) $ signorm v1 `dot` signorm v2) +-- N.B.: Currently discards the common plane information. + +-- | Normalize an angle so that it lies in the [0,tau) range. +normalizeAngle :: (Floating n, Real n) => Angle n -> Angle n +normalizeAngle = over rad (`mod'` (2 * pi)) + +------------------------------------------------------------ +-- Rotation + +-- These functions are defined here (instead of in +-- Diagrams.TwoD.Transform) because the Action instance needs to go +-- here. + +-- | Create a transformation which performs a rotation about the local +-- origin by the given angle. See also 'rotate'. +rotation :: Floating n => Angle n -> Transformation V2 n +rotation theta = fromLinear r (linv r) + where + c = cosA theta + s = sinA theta + r = rot c s <-> rot c (-s) + rot co si (V2 x y) = V2 (co * x - si * y) + (si * x + co * y) + +-- | Rotate about the local origin by the given angle. Positive angles +-- correspond to counterclockwise rotation, negative to +-- clockwise. The angle can be expressed using any of the 'Iso's on +-- 'Angle'. For example, @rotate (1\/4 \@\@ 'turn')@, @rotate +-- (tau\/4 \@\@ rad)@, and @rotate (90 \@\@ deg)@ all +-- represent the same transformation, namely, a counterclockwise +-- rotation by a right angle. To rotate about some point other than +-- the local origin, see 'rotateAbout'. +-- +-- Note that writing @rotate (1\/4)@, with no 'Angle' constructor, +-- will yield an error since GHC cannot figure out which sort of +-- angle you want to use. In this common situation you can use +-- 'rotateBy', which interprets its argument as a number of turns. + +rotate :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t +rotate = transform . rotation + +-- | Angles act on other things by rotation. +instance (V t ~ V2, N t ~ n, Transformable t, Floating n) + => Action (Angle n) t where + act = rotate + +------------------------------------------------------------ +-- Polar Coordinates + +-- | The class of types with at least one angle coordinate, called '_theta'. +class HasTheta t where + _theta :: RealFloat n => Lens' (t n) (Angle n) + +-- | The class of types with at least two angle coordinates, the second called +-- '_phi'. '_phi' is the positive angle measured from the z axis. +class HasTheta t => HasPhi t where + _phi :: RealFloat n => Lens' (t n) (Angle n) + +-- Point instances +instance HasTheta v => HasTheta (Point v) where + _theta = lensP . _theta + {-# INLINE _theta #-} + +instance HasPhi v => HasPhi (Point v) where + _phi = lensP . _phi + {-# INLINE _phi #-} diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -29,6 +30,9 @@ ) where +import Data.Active +import Data.Semigroup + import Diagrams.Core import Diagrams.Animation.Active () @@ -38,18 +42,13 @@ import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types -import Data.Active -import Data.Semigroup - -import Control.Applicative ((<$>)) -import Data.Foldable (foldMap) -import Data.VectorSpace +import Linear.Metric -- | A value of type @QAnimation b v m@ is an animation (a -- time-varying diagram with start and end times) that can be --- rendered by backspace @b@, with vector space @v@ and monoidal +-- rendered by backend @b@, with vector space @v@ and monoidal -- annotations of type @m@. -type QAnimation b v m = Active (QDiagram b v m) +type QAnimation b v n m = Active (QDiagram b v n m) -- | A value of type @Animation b v@ is an animation (a time-varying -- diagram with start and end times) in vector space @v@ that can be @@ -58,7 +57,7 @@ -- Note that @Animation@ is actually a synonym for @QAnimation@ -- where the type of the monoidal annotations has been fixed to -- 'Any' (the default). -type Animation b v = QAnimation b v Any +type Animation b v n = QAnimation b v n Any -- $animComb -- Most combinators for working with animations are to be found in the @@ -90,16 +89,16 @@ -- -- See also 'animRect' for help constructing a background to go -- behind an animation. -animEnvelope :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => QAnimation b v m -> QAnimation b v m +animEnvelope :: (OrderedField n, Metric v, Monoid' m) + => QAnimation b v n m -> QAnimation b v n m animEnvelope = animEnvelope' 30 -- | Like 'animEnvelope', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animEnvelope' :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => Rational -> QAnimation b v m -> QAnimation b v m +animEnvelope' :: (OrderedField n, Metric v, Monoid' m) + => Rational -> QAnimation b v n m -> QAnimation b v n m animEnvelope' r a = withEnvelope (simulate r a) <$> a -- | @animRect@ works similarly to 'animEnvelope' for 2D diagrams, but @@ -109,16 +108,16 @@ -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) - => QAnimation b R2 m -> t +animRect :: (InSpace V2 n t, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t) + => QAnimation b V2 n m -> t animRect = animRect' 30 -- | Like 'animRect', but with an adjustible sample rate. The first -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) - => Rational -> QAnimation b R2 m -> t +animRect' :: (InSpace V2 n t, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t) + => Rational -> QAnimation b V2 n m -> t animRect' r anim | null results = rect 1 1 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -37,16 +37,13 @@ module Diagrams.Animation.Active where -import Control.Applicative (pure, (<$>)) - -import Diagrams.Align import Diagrams.Core -import Diagrams.Path import Diagrams.TrailLike import Data.Active type instance V (Active a) = V a +type instance N (Active a) = N a -- Yes, these are all orphan instances. Get over it. We don't want to -- put them in the 'active' package because 'active' is supposed to be @@ -97,5 +94,5 @@ ) a1 -instance Alignable a => Alignable (Active a) where - alignBy v d a = alignBy v d <$> a +-- instance Alignable a => Alignable (Active a) where +-- alignBy v d a = alignBy v d <$> a diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,11 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable - , ExistentialQuantification - , GeneralizedNewtypeDeriving - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -23,58 +31,220 @@ ----------------------------------------------------------------------------- module Diagrams.Attributes ( + -- ** Standard measures + ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none + , tiny, verySmall, small, normal, large, veryLarge, huge + + -- ** Line width + , LineWidth, getLineWidth + , _LineWidth, _LineWidthM + , lineWidth, lineWidthM + , _lineWidth, _lw, _lineWidthU + , lw, lwN, lwO, lwL, lwG + + -- ** Dashing + , Dashing(..), getDashing + , dashing, dashingN, dashingO, dashingL, dashingG + , _dashing, _dashingU + -- * Color -- $color - Color(..), SomeColor(..) + , Color(..), SomeColor(..), _SomeColor, someToAlpha - -- ** Line color - , LineColor, getLineColor, lineColor, lineColorA, lc, lcA + -- ** Opacity + , Opacity, _Opacity + , getOpacity, opacity, _opacity - -- ** Fill color - , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA + , FillOpacity, _FillOpacity + , getFillOpacity, fillOpacity, _fillOpacity - -- ** Opacity - , Opacity, getOpacity, opacity + , StrokeOpacity, _StrokeOpacity + , getStrokeOpacity, strokeOpacity, _strokeOpacity -- ** Converting colors - , toRGBAUsingSpace, colorToSRGBA, colorToRGBA - - -- * Lines - -- ** Width - , LineWidth, getLineWidth, lineWidth, lineWidthA, lw + , colorToSRGBA, colorToRGBA + -- * Line stuff -- ** Cap style - , LineCap(..), LineCapA, getLineCap, lineCap + , LineCap(..) + , getLineCap, lineCap, _lineCap -- ** Join style - , LineJoin(..), LineJoinA, getLineJoin, lineJoin + , LineJoin(..) + , getLineJoin, lineJoin, _lineJoin -- ** Miter limit - , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA + , LineMiterLimit(..), _LineMiterLimit + , getLineMiterLimit, lineMiterLimit, lineMiterLimitA, _lineMiterLimit - -- ** Dashing - , Dashing(..), DashingA, getDashing, dashing + -- * Recommend optics + , _Recommend + , _Commit + , _recommend + , isCommitted + , committed + ) where +import Control.Lens hiding (none, over) +import Data.Colour +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) +import Data.Default +import Data.Distributive +import Data.Monoid.Recommend +import Data.Semigroup +import Data.Typeable + import Diagrams.Core -import Data.Default.Class +------------------------------------------------------------------------ +-- Standard measures +------------------------------------------------------------------------ -import Data.Colour -import Data.Colour.RGBSpace -import Data.Colour.SRGB (sRGBSpace) +none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, + tiny, verySmall, small, normal, large, veryLarge, huge + :: OrderedField n => Measure n +none = output 0 +ultraThin = normalized 0.0005 `atLeast` output 0.5 +veryThin = normalized 0.001 `atLeast` output 0.5 +thin = normalized 0.002 `atLeast` output 0.5 +medium = normalized 0.004 `atLeast` output 0.5 +thick = normalized 0.0075 `atLeast` output 0.5 +veryThick = normalized 0.01 `atLeast` output 0.5 +ultraThick = normalized 0.02 `atLeast` output 0.5 -import Data.Typeable +tiny = normalized 0.01 +verySmall = normalized 0.015 +small = normalized 0.023 +normal = normalized 0.035 +large = normalized 0.05 +veryLarge = normalized 0.07 +huge = normalized 0.10 -import Data.Monoid.Recommend -import Data.Semigroup +------------------------------------------------------------------------ +-- Line width +------------------------------------------------------------------------ ------------------------------------------------------------- --- Color ------------------------------------------------- ------------------------------------------------------------- +-- | Line widths specified on child nodes always override line widths +-- specified at parent nodes. +newtype LineWidth n = LineWidth (Last n) + deriving (Typeable, Semigroup) +_LineWidth :: Iso' (LineWidth n) n +_LineWidth = iso getLineWidth (LineWidth . Last) + +_LineWidthM :: Iso' (LineWidthM n) (Measure n) +_LineWidthM = mapping _LineWidth + +instance Typeable n => AttributeClass (LineWidth n) + +type LineWidthM n = Measured n (LineWidth n) + +instance OrderedField n => Default (LineWidthM n) where + def = fmap (LineWidth . Last) medium + +getLineWidth :: LineWidth n -> n +getLineWidth (LineWidth (Last w)) = w + +-- | Set the line (stroke) width. +lineWidth :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a +lineWidth = applyMAttr . fmap (LineWidth . Last) + +-- | Apply a 'LineWidth' attribute. +lineWidthM :: (N a ~ n, HasStyle a, Typeable n) => LineWidthM n -> a -> a +lineWidthM = applyMAttr + +-- | Default for 'lineWidth'. +lw :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a +lw = lineWidth + +-- | A convenient synonym for 'lineWidth (global w)'. +lwG :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a +lwG = lw . global + +-- | A convenient synonym for 'lineWidth (normalized w)'. +lwN :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a +lwN = lw . normalized + +-- | A convenient synonym for 'lineWidth (output w)'. +lwO :: (N a ~ n, HasStyle a, Typeable n) => n -> a -> a +lwO = lw . output + +-- | A convenient sysnonym for 'lineWidth (local w)'. +lwL :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a +lwL = lw . local + +-- | Lens onto a measured line width in a style. +_lineWidth, _lw :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_lineWidth = atMAttr . anon def (const False) . _LineWidthM +_lw = _lineWidth + +-- | Lens onto the unmeasured linewith attribute. This is useful for +-- backends to use on styles once they have been unmeasured. Using on +-- a diagram style could lead to unexpected results. +_lineWidthU :: Typeable n => Lens' (Style v n) (Maybe n) +_lineWidthU = atAttr . mapping _LineWidth + +------------------------------------------------------------------------ +-- Dashing +------------------------------------------------------------------------ + +-- | Create lines that are dashing... er, dashed. +data Dashing n = Dashing [n] n + deriving (Functor, Typeable, Eq) + +instance Semigroup (Dashing n) where + _ <> b = b + +instance Typeable n => AttributeClass (Dashing n) + +getDashing :: Dashing n -> Dashing n +getDashing = id + +-- | Set the line dashing style. +dashing :: (N a ~ n, HasStyle a, Typeable n) + => [Measure n] -- ^ A list specifying alternate lengths of on + -- and off portions of the stroke. The empty + -- list indicates no dashing. + -> Measure n -- ^ An offset into the dash pattern at which the + -- stroke should start. + -> a -> a +dashing ds offs = applyMAttr . distribute $ Dashing ds offs + +-- | A convenient synonym for 'dashing (global w)'. +dashingG :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a +dashingG w v = dashing (map global w) (global v) + +-- | A convenient synonym for 'dashing (normalized w)'. +dashingN :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a +dashingN w v = dashing (map normalized w) (normalized v) + +-- | A convenient synonym for 'dashing (output w)'. +dashingO :: (N a ~ n, HasStyle a, Typeable n) => [n] -> n -> a -> a +dashingO w v = dashing (map output w) (output v) + +-- | A convenient sysnonym for 'dashing (local w)'. +dashingL :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a +dashingL w v = dashing (map local w) (local v) + +-- | Lens onto a measured dashing attribute in a style. +_dashing :: Typeable n + => Lens' (Style v n) (Maybe (Measured n (Dashing n))) +_dashing = atMAttr + +-- | Lens onto the unmeasured 'Dashing' attribute. This is useful for +-- backends to use on styles once they have been unmeasured. Using on +-- a diagram style could lead to unexpected results. +_dashingU :: Typeable n => Lens' (Style v n) (Maybe (Dashing n)) +_dashingU = atAttr + +------------------------------------------------------------------------ +-- Color +------------------------------------------------------------------------ + -- $color -- Diagrams outsources all things color-related to Russell O\'Connor\'s -- very nice colour package @@ -88,123 +258,68 @@ -- both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types -- from the "Data.Colour" library. class Color c where - -- | Convert a color to its standard representation, AlphaColour + -- | Convert a color to its standard representation, AlphaColour. toAlphaColour :: c -> AlphaColour Double + -- | Convert from an AlphaColour Double. Note that this direction + -- may lose some information. For example, the instance for + -- 'Colour' drops the alpha channel. + fromAlphaColour :: AlphaColour Double -> c + -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c deriving Typeable --- | The color with which lines (strokes) are drawn. Note that child --- colors always override parent colors; that is, @'lineColor' c1 --- . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. --- More precisely, the semigroup structure on line color attributes --- is that of 'Last'. -newtype LineColor = LineColor (Last SomeColor) - deriving (Typeable, Semigroup) -instance AttributeClass LineColor - -instance Default LineColor where - def = LineColor (Last (SomeColor black)) - -getLineColor :: LineColor -> SomeColor -getLineColor (LineColor (Last c)) = c - --- | Set the line (stroke) color. This function is polymorphic in the --- color type (so it can be used with either 'Colour' or --- 'AlphaColour'), but this can sometimes create problems for type --- inference, so the 'lc' and 'lcA' variants are provided with more --- concrete types. -lineColor :: (Color c, HasStyle a) => c -> a -> a -lineColor = applyAttr . LineColor . Last . SomeColor - --- | Apply a 'lineColor' attribute. -lineColorA :: HasStyle a => LineColor -> a -> a -lineColorA = applyAttr - --- | A synonym for 'lineColor', specialized to @'Colour' Double@ --- (i.e. opaque colors). -lc :: HasStyle a => Colour Double -> a -> a -lc = lineColor - --- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ --- (i.e. colors with transparency). -lcA :: HasStyle a => AlphaColour Double -> a -> a -lcA = lineColor - --- | The color with which shapes are filled. Note that child --- colors always override parent colors; that is, @'fillColor' c1 --- . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. --- More precisely, the semigroup structure on fill color attributes --- is that of 'Last'. -newtype FillColor = FillColor (Recommend (Last SomeColor)) - deriving (Typeable, Semigroup) -instance AttributeClass FillColor - --- | Set the fill color. This function is polymorphic in the color --- type (so it can be used with either 'Colour' or 'AlphaColour'), --- but this can sometimes create problems for type inference, so the --- 'fc' and 'fcA' variants are provided with more concrete types. -fillColor :: (Color c, HasStyle a) => c -> a -> a -fillColor = applyAttr . FillColor . Commit . Last . SomeColor - --- | Set a \"recommended\" fill color, to be used only if no explicit --- calls to 'fillColor' (or 'fc', or 'fcA') are used. -recommendFillColor :: (Color c, HasStyle a) => c -> a -> a -recommendFillColor = applyAttr . FillColor . Recommend . Last . SomeColor - -getFillColor :: FillColor -> SomeColor -getFillColor (FillColor c) = getLast . getRecommend $ c +instance Show SomeColor where + showsPrec d (colorToSRGBA -> (r,g,b,a)) = + showParen (d > 10) $ showString "SomeColor " . + if a == 0 + then showString "transparent" + else showString "(sRGB " . showsPrec 11 r . showChar ' ' + . showsPrec 11 g . showChar ' ' + . showsPrec 11 b . + (if a /= 1 + then showString " `withOpacity` " . showsPrec 11 a + else id) . showChar ')' --- | A synonym for 'fillColor', specialized to @'Colour' Double@ --- (i.e. opaque colors). -fc :: HasStyle a => Colour Double -> a -> a -fc = fillColor +-- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'. +_SomeColor :: Iso' SomeColor (AlphaColour Double) +_SomeColor = iso toAlphaColour fromAlphaColour --- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ --- (i.e. colors with transparency). -fcA :: HasStyle a => AlphaColour Double -> a -> a -fcA = fillColor +someToAlpha :: SomeColor -> AlphaColour Double +someToAlpha (SomeColor c) = toAlphaColour c -instance (Floating a, Real a) => Color (Colour a) where - toAlphaColour = opaque . colourConvert +instance a ~ Double => Color (Colour a) where + toAlphaColour = opaque + fromAlphaColour = (`over` black) -instance (Floating a, Real a) => Color (AlphaColour a) where - toAlphaColour = alphaColourConvert +instance a ~ Double => Color (AlphaColour a) where + toAlphaColour = id + fromAlphaColour = id instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c - -instance Color LineColor where - toAlphaColour (LineColor (Last c)) = toAlphaColour c - -instance Color FillColor where - toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c - --- | Convert to an RGB space while preserving the alpha channel. -toRGBAUsingSpace :: Color c => RGBSpace Double -> c - -> (Double, Double, Double, Double) -toRGBAUsingSpace s col = (r,g,b,a) - where c' = toAlphaColour col - c = toRGBUsingSpace s (alphaToColour c') - a = alphaChannel c' - r = channelRed c - g = channelGreen c - b = channelBlue c + fromAlphaColour = SomeColor -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) -colorToSRGBA = toRGBAUsingSpace sRGBSpace +colorToSRGBA col = (r, g, b, a) + where + c' = toAlphaColour col + c = alphaToColour c' + a = alphaChannel c' + RGB r g b = toSRGB c colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} -alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a +alphaToColour :: (Floating a, Ord a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black | otherwise = darken (recip (alphaChannel ac)) (ac `over` black) ------------------------------------------------------------- +------------------------------------------------------------------------ -- Opacity +------------------------------------------------------------------------ -- | Although the individual colors in a diagram can have -- transparency, the opacity/transparency of a diagram as a whole @@ -218,6 +333,9 @@ deriving (Typeable, Semigroup) instance AttributeClass Opacity +_Opacity :: Iso' Opacity Double +_Opacity = iso getOpacity (Opacity . Product) + getOpacity :: Opacity -> Double getOpacity (Opacity (Product d)) = d @@ -227,98 +345,139 @@ opacity :: HasStyle a => Double -> a -> a opacity = applyAttr . Opacity . Product ------------------------------------------------------------- --- Lines and stuff ------------------------------------- ------------------------------------------------------------- +-- | Lens onto the opacity in a style. +_opacity :: Lens' (Style v n) Double +_opacity = atAttr . mapping _Opacity . non 1 --- | The width of lines. By default, the line width is measured with --- respect to the /final/ coordinate system of a rendered diagram, --- as opposed to the local coordinate systems in effect at the time --- the line width was set for various subdiagrams. This is so that --- it is easy to combine a variety of shapes (some created by --- scaling) and have them all drawn using a consistent line width. --- However, sometimes it is desirable for scaling to affect line --- width; the 'freeze' operation is provided for this purpose. The --- line width of frozen diagrams is affected by transformations. --- --- Line widths specified on child nodes always override line widths --- specified at parent nodes. -newtype LineWidth = LineWidth (Last Double) +-- fill opacity -------------------------------------------------------- + +-- | Like 'Opacity', but set the opacity only for fills (as opposed to strokes). +-- As with 'Opacity', the fill opacity is a value between 1 +-- (completely opaque, the default) and 0 (completely transparent), +-- and is multiplicative. +newtype FillOpacity = FillOpacity (Product Double) deriving (Typeable, Semigroup) -instance AttributeClass LineWidth +instance AttributeClass FillOpacity -instance Default LineWidth where - def = LineWidth (Last 0.01) +_FillOpacity :: Iso' FillOpacity Double +_FillOpacity = iso getFillOpacity (FillOpacity . Product) -getLineWidth :: LineWidth -> Double -getLineWidth (LineWidth (Last w)) = w +getFillOpacity :: FillOpacity -> Double +getFillOpacity (FillOpacity (Product d)) = d --- | Set the line (stroke) width. -lineWidth :: HasStyle a => Double -> a -> a -lineWidth = applyAttr . LineWidth . Last +-- | Multiply the fill opacity (see 'FillOpacity') by the given value. For +-- example, @fillOpacity 0.8@ means \"decrease this diagram's fill opacity to +-- 80% of its previous value\". +fillOpacity :: HasStyle a => Double -> a -> a +fillOpacity = applyAttr . FillOpacity . Product --- | Apply a 'LineWidth' attribute. -lineWidthA :: HasStyle a => LineWidth -> a -> a -lineWidthA = applyAttr +-- | Lens onto the fill opacity in a style. +_fillOpacity :: Lens' (Style v n) Double +_fillOpacity = atAttr . mapping _FillOpacity . non 1 --- | A convenient synonym for 'lineWidth'. -lw :: HasStyle a => Double -> a -> a -lw = lineWidth +-- stroke opacity -------------------------------------------------------- +-- | Like 'Opacity', but set the opacity only for strokes (as opposed to fills). +-- As with 'Opacity', the fill opacity is a value between 1 +-- (completely opaque, the default) and 0 (completely transparent), +-- and is multiplicative. +newtype StrokeOpacity = StrokeOpacity (Product Double) + deriving (Typeable, Semigroup) +instance AttributeClass StrokeOpacity + +_StrokeOpacity :: Iso' StrokeOpacity Double +_StrokeOpacity = iso getStrokeOpacity (StrokeOpacity . Product) + +getStrokeOpacity :: StrokeOpacity -> Double +getStrokeOpacity (StrokeOpacity (Product d)) = d + +-- | Multiply the stroke opacity (see 'StrokeOpacity') by the given value. For +-- example, @strokeOpacity 0.8@ means \"decrease this diagram's +-- stroke opacity to 80% of its previous value\". +strokeOpacity :: HasStyle a => Double -> a -> a +strokeOpacity = applyAttr . StrokeOpacity . Product + +-- | Lens onto the stroke opacity in a style. +_strokeOpacity :: Lens' (Style v n) Double +_strokeOpacity = atAttr . mapping _StrokeOpacity . non 1 + +------------------------------------------------------------------------ +-- Line stuff +------------------------------------------------------------------------ + +-- line cap ------------------------------------------------------------ + -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. | LineCapRound -- ^ Lines are capped with semicircles -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints. - deriving (Eq,Show,Typeable) - -newtype LineCapA = LineCapA (Last LineCap) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass LineCapA + deriving (Eq, Ord, Show, Typeable) instance Default LineCap where - def = LineCapButt + def = LineCapButt -getLineCap :: LineCapA -> LineCap -getLineCap (LineCapA (Last c)) = c +instance AttributeClass LineCap +-- | Last semigroup structure. +instance Semigroup LineCap where + _ <> b = b + +getLineCap :: LineCap -> LineCap +getLineCap = id + -- | Set the line end cap attribute. lineCap :: HasStyle a => LineCap -> a -> a -lineCap = applyAttr . LineCapA . Last +lineCap = applyAttr +-- | Lens onto the line cap in a style. +_lineCap :: Lens' (Style v n) LineCap +_lineCap = atAttr . non def +-- line join ----------------------------------------------------------- + -- | How should the join points between line segments be drawn? data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinRound -- ^ Use rounded join points. | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms? - deriving (Eq,Show,Typeable) + deriving (Eq, Ord, Show, Typeable) -newtype LineJoinA = LineJoinA (Last LineJoin) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass LineJoinA +instance AttributeClass LineJoin +-- | Last semigroup structure. +instance Semigroup LineJoin where + _ <> b = b + instance Default LineJoin where - def = LineJoinMiter + def = LineJoinMiter -getLineJoin :: LineJoinA -> LineJoin -getLineJoin (LineJoinA (Last j)) = j +getLineJoin :: LineJoin -> LineJoin +getLineJoin = id -- | Set the segment join style. lineJoin :: HasStyle a => LineJoin -> a -> a -lineJoin = applyAttr . LineJoinA . Last +lineJoin = applyAttr +-- | Lens onto the line join type in a style. +_lineJoin :: Lens' (Style v n) LineJoin +_lineJoin = atAttr . non def +-- miter limit --------------------------------------------------------- + -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq, Ord) instance AttributeClass LineMiterLimit +_LineMiterLimit :: Iso' LineMiterLimit Double +_LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last) + instance Default LineMiterLimit where - def = LineMiterLimit (Last 10) + def = LineMiterLimit (Last 10) getLineMiterLimit :: LineMiterLimit -> Double getLineMiterLimit (LineMiterLimit (Last l)) = l @@ -331,23 +490,39 @@ lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr --- | Create lines that are dashing... er, dashed. -data Dashing = Dashing [Double] Double - deriving (Typeable, Eq) +-- | Lens onto the line miter limit in a style. +_lineMiterLimit :: Lens' (Style v n) Double +_lineMiterLimit = atAttr . non def . _LineMiterLimit -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass DashingA +------------------------------------------------------------------------ +-- Recommend optics +------------------------------------------------------------------------ -getDashing :: DashingA -> Dashing -getDashing (DashingA (Last d)) = d +-- | Prism onto a 'Recommend'. +_Recommend :: Prism' (Recommend a) a +_Recommend = prism' Recommend $ \case (Recommend a) -> Just a; _ -> Nothing --- | Set the line dashing style. -dashing :: HasStyle a => - [Double] -- ^ A list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Double -- ^ An offset into the dash pattern at which the - -- stroke should start. - -> a -> a -dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) +-- | Prism onto a 'Commit'. +_Commit :: Prism' (Recommend a) a +_Commit = prism' Commit $ \case (Commit a) -> Just a; _ -> Nothing + +-- | Lens onto the value inside either a 'Recommend' or 'Commit'. Unlike +-- 'committed', this is a valid lens. +_recommend :: Lens (Recommend a) (Recommend b) a b +_recommend f (Recommend a) = Recommend <$> f a +_recommend f (Commit a) = Commit <$> f a + +-- | Lens onto whether something is committed or not. +isCommitted :: Lens' (Recommend a) Bool +isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r +isCommitted f r@(Commit a) = f True <&> \b -> if b then r else Recommend a + +-- | 'Commit' a value for any 'Recommend'. This is *not* a valid 'Iso' +-- because the resulting @Recommend b@ is always a 'Commit'. This is +-- useful because it means any 'Recommend' styles set with a lens will +-- not be accidentally overridden. If you want a valid lens onto a +-- recommend value use '_recommend'. +-- +-- Other lenses that use this are labeled with a warning. +committed :: Iso (Recommend a) (Recommend b) a b +committed = iso getRecommend Commit diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Attributes/Compile.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Attributes.Compile +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- XXX +-- +----------------------------------------------------------------------------- + +module Diagrams.Attributes.Compile ( + SplitAttribute(..), splitAttr + ) where + +import Data.Typeable + +import Control.Arrow (second) +import Control.Lens ((%~), (&), _Wrapping') +import Data.Kind (Type) +import qualified Data.HashMap.Strict as HM +import Data.Semigroup +import Data.Tree (Tree (..)) + +import Diagrams.Core +import Diagrams.Core.Style (Style (..), attributeToStyle) +import Diagrams.Core.Types (RNode (..), RTree) + +------------------------------------------------------------ + +-- This is a sort of roundabout, overly-general way to define +-- splitFills; it's done this way to facilitate testing. + +class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where + type AttrType code :: Type + type PrimType code :: Type + + primOK :: code -> PrimType code -> Bool + +-- | Push certain attributes down until they are at the roots of trees +-- containing only "safe" nodes. In particular this is used to push +-- fill attributes down until they are over only loops; see +-- 'splitFills'. +splitAttr :: forall code b v n a. SplitAttribute code => code -> RTree b v n a -> RTree b v n a +splitAttr code = fst . splitAttr' Nothing + where + + -- splitAttr' is where the most interesting logic happens. + -- Mutually recursive with splitAttr'Forest. rebuildNode and + -- applyMfc are helper functions. + -- + -- Input: attribute to apply to "safe" subtrees. + -- + -- Output: tree with attributes pushed down appropriately, and + -- a Bool indicating whether the tree contains only "safe" prims (True) or + -- contains some unsafe ones (False). + splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool) + + -- RStyle node: Check for the special attribute, and split it out of + -- the style, combining it with the incoming attribute. Recurse and + -- rebuild. The tricky bit is that we use some knot-tying to + -- determine the right attribute to pass down to the subtrees based + -- on this computed Bool: if all subtrees are safe, then we will + -- apply the attribute at the root of this tree, and pass Nothing to + -- all the subtrees. Otherwise, we pass the given attribute along. + -- This works out because the attribute does not need to be + -- pattern-matched until actually applying it at some root, so the + -- recursion can proceed and the Bool values be computed with the + -- actual value of the attributes nodes filled in lazily. + splitAttr' mattr (Node (RStyle sty) cs) = (t', ok) + where + mattr' = mattr <> getAttr sty + sty' = sty & _Wrapping' Style %~ HM.delete ty + ty = typeOf (undefined :: AttrType code) + (cs', ok) = splitAttr'Forest mattr' cs + t' | ok = rebuildNode Nothing ok (RStyle sty) cs' + | otherwise = rebuildNode mattr ok (RStyle sty') cs' + + -- RPrim node: check whether it + -- * is some sort of prim not under consideration: don't apply the attribute; return True + -- * is unsafe: don't apply the attribute; return False + -- * is safe : do apply the attribute; return True + splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) = + case cast prm :: Maybe (PrimType code) of + Nothing -> (Node rp [], True) + Just p -> + if primOK code p + then (rebuildNode mattr True rp [], True) + else (Node rp [], False) + + -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note + -- we assume that transformations do not affect the attributes. + splitAttr' mattr (Node nd cs) = (t', ok) + where + (cs', ok) = splitAttr'Forest mattr cs + t' = rebuildNode mattr ok nd cs' + + -- Recursively call splitAttr' on all subtrees, returning the + -- logical AND of the Bool results returned (the whole forest is + -- safe iff all subtrees are). + splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v n a] -> ([RTree b v n a], Bool) + splitAttr'Forest mattr cs = (cs', ok) + where + (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs + + -- Given a fill attribute, a Bool indicating whether the given + -- subforest contains only loops, a node, and a subforest, rebuild a + -- tree, applying the fill attribute as appropriate (only if the + -- Bool is true and the attribute is not Nothing). + rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v n a -> [RTree b v n a] -> RTree b v n a + rebuildNode mattr ok nd cs + | ok = applyMattr mattr (Node nd cs) + | otherwise = Node nd cs + + -- Prepend a new fill color node if Just; the identity function if + -- Nothing. + applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a + applyMattr Nothing t = t + applyMattr (Just a) t = Node (RStyle $ attributeToStyle (Attribute a)) [t] diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/CmdLine.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.CmdLine +-- Copyright : (c) 2013 Diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Convenient creation of command-line-driven executables for rendering +-- diagrams. This module provides a general framework and default +-- behaviors for parsing command-line arguments, records for diagram +-- creation options in various forms, and classes and instances for a +-- unified entry point to command-line-driven diagram creation +-- executables. +-- +-- For a tutorial on command-line diagram creation see +-- . +-- +----------------------------------------------------------------------------- + +module Diagrams.Backend.CmdLine + ( + + -- * Options + + -- ** Standard options + DiagramOpts(..) + , diagramOpts + , width + , height + , output + + -- ** Multi-diagram options + , DiagramMultiOpts(..) + , diagramMultiOpts + , selection + , list + + -- ** Animation options + , DiagramAnimOpts(..) + , diagramAnimOpts + , fpu + + -- * Parsing + , Parseable(..) + , readHexColor + + -- * Command-line programs (@Mainable@) + -- ** Arguments, rendering, and entry point + , Mainable(..) + + -- ** General currying + , ToResult(..) + + -- ** helper functions for implementing @mainRender@ + , defaultAnimMainRender + , defaultMultiMainRender + ) where + +import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Core hiding (output) + +import Options.Applicative +import Options.Applicative.Types (readerAsk) + +import Control.Monad (forM_) + +-- MonadFail comes from Prelude in base-4.13 and up +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif + +import Data.Active hiding (interval) +import Data.Char (isDigit) +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Data +import Data.Functor.Identity +import Data.Kind (Type) +import Data.Monoid +import Numeric + +import System.Environment (getProgName) +import System.FilePath (addExtension, splitExtension) + +import Text.Printf + +-- | Standard options most diagrams are likely to have. +data DiagramOpts = DiagramOpts + { _width :: Maybe Int -- ^ Final output width of diagram. + , _height :: Maybe Int -- ^ Final output height of diagram. + , _output :: FilePath -- ^ Output file path, format is typically chosen by extension. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramOpts + +-- | Extra options for a program that can offer a choice +-- between multiple diagrams. +data DiagramMultiOpts = DiagramMultiOpts + { _selection :: Maybe String -- ^ Selected diagram to render. + , _list :: Bool -- ^ Flag to indicate that a list of available diagrams should + -- be printed to standard out. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramMultiOpts + +-- | Extra options for animations. +data DiagramAnimOpts = DiagramAnimOpts + { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramAnimOpts + +-- | Command line parser for 'DiagramOpts'. +-- Width is option @--width@ or @-w@. +-- Height is option @--height@ or @-h@ (note we change help to be @-?@ due to this). +-- Output is option @--output@ or @-o@. +diagramOpts :: Parser DiagramOpts +diagramOpts = DiagramOpts + <$> (optional . option auto) + ( long "width" <> short 'w' + <> metavar "WIDTH" + <> help "Desired WIDTH of the output image") + <*> (optional . option auto) + ( long "height" <> short 'h' + <> metavar "HEIGHT" + <> help "Desired HEIGHT of the output image") + <*> strOption + ( long "output" <> short 'o' + <> value "" + <> metavar "OUTPUT" + <> help "OUTPUT file") + +-- | Command line parser for 'DiagramMultiOpts'. +-- Selection is option @--selection@ or @-S@. +-- List is @--list@ or @-L@. +diagramMultiOpts :: Parser DiagramMultiOpts +diagramMultiOpts = DiagramMultiOpts + <$> (optional . strOption) + ( long "selection" <> short 'S' + <> metavar "NAME" + <> help "NAME of the diagram to render") + <*> switch + ( long "list" <> short 'L' + <> help "List all available diagrams") + +-- | Command line parser for 'DiagramAnimOpts' +-- Frames per unit is @--fpu@ or @-f@. +diagramAnimOpts :: Parser DiagramAnimOpts +diagramAnimOpts = DiagramAnimOpts + <$> option auto + ( long "fpu" <> short 'f' + <> value 30.0 + <> help "Frames per unit time (for animations)") + +-- | A hidden \"helper\" option which always fails. +-- Taken from Options.Applicative.Extra but without the +-- short option 'h'. We want the 'h' for Height. +helper' :: Parser (a -> a) +helper' = abortOption param $ mconcat + [ long "help" + , short '?' + , help "Show this help text" + ] + where +#if MIN_VERSION_optparse_applicative(0,16,0) + param = ShowHelpText Nothing +#else + param = ShowHelpText +#endif + +-- | Apply a parser to the command line that includes the standard +-- program description and help behavior. Results in parsed commands +-- or fails with a help message. +defaultOpts :: Parser a -> IO a +defaultOpts optsParser = do + prog <- getProgName + let p = info (helper' <*> optsParser) + ( fullDesc + <> progDesc "Command-line diagram generation." + <> header prog) + execParser p + +-- | Parseable instances give a command line parser for a type. If a custom +-- parser for a common type is wanted a newtype wrapper could be used to make +-- a new 'Parseable' instance. Notice that we do /not/ want as many +-- instances as 'Read' because we want to limit ourselves to things that make +-- sense to parse from the command line. +class Parseable a where + parser :: Parser a + +-- The following instance would overlap with the product instance for +-- Parseable. We can't tell if one wants to parse (a,b) as one argument or a +-- as one argument and b as another. Since this is the command line we almost +-- certainly want the latter. So we need to have less Read instances. +-- +-- instance Read a => Parseable a where +-- parser = argument auto mempty + +-- | Parse 'Int' according to its 'Read' instance. +instance Parseable Int where + parser = argument auto mempty + +-- | Parse 'Double' according to its 'Read' instance. +instance Parseable Double where + parser = argument auto mempty + +-- | Parse a string by just accepting the given string. +instance Parseable String where + parser = argument str mempty + +-- | Parse 'DiagramOpts' using the 'diagramOpts' parser. +instance Parseable DiagramOpts where + parser = diagramOpts + +-- | Parse 'DiagramMultiOpts' using the 'diagramMultiOpts' parser. +instance Parseable DiagramMultiOpts where + parser = diagramMultiOpts + +-- | Parse 'DiagramAnimOpts' using the 'diagramAnimOpts' parser. +instance Parseable DiagramAnimOpts where + parser = diagramAnimOpts + +-- | Parse @'Colour' Double@ as either a named color from "Data.Colour.Names" +-- or a hexadecimal color. +instance Parseable (Colour Double) where + parser = argument (rc <|> rh) mempty + where + rh, rc :: ReadM (Colour Double) + rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor) + rc = readerAsk >>= readColourName + f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha + -- value be applied to the r g b values? + +-- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names" +-- or a hexadecimal color. +instance Parseable (AlphaColour Double) where + parser = argument (rc <|> rh) mempty + where + rh = readerAsk >>= readHexColor + rc = opaque <$> (readerAsk >>= readColourName) + +-- Addapted from the Clay.Color module of the clay package + +-- | Parses a hexadecimal color. The string can start with @\"0x\"@ or @\"#\"@ +-- or just be a string of hexadecimal values. If four or three digits are +-- given each digit is repeated to form a full 24 or 32 bit color. For +-- example, @\"0xfc4\"@ is the same as @\"0xffcc44\"@. When eight or six +-- digits are given each pair of digits is a color or alpha channel with the +-- order being red, green, blue, alpha. +readHexColor :: (Applicative m, MonadFail m) => String -> m (AlphaColour Double) +readHexColor cs = case cs of + ('0':'x':hs) -> handle hs + ('#':hs) -> handle hs + hs -> handle hs + where + handle hs | length hs <= 8 && all isHexDigit hs + = case hs of + [a,b,c,d,e,f,g,h] -> withOpacity <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) <*> hex g h + [a,b,c,d,e,f ] -> opaque <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) + [a,b,c,d ] -> withOpacity <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) <*> hex d d + [a,b,c ] -> opaque <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) + _ -> fail $ "could not parse as a colour" ++ cs + handle _ = fail $ "could not parse as a colour: " ++ cs + + isHexDigit c = isDigit c || c `elem` "abcdef" + + hex a b = (/ 255) <$> case readHex [a,b] of + [(h,"")] -> return h + _ -> fail $ "could not parse as a hex value" ++ [a,b] + + +-- | This instance is needed to signal the end of a chain of +-- nested tuples, it always just results in the unit value +-- without consuming anything. +instance Parseable () where + parser = pure () + +-- | Allow 'Parseable' things to be combined. +instance (Parseable a, Parseable b) => Parseable (a,b) where + parser = (,) <$> parser <*> parser + +-- | Triples of Parsebales should also be Parseable. +instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) where + parser = (,,) <$> parser <*> parser <*> parser + +instance (Parseable a, Parseable b, Parseable c, Parseable d) => Parseable (a, b, c, d) where + parser = (,,,) <$> parser <*> parser <*> parser <*> parser + +-- | This class allows us to abstract over functions that take some arguments +-- and produce a final value. When some @d@ is an instance of +-- 'ToResult' we get a type @'Args' d@ that is a type of /all/ the arguments +-- at once, and a type @'ResultOf' d@ that is the type of the final result from +-- some base case instance. +class ToResult d where + type Args d :: Type + type ResultOf d :: Type + + toResult :: d -> Args d -> ResultOf d + +-- | A diagram can always produce a diagram when given @()@ as an argument. +-- This is our base case. +instance ToResult (QDiagram b v n Any) where + type Args (QDiagram b v n Any) = () + type ResultOf (QDiagram b v n Any) = QDiagram b v n Any + + toResult d _ = d + +-- | A list of diagrams can produce pages. +instance ToResult [QDiagram b v n Any] where + type Args [QDiagram b v n Any] = () + type ResultOf [QDiagram b v n Any] = [QDiagram b v n Any] + + toResult ds _ = ds + +-- | A list of named diagrams can give the multi-diagram interface. +instance ToResult [(String, QDiagram b v n Any)] where + type Args [(String,QDiagram b v n Any)] = () + type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)] + + toResult ds _ = ds + +-- | An animation is another suitable base case. +instance ToResult (Animation b v n) where + type Args (Animation b v n) = () + type ResultOf (Animation b v n) = Animation b v n + + toResult a _ = a + +-- | Diagrams that require IO to build are a base case. +instance ToResult d => ToResult (IO d) where + type Args (IO d) = Args d + type ResultOf (IO d) = IO (ResultOf d) + + toResult d args = flip toResult args <$> d + +-- | An instance for a function that, given some 'a', can produce a 'd' that is +-- also an instance of 'ToResult'. For this to work we need both the +-- argument 'a' and all the arguments that 'd' will need. Producing the +-- result is simply applying the argument to the producer and passing the +-- remaining arguments to the produced producer. + +-- The previous paragraph stands as a witness to the fact that Haskell code +-- is clearer and easier to understand then paragraphs in English written by +-- me. +instance ToResult d => ToResult (a -> d) where + type Args (a -> d) = (a, Args d) + type ResultOf (a -> d) = ResultOf d + + toResult f (a,args) = toResult (f a) args + + +-- | This class represents the various ways we want to support diagram creation +-- from the command line. It has the right instances to select between creating +-- single static diagrams, multiple static diagrams, static animations, and +-- functions that produce diagrams as long as the arguments are 'Parseable'. +-- +-- Backends are expected to create @Mainable@ instances for the types that are +-- suitable for generating output in the backend's format. For instance, +-- Postscript can handle single diagrams, pages of diagrams, animations as +-- separate files, and association lists. This implies instances for +-- @Diagram Postscript R2@, @[Diagram Postscript R2]@, @Animation Postscript R2@, +-- and @[(String,Diagram Postscript R2)]@. We can consider these as the base +-- cases for the function instance. +-- +-- The associated type 'MainOpts' describes the options which need to be parsed +-- from the command-line and passed to @mainRender@. +class Mainable d where + -- | Associated type that describes the options which need to be parsed + -- from the command-line and passed to @mainRender@. + type MainOpts d :: Type + + -- | This method invokes the command-line parser resulting in an options + -- value or ending the program with an error or help message. + -- Typically the default instance will work. If a different help message + -- or parsing behavior is desired a new implementation is appropriate. + mainArgs :: Parseable (MainOpts d) => proxy d -> IO (MainOpts d) + mainArgs _ = defaultOpts parser + + -- | Backend specific work of rendering with the given options and mainable + -- value is done here. All backend instances should implement this method. + mainRender :: MainOpts d -> d -> IO () + + -- | Main entry point for command-line diagram creation. This is the method + -- that users will call from their program @main@. For instance an expected + -- user program would take the following form. + -- + -- @ + -- import Diagrams.Prelude + -- import Diagrams.Backend.TheBestBackend.CmdLine + -- + -- d :: Diagram B R2 + -- d = ... + -- + -- main = mainWith d + -- @ + -- + -- Most backends should be able to use the default implementation. A different + -- implementation should be used to handle more complex interactions with the user. + mainWith :: Parseable (MainOpts d) => d -> IO () + mainWith d = do + opts <- mainArgs (Identity d) + mainRender opts d + +-- | This instance allows functions resulting in something that is 'Mainable' to +-- be 'Mainable'. It takes a parse of collected arguments and applies them to +-- the given function producing the 'Mainable' result. +instance (ToResult d, Mainable (ResultOf d)) + => Mainable (a -> d) where + type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d)) + + mainRender (opts, a) f = mainRender opts (toResult f a) +-- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ... +-- Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ? + +-- | With this instance we can perform IO to produce something +-- 'Mainable' before rendering. +instance Mainable d => Mainable (IO d) where + type MainOpts (IO d) = MainOpts d + + mainRender opts dio = dio >>= mainRender opts + +-- | @defaultMultiMainRender@ is an implementation of 'mainRender' where +-- instead of a single diagram it takes a list of diagrams paired with names +-- as input. The generated executable then takes a @--selection@ option +-- specifying the name of the diagram that should be rendered. The list of +-- available diagrams may also be printed by passing the option @--list@. +-- +-- Typically a backend can write its @[(String,QDiagram b v n Any)]@ instance as +-- +-- @ +-- instance Mainable [(String,QDiagram b v n Any)] where +-- type MainOpts [(String,QDiagram b v n Any)] = (DiagramOpts, DiagramMultiOpts) +-- mainRender = defaultMultiMainRender +-- @ +-- +-- We do not provide this instance in general so that backends can choose to +-- opt-in to this form or provide a different instance that makes more sense. +defaultMultiMainRender :: Mainable d => (MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO () +defaultMultiMainRender (opts,multi) ds = + if multi^.list + then showDiaList (map fst ds) + else case multi^.selection of + Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds) + Just sel -> case lookup sel ds of + Nothing -> putStrLn $ "Unknown diagram: " ++ sel + Just d -> mainRender opts d + +-- | Display the list of diagrams available for rendering. +showDiaList :: [String] -> IO () +showDiaList ds = do + putStrLn "Available diagrams:" + putStrLn $ " " ++ unwords ds + +-- | @defaultAnimMainRender@ is an implementation of 'mainRender' which renders +-- an animation as numbered frames, named by extending the given output file +-- name by consecutive integers. For example if the given output file name is +-- @foo\/blah.ext@, the frames will be saved in @foo\/blah001.ext@, +-- @foo\/blah002.ext@, and so on (the number of padding digits used depends on +-- the total number of frames). It is up to the user to take these images and +-- stitch them together into an actual animation format (using, /e.g./ +-- @ffmpeg@). +-- +-- Of course, this is a rather crude method of rendering animations; +-- more sophisticated methods will likely be added in the future. +-- +-- The @fpu@ option from 'DiagramAnimOpts' can be used to control how many frames will +-- be output for each second (unit time) of animation. +-- +-- This function requires a lens into the structure that the particular backend +-- uses for its diagram base case. If @MainOpts (QDiagram b v n Any) ~ DiagramOpts@ +-- then this lens will simply be 'output'. This lens is required because the +-- implementation works by modifying the output field and running the base @mainRender@. +-- Typically a backend can write its @Animation B V@ instance as +-- +-- @ +-- instance Mainable (Animation B V) where +-- type MainOpts (Animation B V) = (DiagramOpts, DiagramAnimOpts) +-- mainRender = defaultAnimMainRender output +-- @ +-- +-- We do not provide this instance in general so that backends can choose to +-- opt-in to this form or provide a different instance that makes more sense. + +defaultAnimMainRender :: + (opts -> QDiagram b v n Any -> IO ()) + -> Lens' opts FilePath -- ^ A lens into the output path. + -> (opts, DiagramAnimOpts) + -> Animation b v n + -> IO () +defaultAnimMainRender renderF out (opts,animOpts) anim = do + let frames = simulate (toRational $ animOpts^.fpu) anim + nDigits = length . show . length $ frames + forM_ (zip [1..] frames) $ \(i,d) -> renderF (indexize out nDigits i opts) d + +-- | @indexize d n@ adds the integer index @n@ to the end of the +-- output file name, padding with zeros if necessary so that it uses +-- at least @d@ digits. +indexize :: Lens' s FilePath -> Int -> Integer -> s -> s +indexize out nDigits i opts = opts & out .~ output' + where fmt = "%0" ++ show nDigits ++ "d" + output' = addExtension (base ++ printf fmt i) ext + (base, ext) = splitExtension (opts^.out) diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs deleted file mode 100644 --- a/src/Diagrams/Backend/Show.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Backend.Show --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A simple Show-based diagrams backend, for testing purposes. --- ------------------------------------------------------------------------------ -module Diagrams.Backend.Show where - -import Diagrams.Core.Transform (onBasis) -import Diagrams.Prelude -import Diagrams.Trail - -import Data.Basis - -import Text.PrettyPrint (Doc, empty, hsep, parens, ($+$)) -import qualified Text.PrettyPrint as PP - -import Data.List (transpose) - --- | Token for identifying this backend. -data ShowBackend = ShowBackend - -instance HasLinearMap v => Backend ShowBackend v where - data Render ShowBackend v = SR Doc - type Result ShowBackend v = String - data Options ShowBackend v = SBOpt - - withStyle _ _ _ r = r -- XXX FIXME - - doRender _ _ (SR r) = PP.render r - -instance Monoid (Render ShowBackend v) where - mempty = SR empty - (SR d1) `mappend` (SR d2) = SR (d1 $+$ d2) - -renderTransf :: forall v. (Num (Scalar v), HasLinearMap v, Show (Scalar v)) - => Transformation v -> Doc -renderTransf t = renderMat mat - where vmat :: [v] - (vmat, _) = onBasis t - mat :: [[Scalar v]] - mat = map decompV vmat --- mat' :: [[Scalar v]] --- mat' = map (++[0]) mat ++ [decompV tr ++ [1]] - decompV = map snd . decompose - -renderMat :: Show a => [[a]] -> Doc -renderMat = PP.vcat . map renderRow . transpose - where renderRow = parens . hsep . map (PP.text . show) - -instance (Show v, HasLinearMap v) => Renderable (Segment o v) ShowBackend where - render _ s = SR $ PP.text (show s) - -instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Trail v) ShowBackend where - render _ t = SR $ PP.text (show t) - -instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Path v) ShowBackend where - render _ p = SR $ PP.text (show p) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable - , DeriveFunctor - , FlexibleContexts - , GeneralizedNewtypeDeriving - , NoMonomorphismRestriction - , ScopedTypeVariables - , StandaloneDeriving - , TypeFamilies - , UndecidableInstances - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -24,309 +26,309 @@ ----------------------------------------------------------------------------- module Diagrams.BoundingBox - ( -- * Bounding boxes - BoundingBox() - - -- * Constructing bounding boxes - , emptyBox, fromCorners, fromPoint, fromPoints - , boundingBox + ( -- * Bounding boxes + BoundingBox - -- * Queries on bounding boxes - , isEmptyBox - , getCorners, getAllCorners - , boxExtents, boxTransform, boxFit - , contains, contains' - , inside, inside', outside, outside' + -- * Constructing bounding boxes + , emptyBox, fromCorners, fromPoint, fromPoints + , boundingBox - -- * Operations on bounding boxes - , union, intersection - ) where + -- * Queries on bounding boxes + , isEmptyBox + , getCorners, getAllCorners + , boxExtents, boxCenter + , mCenterPoint, centerPoint + , boxTransform, boxFit + , contains, contains' + , inside, inside', outside, outside' -import Control.Applicative ((<$>)) -import Control.Monad (join, liftM2) -import Data.Map (Map, fromList, toList, fromDistinctAscList, toAscList) -import qualified Data.Foldable as F + , boxGrid -import Data.Maybe (fromMaybe) + -- * Operations on bounding boxes + , union, intersection + ) where -import Data.VectorSpace --- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) -import Data.Basis (HasBasis, Basis, decompose, recompose, basisValue) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..), Option(..)) +import Control.Lens (AsEmpty (..), Each (..), nearly) +import Data.Foldable as F +import Data.Maybe (fromMaybe) +import Data.Semigroup +import Text.Read -import Data.Data (Data) -import Data.Typeable (Typeable) +import Diagrams.Align +import Diagrams.Core +import Diagrams.Core.Transform +import Diagrams.Path +import Diagrams.Query +import Diagrams.ThreeD.Shapes (cube) +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Types -import Diagrams.Core.Points (Point(..)) -import Diagrams.Core.HasOrigin (HasOrigin(..)) -import Diagrams.Core.Envelope (Enveloped(..), appEnvelope) -import Diagrams.Core.V (V) -import Diagrams.Core.Transform - (Transformation(..), Transformable(..), HasLinearMap, (<->)) +import Control.Applicative +import Data.Traversable as T +import Linear.Affine +import Linear.Metric +import Linear.Vector hiding (lerp) +import Linear.Vector.Compat (lerp) -- Unexported utility newtype -newtype NonEmptyBoundingBox v = NonEmptyBoundingBox (Point v, Point v) - deriving (Eq, Data, Typeable) +newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) + deriving (Eq, Functor) -fromNonEmpty :: NonEmptyBoundingBox v -> BoundingBox v -fromNonEmpty = BoundingBox . Option . Just +type instance V (NonEmptyBoundingBox v n) = v +type instance N (NonEmptyBoundingBox v n) = n -fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v) -> BoundingBox v +fromNonEmpty :: NonEmptyBoundingBox v n -> BoundingBox v n +fromNonEmpty = BoundingBox . Just + +fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v n) -> BoundingBox v n fromMaybeEmpty = maybe emptyBox fromNonEmpty -nonEmptyCorners :: NonEmptyBoundingBox v -> (Point v, Point v) +nonEmptyCorners :: NonEmptyBoundingBox v n -> (Point v n, Point v n) nonEmptyCorners (NonEmptyBoundingBox x) = x -instance (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Semigroup (NonEmptyBoundingBox v) where +instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where (NonEmptyBoundingBox (ul, uh)) <> (NonEmptyBoundingBox (vl, vh)) - = NonEmptyBoundingBox - $ mapT toPoint (combineP min ul vl, combineP max uh vh) - + = NonEmptyBoundingBox (liftU2 min ul vl, liftU2 max uh vh) -- | A bounding box is an axis-aligned region determined by two points -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. -newtype BoundingBox v = BoundingBox (Option (NonEmptyBoundingBox v)) - deriving (Eq, Data, Typeable) +newtype BoundingBox v n = BoundingBox (Maybe (NonEmptyBoundingBox v n)) + deriving (Eq, Functor) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Semigroup (BoundingBox v) -deriving instance - ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) - ) => Monoid (BoundingBox v) +deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) +deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) -type instance V (BoundingBox v) = v +instance AsEmpty (BoundingBox v n) where + _Empty = nearly emptyBox isEmptyBox --- Map a function on a homogenous 2-tuple. (unexported utility) +-- | Only valid if the second point is not smaller than the first. +instance (Additive v', Foldable v', Ord n') => + Each (BoundingBox v n) (BoundingBox v' n') (Point v n) (Point v' n') where + each f (getCorners -> Just (l, u)) = fromCorners <$> f l <*> f u + each _ _ = pure emptyBox + +type instance V (BoundingBox v n) = v +type instance N (BoundingBox v n) = n + +-- Map a function on a homogeneous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) -instance ( VectorSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v) - ) => HasOrigin (BoundingBox v) where +instance (Additive v, Num n) => HasOrigin (BoundingBox v n) where moveOriginTo p b = fromMaybeEmpty - ( NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b ) + (NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b) -instance ( InnerSpace v, HasBasis v, Ord (Basis v) - , AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v) - ) => Enveloped (BoundingBox v) where +instance (Additive v, Foldable v, Ord n) + => HasQuery (BoundingBox v n) Any where + getQuery bb = Query $ Any . contains bb + +instance (Metric v, Traversable v, OrderedField n) + => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners -instance Show v => Show (BoundingBox v) where - show - = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) - . getCorners +-- Feels like cheating. +-- Should be possible to generalise this. +instance RealFloat n => Traced (BoundingBox V2 n) where + getTrace = getTrace + . ((`boxFit` rect 1 1) . boundingBox :: Envelope V2 n -> Path V2 n) + . getEnvelope -{- TODO -instance Read v => Read (BoundingBox v) where - read "emptyBox" = emptyBox --} +instance TypeableFloat n => Traced (BoundingBox V3 n) where + getTrace bb = foldMap (\tr -> getTrace $ transform tr cube) $ + boxTransform (boundingBox cube) bb +instance (Metric v, Traversable v, OrderedField n) => Alignable (BoundingBox v n) where + defaultBoundary = envelopeP + +instance Show (v n) => Show (BoundingBox v n) where + showsPrec d b = case getCorners b of + Just (l, u) -> showParen (d > 10) $ + showString "fromCorners " . showsPrec 11 l . showChar ' ' . showsPrec 11 u + Nothing -> showString "emptyBox" + +instance Read (v n) => Read (BoundingBox v n) where + readPrec = parens $ + (do + Ident "emptyBox" <- lexP + pure emptyBox + ) <|> + (prec 10 $ do + Ident "fromCorners" <- lexP + l <- step readPrec + h <- step readPrec + pure . fromNonEmpty $ NonEmptyBoundingBox (l, h) + ) + -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't --- require the same type constraints that the @Monoid@ -emptyBox :: BoundingBox v -emptyBox = BoundingBox $ Option Nothing +-- require the same type constraints that the @Monoid@ instance does. +emptyBox :: BoundingBox v n +emptyBox = BoundingBox Nothing -- | Create a bounding box from a point that is component-wise @(<=)@ than the -- other. If this is not the case, then @mempty@ is returned. fromCorners - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> Point v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => Point v n -> Point v n -> BoundingBox v n fromCorners l h - | F.and (combineP (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) - | otherwise = mempty + | F.and (liftI2 (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) + | otherwise = mempty -- | Create a degenerate bounding \"box\" containing only a single point. -fromPoint - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => Point v -> BoundingBox v +fromPoint :: Point v n -> BoundingBox v n fromPoint p = fromNonEmpty $ NonEmptyBoundingBox (p, p) -- | Create the smallest bounding box containing all the given points. -fromPoints - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => [Point v] -> BoundingBox v +fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). -boundingBox :: forall a. ( Enveloped a, HasBasis (V a), AdditiveGroup (V a) - , Ord (Basis (V a)) - ) => a -> BoundingBox (V a) +boundingBox :: (InSpace v n a, HasBasis v, Enveloped a) + => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do - env <- appEnvelope $ getEnvelope a - let h = recompose $ map (\v -> (v, env $ basisValue v)) us - l = recompose $ map (\v -> (v, negate . env . negateV $ basisValue v)) us - return $ NonEmptyBoundingBox (P l, P h) - where - -- The units. Might not work if 0-components aren't reported. - --TODO: Depend on Enum Basis? - us = map fst $ decompose (zeroV :: V a) + env <- (appEnvelope . getEnvelope) a + let h = fmap env eye + l = negated $ fmap (env . negated) eye + return $ NonEmptyBoundingBox (P l, P h) -- | Queries whether the BoundingBox is empty. -isEmptyBox :: BoundingBox v -> Bool -isEmptyBox (BoundingBox (Option Nothing)) = True -isEmptyBox _ = False +isEmptyBox :: BoundingBox v n -> Bool +isEmptyBox (BoundingBox Nothing) = True +isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. -getCorners :: BoundingBox v -> Maybe (Point v, Point v) -getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p +getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) +getCorners (BoundingBox p) = nonEmptyCorners <$> p -- | Computes all of the corners of the bounding box. -getAllCorners :: (HasBasis v, AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> [Point v] -getAllCorners (BoundingBox (Option Nothing)) = [] -getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) - = map (P . recompose) - -- Enumerate all combinations of selections of lower / higher values. - . mapM (\(b, (l', u')) -> [(b, l'), (b, u')]) - -- List of [(basis, (lower, upper))] - . toList - $ combineP (,) l u +getAllCorners :: (Additive v, Traversable v) => BoundingBox v n -> [Point v n] +getAllCorners (BoundingBox Nothing) = [] +getAllCorners (BoundingBox (Just (NonEmptyBoundingBox (l, u)))) + = T.sequence (liftI2 (\a b -> [a,b]) l u) -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. -boxExtents :: (AdditiveGroup v) => BoundingBox v -> v -boxExtents = maybe zeroV (\(P l, P h) -> h ^-^ l) . getCorners +boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n +boxExtents = maybe zero (\(l,u) -> u .-. l) . getCorners --- | Create a transformation mapping points from one bounding box to the other. -boxTransform :: (AdditiveGroup v, HasLinearMap v, - Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v)) - => BoundingBox v -> BoundingBox v -> Maybe (Transformation v) +-- | Get the center point in a bounding box. +boxCenter :: (Additive v, Fractional n) => BoundingBox v n -> Maybe (Point v n) +boxCenter = fmap (uncurry (lerp 0.5)) . getCorners + +-- | Get the center of a the bounding box of an enveloped object, return +-- 'Nothing' for object with empty envelope. +mCenterPoint :: (InSpace v n a, HasBasis v, Enveloped a) + => a -> Maybe (Point v n) +mCenterPoint = boxCenter . boundingBox + +-- | Get the center of a the bounding box of an enveloped object, return +-- the origin for object with empty envelope. +centerPoint :: (InSpace v n a, HasBasis v, Enveloped a) + => a -> Point v n +centerPoint = fromMaybe origin . mCenterPoint + +-- | Create a transformation mapping points from one bounding box to the +-- other. Returns 'Nothing' if either of the boxes are empty. +boxTransform + :: (Additive v, Fractional n) + => BoundingBox v n -> BoundingBox v n -> Maybe (Transformation v n) boxTransform u v = do - ((P ul), _) <- getCorners u - ((P vl), _) <- getCorners v - let lin_map = box_scale (v, u) <-> box_scale (u, v) - box_scale = combineV' (*) . uncurry (combineV' (/)) . mapT boxExtents - combineV' f x = toVector . combineV f x - return $ Transformation lin_map lin_map (vl ^-^ box_scale (v, u) ul) + (P ul, _) <- getCorners u + (P vl, _) <- getCorners v + let i = s (v, u) <-> s (u, v) + s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents + return $ Transformation i i (vl ^-^ s (v, u) ul) --- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's --- empty, then the result is also @mempty@. -boxFit :: (Enveloped a, Transformable a, Monoid a, Ord (Basis (V a))) - => BoundingBox (V a) -> a -> a +-- | Transforms an enveloped thing to fit within a @BoundingBox@. If the +-- bounding box is empty, then the result is also @mempty@. +boxFit + :: (InSpace v n a, HasBasis v, Enveloped a, Transformable a, Monoid a) + => BoundingBox v n -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b -- | Check whether a point is contained in a bounding box (including its edges). -contains - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<=) l p) - && F.and (combineP (<=) p h) + check (l, h) = F.and (liftI2 (<=) l p) + && F.and (liftI2 (<=) p h) -- | Check whether a point is /strictly/ contained in a bounding box. -contains' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> Point v -> Bool +contains' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains' b p = maybe False check $ getCorners b where - check (l, h) = F.and (combineP (<) l p) - && F.and (combineP (<) p h) + check (l, h) = F.and (liftI2 (<) l p) + && F.and (liftI2 (<) p h) -- | Test whether the first bounding box is contained inside -- the second. -inside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>=) ul vl) - && F.and (combineP (<=) uh vh) + return $ F.and (liftI2 (>=) ul vl) + && F.and (liftI2 (<=) uh vh) -- | Test whether the first bounding box is /strictly/ contained -- inside the second. -inside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +inside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside' u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.and (combineP (>) ul vl) - && F.and (combineP (<) uh vh) + return $ F.and (liftI2 (>) ul vl) + && F.and (liftI2 (<) uh vh) -- | Test whether the first bounding box lies outside the second -- (although they may intersect in their boundaries). -outside - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<=) uh vl) - || F.or (combineP (>=) ul vh) + return $ F.or (liftI2 (<=) uh vl) + || F.or (liftI2 (>=) ul vh) -- | Test whether the first bounding box lies /strictly/ outside the second -- (they do not intersect at all). -outside' - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> Bool +outside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside' u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ F.or (combineP (<) uh vl) - || F.or (combineP (>) ul vh) + return $ F.or (liftI2 (<) uh vl) + || F.or (liftI2 (>) ul vh) -- | Form the largest bounding box contained within this given two -- bounding boxes, or @Nothing@ if the two bounding boxes do not -- overlap at all. intersection - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v + :: (Additive v, Foldable v, Ord n) + => BoundingBox v n -> BoundingBox v n -> BoundingBox v n intersection u v = maybe mempty (uncurry fromCorners) $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v - return $ mapT toPoint (combineP max ul vl, combineP min uh vh) + return (liftI2 max ul vl, liftI2 min uh vh) -- | Form the smallest bounding box containing the given two bound union. This -- function is just an alias for @mappend@. -union :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => BoundingBox v -> BoundingBox v -> BoundingBox v +union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend --- internals using Map (Basis v) (Scalar v) --- probably paranoia, but decompose might not always --- 1. contain basis elements whose component is zero --- 2. have basis elements in the same order - -fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v) -fromVector = fromList . decompose - -toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v -toVector = recompose . toList - -toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v -toPoint = P . toVector - -combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a -combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v) - -combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) - => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a -combineP f (P u) (P v) = combineV f u v - -combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c -combineDefault a b f = combine g +-- | @boxGrid f box@ returns a grid of regularly spaced points inside +-- the box, such that there are @(1/f)@ points along each dimension. +-- For example, for a 3D box with corners at (0,0,0) and (2,2,2), +-- @boxGrid 0.1@ would yield a grid of approximately 1000 points (it +-- might actually be @11^3@ instead of @10^3@) spaced @0.2@ units +-- apart. +boxGrid + :: (Traversable v, Additive v, Num n, Enum n) + => n -> BoundingBox v n -> [Point v n] +boxGrid f = maybe [] (sequenceA . uncurry (liftI2 mkRange)) . getCorners where - g Nothing Nothing = f a b - g Nothing (Just y) = f a y - g (Just x) Nothing = f x b - g (Just x) (Just y) = f x y + mkRange lo hi = [lo, (1-f)*lo + f*hi .. hi] -combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c -combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm) - where - merge [] [] = [] - merge ((x,a):xs) [] = (x, f (Just a) Nothing) : merge xs [] - merge [] ((y,b):ys) = (y, f Nothing (Just b)) : merge [] ys - merge xs0@((x,a):xs) ys0@((y,b):ys) = case compare x y of - LT -> (x, f (Just a) Nothing ) : merge xs ys0 - EQ -> (x, f (Just a) (Just b)) : merge xs ys - GT -> (y, f Nothing (Just b)) : merge xs0 ys + -- liftA2 mkRange on the two corner points creates a (Point V2 + -- [n]), where each component is the range of values for that + -- dimension. sequenceA then yields a grid of type [Point V2 n]. diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -18,55 +21,76 @@ withEnvelope, withTrace , phantom, strut - , pad + , pad, frame , extrudeEnvelope, intrudeEnvelope -- * Binary operations , atop , beneath , beside + , atDirection -- * n-ary operations , appends - , position, decorateTrail, decorateLocatedTrail, decoratePath - , cat, cat', CatOpts(..), CatMethod(..) + , position, atPoints + , cat, cat' + , CatOpts(_catMethod, _sep), catMethod, sep + , CatMethod(..) + , composeAligned ) where -import Data.AdditiveGroup -import Data.AffineSpace ((.+^)) -import Data.Default.Class +import Control.Lens hiding (beside, ( # )) +import Data.Default +import Data.Maybe (fromJust) +import Data.Monoid.Deletable (toDeletable) +import Data.Monoid.MList (inj) +import Data.Proxy import Data.Semigroup -import Data.VectorSpace +import qualified Data.Tree.DUAL as D import Diagrams.Core -import Diagrams.Located -import Diagrams.Path -import Diagrams.Segment (Segment (..), straight) -import Diagrams.Trail (Trail, trailVertices) -import Diagrams.TrailLike (fromOffsets) +import Diagrams.Core.Types (QDiagram (QD)) +import Diagrams.Direction +import Diagrams.Names (named) +import Diagrams.Segment (straight) import Diagrams.Util +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ -- | Use the envelope from some object as the envelope for a -- diagram, in place of the diagram's default envelope. -withEnvelope :: (HasLinearMap (V a), Enveloped a, Monoid' m) - => a -> QDiagram b (V a) m -> QDiagram b (V a) m +-- +-- <> +-- +-- > sqNewEnv = +-- > circle 1 # fc green +-- > ||| +-- > ( c # dashingG [0.1,0.1] 0 # lc white +-- > <> square 2 # withEnvelope (c :: D V2 Double) # fc blue +-- > ) +-- > c = circle 0.8 +-- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 +withEnvelope :: (InSpace v n a, Monoid' m, Enveloped a) + => a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace. -withTrace :: (HasLinearMap (V a), Traced a, OrderedField (Scalar (V a)), InnerSpace (V a), Monoid' m) - => a -> QDiagram b (V a) m -> QDiagram b (V a) m +withTrace :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) + => a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. -phantom :: (Backend b (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m -phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty +phantom :: (InSpace v n a, Monoid' m, Enveloped a, Traced a) => a -> QDiagram b v n m +phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of -- @s@ (factors between 0 and 1 can be used to shrink the envelope). @@ -74,25 +98,32 @@ -- origin, so if the origin is not centered the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@. -pad :: ( Backend b v - , InnerSpace v, OrderedField (Scalar v) - , Monoid' m ) - => Scalar v -> QDiagram b v m -> QDiagram b v m +pad :: (Metric v, OrderedField n, Monoid' m) + => n -> QDiagram b v n m -> QDiagram b v n m pad s d = withEnvelope (d # scale s) d +-- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, +-- s is in the local units of the diagram. This function is similar to @pad@, +-- only it takes an absolute quantity and pre-centering should not be +-- necessary. +frame :: (Metric v, OrderedField n, Monoid' m) + => n -> QDiagram b v n m -> QDiagram b v n m +frame s = over envelope (onEnvelope $ \f x -> f x + s) + -- | @strut v@ is a diagram which produces no output, but with respect -- to alignment and envelope acts like a 1-dimensional segment -- oriented along the vector @v@, with local origin at its -- center. (Note, however, that it has an empty trace; for 2D struts --- with a nonempty trace see 'strutR2', 'strutX', and 'strutY' from +-- with a nonempty trace see 'strutR2' from -- "Diagrams.TwoD.Combinators".) Useful for manually creating -- separation between two diagrams. -strut :: ( Backend b v, InnerSpace v - , OrderedField (Scalar v) - , Monoid' m - ) - => v -> QDiagram b v m -strut v = mkQD nullPrim env mempty mempty mempty +-- +-- <> +-- +-- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 +strut :: (Metric v, OrderedField n) + => v n -> QDiagram b v n m +strut v = QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only @@ -112,10 +143,9 @@ -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. extrudeEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => v -> QDiagram b v m -> QDiagram b v m -extrudeEnvelope = deformEnvelope 0.5 + :: (Metric v, OrderedField n, Monoid' m) + => v n -> QDiagram b v n m -> QDiagram b v n m +extrudeEnvelope = deformEnvelope 1 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of -- a diagram away from the given direction. All parts of the envelope @@ -125,24 +155,22 @@ -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. intrudeEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => v -> QDiagram b v m -> QDiagram b v m -intrudeEnvelope = deformEnvelope (-0.5) + :: (Metric v, OrderedField n, Monoid' m) + => v n -> QDiagram b v n m -> QDiagram b v n m +intrudeEnvelope = deformEnvelope (-1) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope - :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) - , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) - => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m -deformEnvelope s v d = setEnvelope (inEnvelope deform $ getEnvelope d) d + :: (Metric v, OrderedField n, Monoid' m) + => n -> v n -> QDiagram b v n m -> QDiagram b v n m +deformEnvelope s v = over (envelope . _Wrapping Envelope) deformE where - deform = Option . fmap deform' . getOption - deform' env v' - | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v' + deformE = fmap deformE' + deformE' env v' + | dp > 0 = Max $ getMax (env v') + (dp * s) / quadrance v' | otherwise = env v' where - dot = v' <.> v + dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects @@ -151,8 +179,8 @@ -- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, -- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of -- @d1@. -beneath :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) - => QDiagram b v m -> QDiagram b v m -> QDiagram b v m +beneath :: (Metric v, OrderedField n, Monoid' m) + => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m beneath = flip atop infixl 6 `beneath` @@ -167,7 +195,7 @@ -- identity element, in which case the second object is returned -- unchanged). -- --- <> +-- <> -- -- > besideEx = beside (r2 (20,30)) -- > (circle 1 # fc orange) @@ -192,9 +220,18 @@ -- To get something like @beside v x1 x2@ whose local origin is -- identified with that of @x2@ instead of @x1@, use @beside -- (negateV v) x2 x1@. -beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a +beside :: (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 +-- | Place two diagrams (or other juxtaposable objects) adjacent to +-- one another, with the second diagram placed in the direction 'd' +-- from the first. The local origin of the resulting combined +-- diagram is the same as the local origin of the first. See the +-- documentation of 'beside' for more information. +atDirection :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a) + => Direction v n -> a -> a -> a +atDirection = beside . fromDirection + ------------------------------------------------------------ -- Combining multiple objects ------------------------------------------------------------ @@ -203,42 +240,32 @@ -- @x@ in the corresponding direction. Note that each object in -- @ys@ is positioned beside @x@ /without/ reference to the other -- objects in @ys@, so this is not the same as iterating 'beside'. -appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a +-- +-- <> +-- +-- > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c)) +-- > # centerXY # pad 1.1 +-- > where c = circle 1 +appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in -- the vector space of the combined object. -position :: (HasOrigin a, Monoid' a) => [(Point (V a), a)] -> a +-- +-- <> +-- +-- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat spot)) +-- > where spot = circle 0.2 # fc black +-- > mkPoint :: Double -> P2 Double +-- > mkPoint x = p2 (x,x*x) +position :: (InSpace v n a, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a position = mconcat . map (uncurry moveTo) --- | Combine a list of diagrams (or paths) by using them to --- \"decorate\" a trail, placing the local origin of one object at --- each successive vertex of the trail. The first vertex of the --- trail is placed at the origin. If the trail and list of objects --- have different lengths, the extra tail of the longer one is --- ignored. -decorateTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) - => Trail (V a) -> [a] -> a -decorateTrail = decorateLocatedTrail . (`at` origin) - --- | Combine a list of diagrams (or paths) by using them to --- \"decorate\" a concretely located trail, placing the local origin --- of one object at each successive vertex of the trail. If the --- trail and list of objects have different lengths, the extra tail --- of the longer one is ignored. -decorateLocatedTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) - => Located (Trail (V a)) -> [a] -> a -decorateLocatedTrail t = position . zip (trailVertices t) - --- | Combine a list of diagrams (or paths) by using them to --- \"decorate\" a path, placing the local origin of one object at --- each successive vertex of the path. If the path and list of objects --- have different lengths, the extra tail of the longer one is --- ignored. -decoratePath :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) - => Path (V a) -> [a] -> a -decoratePath p = position . zip (concat $ pathVertices p) +-- | Curried version of @position@, takes a list of points and a list of +-- objects. +atPoints :: (InSpace v n a, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a +atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. data CatMethod = Cat -- ^ Normal catenation: simply put diagrams @@ -257,36 +284,38 @@ -- of separation, diagrams may overlap. -- | Options for 'cat''. -data CatOpts v = CatOpts { catMethod :: CatMethod - -- ^ Which 'CatMethod' should be used: - -- normal catenation (default), or - -- distribution? - , sep :: Scalar v - -- ^ How much separation should be used - -- between successive diagrams - -- (default: 0)? When @catMethod = - -- Cat@, this is the distance between - -- /envelopes/; when @catMethod = - -- Distrib@, this is the distance - -- between /origins/. - , catOptsvProxy__ :: Proxy v - -- ^ This field exists solely to aid type inference; - -- please ignore it. +data CatOpts n = CatOpts { _catMethod :: CatMethod + , _sep :: n + , catOptsvProxy :: Proxy n } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a --- CatOpts record. This causes problems when writing an expression --- like @with { sep = 10 }@, because knowing the type of the whole +-- CatOpts record. This causes problems when using record update, as +-- in @with { _sep = 10 }@, because knowing the type of the whole -- expression does not tell us anything about the type of @with@, and -- therefore the @Num (Scalar v)@ constraint cannot be satisfied. --- Adding the Proxy field constrains the type of @with@ in @with {sep --- = 10}@ to be the same as the type of the whole expression. +-- Adding the Proxy field constrains the type of @with@ in @with {_sep +-- = 10}@ to be the same as the type of the whole expression. Note +-- this is not a problem when using the 'sep' lens, as its type is +-- more restricted. -instance Num (Scalar v) => Default (CatOpts v) where - def = CatOpts { catMethod = Cat - , sep = 0 - , catOptsvProxy__ = Proxy +makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts + +-- | Which 'CatMethod' should be used: +-- normal catenation (default), or distribution? +catMethod :: Lens' (CatOpts n) CatMethod + +-- | How much separation should be used between successive diagrams +-- (default: 0)? When @catMethod = Cat@, this is the distance between +-- /envelopes/; when @catMethod = Distrib@, this is the distance +-- between /origins/. +sep :: Lens' (CatOpts n) n + +instance Num n => Default (CatOpts n) where + def = CatOpts { _catMethod = Cat + , _sep = 0 + , catOptsvProxy = Proxy } -- | @cat v@ positions a list of objects so that their local origins @@ -297,10 +326,8 @@ -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), OrderedField (Scalar (V a)) - ) - => V a -> [a] -> a +cat :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) + => v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the @@ -315,18 +342,58 @@ -- default is 0. -- -- 'CatOpts' is an instance of 'Default', so 'with' may be used for --- the second argument, as in @cat' (1,2) with {sep = 2}@. +-- the second argument, as in @cat' (1,2) (with & sep .~ 2)@. -- --- Note that @cat' v with {catMethod = Distrib} === mconcat@ +-- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a - , InnerSpace (V a), OrderedField (Scalar (V a)) - ) - => V a -> CatOpts (V a) -> [a] -> a -cat' v (CatOpts { catMethod = Cat, sep = s }) = foldB comb mempty +cat' :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) + => v n -> CatOpts n -> [a] -> a +cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) - vs = s *^ normalized (negateV v) + vs = s *^ signorm (negated v) -cat' v (CatOpts { catMethod = Distrib, sep = s }) = - position . zip (iterate (.+^ (s *^ normalized v)) origin) +cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = + position . zip (iterate (.+^ (s *^ signorm v)) origin) + +-- | Compose a list of diagrams using the given composition function, +-- first aligning them all according to the given alignment, /but/ +-- retain the local origin of the first diagram, as it would be if +-- the composition function were applied directly. That is, +-- @composeAligned algn comp@ is equivalent to @translate v . comp +-- . map algn@ for some appropriate translation vector @v@. +-- +-- Unfortunately, this only works for diagrams (and not, say, paths) +-- because there is no most general type for alignment functions, +-- and no generic way to find out what an alignment function does to +-- the origin of things. (However, it should be possible to make a +-- version of this function that works /specifically/ on paths, if +-- such a thing were deemed useful.) +-- +-- <> +-- +-- > alignedEx1 = (hsep 2 # composeAligned alignT) (map circle [1,3,5,2]) +-- > # showOrigin +-- > # frame 0.5 +-- +-- <> +-- +-- > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1] +-- > # showOrigin +-- > # frame 0.1 +composeAligned + :: (Monoid' m, Floating n, Ord n, Metric v) + => (QDiagram b v n m -> QDiagram b v n m) -- ^ Alignment function + -> ([QDiagram b v n m] -> QDiagram b v n m) -- ^ Composition function + -> ([QDiagram b v n m] -> QDiagram b v n m) +composeAligned _ combine [] = combine [] +composeAligned algn comb (d:ds) = (comb $ map algn (d:ds)) # moveOriginTo l + where + mss = ( (() .>> d) -- qualify first to avoid stomping on an existing () name + # named () -- Mark the origin + # algn -- Apply the alignment function + ) + -- then find out what happened to the origin + ^. subMap . _Wrapped . Control.Lens.at (toName ()) + l = location . head . fromJust $ mss + -- the fromJust is Justified since we put the () name in diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Coordinates @@ -10,28 +12,20 @@ -- Nice syntax for constructing and pattern-matching on literal -- points and vectors. -- --- NOTE: to avoid clashing with the '(&)' operator from the @lens@ --- package, this module is not re-exported by "Diagrams.Prelude". To --- make use of the contents of this module, you must explicitly import --- it. --- ----------------------------------------------------------------------------- module Diagrams.Coordinates - ( (:&)(..), Coordinates(..) ) + ( (:&)(..), Coordinates(..) + ) where --- | A pair of values, with a convenient infix (left-associative) --- data constructor. -data a :& b = a :& b - deriving (Eq, Ord, Show) - -infixl 7 :& - +import Data.Kind (Type) +import Diagrams.Points +import Linear (V2 (..), V3 (..), V4 (..)) -- | Types which are instances of the @Coordinates@ class can be --- constructed using '&' (for example, a three-dimensional vector --- could be constructed by @1 & 6 & 3@), and deconstructed using +-- constructed using '^&' (for example, a three-dimensional vector +-- could be constructed by @1 ^& 6 ^& 3@), and deconstructed using -- 'coords'. A common pattern is to use 'coords' in conjunction -- with the @ViewPatterns@ extension, like so: -- @@ -42,33 +36,53 @@ class Coordinates c where -- | The type of the final coordinate. - type FinalCoord c :: * + type FinalCoord c :: Type -- | The type of everything other than the final coordinate. - type PrevDim c :: * + type PrevDim c :: Type -- | Decomposition of @c@ into applications of ':&'. - type Decomposition c :: * + type Decomposition c :: Type -- Decomposition c = Decomposition (PrevDim c) :& FinalCoord c (essentially) -- | Construct a value of type @c@ by providing something of one -- less dimension (which is perhaps itself recursively constructed - -- using @(&)@) and a final coordinate. For example, + -- using @(^&)@) and a final coordinate. For example, -- -- @ - -- 2 & 3 :: P2 - -- 3 & 5 & 6 :: R3 + -- 2 ^& 3 :: P2 + -- 3 ^& 5 ^& 6 :: V3 -- @ -- - -- Note that @&@ is left-associative. - (&) :: PrevDim c -> FinalCoord c -> c + -- Note that @^&@ is left-associative. + (^&) :: PrevDim c -> FinalCoord c -> c + -- | Prefix synonym for @^&@. pr stands for pair of @PrevDim@, @FinalCoord@ + pr :: PrevDim c -> FinalCoord c -> c + pr = (^&) + -- | Decompose a value of type @c@ into its constituent coordinates, -- stored in a nested @(:&)@ structure. coords :: c -> Decomposition c -infixl 7 & +infixl 7 ^& +-- | A pair of values, with a convenient infix (left-associative) +-- data constructor. +data a :& b = a :& b + deriving (Eq, Ord, Show) + +infixl 7 :& + +-- Instance for :& (the buck stops here) +instance Coordinates (a :& b) where + type FinalCoord (a :& b) = b + type PrevDim (a :& b) = a + type Decomposition (a :& b) = a :& b + x ^& y = x :& y + coords (x :& y) = x :& y + + -- Some standard instances for plain old tuples instance Coordinates (a,b) where @@ -76,7 +90,7 @@ type PrevDim (a,b) = a type Decomposition (a,b) = a :& b - x & y = (x,y) + x ^& y = (x,y) coords (x,y) = x :& y instance Coordinates (a,b,c) where @@ -84,7 +98,7 @@ type PrevDim (a,b,c) = (a,b) type Decomposition (a,b,c) = Decomposition (a,b) :& c - (x,y) & z = (x,y,z) + (x,y) ^& z = (x,y,z) coords (x,y,z) = coords (x,y) :& z instance Coordinates (a,b,c,d) where @@ -92,5 +106,40 @@ type PrevDim (a,b,c,d) = (a,b,c) type Decomposition (a,b,c,d) = Decomposition (a,b,c) :& d - (w,x,y) & z = (w,x,y,z) + (w,x,y) ^& z = (w,x,y,z) coords (w,x,y,z) = coords (w,x,y) :& z + +instance Coordinates (v n) => Coordinates (Point v n) where + type FinalCoord (Point v n) = FinalCoord (v n) + type PrevDim (Point v n) = PrevDim (v n) + type Decomposition (Point v n) = Decomposition (v n) + + x ^& y = P (x ^& y) + coords (P v) = coords v + +-- instances for linear + +instance Coordinates (V2 n) where + type FinalCoord (V2 n) = n + type PrevDim (V2 n) = n + type Decomposition (V2 n) = n :& n + + x ^& y = V2 x y + coords (V2 x y) = x :& y + +instance Coordinates (V3 n) where + type FinalCoord (V3 n) = n + type PrevDim (V3 n) = V2 n + type Decomposition (V3 n) = n :& n :& n + + V2 x y ^& z = V3 x y z + coords (V3 x y z) = x :& y :& z + +instance Coordinates (V4 n) where + type FinalCoord (V4 n) = n + type PrevDim (V4 n) = V3 n + type Decomposition (V4 n) = n :& n :& n :& n + + V3 x y z ^& w = V4 x y z w + coords (V4 x y z w) = x :& y :& z :& w + diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline @@ -8,61 +12,68 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- A /cubic spline/ is a smooth, connected sequence of cubic curves --- passing through a given sequence of points. This module provides --- the 'cubicSpline' method, which can be used to create closed or --- open cubic splines from a list of points. For access to the --- internals of the spline generation algorithm (including in --- particular a solver for cyclic tridiagonal systems of linear --- equations), see "Diagrams.CubicSpline.Internal". +-- A /cubic spline/ is a smooth, connected sequence of cubic curves. +-- This module provides two methods for constructing splines. -- +-- The 'cubicSpline' method can be used to create closed or open cubic +-- splines from a list of points. The resulting splines /pass through/ +-- all the control points, but depend on the control points in a +-- "global" way (that is, changing one control point may alter the +-- entire curve). For access to the internals of the spline +-- generation algorithm, see "Diagrams.CubicSpline.Internal". +-- +-- 'bspline' creates a cubic B-spline, which starts and ends at the +-- first and last control points, but does not necessarily pass +-- through any of the other control points. It depends on the control +-- points in a "local" way, that is, changing one control point will +-- only affect a local portion of the curve near that control point. +-- ----------------------------------------------------------------------------- module Diagrams.CubicSpline ( -- * Constructing paths from cubic splines cubicSpline + , BSpline + , bspline ) where +import Control.Lens (view) + import Diagrams.Core -import Diagrams.Core.Points +import Diagrams.CubicSpline.Boehm import Diagrams.CubicSpline.Internal -import Diagrams.Located (at) -import Diagrams.Located -import Diagrams.Path +import Diagrams.Located (Located, at, mapLoc) import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) --- for e.g. the Fractional (Double, Double) instance -import Data.NumInstances.Tuple () - -import Control.Newtype -import Data.Semigroup -import Data.VectorSpace +import Linear.Affine +import Linear.Metric -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first -- argument specifies whether the path should be closed. -- --- <> +-- <> -- -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] --- > dot = circle 0.2 # fc blue # lw 0 --- > mkPath closed = position (zip pts (repeat dot)) --- > <> cubicSpline closed pts # lw 0.05 +-- > spot = circle 0.2 # fc blue # lw none +-- > mkPath closed = position (zip pts (repeat spot)) +-- > <> cubicSpline closed pts -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) -- > # centerXY # pad 1.1 -- -- For more information, see . -cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t -cubicSpline c [] = trailLike . closeIf c $ emptyLine `at` origin -cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . map unpack $ ps +cubicSpline :: (V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t +cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin +cubicSpline closed [p] = trailLike . closeIf closed $ emptyLine `at` p +cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) - = trailLike . closeIf c $ lineFromSegments (map bez bs) `at` P b + = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) -closeIf :: (InnerSpace v, OrderedField (Scalar v)) - => Bool -> Located (Trail' Line v) -> Located (Trail v) +closeIf :: (Metric v, OrderedField n) + => Bool -> Located (Trail' Line v n) -> Located (Trail v n) closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) diff --git a/src/Diagrams/CubicSpline/Boehm.hs b/src/Diagrams/CubicSpline/Boehm.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline/Boehm.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.CubicSpline.Boehm +-- Copyright : (c) 2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Boehm's algorithm for converting a cubic B-spline into a sequence +-- of cubic Bezier curves. +-- +-- See +-- +-- * Thomas W. Sederberg, /An Introduction to B-Spline Curves/, +-- +-- +-- * Lyle Ramshaw, /Blossoming: A Connect-the-Dots Approach to Splines/, +-- +-- +----------------------------------------------------------------------------- +module Diagrams.CubicSpline.Boehm + ( BSpline + , bsplineToBeziers + , bspline + ) where + +import Data.List (sort, tails) +import Diagrams.Core (N, Point, V, origin) +import Diagrams.Located (at, loc, unLoc) +import Diagrams.Segment (FixedSegment (..), fromFixedSeg) +import Diagrams.TrailLike (TrailLike, fromLocSegments) +import Diagrams.Util (iterateN) +import Linear.Vector (Additive) +import Linear.Vector.Compat (lerp) + +type BSpline v n = [Point v n] + +-- | @affineCombo a b t x y@ computes an affine combination of x and y +-- which lies at parameter t, if x has parameter a and y has parameter b. +-- The usual @lerp@ arises by giving x parameter 0 and y parameter 1. +affineCombo :: (Additive f, Fractional a) => a -> a -> a -> f a -> f a -> f a +affineCombo a b t = lerp ((t-a)/(b-a)) + +-- | @windows k xs@ yields all the length-@k@ windows from @xs@, e.g. +-- @windows 3 [a,b,c,d,e] == [[a,b,c], [b,c,d], [c,d,e]]@. +windows :: Int -> [a] -> [[a]] +windows k = takeWhile ((==k) . length) . map (take k) . tails + +-- | @extend k xs@ extends @xs@ on both ends by prepending @k@ copies +-- of its head and appending @k@ copies of its last element. For example, +-- @extend 2 [1..5] == [1,1,1,2,3,4,5,5,5]@. +extend :: Int -> [a] -> [a] +extend k xs = replicate k (head xs) ++ xs ++ replicate k (last xs) + +-- | A "polar point" is a point along with three knot values. +-- We consider the "blossom" of a cubic spline, a 3-ary symmetric +-- polynomial; a polar point consists of 3 values paired with the +-- output of the blossom at those input values. Blossoms have nice +-- affine properties so this makes it easy to keep track of how +-- points may be combined to yield other points of interest. +-- +-- Invariant: knot values are in nondecreasing order. +data PolarPt v n = PP { unPP :: Point v n, _knots :: [n] } + +mkPolarPt :: Ord n => Point v n -> [n] -> PolarPt v n +mkPolarPt pt kts = PP pt (sort kts) + +-- | Precondition: the knots of the two polar points overlap, like abc +-- and bcd. The @Int@ should be 0 or 1, indicating which knot to +-- replicate (0 means to replicate b, yielding bbc, 1 means to +-- replicate c, yielding bcc). +combine + :: (Additive v, Fractional n, Ord n) + => Int -> PolarPt v n -> PolarPt v n -> PolarPt v n +combine k (PP pt1 kts1) (PP pt2 kts2) + = mkPolarPt + (affineCombo (head kts1) (last kts2) newKt pt1 pt2) + (newKt : drop 1 kts1) + where + newKt = kts2 !! k + +-- | Convert a uniform cubic B-spline to a sequence of cubic beziers. +-- (/Uniform/ refers to the fact that the knots are assumed to be +-- evenly spaced, with no duplicates.) The knots at the end are +-- replicated so the cubic spline begins and ends at the first and +-- last control points, tangent to the line from the end control +-- point to the next. +bsplineToBeziers + :: (Additive v, Fractional n, Num n, Ord n) + => BSpline v n + -> [FixedSegment v n] +bsplineToBeziers controls = beziers + where + n = length controls + numKnots = n + 2 + knots = iterateN numKnots (+1/(fromIntegral numKnots - 1)) 0 + + -- The control points are P(a,b,c), P(b,c,d), P(c,d,e), and so on. + controls' = zipWith mkPolarPt (extend 2 controls) (windows 3 $ extend 2 knots) + + -- The bezier internal control points are affine combinations of + -- the spline control points. + bezierControls = map combineC (windows 2 controls') + combineC [pabc, pbcd] = (combine 0 pabc pbcd, combine 1 pabc pbcd) + combineC _ = error "combineC must be called on a list of length 2" + + -- The bezier end points are affine combinations of the bezier + -- control points. + bezierEnds = map combineE (windows 2 bezierControls) + combineE [(_,pabb),(pbbc,_)] = combine 0 pabb pbbc + combineE _ = error "combineE must be called on a list of length 2" + + -- Finally, we actually put together the generated bezier segments. + beziers = zipWith mkBezier (drop 1 bezierControls) (windows 2 bezierEnds) + where + mkBezier (paab,pabb) [paaa,pbbb] + = FCubic (unPP paaa) (unPP paab) (unPP pabb) (unPP pbbb) + mkBezier _ _ = error "mkBezier must be called on a list of length 2" + + -- Note that the above algorithm works in any dimension but is + -- very specific to *cubic* splines. This can of course be + -- generalized to higher degree splines but keeping track of + -- everything gets a bit more complicated; to be honest I am not + -- quite sure how to do it. + +-- | Generate a uniform cubic B-spline from the given control points. +-- The spline starts and ends at the first and last control points, +-- and is tangent to the line to the second(-to-last) control point. +-- It does not necessarily pass through any of the other control +-- points. +-- +-- <> +-- +-- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] +-- > spot = circle 0.2 # fc blue # lw none +-- > bsplineEx = mconcat +-- > [ position (zip pts (repeat spot)) +-- > , bspline pts +-- > ] +-- > # frame 0.5 + +bspline :: (TrailLike t, V t ~ v, N t ~ n) => BSpline v n -> t +bspline = fromLocSegments . fixup . map fromFixedSeg . bsplineToBeziers + where + fixup [] = [] `at` origin + fixup (b1:rest) = (unLoc b1 : map unLoc rest) `at` loc b1 diff --git a/src/Diagrams/CubicSpline/Internal.hs b/src/Diagrams/CubicSpline/Internal.hs --- a/src/Diagrams/CubicSpline/Internal.hs +++ b/src/Diagrams/CubicSpline/Internal.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline @@ -18,76 +14,19 @@ module Diagrams.CubicSpline.Internal ( -- * Solving for spline coefficents - solveTriDiagonal - , solveCyclicTriDiagonal - , solveCubicSplineDerivatives + solveCubicSplineDerivatives , solveCubicSplineDerivativesClosed , solveCubicSplineCoefficients ) where -import Data.List - --- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an --- 'n' by 'n' matrix with 'bs' as the main diagonal and --- 'as' the diagonal below and 'cs' the diagonal above. --- See: -solveTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> [a] -solveTriDiagonal as (b0:bs) (c0:cs) (d0:ds) = h cs' ds' - where - cs' = c0 / b0 : f cs' as bs cs - f _ [_] _ _ = [] - f (c':cs') (a:as) (b:bs) (c:cs) = c / (b - c' * a) : f cs' as bs cs - f _ _ _ _ = error "solveTriDiagonal.f: impossible!" - - ds' = d0 / b0 : g ds' as bs cs' ds - g _ [] _ _ _ = [] - g (d':ds') (a:as) (b:bs) (c':cs') (d:ds) = (d - d' * a)/(b - c' * a) : g ds' as bs cs' ds - g _ _ _ _ _ = error "solveTriDiagonal.g: impossible!" - - h _ [d] = [d] - h (c:cs) (d:ds) = let xs@(x:_) = h cs ds in d - c * x : xs - h _ _ = error "solveTriDiagonal.h: impossible!" - -solveTriDiagonal _ _ _ _ = error "arguments 2,3,4 to solveTriDiagonal must be nonempty" - --- Helper that applies the passed function only to the last element of a list -modifyLast :: (a -> a) -> [a] -> [a] -modifyLast _ [] = [] -modifyLast f [a] = [f a] -modifyLast f (a:as) = a : modifyLast f as - --- Helper that builds a list of length n of the form: '[s,m,m,...,m,m,e]' -sparseVector :: Int -> a -> a -> a -> [a] -sparseVector n s m e - | n < 1 = [] - | otherwise = s : h (n - 1) - where - h 1 = [e] - h n = m : h (n - 1) - --- | Solves a system similar to the tri-diagonal system using a special case --- of the Sherman-Morrison formula . --- This code is based on /Numerical Recpies in C/'s @cyclic@ function in section 2.7. -solveCyclicTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> a -> a -> [a] -solveCyclicTriDiagonal as (b0:bs) cs ds alpha beta = zipWith ((+) . (fact *)) zs xs - where - l = length ds - gamma = -b0 - us = sparseVector l gamma 0 alpha - - bs' = (b0 - gamma) : modifyLast (subtract (alpha*beta/gamma)) bs - - xs@(x:_) = solveTriDiagonal as bs' cs ds - zs@(z:_) = solveTriDiagonal as bs' cs us - - fact = -(x + beta * last xs / gamma) / (1.0 + z + beta * last zs / gamma) +import Diagrams.Solve.Tridiagonal -solveCyclicTriDiagonal _ _ _ _ _ _ = error "second argument to solveCyclicTriDiagonal must be nonempty" +import Data.List -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. solveCubicSplineDerivatives :: Fractional a => [a] -> [a] solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds - where + where as = replicate (l - 1) 1 bs = 2 : replicate (l - 2) 4 ++ [2] l = length ds @@ -99,7 +38,7 @@ -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 - where + where as = replicate (l - 1) 1 bs = replicate l 4 l = length xs @@ -109,11 +48,11 @@ -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] -solveCubicSplineCoefficients closed xs = +solveCubicSplineCoefficients closed xs = [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1] | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds') ] - where + where ds | closed = solveCubicSplineDerivativesClosed xs | otherwise = solveCubicSplineDerivatives xs close as | closed = as ++ [head as] diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Deform.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Diagrams.Deform + ( Deformation(..) + , Deformable(..) + , asDeformation + ) where + +import Control.Lens (mapped, over, _Wrapped) +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Prelude + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +------------------------------------------------------------ +-- Deformations + +-- | @Deformations@ are a superset of the affine transformations +-- represented by the 'Transformation' type. In general they are not +-- invertible. @Deformation@s include projective transformations. +-- @Deformation@ can represent other functions from points to points +-- which are "well-behaved", in that they do not introduce small wiggles. +newtype Deformation v u n = Deformation (Point v n -> Point u n) + +instance Semigroup (Deformation v v n) where + (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) + +instance Monoid (Deformation v v n) where + mappend = (<>) + mempty = Deformation id + +class Deformable a b where + -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, approximate + -- to accuracy @epsilon@. + deform' :: N a -> Deformation (V a) (V b) (N a) -> a -> b + + -- | @deform d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, @deform@ + -- should call @deform'@ with some reasonable default value of + -- @epsilon@. + deform :: Deformation (V a) (V b) (N a) -> a -> b + +-- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by +-- discarding the inverse transform. This allows reusing +-- @Transformation@s in the construction of @Deformation@s. +asDeformation :: (Additive v, Num n) => Transformation v n -> Deformation v v n +asDeformation t = Deformation (papply t) + +------------------------------------------------------------ +-- Instances + +instance r ~ Point u n => Deformable (Point v n) r where + deform' = const deform + + deform (Deformation l) = l + +-- | Cubic curves are not closed under perspective projections. +-- Therefore @Segment@s are not an instance of Deformable. However, +-- the deformation of a @Segment@ can be approximated to arbitrary +-- precision by a series of @Segment@s. @deformSegment@ does this, +-- which allows types built from lists of @Segment@s to themselves be +-- @Deformable@. +deformSegment :: (Metric v, Metric u, OrderedField n) + => n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n] +deformSegment epsilon t = go (0::Int) + where + go n s + | n == 100 = [approx t s] + | goodEnough epsilon t s = [approx t s] + | otherwise = concatMap (go (n+1)) [s1, s2] + where + (s1, s2) = splitAtParam s 0.5 +-- deformSegment epsilon t s +-- | goodEnough epsilon t s = [approx t s] +-- | otherwise = concatMap (deformSegment epsilon t) [s1, s2] +-- where +-- (s1, s2) = splitAtParam s 0.5 + +approx :: Deformation v u n -> FixedSegment v n -> FixedSegment u n +approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) +approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) + where f = deform t + +goodEnough :: (Metric v, Metric u, OrderedField n) => n -> Deformation v u n -> FixedSegment v n -> Bool +goodEnough e t s = + all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u + | u <- [0.25, 0.5, 0.75]] + +instance (Metric v, Metric u, OrderedField n, r ~ Located (Trail u n)) + => Deformable (Located (Trail v n)) r where + deform' eps p t + | isLine $ unLoc t = line `at` p0 + | otherwise = glueTrail line `at` p0 + where + segs = concatMap (deformSegment eps p) $ fixTrail t + p0 = case segs of + (FLinear start _:_) -> start + (FCubic start _ _ _:_) -> start + _ -> deform p (loc t) + line = trailFromSegments $ map (unLoc . fromFixedSeg) segs + + deform p t = deform' (0.01 * extent) p t + where + -- estimate the "size" of the Trail' as + -- the maximum distance to any vertex + extent = maximum . map dist . trailVertices $ t + dist pt = norm $ pt .-. loc t + +instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => Deformable (Path v n) r where + deform' eps p = over (_Wrapped . mapped) (deform' eps p) + deform p = over (_Wrapped . mapped) (deform p) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Direction.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Direction +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing directions, polymorphic in vector space +-- +----------------------------------------------------------------------------- + +module Diagrams.Direction + ( Direction + , _Dir + , direction, dir, fromDirection, fromDir + , angleBetweenDirs + , dirBetween + ) where + +import Control.Lens (Iso', iso) + +import Diagrams.Angle +import Diagrams.Core + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +-------------------------------------------------------------------------------- +-- Direction + +-- | A vector is described by a @Direction@ and a magnitude. So we +-- can think of a @Direction@ as a vector that has forgotten its +-- magnitude. @Direction@s can be used with 'fromDirection' and the +-- lenses provided by its instances. +newtype Direction v n = Dir (v n) + deriving (Read, Show, Eq, Ord, Functor) -- todo: special instances + +type instance V (Direction v n) = v +type instance N (Direction v n) = n + +instance (V (v n) ~ v, N (v n) ~ n, Transformable (v n)) => Transformable (Direction v n) where + transform t (Dir v) = Dir (transform t v) + +instance HasTheta v => HasTheta (Direction v) where + _theta = _Dir . _theta + +instance HasPhi v => HasPhi (Direction v) where + _phi = _Dir . _phi + +-- | _Dir is provided to allow efficient implementations of functions +-- in particular vector-spaces, but should be used with care as it +-- exposes too much information. +_Dir :: Iso' (Direction v n) (v n) +_Dir = iso (\(Dir v) -> v) Dir + +-- | @direction v@ is the direction in which @v@ points. Returns an +-- unspecified value when given the zero vector as input. +direction :: v n -> Direction v n +direction = Dir + +-- | Synonym for 'direction'. +dir :: v n -> Direction v n +dir = Dir + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: (Metric v, Floating n) => Direction v n -> v n +fromDirection (Dir v) = signorm v + +-- | Synonym for 'fromDirection'. +fromDir :: (Metric v, Floating n) => Direction v n -> v n +fromDir (Dir v) = signorm v + +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: (Metric v, Floating n, Ord n) + => Direction v n -> Direction v n -> Angle n +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) + +-- | @dirBetween p q@ returns the direction from @p@ to @q@. +dirBetween :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n +dirBetween p q = dir $ q .-. p diff --git a/src/Diagrams/LinearMap.hs b/src/Diagrams/LinearMap.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/LinearMap.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.LinearMap +-- Copyright : (c) 2014-2015 diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Linear maps. Unlike 'Transformation's these are not restricted to the +-- same space. In practice these are used for projections in +-- "Diagrams.ThreeD.Projection". Unless you want to work with +-- projections you're probably better off using 'Diagrams.Transform'. +-- +-- Currently only path-like things can be projected. In the future we +-- hope to support projecting diagrams. +-- +----------------------------------------------------------------------------- + +module Diagrams.LinearMap + ( -- * Linear maps + LinearMap (..) + , LinearMappable (..) + -- ** Applying linear maps + , linmap + + -- * Affine maps + , AffineMap (..) + , AffineMappable (..) + + -- ** Constructing affine maps + , mkAffineMap + , toAffineMap + ) where + +import Control.Lens +import Data.FingerTree as FT +import qualified Data.Foldable as F + +import Diagrams.Core +import Diagrams.Core.Transform +import Diagrams.Located +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail hiding (offset) + +import Linear.Affine +import Linear.Metric +import Linear.Vector + + +-- | Type for holding linear maps. Note that these are not affine transforms so +-- attemping apply a translation with 'LinearMap' will likely produce incorrect +-- results. +newtype LinearMap v u n = LinearMap { lapply :: v n -> u n } + +toLinearMap :: Transformation v n -> LinearMap v v n +toLinearMap (Transformation (m :-: _) _ _) = LinearMap m + +-- | Class of things that have vectors that can be mapped over. +class LinearMappable a b where + -- | Apply a linear map to an object. If the map is not linear, + -- behaviour will likely be wrong. + vmap :: (Vn a -> Vn b) -> a -> b + -- this uses a function instead of LinearMap so we can also use this + -- class to change number types + +-- Note: instances need to be of the form +-- +-- r ~ A u m => LinearMappable (A v n) r +-- +-- so ghc knows there's only one possible result from calling vmap. + +-- | Apply a linear map. +linmap :: (InSpace v n a, LinearMappable a b, N b ~ n) + => LinearMap v (V b) n -> a -> b +linmap = vmap . lapply + +instance r ~ Offset c u m => LinearMappable (Offset c v n) r where + vmap f (OffsetClosed v) = OffsetClosed (f v) + vmap _ OffsetOpen = OffsetOpen + {-# INLINE vmap #-} + +instance r ~ Segment c u m => LinearMappable (Segment c v n) r where + vmap f (Linear offset) = Linear (vmap f offset) + vmap f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (vmap f offset) + {-# INLINE vmap #-} + +instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ SegTree u m) + => LinearMappable (SegTree v n) r where + vmap f = over _Wrapped (fmap' (vmap f)) + {-# INLINE vmap #-} + +instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail' l u m) + => LinearMappable (Trail' l v n) r where + vmap f (Line st) = Line (vmap f st) + vmap f (Loop st offset) = Loop (vmap f st) (vmap f offset) + {-# INLINE vmap #-} + +instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m) + => LinearMappable (Trail v n) r where + vmap f (Trail (Line st)) = Trail $ Line (vmap f st) + vmap f (Trail (Loop st offset)) = Trail $ Loop (vmap f st) (vmap f offset) + {-# INLINE vmap #-} + +instance LinearMappable (Point v n) (Point u m) where + vmap f (P v) = P (f v) + {-# INLINE vmap #-} + +instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where + vmap f (FLinear p0 p1) = FLinear (vmap f p0) (vmap f p1) + vmap f (FCubic p0 p1 p2 p3) = FCubic (vmap f p0) (vmap f p1) + (vmap f p2) (vmap f p3) + {-# INLINE vmap #-} + +instance (LinearMappable a b, r ~ Located b) => LinearMappable (Located a) r where + vmap f (Loc p a) = Loc (vmap f p) (vmap f a) + {-# INLINE vmap #-} + +instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m) + => LinearMappable (Path v n) r where + vmap f = _Wrapped . mapped %~ vmap f + {-# INLINE vmap #-} + +-- | Affine linear maps. Unlike 'Transformation' these do not have to be +-- invertible so we can map between spaces. +data AffineMap v u n = AffineMap (LinearMap v u n) (u n) + +-- | Make an affine map from a linear function and a translation. +mkAffineMap :: (v n -> u n) -> u n -> AffineMap v u n +mkAffineMap f = AffineMap (LinearMap f) + +toAffineMap :: Transformation v n -> AffineMap v v n +toAffineMap t = AffineMap (toLinearMap t) (transl t) + +class (LinearMappable a b, N a ~ N b) => AffineMappable a b where + -- | Affine map over an object. Has a default implimentation of only + -- applying the linear map + amap :: (Additive (V a), F.Foldable (V a), Additive (V b), Num (N b)) + => AffineMap (V a) (V b) (N b) -> a -> b + amap (AffineMap f _) = linmap f + {-# INLINE amap #-} + +instance r ~ Offset c u n => AffineMappable (Offset c v n) r +instance r ~ Segment c u n => AffineMappable (Segment c v n) r +instance (Metric v, Metric u, OrderedField n, r ~ SegTree u n) => AffineMappable (SegTree v n) r +instance (Metric v, Metric u, OrderedField n, r ~ Trail' l u n) => AffineMappable (Trail' l v n) r +instance (Metric v, Metric u, OrderedField n, r ~ Trail u n) => AffineMappable (Trail v n) r + +instance (Additive v, Num n, r ~ Point u n) => AffineMappable (Point v n) r where + amap (AffineMap f v) p = linmap f p .+^ v + {-# INLINE amap #-} + +instance r ~ FixedSegment u n => AffineMappable (FixedSegment v n) r where + amap m (FLinear p0 p1) = FLinear (amap m p0) (amap m p1) + amap m (FCubic p0 p1 p2 p3) = FCubic (amap m p0) (amap m p1) (amap m p2) (amap m p3) + {-# INLINE amap #-} + +instance (LinearMappable a b, N a ~ N b, r ~ Located b) => AffineMappable (Located a) r where + amap m@(AffineMap l _) (Loc p x) = Loc (amap m p) (linmap l x) + {-# INLINE amap #-} + +instance (Metric v, Metric u, OrderedField n, r ~ Path u n) + => AffineMappable (Path v n) r where + amap m = _Wrapped . mapped %~ amap m + {-# INLINE amap #-} diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -19,20 +22,25 @@ ----------------------------------------------------------------------------- module Diagrams.Located - ( Located - , at, viewLoc, unLoc, loc, mapLoc + ( Located (..) + , at, viewLoc, mapLoc, located, _loc ) where -import Data.AffineSpace -import Data.VectorSpace +import Control.Lens (Lens, Lens') +import Text.Read +import Linear.Affine +import Linear.Vector + +import Diagrams.Align import Diagrams.Core -import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Parametric - -- for GHC 7.4 type family bug +import Data.Serialize (Serialize) +import GHC.Generics (Generic) + -- | \"Located\" things, /i.e./ things with a concrete location: -- intuitively, @Located a ~ (Point, a)@. Wrapping a translationally -- invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins @@ -48,27 +56,30 @@ -- 'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and -- 'TrailLike' instances are particularly useful; see the documented -- instances below for more information. -data Located a = Loc { loc :: Point (V a) -- ^ Project out the - -- location of a @Located@ - -- value. - , unLoc :: a -- ^ Project the value - -- of type @a@ out of - -- a @Located a@, - -- discarding the - -- location. - } +data Located a = + Loc { loc :: Point (V a) (N a) -- ^ Project out the + -- location of a @Located@ + -- value. + , unLoc :: a -- ^ Project the value + -- of type @a@ out of + -- a @Located a@, + -- discarding the + -- location. + } deriving (Generic) +instance (Serialize a, Serialize (V a (N a))) => Serialize (Located a) + infix 5 `at` -- | Construct a @Located a@ from a value of type @a@ and a location. -- @at@ is intended to be used infix, like @x \`at\` origin@. -at :: a -> Point (V a) -> Located a +at :: a -> Point (V a) (N a) -> Located a at a p = Loc p a -- | Deconstruct a @Located a@ into a location and a value of type -- @a@. @viewLoc@ can be especially useful in conjunction with the -- @ViewPatterns@ extension. -viewLoc :: Located a -> (Point (V a), a) +viewLoc :: Located a -> (Point (V a) (N a), a) viewLoc (Loc p a) = (p,a) -- | 'Located' is not a @Functor@, since changing the type could @@ -81,28 +92,49 @@ -- @Located@ is a little-f (endo)functor on the category of types -- with associated vector space @v@; but that is not covered by the -- standard @Functor@ class.) -mapLoc :: (V a ~ V b) => (a -> b) -> Located a -> Located b +mapLoc :: SameSpace a b => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) -deriving instance (Eq (V a), Eq a ) => Eq (Located a) -deriving instance (Ord (V a), Ord a ) => Ord (Located a) -deriving instance (Show (V a), Show a) => Show (Located a) +-- | A lens giving access to the object within a 'Located' wrapper. +located :: SameSpace a b => Lens (Located a) (Located b) a b +located f (Loc p a) = Loc p <$> f a +-- | Lens onto the location of something 'Located'. +_loc :: Lens' (Located a) (Point (V a) (N a)) +_loc f (Loc p a) = flip Loc a <$> f p + +deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) +deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) + +instance (Show (V a (N a)), Show a) => Show (Located a) where + showsPrec d (Loc p a) = showParen (d > 5) $ + showsPrec 6 a . showString " `at` " . showsPrec 6 p + +instance (Read (V a (N a)), Read a) => Read (Located a) where + readPrec = parens . prec 5 $ do + a <- readPrec + Punc "`" <- lexP + Ident "at" <- lexP + Punc "`" <- lexP + p <- readPrec + return (Loc p a) + type instance V (Located a) = V a +type instance N (Located a) = N a -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not. -- In particular, translating a @Located a@ simply translates the -- associated point (and does /not/ affect the value of type @a@). -instance VectorSpace (V a) => HasOrigin (Located a) where +instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a -- | Applying a transformation @t@ to a @Located a@ results in the -- transformation being applied to the location, and the /linear/ -- /portion/ of @t@ being applied to the value of type @a@ (/i.e./ -- it is not translated). -instance Transformable a => Transformable (Located a) where +instance (Additive (V a), Num (N a), Transformable a) => Transformable (Located a) where transform t@(Transformation t1 t2 _) (Loc p a) - = Loc (transform t p) (transform (Transformation t1 t2 zeroV) a) + = Loc (transform t p) (transform (Transformation t1 t2 zero) a) -- | The envelope of a @Located a@ is the envelope of the @a@, -- translated to the location. @@ -114,31 +146,38 @@ -- | The trace of a @Located a@ is the trace of the @a@, -- translated to the location. -instance Traced a => Traced (Located a) where +instance (Traced a, Num (N a)) => Traced (Located a) where getTrace (Loc p a) = moveTo p (getTrace a) +instance Alignable a => Alignable (Located a) where + defaultBoundary v = defaultBoundary v . unLoc + instance Qualifiable a => Qualifiable (Located a) where - n |> (Loc p a) = Loc p (n |> a) + n .>> Loc p a = Loc p (n .>> a) -type instance Codomain (Located a) = Located (Codomain a) +type instance Codomain (Located a) = Point (Codomain a) -instance (V a ~ V (Codomain a), Parametric a) => Parametric (Located a) where - (Loc x a) `atParam` p = Loc x (a `atParam` p) +instance (InSpace v n a, Parametric a, Codomain a ~ v) + => Parametric (Located a) where + Loc x a `atParam` p = x .+^ (a `atParam` p) instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (V a ~ V (Codomain a), EndValues a) => EndValues (Located a) +instance (InSpace v n a, EndValues a, Codomain a ~ v) => EndValues (Located a) -instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) - , Sectionable a, Parametric a - ) +instance (InSpace v n a, Fractional n, Parametric a, Sectionable a, Codomain a ~ v) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p -instance (HasArcLength a, Fractional (Scalar (V a)), V a ~ V (Codomain a)) + section (Loc x a) p1 p2 = Loc (x .+^ (a `atParam` p1)) (section a p1 p2) + + reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) + where y = a `atParam` domainUpper a + +instance (InSpace v n a, Fractional n, HasArcLength a, Codomain a ~ v) => HasArcLength (Located a) where - arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a - arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l + arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a + arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs --- a/src/Diagrams/Names.hs +++ b/src/Diagrams/Names.hs @@ -1,4 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Names @@ -33,28 +39,28 @@ -- * Querying by name , names + , lookupName , withName, withNameAll, withNames ) where import Data.Semigroup -import Data.VectorSpace -import Diagrams.Core (HasLinearMap, OrderedField, Point) +import Diagrams.Core (OrderedField, Point) import Diagrams.Core.Names import Diagrams.Core.Types +import Linear.Metric + -- | Attach an atomic name to a diagram. -named :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => n -> QDiagram b v m -> QDiagram b v m +named :: (IsName nm, Metric v, OrderedField n, Semigroup m) + => nm -> QDiagram b v n m -> QDiagram b v n m named = nameSub mkSubdiagram -- | Attach an atomic name to a certain point (which may be computed -- from the given diagram), treated as a subdiagram with no content -- and a point envelope. -namePoint :: ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) - => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m +namePoint :: (IsName nm , Metric v, OrderedField n, Semigroup m) + => (QDiagram b v n m -> Point v n) -> nm -> QDiagram b v n m -> QDiagram b v n m namePoint p = nameSub (subPoint . p) diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -15,28 +15,20 @@ ----------------------------------------------------------------------------- module Diagrams.Parametric ( - -- * Parametric functions stdTolerance , Codomain, Parametric(..) - , DomainBounds(..), EndValues(..), Sectionable(..), HasArcLength(..) - - -- * Adjusting - , adjust - , AdjustOpts(..), AdjustMethod(..), AdjustSide(..) + , DomainBounds(..), domainBounds, EndValues(..), Sectionable(..), HasArcLength(..) ) where -import Diagrams.Core -import Diagrams.Util - -import Data.Default.Class -import Data.VectorSpace -import qualified Numeric.Interval as I +import Data.Kind (Type) +import Diagrams.Core.V +import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. -type family Codomain p :: * +type family Codomain p :: Type -> Type -- | Type class for parametric functions. class Parametric p where @@ -44,7 +36,7 @@ -- | 'atParam' yields a parameterized view of an object as a -- continuous function. It is designed to be used infix, like @path -- ``atParam`` 0.5@. - atParam :: p -> Scalar (V p) -> Codomain p + atParam :: p -> N p -> Codomain p (N p) -- | Type class for parametric functions with a bounded domain. The -- default bounds are @[0,1]@. @@ -55,16 +47,16 @@ class DomainBounds p where -- | 'domainLower' defaults to being constantly 0 (for vector spaces with -- numeric scalars). - domainLower :: p -> Scalar (V p) + domainLower :: p -> N p - default domainLower :: Num (Scalar (V p)) => p -> Scalar (V p) + default domainLower :: Num (N p) => p -> N p domainLower = const 0 -- | 'domainUpper' defaults to being constantly 1 (for vector spaces -- with numeric scalars). - domainUpper :: p -> Scalar (V p) + domainUpper :: p -> N p - default domainUpper :: Num (Scalar (V p)) => p -> Scalar (V p) + default domainUpper :: Num (N p) => p -> N p domainUpper = const 1 -- | Type class for querying the values of a parametric object at the @@ -76,7 +68,7 @@ -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. - atStart :: p -> Codomain p + atStart :: p -> Codomain p (N p) atStart x = x `atParam` domainLower x -- | 'atEnd' is the value at the end of the domain. That is, @@ -85,28 +77,31 @@ -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. - atEnd :: p -> Codomain p + atEnd :: p -> Codomain p (N p) atEnd x = x `atParam` domainUpper x -- | Return the lower and upper bounds of a parametric domain together -- as a pair. -domainBounds :: DomainBounds p => p -> (Scalar (V p), Scalar (V p)) +domainBounds :: DomainBounds p => p -> (N p, N p) domainBounds x = (domainLower x, domainUpper x) -- | Type class for parametric objects which can be split into -- subobjects. -- --- Minimal definition: Either 'splitAtParam' or 'section'. +-- Minimal definition: Either 'splitAtParam' or 'section', +-- plus 'reverseDomain'. class DomainBounds p => Sectionable p where -- | 'splitAtParam' splits an object @p@ into two new objects -- @(l,r)@ at the parameter @t@, where @l@ corresponds to the -- portion of @p@ for parameter values from @0@ to @t@ and @r@ for -- to that from @t@ to @1@. The following property should hold: -- - -- > prop_splitAtParam f t u = - -- > | u < t = atParam f u == atParam l (u / t) - -- > | otherwise = atParam f u == atParam f t ??? atParam l ((u - t) / (domainUpper f - t)) - -- > where (l,r) = splitAtParam f t + -- @ + -- prop_splitAtParam f t u = + -- | u < t = atParam f u == atParam l (u / t) + -- | otherwise = atParam f u == atParam f t ??? atParam l ((u - t) / (domainUpper f - t)) + -- where (l,r) = splitAtParam f t + -- @ -- -- where @(???) = (^+^)@ if the codomain is a vector type, or -- @const flip@ if the codomain is a point type. Stated more @@ -119,7 +114,7 @@ -- result paths where the first is the original path extended to -- the parameter 2, and the second result path travels /backwards/ -- from the end of the first to the end of the original path. - splitAtParam :: p -> Scalar (V p) -> (p, p) + splitAtParam :: p -> N p -> (p, p) splitAtParam x t = ( section x (domainLower x) t , section x t (domainUpper x)) @@ -135,16 +130,12 @@ -- -- That is, the section should have the same domain as the -- original, and the reparameterization should be linear. - section :: p -> Scalar (V p) -> Scalar (V p) -> p - default section :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) -> p + section :: p -> N p -> N p -> p + default section :: Fractional (N p) => p -> N p -> N p -> p section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) - -- | Flip the parameterization on the domain. This has the - -- following default definition: - -- - -- > reverse x = section x (domainUpper x) (domainLower x) + -- | Flip the parameterization on the domain. reverseDomain :: p -> p - reverseDomain x = section x (domainUpper x) (domainLower x) -- | The standard tolerance used by @std...@ functions (like -- 'stdArcLength' and 'stdArcLengthToParam', currently set at @@ -158,18 +149,18 @@ -- | @arcLengthBounded eps x@ approximates the arc length of @x@. -- The true arc length is guaranteed to lie within the interval -- returned, which will have a size of at most @eps@. - arcLengthBounded :: Scalar (V p) -> p -> I.Interval (Scalar (V p)) + arcLengthBounded :: N p -> p -> I.Interval (N p) -- | @arcLength eps s@ approximates the arc length of @x@ up to the -- accuracy @eps@ (plus or minus). - arcLength :: Scalar (V p) -> p -> Scalar (V p) - default arcLength :: Fractional (Scalar (V p)) => Scalar (V p ) -> p -> Scalar (V p) + arcLength :: N p -> p -> N p + default arcLength :: Fractional (N p) => N p -> p -> N p arcLength eps = I.midpoint . arcLengthBounded eps -- | Approximate the arc length up to a standard accuracy of -- 'stdTolerance' (@1e-6@). - stdArcLength :: p -> Scalar (V p) - default stdArcLength :: Fractional (Scalar (V p)) => p -> Scalar (V p) + stdArcLength :: p -> N p + default stdArcLength :: Fractional (N p) => p -> N p stdArcLength = arcLength stdTolerance -- | @'arcLengthToParam' eps s l@ converts the absolute arc length @@ -179,65 +170,11 @@ -- -- This should work for /any/ arc length, and may return any -- parameter value (not just parameters in the domain). - arcLengthToParam :: Scalar (V p) -> p -> Scalar (V p) -> Scalar (V p) + arcLengthToParam :: N p -> p -> N p -> N p -- | A simple interface to convert arc length to a parameter, -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. - stdArcLengthToParam :: p -> Scalar (V p) -> Scalar (V p) - default stdArcLengthToParam :: Fractional (Scalar (V p)) - => p -> Scalar (V p) -> Scalar (V p) + stdArcLengthToParam :: p -> N p -> N p + default stdArcLengthToParam :: Fractional (N p) => p -> N p -> N p stdArcLengthToParam = arcLengthToParam stdTolerance --------------------------------------------------- --- Adjusting length --------------------------------------------------- - --- | What method should be used for adjusting a segment, trail, or --- path? -data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value - -- (use a negative parameter to shrink) - | ByAbsolute (Scalar v) -- ^ Extend by the given arc length - -- (use a negative length to shrink) - | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given - -- arc length - --- | Which side of a segment, trail, or path should be adjusted? -data AdjustSide = Start -- ^ Adjust only the beginning - | End -- ^ Adjust only the end - | Both -- ^ Adjust both sides equally - deriving (Show, Read, Eq, Ord, Bounded, Enum) - --- | How should a segment, trail, or path be adjusted? -data AdjustOpts v = AO { adjMethod :: AdjustMethod v - , adjSide :: AdjustSide - , adjEps :: Scalar v - , adjOptsvProxy__ :: Proxy v - } - -instance Fractional (Scalar v) => Default (AdjustMethod v) where - def = ByParam 0.2 - -instance Default AdjustSide where - def = Both - -instance Fractional (Scalar v) => Default (AdjustOpts v) where - def = AO def def stdTolerance Proxy - --- | Adjust the length of a parametric object such as a segment or --- trail. The second parameter is an option record which controls how --- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) - => a -> AdjustOpts (V a) -> a -adjust s opts = section s - (if adjSide opts == End then domainLower s else getParam s) - (if adjSide opts == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) - where - getParam seg = case adjMethod opts of - ByParam p -> -p * bothCoef - ByAbsolute len -> param (-len * bothCoef) - ToAbsolute len -> param (absDelta len * bothCoef) - where - param = arcLengthToParam eps seg - absDelta len = arcLength eps s - len - bothCoef = if adjSide opts == Both then 0.5 else 1 - eps = adjEps opts diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Parametric/Adjust.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Parametric.Adjust +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Tools for adjusting the length of parametric objects such as +-- segments and trails. +-- +----------------------------------------------------------------------------- +module Diagrams.Parametric.Adjust + ( adjust + , AdjustOpts(_adjMethod, _adjSide, _adjEps) + , adjMethod, adjSide, adjEps + , AdjustMethod(..), AdjustSide(..) + + ) where + +import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), + (.~), (^.)) +import Data.Proxy + +import Data.Default + +import Diagrams.Core.V +import Diagrams.Parametric + +-- | What method should be used for adjusting a segment, trail, or +-- path? +data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value + -- (use a negative parameter to shrink) + | ByAbsolute n -- ^ Extend by the given arc length + -- (use a negative length to shrink) + | ToAbsolute n -- ^ Extend or shrink to the given + -- arc length + +-- | Which side of a segment, trail, or path should be adjusted? +data AdjustSide = Start -- ^ Adjust only the beginning + | End -- ^ Adjust only the end + | Both -- ^ Adjust both sides equally + deriving (Show, Read, Eq, Ord, Bounded, Enum) + +-- | How should a segment, trail, or path be adjusted? +data AdjustOpts n = AO { _adjMethod :: AdjustMethod n + , _adjSide :: AdjustSide + , _adjEps :: n + , adjOptsvProxy :: Proxy n + } + +-- See Diagrams.Combinators for reasoning behind 'Proxy'. + +makeLensesWith (lensRules & generateSignatures .~ False) ''AdjustOpts + +-- | Which method should be used for adjusting? +adjMethod :: Lens' (AdjustOpts n) (AdjustMethod n) + +-- | Which end(s) of the object should be adjusted? +adjSide :: Lens' (AdjustOpts n) AdjustSide + +-- | Tolerance to use when doing adjustment. +adjEps :: Lens' (AdjustOpts n) n + +instance Fractional n => Default (AdjustMethod n) where + def = ByParam 0.2 + +instance Default AdjustSide where + def = Both + +instance Fractional n => Default (AdjustOpts n) where + def = AO { _adjMethod = def + , _adjSide = def + , _adjEps = stdTolerance + , adjOptsvProxy = Proxy + } + +-- | Adjust the length of a parametric object such as a segment or +-- trail. The second parameter is an option record which controls how +-- the adjustment should be performed; see 'AdjustOpts'. +adjust :: (N t ~ n, Sectionable t, HasArcLength t, Fractional n) + => t -> AdjustOpts n -> t +adjust s opts = section s + (if opts^.adjSide == End then domainLower s else getParam s) + (if opts^.adjSide == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) + where + getParam seg = case opts^.adjMethod of + ByParam p -> -p * bothCoef + ByAbsolute len -> param (-len * bothCoef) + ToAbsolute len -> param (absDelta len * bothCoef) + where + param = arcLengthToParam eps seg + absDelta len = arcLength eps s - len + bothCoef = if opts^.adjSide == Both then 0.5 else 1 + eps = opts^.adjEps diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -6,8 +8,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Path @@ -28,21 +35,24 @@ -- * Paths - Path(..) + Path(..), pathTrails -- * Constructing paths -- $construct + , ToPath (..) , pathFromTrail , pathFromTrailAt , pathFromLocTrail -- * Eliminating paths + , pathPoints + , pathVertices' , pathVertices , pathOffsets , pathCentroid - , fixPath + , pathLocSegments, fixPath -- * Modifying paths @@ -56,9 +66,15 @@ ) where +import Control.Arrow ((***)) +import Control.Lens hiding (at, transform, ( # )) +import qualified Data.Foldable as F +import Data.List (partition) +import Data.Semigroup +import Data.Typeable + import Diagrams.Align import Diagrams.Core -import Diagrams.Core.Points import Diagrams.Located import Diagrams.Points import Diagrams.Segment @@ -66,14 +82,12 @@ import Diagrams.TrailLike import Diagrams.Transform -import Control.Arrow (first, second, (***)) -import Control.Newtype hiding (under) -import Data.AffineSpace -import qualified Data.Foldable as F -import Data.List (mapAccumL, partition) -import Data.Semigroup -import Data.VectorSpace +import Linear.Metric +import Linear.Vector +import Data.Serialize (Serialize) +import GHC.Generics (Generic) + ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ @@ -82,81 +96,136 @@ -- Hence, unlike trails, paths are not translationally invariant, -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. -newtype Path v = Path { pathTrails :: [Located (Trail v)] } - deriving (Semigroup, Monoid) +newtype Path v n = Path [Located (Trail v n)] + deriving (Semigroup, Monoid, Generic + , Typeable + ) -deriving instance Show v => Show (Path v) -deriving instance Eq v => Eq (Path v) -deriving instance Ord v => Ord (Path v) +-- instance (OrderedField n, Metric v, Serialize (v n), Serialize (V n (N n))) => +instance (OrderedField n, Metric v, Serialize (v n), Serialize (V (v n) (N (v n)))) => + Serialize (Path v n) -type instance V (Path v) = v +instance Wrapped (Path v n) where + type Unwrapped (Path v n) = [Located (Trail v n)] + _Wrapped' = iso (\(Path x) -> x) Path -instance Newtype (Path v) [Located (Trail v)] where - pack = Path - unpack = pathTrails +instance Rewrapped (Path v n) (Path v' n') -instance VectorSpace v => HasOrigin (Path v) where - moveOriginTo = over Path . map . moveOriginTo +instance Each (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where + each = _Wrapped . traverse --- | Paths are trail-like; a trail can be used to construct a --- singleton path. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Path v) where - trailLike = Path . (:[]) +instance AsEmpty (Path v n) where + _Empty = _Wrapped' . _Empty --- See Note [Transforming paths] -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Path v) where - transform = over Path . map . transform +instance Cons (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where + _Cons = _Wrapped . _Cons . bimapping id _Unwrapped + {-# INLINE _Cons #-} -{- ~~~~ Note [Transforming paths] +instance Snoc (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where + _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id + {-# INLINE _Snoc #-} -Careful! It's tempting to just define +-- | Extract the located trails making up a 'Path'. +pathTrails :: Path v n -> [Located (Trail v n)] +pathTrails = op Path -> transform = fmap . transform +deriving instance Show (v n) => Show (Path v n) +deriving instance Eq (v n) => Eq (Path v n) +deriving instance Ord (v n) => Ord (Path v n) -but that doesn't take into account the fact that some -of the v's are inside Points and hence ought to be translated. --} +type instance V (Path v n) = v +type instance N (Path v n) = n -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => IsPrim (Path v) +instance (Additive v, Num n) => HasOrigin (Path v n) where + moveOriginTo = over _Wrapped' . map . moveOriginTo -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where - getEnvelope = F.foldMap trailEnvelope . pathTrails +-- | Paths are trail-like; a trail can be used to construct a +-- singleton path. +instance (Metric v, OrderedField n) => TrailLike (Path v n) where + trailLike = Path . (:[]) + +-- See Note [Transforming paths] +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Path v n) where + transform = over _Wrapped . map . transform + +instance (Metric v, OrderedField n) => Enveloped (Path v n) where + getEnvelope = F.foldMap trailEnvelope . op Path -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 - where trailEnvelope :: Located (Trail v) -> Envelope v + where trailEnvelope :: Located (Trail v n) -> Envelope v n trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) -instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where +instance (Metric v, OrderedField n) => Juxtaposable (Path v n) where juxtapose = juxtaposeDefault -instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where - alignBy = alignByDefault +instance (Metric v, OrderedField n) => Alignable (Path v n) where + defaultBoundary = envelopeBoundary -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Renderable (Path v) NullBackend where +instance (HasLinearMap v, Metric v, OrderedField n) + => Renderable (Path v n) NullBackend where render _ _ = mempty ------------------------------------------------------------ -- Constructing paths ------------------------------------ ------------------------------------------------------------ +-- | Type class for things that can be converted to a 'Path'. +-- +-- Note that this class is very different from 'TrailLike'. 'TrailLike' is +-- usually the result of a library function to give you a convenient, +-- polymorphic result ('Path', 'Diagram' etc.). +-- +class ToPath t where + -- | 'toPath' takes something that can be converted to 'Path' and returns + -- the 'Path'. + toPath :: (Metric (V t), OrderedField (N t)) => t -> Path (V t) (N t) + +instance ToPath (Path v n) where + toPath = id + +instance ToPath (Trail v n) where + toPath = pathFromTrail + +instance ToPath (Trail' l v n) where + toPath t = Path [Trail t `at` origin] + +instance ToPath (Located (Trail v n)) where + toPath = pathFromLocTrail + +instance ToPath (Located (Trail' l v n)) where + toPath = pathFromLocTrail . mapLoc Trail + +instance ToPath (Located (Segment Closed v n)) where + toPath (viewLoc -> (p,seg)) + = Path [trailFromSegments [seg] `at` p] + +instance ToPath (Located [Segment Closed v n]) where + toPath (viewLoc -> (p,segs)) + = Path [trailFromSegments segs `at` p] + +instance ToPath (FixedSegment v n) where + toPath = toPath . fromFixedSeg + +instance ToPath a => ToPath [a] where + toPath = F.foldMap toPath + -- $construct -- Since paths are 'TrailLike', any function producing a 'TrailLike' -- can be used to construct a (singleton) path. The functions in this -- section are provided for convenience. -- | Convert a trail to a path beginning at the origin. -pathFromTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Path v +pathFromTrail :: (Metric v, OrderedField n) => Trail v n -> Path v n pathFromTrail = trailLike . (`at` origin) -- | Convert a trail to a path with a particular starting point. -pathFromTrailAt :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Point v -> Path v +pathFromTrailAt :: (Metric v, OrderedField n) => Trail v n -> Point v n -> Path v n pathFromTrailAt t p = trailLike (t `at` p) -- | Convert a located trail to a singleton path. This is equivalent -- to 'trailLike', but provided with a more specific name and type -- for convenience. -pathFromLocTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Path v +pathFromLocTrail :: (Metric v, OrderedField n) => Located (Trail v n) -> Path v n pathFromLocTrail = trailLike ------------------------------------------------------------ @@ -164,33 +233,65 @@ ------------------------------------------------------------ -- | Extract the vertices of a path, resulting in a separate list of --- vertices for each component trail (see 'trailVertices'). -pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] -pathVertices = map trailVertices . pathTrails +-- vertices for each component trail. Here a /vertex/ is defined as +-- a non-differentiable point on the trail, /i.e./ a sharp corner. +-- (Vertices are thus a subset of the places where segments join; if +-- you want all joins between segments, see 'pathPoints'.) The +-- tolerance determines how close the tangents of two segments must be +-- at their endpoints to consider the transition point to be +-- differentiable. See 'trailVertices' for more information. +pathVertices' :: (Metric v, OrderedField n) => n -> Path v n -> [[Point v n]] +pathVertices' toler = map (trailVertices' toler) . op Path +-- | Like 'pathVertices'', with a default tolerance. +pathVertices :: (Metric v, OrderedField n) => Path v n -> [[Point v n]] +pathVertices = map trailVertices . op Path + +-- | Extract the points of a path, resulting in a separate list of +-- points for each component trail. Here a /point/ is any place +-- where two segments join; see also 'pathVertices' and 'trailPoints'. +-- +-- This function allows you "observe" the fact that trails are +-- implemented as lists of segments, which may be problematic if we +-- want to think of trails as parametric vector functions. This also +-- means that the behavior of this function may not be stable under +-- future changes to the implementation of trails and paths. For an +-- unproblematic version which only yields vertices at which there +-- is a sharp corner, excluding points differentiable points, see +-- 'pathVertices'. +-- +-- This function is not re-exported from "Diagrams.Prelude"; to use +-- it, import "Diagrams.Path". +pathPoints :: (Metric v, OrderedField n) => Path v n -> [[Point v n]] +pathPoints = map trailPoints . op Path + -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). -pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] -pathOffsets = map (trailOffset . unLoc) . pathTrails +pathOffsets :: (Metric v, OrderedField n) => Path v n -> [v n] +pathOffsets = map (trailOffset . unLoc) . op Path -- | Compute the /centroid/ of a path (/i.e./ the average location of --- its vertices). -pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v +-- its /vertices/; see 'pathVertices'). +pathCentroid :: (Metric v, OrderedField n) => Path v n -> Point v n pathCentroid = centroid . concat . pathVertices +-- | Convert a path into a list of lists of located segments. +pathLocSegments :: (Metric v, OrderedField n) => Path v n -> [[Located (Segment Closed v n)]] +pathLocSegments = map trailLocSegments . op Path + -- | Convert a path into a list of lists of 'FixedSegment's. -fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] -fixPath = map fixTrail . unpack +fixPath :: (Metric v, OrderedField n) => Path v n -> [[FixedSegment v n]] +fixPath = map fixTrail . op Path -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). -explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] -explodePath = map explodeTrail . pathTrails +explodePath :: (V t ~ v, N t ~ n, TrailLike t) => Path v n -> [[t]] +explodePath = map explodeTrail . op Path -- | Partition a path into two paths based on a predicate on trails: -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. -partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) -partitionPath p = (pack *** pack) . partition p . unpack +partitionPath :: (Located (Trail v n) -> Bool) -> Path v n -> (Path v n, Path v n) +partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Path ------------------------------------------------------------ -- Modifying paths --------------------------------------- @@ -198,10 +299,13 @@ -- | Scale a path using its centroid (see 'pathCentroid') as the base -- point for the scale. -scalePath :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Scalar v -> Path v -> Path v -scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p +scalePath :: (HasLinearMap v, Metric v, OrderedField n) => n -> Path v n -> Path v n +scalePath d p = under (movedFrom (pathCentroid p)) (scale d) p -- | Reverse all the component trails of a path. -reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v -reversePath = (over Path . map) reverseLocTrail +reversePath :: (Metric v, OrderedField n) => Path v n -> Path v n +reversePath = _Wrapped . mapped %~ reverseLocTrail + +-- | Same as 'reversePath'. +instance (Metric v, OrderedField n) => Reversing (Path v n) where + reversing = _Wrapped' . mapped %~ reversing diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Points @@ -9,36 +6,36 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Points in space. For more tools for working with points and --- vectors, see "Data.AffineSpace" and "Diagrams.Coordinates". +-- vectors, see "Linear.Affine". -- ----------------------------------------------------------------------------- module Diagrams.Points ( -- * Points - Point, origin, (*.) + Point (..), origin, (*.) -- * Point-related utilities , centroid - + , pointDiagram + , _Point, lensP ) where -import Diagrams.Coordinates +import Diagrams.Core (pointDiagram) import Diagrams.Core.Points -import Control.Newtype - -import Control.Arrow ((&&&)) +import Data.Foldable as F -import Data.VectorSpace +import Linear.Affine +import Linear.Vector -- | The centroid of a set of /n/ points is their sum divided by /n/. -centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v -centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack +-- Returns the origin for an empty list of points. +centroid :: (Additive v, Fractional n) => [Point v n] -> Point v n +centroid [] = origin +centroid ps = meanV ps +{-# INLINE centroid #-} -instance Coordinates v => Coordinates (Point v) where - type FinalCoord (Point v) = FinalCoord v - type PrevDim (Point v) = PrevDim v - type Decomposition (Point v) = Decomposition v +meanV :: (Foldable f, Additive v, Fractional a) => f (v a) -> v a +meanV = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) +{-# INLINE meanV #-} - x & y = P (x & y) - coords (P v) = coords v diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -1,8 +1,9 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Prelude --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -12,129 +13,93 @@ ----------------------------------------------------------------------------- module Diagrams.Prelude - ( - -- * Core library - -- | The core definitions of transformations, diagrams, - -- backends, and so on. - module Diagrams.Core - - -- * Standard library - - -- | Attributes (color, line style, etc.) and styles. - , module Diagrams.Attributes - - -- | Alignment of diagrams relative to their envelopes. - , module Diagrams.Align - - -- | Combining multiple diagrams into one. - , module Diagrams.Combinators - - -- | Giving concrete locations to translation-invariant things. - , module Diagrams.Located - - -- | Linear and cubic bezier segments. - , module Diagrams.Segment - - -- | Trails. - , module Diagrams.Trail - - -- | Parametrization of segments and trails. - , module Diagrams.Parametric - - -- | Trail-like things. - , module Diagrams.TrailLike - - -- | Paths. - , module Diagrams.Path - - -- | Cubic splines. - , module Diagrams.CubicSpline + ( + -- * Diagrams library + -- | Exports from this library for working with diagrams. + module Diagrams - -- | Some additional transformation-related functions, like - -- conjugation of transformations. - , module Diagrams.Transform + -- * Convenience re-exports from other packages - -- | Convenient definitions and utilities for working with - -- good old-fashioned, axis-aligned bounding boxes. - , module Diagrams.BoundingBox + -- | For working with default values. Diagrams also exports 'with', + -- an alias for 'def'. + , module Data.Default - -- | Giving names to subdiagrams and later retrieving - -- subdiagrams by name. - , module Diagrams.Names + -- | For representing and operating on colors. + , module Data.Colour - -- | Envelopes, aka functional bounding regions. - , module Diagrams.Envelope + -- | A large list of color names. + , module Data.Colour.Names - -- | Traces, aka embedded raytracers, for finding points on - -- the boundary of a diagram. - , module Diagrams.Trace + -- | Specify your own colours. + , module Data.Colour.SRGB - -- | A query is a function that maps points in a vector space - -- to values in some monoid; they can be used to annotate - -- the points of a diagram with some values. - , module Diagrams.Query + -- | Semigroups and monoids show up all over the place, so things from + -- Data.Semigroup and Data.Monoid often come in handy. + , module Data.Semigroup - -- | Utilities for working with points. - , module Diagrams.Points + -- | For computing with vectors. + , module Linear.Vector - -- | A wide range of things (shapes, transformations, - -- combinators) specific to creating two-dimensional - -- diagrams. - , module Diagrams.TwoD + -- | For computing with points and vectors. + , module Linear.Affine - -- | Tools for making animations. - , module Diagrams.Animation + -- | For computing with dot products and norm. + , module Linear.Metric - -- | Various utility definitions. - , module Diagrams.Util + -- | For working with 'Active' (i.e. animated) things. + , module Data.Active - -- * Convenience re-exports - -- | For representing and operating on colors. - , module Data.Colour - -- | A large list of color names. - , module Data.Colour.Names - -- | Semigroups and monoids show up all over the place, so things from - -- Data.Semigroup and Data.Monoid often come in handy. - , module Data.Semigroup - -- | For computing with vectors. - , module Data.VectorSpace - -- | For computing with points and vectors. - , module Data.AffineSpace + -- | Most of the lens package. The following functions are not + -- exported from lens because they either conflict with + -- diagrams or may conflict with other libraries: + -- + -- * 'Control.Lens.At.at' + -- * 'Control.Lens.At.contains' + -- * 'Control.Lens.Indexed..>' + -- * 'Control.Lens.Indexed.<.>' + -- * 'Control.Lens.Indexed.index' + -- * 'Control.Lens.Indexed.indices' + -- * 'Control.Lens.Indexed.none' + -- * 'Control.Lens.Internal.Getter.coerce' + -- * 'Control.Lens.Internal.Indexed.indexed' + -- * 'Control.Lens.Lens.inside' + -- * 'Control.Lens.Level.levels' + -- * 'Control.Lens.Plated....' + -- * 'Control.Lens.Plated.children' + -- * 'Control.Lens.Plated.transform' + -- * 'Control.Lens.Prism.outside' + -- * 'Control.Lens.Setter.argument' + -- * 'Control.Lens.Traversal.beside' + -- * 'Control.Lens.Traversal.singular' + , module Control.Lens - -- | For working with 'Active' (i.e. animated) things. - , module Data.Active + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 + ) where - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 - ) where +import Diagrams -import Diagrams.Core +import Control.Applicative -import Diagrams.Align -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.BoundingBox -import Diagrams.Combinators -import Diagrams.Coordinates -import Diagrams.CubicSpline -import Diagrams.Envelope -import Diagrams.Located -import Diagrams.Names -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Points -import Diagrams.Query -import Diagrams.Segment -import Diagrams.Trace -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.Transform -import Diagrams.TwoD -import Diagrams.Util +#if MIN_VERSION_lens(4,13,0) +import Control.Lens hiding (argument, at, backwards, beside, + children, contains, indexed, indices, + inside, levels, none, outside, singular, + transform, ( # ), (...), (.>), (<.>)) +#else +import Control.Lens hiding (argument, at, backwards, beside, + children, coerce, contains, indexed, + indices, inside, levels, none, outside, + singular, transform, ( # ), (...), (.>), + (<.>)) +#endif -import Control.Applicative import Data.Active -import Data.AffineSpace -import Data.Colour hiding (AffineSpace (..), atop) -import Data.Colour.Names +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) +import Data.Colour.SRGB +import Data.Default import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) + +import Linear.Affine +import Linear.Metric +import Linear.Vector diff --git a/src/Diagrams/Query.hs b/src/Diagrams/Query.hs --- a/src/Diagrams/Query.hs +++ b/src/Diagrams/Query.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Query @@ -12,8 +16,78 @@ ----------------------------------------------------------------------------- module Diagrams.Query - ( Query(..), query, sample, value, resetValue, clearValue + ( -- * Queries + Query(..) + , HasQuery (..) + , sample + , inquire - ) where + -- ** Queries on diagrams + , query + , value + , resetValue + , clearValue + ) where +import Data.Monoid + import Diagrams.Core + +-- | Types which can answer a 'Query' about points inside the geometric +-- object. +-- +-- If @t@ and @m@ are both a 'Semigroup's, 'getQuery' should satisfy +-- +-- @ +-- 'getQuery' (t1 <> t2) = 'getQuery' t1 <> 'getQuery' t2 +-- @ +class HasQuery t m | t -> m where + -- | Extract the query of an object. + getQuery :: t -> Query (V t) (N t) m + +instance HasQuery (Query v n m) m where + getQuery = id + +instance Monoid m => HasQuery (QDiagram b v n m) m where + getQuery = query + +-- | Test if a point is not equal to 'mempty'. +-- +-- @ +-- 'inquire' :: 'QDiagram' b v n 'Any' -> 'Point' v n -> 'Bool' +-- 'inquire' :: 'Query' v n 'Any' -> 'Point' v n -> 'Bool' +-- 'inquire' :: 'Diagrams.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Bool' +-- @ +inquire :: HasQuery t Any => t -> Point (V t) (N t) -> Bool +inquire t = getAny . sample t + +-- | Sample a diagram's query function at a given point. +-- +-- @ +-- 'sample' :: 'QDiagram' b v n m -> 'Point' v n -> m +-- 'sample' :: 'Query' v n m -> 'Point' v n -> m +-- 'sample' :: 'Diagrams.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Any' +-- 'sample' :: 'Diagrams.Path.Path' 'V2' 'Double' -> 'Point' v n -> 'Diagrams.TwoD.Path.Crossings' +-- @ +sample :: HasQuery t m => t -> Point (V t) (N t) -> m +sample = runQuery . getQuery + +-- | Set the query value for 'True' points in a diagram (/i.e./ points +-- \"inquire\" the diagram); 'False' points will be set to 'mempty'. +value :: Monoid m => m -> QDiagram b v n Any -> QDiagram b v n m +value m = fmap fromAny + where fromAny (Any True) = m + fromAny (Any False) = mempty + +-- | 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 n m -> QDiagram b v n Any +resetValue = fmap toAny + where toAny m | m == mempty = Any False + | otherwise = Any True + +-- | Set all the query values of a diagram to 'False'. +clearValue :: QDiagram b v n m -> QDiagram b v n Any +clearValue = fmap (const (Any False)) + diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,10 +8,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -40,43 +42,50 @@ -- * Segment offsets - , Offset(..), segOffset + , Offset(..) , segOffset -- * Constructing and modifying segments - , Segment(..), straight, bezier3, bézier3, reverseSegment + , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors + , openLinear, openCubic -- * Fixed (absolutely located) segments , FixedSegment(..) , mkFixedSeg, fromFixedSeg + , fixedSegIso -- * Segment measures -- $segmeas , SegCount(..) - , ArcLength(..), getArcLengthCached, getArcLengthFun, getArcLengthBounded + , ArcLength(..) + , getArcLengthCached, getArcLengthFun, getArcLengthBounded , TotalOffset(..) - , OffsetEnvelope(..) + , OffsetEnvelope(..), oeOffset, oeEnvelope , SegMeasure ) where -import Control.Applicative (liftA2) -import Data.AffineSpace -import Data.Default.Class +import Control.Lens hiding (at, transform) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) -import Numeric.Interval (Interval (..)) -import qualified Numeric.Interval as I +import Numeric.Interval.Kaucher (Interval (..)) +import qualified Numeric.Interval.Kaucher as I -import Diagrams.Core +import Linear.Affine +import Linear.Metric +import Linear.Vector hiding (lerp) +import Linear.Vector.Compat (lerp) + +import Control.Applicative +import Diagrams.Core hiding (Measured) import Diagrams.Located import Diagrams.Parametric -import Diagrams.Solve -import Diagrams.Util +import Diagrams.Solve.Polynomial +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize ------------------------------------------------------------ -- Open/closed type tags --------------------------------- @@ -100,23 +109,35 @@ -- the context, /i.e./ its endpoint is not fixed. The offset for a -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. -data Offset c v where - OffsetOpen :: Offset Open v - OffsetClosed :: v -> Offset Closed v +data Offset c v n where + OffsetOpen :: Offset Open v n + OffsetClosed :: v n -> Offset Closed v n -deriving instance Show v => Show (Offset c v) -deriving instance Eq v => Eq (Offset c v) -deriving instance Ord v => Ord (Offset c v) +deriving instance Show (v n) => Show (Offset c v n) +deriving instance Eq (v n) => Eq (Offset c v n) +deriving instance Ord (v n) => Ord (Offset c v n) -instance Functor (Offset c) where +instance Functor v => Functor (Offset c v) where fmap _ OffsetOpen = OffsetOpen - fmap f (OffsetClosed v) = OffsetClosed (f v) + fmap f (OffsetClosed v) = OffsetClosed (fmap f v) -type instance V (Offset c v) = v +instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where + each f (OffsetClosed v) = OffsetClosed <$> f v + each _ OffsetOpen = pure OffsetOpen + {-# INLINE each #-} -instance HasLinearMap v => Transformable (Offset c v) where - transform = fmap . apply +-- | Reverses the direction of closed offsets. +instance (Additive v, Num n) => Reversing (Offset c v n) where + reversing (OffsetClosed off) = OffsetClosed $ negated off + reversing a@OffsetOpen = a +type instance V (Offset c v n) = v +type instance N (Offset c v n) = n + +instance Transformable (Offset c v n) where + transform _ OffsetOpen = OffsetOpen + transform t (OffsetClosed v) = OffsetClosed (apply t v) + ------------------------------------------------------------ -- Constructing segments --------------------------------- ------------------------------------------------------------ @@ -128,34 +149,62 @@ -- \"location\" and are unaffected by translations. They are, -- however, affected by other transformations such as rotations and -- scales. -data Segment c v - = Linear (Offset c v) +data Segment c v n + = Linear !(Offset c v n) -- ^ A linear segment with given offset. - | Cubic v v (Offset c v) + | Cubic !(v n) !(v n) !(Offset c v n) -- ^ A cubic Bézier segment specified by -- three offsets from the starting -- point to the first control point, -- second control point, and ending -- point, respectively. - deriving (Show, Functor, Eq, Ord) + deriving (Functor, Eq, Ord) +instance Show (v n) => Show (Segment c v n) where + showsPrec d seg = case seg of + Linear (OffsetClosed v) -> showParen (d > 10) $ + showString "straight " . showsPrec 11 v + Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $ + showString "bézier3 " . showsPrec 11 v1 . showChar ' ' + . showsPrec 11 v2 . showChar ' ' + . showsPrec 11 v3 + Linear OffsetOpen -> showString "openLinear" + Cubic v1 v2 OffsetOpen -> showParen (d > 10) $ + showString "openCubic " . showsPrec 11 v1 . showChar ' ' + . showsPrec 11 v2 + + +instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where + each f (Linear offset) = Linear <$> each f offset + each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset + {-# INLINE each #-} + +-- | Reverse the direction of a segment. +instance (Additive v, Num n) => Reversing (Segment Closed v n) where + reversing = reverseSegment + +-- | Map over the vectors of each segment. +mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' +mapSegmentVectors = over each + -- Note, can't yet have Haddock comments on GADT constructors; see -- http://trac.haskell.org/haddock/ticket/43. For now we don't need -- Segment to be a GADT but we might in the future. (?) -type instance V (Segment c v) = v +type instance V (Segment c v n) = v +type instance N (Segment c v n) = n -instance HasLinearMap v => Transformable (Segment c v) where - transform = fmap . apply +instance Transformable (Segment c v n) where + transform = mapSegmentVectors . apply -instance HasLinearMap v => Renderable (Segment c v) NullBackend where +instance Renderable (Segment c v n) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. -straight :: v -> Segment Closed v +straight :: v n -> Segment Closed v n straight = Linear . OffsetClosed -- Note, if we didn't have a Linear constructor we could also create @@ -167,40 +216,50 @@ -- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively -- given by @c1@, @c2@, and @x@. -bezier3 :: v -> v -> v -> Segment Closed v +bezier3 :: v n -> v n -> v n -> Segment Closed v n bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) -- | @bézier3@ is the same as @bezier3@, but with more snobbery. -bézier3 :: v -> v -> v -> Segment Closed v +bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 -type instance Codomain (Segment Closed v) = v +type instance Codomain (Segment Closed v n) = v -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of -- the segment for each value of the parameter between @0@ and @1@. -- It is designed to be used infix, like @seg ``atParam`` 0.5@. -instance (VectorSpace v, Num (Scalar v)) => Parametric (Segment Closed v) where +instance (Additive v, Num n) => Parametric (Segment Closed v n) where atParam (Linear (OffsetClosed x)) t = t *^ x atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1 ^+^ (3 * t'*t *t ) *^ c2 ^+^ ( t *t *t ) *^ x2 where t' = 1-t -instance Num (Scalar v) => DomainBounds (Segment Closed v) +instance Num n => DomainBounds (Segment Closed v n) -instance (VectorSpace v, Num (Scalar v)) => EndValues (Segment Closed v) where - atStart = const zeroV +instance (Additive v, Num n) => EndValues (Segment Closed v n) where + atStart = const zero atEnd (Linear (OffsetClosed v)) = v atEnd (Cubic _ _ (OffsetClosed v)) = v -- | Compute the offset from the start of a segment to the -- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. -segOffset :: Segment Closed v -> v +segOffset :: Segment Closed v n -> v n segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v +-- | An open linear segment. This means the trail makes a straight line +-- from the last segment the beginning to form a loop. +openLinear :: Segment Open v n +openLinear = Linear OffsetOpen + +-- | An open cubic segment. This means the trail makes a cubic bézier +-- with control vectors @v1@ and @v2@ to form a loop. +openCubic :: v n -> v n -> Segment Open v n +openCubic v1 v2 = Cubic v1 v2 OffsetOpen + ------------------------------------------------------------ -- Computing segment envelope ------------------------------ ------------------------------------------------------------ @@ -228,63 +287,68 @@ -} -- | The envelope for a segment is based at the segment's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where +instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> - maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] + maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . - map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ + map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $ [0,1] ++ filter (liftA2 (&&) (>0) (<1)) - (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) <.> v)) - (6 * (((-2) *^ c1 ^+^ c2) <.> v)) - ((3 *^ c1) <.> v)) + (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) + (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) + ((3 *^ c1) `dot` v)) ------------------------------------------------------------ -- Manipulating segments ------------------------------------------------------------ -instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (Segment Closed v) where +instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) - p = lerp zeroV x1 t + p = lerp t zero x1 splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) where left = bezier3 a b e right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) - p = lerp c1 c2 t - a = lerp zeroV c1 t - b = lerp a p t - d = lerp c2 x2 t - c = lerp p d t - e = lerp b c t + p = lerp t c1 c2 + a = lerp t zero c1 + b = lerp t a p + d = lerp t c2 x2 + c = lerp t p d + e = lerp t b c reverseDomain = reverseSegment -- | Reverse the direction of a segment. -reverseSegment :: AdditiveGroup v => Segment Closed v -> Segment Closed v -reverseSegment (Linear (OffsetClosed v)) = straight (negateV v) -reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) +reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n +reverseSegment (Linear (OffsetClosed v)) = straight (negated v) +reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -instance (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) - => HasArcLength (Segment Closed v) where +-- Imitates I.elem for intervals<0.8 and I.member for intervals>=0.8 +member :: Ord a => a -> I.Interval a -> Bool +member x (I.I a b) = x >= a && x <= b +{-# INLINE member #-} - arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ magnitude x1 +instance (Metric v, OrderedField n) + => HasArcLength (Segment Closed v n) where + + arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1 arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2)) | ub - lb < m = I lb ub | otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r where (l,r) = s `splitAtParam` 0.5 - ub = sum (map magnitude [c1, c2 ^-^ c1, x2 ^-^ c2]) - lb = magnitude x2 + ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2]) + lb = norm x2 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s arcLengthToParam m s@(Cubic {}) len - | len `I.elem` (I (-m/2) (m/2)) = 0 + | len `member` I (-m/2) (m/2) = 0 | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) - | len `I.elem` slen = 1 + | len `member` slen = 1 | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len | len < I.sup llen = (*0.5) $ arcLengthToParam m l len | otherwise = (+0.5) . (*0.5) @@ -306,39 +370,30 @@ -- (Segment Closed v)@, as witnessed by 'mkFixedSeg' and -- 'fromFixedSeg', but @FixedSegment@ is convenient when one needs -- the absolute locations of the vertices and control points. -data FixedSegment v = FLinear (Point v) (Point v) - | FCubic (Point v) (Point v) (Point v) (Point v) - deriving Show +data FixedSegment v n = FLinear (Point v n) (Point v n) + | FCubic (Point v n) (Point v n) (Point v n) (Point v n) + deriving (Eq, Ord, Show) -type instance V (FixedSegment v) = v +type instance V (FixedSegment v n) = v +type instance N (FixedSegment v n) = n -instance HasLinearMap v => Transformable (FixedSegment v) where - transform t (FLinear p1 p2) - = FLinear - (transform t p1) - (transform t p2) +instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where + each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1 + each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 + {-# INLINE each #-} - transform t (FCubic p1 c1 c2 p2) - = FCubic - (transform t p1) - (transform t c1) - (transform t c2) - (transform t p2) +-- | Reverses the control points. +instance Reversing (FixedSegment v n) where + reversing (FLinear p0 p1) = FLinear p1 p0 + reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 -instance VectorSpace v => HasOrigin (FixedSegment v) where - moveOriginTo o (FLinear p1 p2) - = FLinear - (moveOriginTo o p1) - (moveOriginTo o p2) +instance (Additive v, Num n) => Transformable (FixedSegment v n) where + transform t = over each (papply t) - moveOriginTo o (FCubic p1 c1 c2 p2) - = FCubic - (moveOriginTo o p1) - (moveOriginTo o c1) - (moveOriginTo o c2) - (moveOriginTo o p2) +instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where + moveOriginTo o = over each (moveOriginTo o) -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (FixedSegment v) where +instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) where (p, s) = viewLoc $ fromFixedSeg f @@ -347,32 +402,71 @@ -- Envelope, and implement the Segment instance in terms of it, -- instead of the other way around +instance (Metric v, OrderedField n) + => HasArcLength (FixedSegment v n) where + arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) + arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) + -- | Create a 'FixedSegment' from a located 'Segment'. -mkFixedSeg :: AdditiveGroup v => Located (Segment Closed v) -> FixedSegment v -mkFixedSeg (viewLoc -> (p, Linear (OffsetClosed v))) - = FLinear p (p .+^ v) -mkFixedSeg (viewLoc -> (p, Cubic c1 c2 (OffsetClosed x2))) - = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) +mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n +mkFixedSeg ls = + case viewLoc ls of + (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) + (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. -fromFixedSeg :: AdditiveGroup v => FixedSegment v -> Located (Segment Closed v) +fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n) fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -type instance Codomain (FixedSegment v) = Point v +-- | Use a 'FixedSegment' to make an 'Iso' between an +-- a fixed segment and a located segment. +fixedSegIso :: (Num n, Additive v) => Iso' (FixedSegment v n) (Located (Segment Closed v n)) +fixedSegIso = iso fromFixedSeg mkFixedSeg -instance VectorSpace v => Parametric (FixedSegment v) where - atParam (FLinear p1 p2) t = alerp p1 p2 t +type instance Codomain (FixedSegment v n) = Point v + +instance (Additive v, Num n) => Parametric (FixedSegment v n) where + atParam (FLinear p1 p2) t = lerp t p1 p2 atParam (FCubic x1 c1 c2 x2) t = p3 - where p11 = alerp x1 c1 t - p12 = alerp c1 c2 t - p13 = alerp c2 x2 t + where p11 = lerp t x1 c1 + p12 = lerp t c1 c2 + p13 = lerp t c2 x2 - p21 = alerp p11 p12 t - p22 = alerp p12 p13 t + p21 = lerp t p11 p12 + p22 = lerp t p12 p13 - p3 = alerp p21 p22 t + p3 = lerp t p21 p22 +instance Num n => DomainBounds (FixedSegment v n) + +instance (Additive v, Num n) => EndValues (FixedSegment v n) where + atStart (FLinear p0 _) = p0 + atStart (FCubic p0 _ _ _) = p0 + atEnd (FLinear _ p1) = p1 + atEnd (FCubic _ _ _ p1 ) = p1 + +instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where + splitAtParam (FLinear p0 p1) t = (left, right) + where left = FLinear p0 p + right = FLinear p p1 + p = lerp t p0 p1 + splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) + where left = FCubic p0 a b cut + right = FCubic cut c d p1 + -- first round + a = lerp t p0 c1 + p = lerp t c1 c2 + d = lerp t c2 p1 + -- second round + b = lerp t a p + c = lerp t p d + -- final round + cut = lerp t b c + + reverseDomain (FLinear p0 p1) = FLinear p1 p0 + reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 + ------------------------------------------------------------ -- Segment measures -------------------------------------- ------------------------------------------------------------ @@ -382,94 +476,161 @@ -- automatically track various monoidal \"measures\" on segments. -- | A type to track the count of segments in a 'Trail'. -newtype SegCount = SegCount { getSegCount :: Sum Int } +newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) +instance Wrapped SegCount where + type Unwrapped SegCount = Sum Int + _Wrapped' = iso (\(SegCount x) -> x) SegCount + +instance Rewrapped SegCount SegCount + -- | A type to represent the total arc length of a chain of -- segments. The first component is a \"standard\" arc length, -- computed to within a tolerance of @10e-6@. The second component is -- a generic arc length function taking the tolerance as an -- argument. -newtype ArcLength v = ArcLength - { getArcLength :: (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) } +newtype ArcLength n + = ArcLength (Sum (Interval n), n -> Sum (Interval n)) + +instance Wrapped (ArcLength n) where + type Unwrapped (ArcLength n) = (Sum (Interval n), n -> Sum (Interval n)) + _Wrapped' = iso (\(ArcLength x) -> x) ArcLength + +instance Rewrapped (ArcLength n) (ArcLength n') + -- | Project out the cached arc length, stored together with error -- bounds. -getArcLengthCached :: ArcLength v -> Interval (Scalar v) -getArcLengthCached = getSum . fst . getArcLength +getArcLengthCached :: ArcLength n -> Interval n +getArcLengthCached = getSum . fst . op ArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. -getArcLengthFun :: ArcLength v -> Scalar v -> Interval (Scalar v) -getArcLengthFun = fmap getSum . snd . getArcLength +getArcLengthFun :: ArcLength n -> n -> Interval n +getArcLengthFun = fmap getSum . snd . op ArcLength -- | Given a specified tolerance, project out the cached arc length if -- it is accurate enough; otherwise call the generic arc length -- function with the given tolerance. -getArcLengthBounded :: (Num (Scalar v), Ord (Scalar v)) - => Scalar v -> ArcLength v -> Interval (Scalar v) +getArcLengthBounded :: (Num n, Ord n) + => n -> ArcLength n -> Interval n getArcLengthBounded eps al | I.width cached <= eps = cached | otherwise = getArcLengthFun al eps where cached = getArcLengthCached al -deriving instance (Num (Scalar v), Ord (Scalar v)) => Semigroup (ArcLength v) -deriving instance (Num (Scalar v), Ord (Scalar v)) => Monoid (ArcLength v) +deriving instance (Num n, Ord n) => Semigroup (ArcLength n) +deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments. -newtype TotalOffset v = TotalOffset { getTotalOffset :: v } +newtype TotalOffset v n = TotalOffset (v n) -instance AdditiveGroup v => Semigroup (TotalOffset v) where +instance Wrapped (TotalOffset v n) where + type Unwrapped (TotalOffset v n) = v n + _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset + +instance Rewrapped (TotalOffset v n) (TotalOffset v' n') + +instance (Num n, Additive v) => Semigroup (TotalOffset v n) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) -instance AdditiveGroup v => Monoid (TotalOffset v) where - mempty = TotalOffset zeroV +instance (Num n, Additive v) => Monoid (TotalOffset v n) where + mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of -- segments. They have to be paired into one data structure, since -- combining the envelopes of two consecutive chains needs to take --- the offset of the the offset of the first into account. -data OffsetEnvelope v = OffsetEnvelope - { oeOffset :: TotalOffset v - , oeEnvelope :: Envelope v +-- the offset of the first into account. +data OffsetEnvelope v n = OffsetEnvelope + { _oeOffset :: !(TotalOffset v n) + , _oeEnvelope :: Envelope v n } -instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where +makeLenses ''OffsetEnvelope + +instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) - = OffsetEnvelope - (o1 <> o2) - (e1 <> moveOriginBy (negateV . getTotalOffset $ o1) e2) + = let !negOff = negated . op TotalOffset $ o1 + e2Off = moveOriginBy negOff e2 + !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + in OffsetEnvelope + (o1 <> o2) + (e1 <> e2Off) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. -type SegMeasure v = SegCount - ::: ArcLength v - ::: OffsetEnvelope v - ::: () +type SegMeasure v n = SegCount + ::: ArcLength n + ::: OffsetEnvelope v n + ::: () -- unfortunately we can't cache Trace, since there is not a generic -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). -instance (InnerSpace v, OrderedField (Scalar v)) - => Measured (SegMeasure v) (SegMeasure v) where +instance (Metric v, OrderedField n) + => Measured (SegMeasure v n) (SegMeasure v n) where measure = id -instance (OrderedField (Scalar v), InnerSpace v) - => Measured (SegMeasure v) (Segment Closed v) where - measure s = (SegCount . Sum $ 1) +instance (OrderedField n, Metric v) + => Measured (SegMeasure v n) (Segment Closed v n) where + measure s = (SegCount . Sum) 1 -- cache arc length with two orders of magnitude more -- accuracy than standard, so we have a hope of coming out -- with an accurate enough total arc length for -- reasonable-length trails - *: (ArcLength $ ( Sum $ arcLengthBounded (stdTolerance/100) s - , Sum . flip arcLengthBounded s - ) - ) + *: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s + , Sum . flip arcLengthBounded s ) - *: (OffsetEnvelope - (TotalOffset . segOffset $ s) - (getEnvelope s) - ) - *: () + *: OffsetEnvelope (TotalOffset . segOffset $ s) + (getEnvelope s) + + *: () + +------------------------------------------------------------ +-- Serialize instances +------------------------------------------------------------ + +instance (Serialize (v n)) => Serialize (Segment Open v n) where + {-# INLINE put #-} + put segment = case segment of + Linear OffsetOpen -> Serialize.put True + Cubic v w OffsetOpen -> do + Serialize.put False + Serialize.put v + Serialize.put w + + {-# INLINE get #-} + get = do + isLinear <- Serialize.get + case isLinear of + True -> return (Linear OffsetOpen) + False -> do + v <- Serialize.get + w <- Serialize.get + return (Cubic v w OffsetOpen) + +instance (Serialize (v n)) => Serialize (Segment Closed v n) where + {-# INLINE put #-} + put segment = case segment of + Linear (OffsetClosed z) -> do + Serialize.put z + Serialize.put True + Cubic v w (OffsetClosed z) -> do + Serialize.put z + Serialize.put False + Serialize.put v + Serialize.put w + + {-# INLINE get #-} + get = do + z <- Serialize.get + isLinear <- Serialize.get + case isLinear of + True -> return (Linear (OffsetClosed z)) + False -> do + v <- Serialize.get + w <- Serialize.get + return (Cubic v w (OffsetClosed z)) diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Size.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Size +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Utilities for working with sizes of objects. +-- +----------------------------------------------------------------------------- +module Diagrams.Size + ( -- * Size spec + SizeSpec + + -- ** Making size spec + , mkSizeSpec + , dims + , absolute + + -- ** Extracting size specs + , getSpec + , specToSize + + -- ** Functions on size specs + , requiredScale + , requiredScaling + , sized + , sizedAs + , sizeAdjustment + ) where + +import Control.Applicative +import Control.Lens hiding (transform) +import Control.Monad +import Data.Foldable as F +import Data.Hashable +import Data.Maybe +import Data.Semigroup +import Data.Typeable +import GHC.Generics (Generic) +import Prelude + +import Diagrams.BoundingBox +import Diagrams.Core + +import Linear.Affine +import Linear.Vector + +------------------------------------------------------------ +-- Computing diagram sizes +------------------------------------------------------------ + +-- | A 'SizeSpec' is a way of specifying a size without needed lengths for all +-- the dimensions. +newtype SizeSpec v n = SizeSpec (v n) + deriving ( + Eq, + Typeable, + Functor, + Generic, + Hashable, + Show) + +type instance V (SizeSpec v n) = v +type instance N (SizeSpec v n) = n + +-- | Retrieve a size spec as a vector of maybe values. Only positive sizes are +-- returned. +getSpec :: (Functor v, Num n, Ord n) => SizeSpec v n -> v (Maybe n) +getSpec (SizeSpec sp) = mfilter (>0) . Just <$> sp + +-- | Make a 'SizeSpec' from a vector of maybe values. Any negative values will +-- be ignored. For 2D 'SizeSpec's see 'mkWidth' and 'mkHeight' from +-- "Diagrams.TwoD.Size". +mkSizeSpec :: (Functor v, Num n) => v (Maybe n) -> SizeSpec v n +mkSizeSpec = dims . fmap (fromMaybe 0) + +-- | Make a 'SizeSpec' from a vector. Any negative values will be ignored. +dims :: v n -> SizeSpec v n +dims = SizeSpec + +-- | A size spec with no hints to the size. +absolute :: (Additive v, Num n) => SizeSpec v n +absolute = SizeSpec zero + +-- | @specToSize n spec@ extracts a size from a 'SizeSpec' @sz@. Any values not +-- specified in the spec are replaced by the smallest of the values that are +-- specified. If there are no specified values (i.e. 'absolute') then @n@ is +-- used. +specToSize :: (Foldable v, Functor v, Num n, Ord n) => n -> SizeSpec v n -> v n +specToSize n (getSpec -> spec) = fmap (fromMaybe smallest) spec + where + smallest = fromMaybe n $ minimumOf (folded . _Just) spec + +-- | @requiredScale spec sz@ returns the largest scaling factor to make +-- something of size @sz@ fit the requested size @spec@ without changing the +-- aspect ratio. @sz@ should be non-zero (otherwise a scale of 1 is +-- returned). For non-uniform scaling see 'boxFit'. +requiredScale :: (Additive v, Foldable v, Fractional n, Ord n) + => SizeSpec v n -> v n -> n +requiredScale (getSpec -> spec) sz + | allOf (folded . _Just) (<= 0) usedSz = 1 + | otherwise = fromMaybe 1 mScale + where + usedSz = liftI2 (<$) sz spec + scales = liftI2 (^/) spec sz + mScale = minimumOf (folded . _Just) scales + +-- | Return the 'Transformation' calcuated from 'requiredScale'. +requiredScaling :: (Additive v, Foldable v, Fractional n, Ord n) + => SizeSpec v n -> v n -> Transformation v n +requiredScaling spec = scaling . requiredScale spec + +-- | Uniformly scale any enveloped object so that it fits within the +-- given size. For non-uniform scaling see 'boxFit'. +sized :: (InSpace v n a, HasLinearMap v, Transformable a, Enveloped a) + => SizeSpec v n -> a -> a +sized spec a = transform (requiredScaling spec (size a)) a + +-- | Uniformly scale an enveloped object so that it \"has the same +-- size as\" (fits within the width and height of) some other +-- object. +sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, Transformable a, + Enveloped a, Enveloped b) + => b -> a -> a +sizedAs other = sized (dims $ size other) + +-- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The +-- vector is the new size and the transformation to position the lower +-- corner at the origin and scale to the size spec. +sizeAdjustment :: (Additive v, Foldable v, OrderedField n) + => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) +sizeAdjustment spec bb = (sz', t) + where + v = (0.5 *^ P sz') .-. (s *^ fromMaybe origin (boxCenter bb)) + + sz = boxExtents bb + sz' = if allOf folded isJust (getSpec spec) + then specToSize 0 spec + else s *^ sz + + s = requiredScale spec sz + + t = translation v <> scaling s diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs deleted file mode 100644 --- a/src/Diagrams/Solve.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Solve --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Exact solving of low-degree (n <= 3) polynomials. --- ------------------------------------------------------------------------------ -module Diagrams.Solve - ( quadForm - , cubForm - ) where - -import Data.List (maximumBy) -import Data.Ord (comparing) - -import Diagrams.Util (tau) - ------------------------------------------------------------- --- Quadratic formula ------------------------------------------------------------- - --- | The quadratic formula. -quadForm :: (Floating d, Ord d) => d -> d -> d -> [d] -quadForm a b c - - -- There are infinitely many solutions in this case, - -- so arbitrarily return 0 - | a == 0 && b == 0 && c == 0 = [0] - - -- c /= 0 - | a == 0 && b == 0 = [] - - -- linear - | a == 0 = [-c/b] - - -- no real solutions - | d < 0 = [] - - -- ax^2 + c = 0 - | b == 0 = [sqrt (-c/a), -sqrt (-c/a)] - - -- multiplicity 2 solution - | d == 0 = [-b/(2*a)] - - -- see http://www.mpi-hd.mpg.de/astrophysik/HEA/internal/Numerical_Recipes/f5-6.pdf - | otherwise = [q/a, c/q] - where d = b*b - 4*a*c - q = -1/2*(b + signum b * sqrt d) - -quadForm_prop :: Double -> Double -> Double -> Bool -quadForm_prop a b c = all (aboutZero . eval) (quadForm a b c) - where eval x = a*x*x + b*x + c - aboutZero x = abs x < tolerance - tolerance = 1e-10 - ------------------------------------------------------------- --- Cubic formula ------------------------------------------------------------- - --- See http://en.wikipedia.org/wiki/Cubic_formula#General_formula_of_roots - --- | Solve the cubic equation ax^3 + bx^2 + cx + d = 0, returning a --- list of all real roots. -cubForm :: (Floating d, Ord d) => d -> d -> d -> d -> [d] -cubForm a b c d - | aboutZero a = quadForm b c d - - -- three real roots, use trig method to avoid complex numbers - | delta > 0 = map trig [0,1,2] - - -- one real root of multiplicity 3 - | delta == 0 && disc == 0 = [ -b/(3*a) ] - - -- two real roots, one of multiplicity 2 - | delta == 0 && disc /= 0 = [ (b*c - 9*a*d)/(2*disc) - , (9*a*a*d - 4*a*b*c + b*b*b)/(a * disc) - ] - - -- one real root (and two complex) - | otherwise = [-b/(3*a) - cc/(3*a) + disc/(3*a*cc)] - - where delta = 18*a*b*c*d - 4*b*b*b*d + b*b*c*c - 4*a*c*c*c - 27*a*a*d*d - disc = 3*a*c - b*b - qq = sqrt(-27*a*a*delta) - qq' | aboutZero disc = maximumBy (comparing (abs . (+xx))) [qq, -qq] - | otherwise = qq - cc = cubert (1/2*(qq' + xx)) - xx = 2*b*b*b - 9*a*b*c + 27*a*a*d - p = disc/(3*a*a) - q = xx/(27*a*a*a) - trig k = 2 * sqrt(-p/3) * cos(1/3*acos(3*q/(2*p)*sqrt(-3/p)) - k*tau/3) - - b/(3*a) - - cubert x | x < 0 = -((-x)**(1/3)) - | otherwise = x**(1/3) - - aboutZero x = abs x < toler - toler = 1e-10 - -cubForm_prop :: Double -> Double -> Double -> Double -> Bool -cubForm_prop a b c d = all (aboutZero . eval) (cubForm a b c d) - where eval x = a*x*x*x + b*x*x + c*x + d - aboutZero x = abs x < tolerance - tolerance = 1e-5 - -- Basically, however large you set the tolerance it seems - -- that quickcheck can always come up with examples where - -- the returned solutions evaluate to something near zero - -- but larger than the tolerance (but it takes it more - -- tries the larger you set the tolerance). Wonder if this - -- is an inherent limitation or (more likely) a problem - -- with numerical stability. If this turns out to be an - -- issue in practice we could, say, use the solutions - -- generated here as very good guesses to a numerical - -- solver which can give us a more precise answer? diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Tangent.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} -- for ghc < 7.8, TypeFamilies covers GADT patten mathcing in > 7.8 +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Tangent +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Computing tangent and normal vectors for segments and trails. +-- +----------------------------------------------------------------------------- +module Diagrams.Tangent + ( -- ** Tangents + tangentAtParam + , tangentAtStart + , tangentAtEnd + + -- ** Normals + , normalAtParam + , normalAtStart + , normalAtEnd + + -- ** Tangent newtype + , Tangent(..) + ) + where + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment + +import Linear.Vector +import Linear.Metric +import Linear.V2 + +------------------------------------------------------------ +-- Tangent +------------------------------------------------------------ + +-- | A newtype wrapper used to give different instances of +-- 'Parametric' and 'EndValues' that compute tangent vectors. +newtype Tangent t = Tangent t + +type instance V (Tangent t) = V t +type instance N (Tangent t) = N t +type instance Codomain (Tangent t) = V t + +instance DomainBounds t => DomainBounds (Tangent t) where + domainLower (Tangent t) = domainLower t + domainUpper (Tangent t) = domainUpper t + +instance Parametric (Tangent t) => Parametric (Tangent (Located t)) where + Tangent l `atParam` p = Tangent (unLoc l) `atParam` p + +instance (DomainBounds t, EndValues (Tangent t)) + => EndValues (Tangent (Located t)) where + atStart (Tangent l) = atStart (Tangent (unLoc l)) + atEnd (Tangent l) = atEnd (Tangent (unLoc l)) + +-- | Compute the tangent vector to a segment or trail at a particular +-- parameter. +-- +-- Examples of more specific types this function can have include +-- +-- * @Segment Closed V2 -> Double -> V2 Double@ +-- +-- * @Trail' Line V2 -> Double -> V2 Double@ +-- +-- * @Located (Trail V2) -> Double -> V2 Double@ +-- +-- See the instances listed for the 'Tangent' newtype for more. +tangentAtParam :: Parametric (Tangent t) => t -> N t -> Vn t +tangentAtParam t p = Tangent t `atParam` p + +-- | Compute the tangent vector at the start of a segment or trail. +tangentAtStart :: EndValues (Tangent t) => t -> Vn t +tangentAtStart = atStart . Tangent + +-- | Compute the tangent vector at the end of a segment or trail. +tangentAtEnd :: EndValues (Tangent t) => t -> Vn t +tangentAtEnd = atEnd . Tangent + +-------------------------------------------------- +-- Segment + +instance (Additive v, Num n) + => Parametric (Tangent (Segment Closed v n)) where + Tangent (Linear (OffsetClosed v)) `atParam` _ = v + Tangent (Cubic c1 c2 (OffsetClosed x2)) `atParam` p + = (3*(3*p*p-4*p+1))*^c1 ^+^ (3*(2-3*p)*p)*^c2 ^+^ (3*p*p)*^x2 + +instance (Additive v, Num n) + => EndValues (Tangent (Segment Closed v n)) where + atStart (Tangent (Linear (OffsetClosed v))) = v + atStart (Tangent (Cubic c1 _ _)) = c1 + atEnd (Tangent (Linear (OffsetClosed v))) = v + atEnd (Tangent (Cubic _ c2 (OffsetClosed x2))) = x2 ^-^ c2 + +instance (Additive v, Num n) + => Parametric (Tangent (FixedSegment v n)) where + atParam (Tangent fSeg) = atParam $ Tangent (fromFixedSeg fSeg) + +instance (Additive v, Num n) + => EndValues (Tangent (FixedSegment v n)) where + atStart (Tangent fSeg) = atStart $ Tangent (fromFixedSeg fSeg) + atEnd (Tangent fSeg) = atEnd $ Tangent (fromFixedSeg fSeg) + +------------------------------------------------------------ +-- Normal +------------------------------------------------------------ + +-- | Compute the (unit) normal vector to a segment or trail at a +-- particular parameter. +-- +-- Examples of more specific types this function can have include +-- +-- * @Segment Closed V2 Double -> Double -> V2 Double@ +-- +-- * @Trail' Line V2 Double -> Double -> V2 Double@ +-- +-- * @Located (Trail V2 Double) -> Double -> V2 Double@ +-- +-- See the instances listed for the 'Tangent' newtype for more. +normalAtParam + :: (InSpace V2 n t, Parametric (Tangent t), Floating n) + => t -> n -> V2 n +normalAtParam t p = normize (t `tangentAtParam` p) + +-- | Compute the normal vector at the start of a segment or trail. +normalAtStart + :: (InSpace V2 n t, EndValues (Tangent t), Floating n) + => t -> V2 n +normalAtStart = normize . tangentAtStart + +-- | Compute the normal vector at the end of a segment or trail. +normalAtEnd + :: (InSpace V2 n t, EndValues (Tangent t), Floating n) + => t -> V2 n +normalAtEnd = normize . tangentAtEnd + +-- | Construct a normal vector from a tangent. +normize :: Floating n => V2 n -> V2 n +normize = negated . perp . signorm diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module defines the three-dimensional vector space R^3, +-- three-dimensional transformations, and various predefined +-- three-dimensional shapes. This module re-exports useful +-- functionality from a group of more specific modules: +-- +-- * "Diagrams.ThreeD.Types" defines basic types for two-dimensional +-- diagrams, including types representing the 3D Euclidean vector +-- space and various systems of representing directions. +-- +-- * "Diagrams.ThreeD.Transform" defines R^3-specific +-- transformations such as rotation by an angle, and scaling, +-- translation, and reflection in the X, Y, and Z directions. +-- "Diagrams.ThreeD.Deform" defines several R^3-specific +-- non-affine transformations, such as projections. +-- +-- * "Diagrams.ThreeD.Shapes" defines three-dimensional solids, +-- e.g. spheres and cubes. +-- +-- * "Diagrams.ThreeD.Vector" defines some special 3D vectors and +-- functions for converting between vectors and directions. +-- +-- * "Diagrams.ThreeD.Light" and "Diagrams.ThreeD.Camera" define types needed +-- for rendering 3D geometry to (2D) images. +-- +-- * "Diagrams.ThreeD.Align" defines many alignment combinators +-- specialized to three dimensions. +-- +-- * "Diagrams.ThreeD.Attributes" defines 3D-specific attributes +-- such as surface color, diffuse reflectance, and specular +-- highlights. +----------------------------------------------------------------------------- +module Diagrams.ThreeD + ( module Diagrams.ThreeD.Align + , module Diagrams.ThreeD.Attributes + , module Diagrams.ThreeD.Camera + , module Diagrams.ThreeD.Deform + , module Diagrams.ThreeD.Light + , module Diagrams.ThreeD.Shapes + , module Diagrams.ThreeD.Transform + , module Diagrams.ThreeD.Types + , module Diagrams.ThreeD.Vector + ) where + +import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes +import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Deform +import Diagrams.ThreeD.Light +import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Align.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Align +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Alignment combinators specialized for three dimensions. See +-- "Diagrams.Align" for more general alignment combinators. +-- +-- The basic idea is that alignment is achieved by moving diagrams' +-- local origins relative to their envelopes or traces (or some other +-- sort of boundary). For example, to align several diagrams along +-- their tops, we first move their local origins to the upper edge of +-- their boundary (using e.g. @map 'alignZMax'@), and then put them +-- together with their local origins along a line (using e.g. 'cat' +-- from "Diagrams.Combinators"). +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Align + ( -- * Absolute alignment + -- ** Align by envelope + alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax + + -- ** Align by trace + , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax + + -- * Relative alignment + , alignX, snugX, alignY, snugY, alignZ, snugZ + + -- * Centering + , centerX, centerY, centerZ + , centerXY, centerXZ, centerYZ, centerXYZ + , snugCenterX, snugCenterY, snugCenterZ + , snugCenterXY, snugCenterXZ, snugCenterYZ, snugCenterXYZ + + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector +import Diagrams.TwoD.Align + +-- | Translate the diagram along unitX so that all points have +-- positive x-values. +alignXMin :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignXMin = align unit_X + +snugXMin :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugXMin = snug unit_X + +-- | Translate the diagram along unitX so that all points have +-- negative x-values. +alignXMax :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignXMax = align unitX + +snugXMax :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugXMax = snug unitX + + +-- | Translate the diagram along unitY so that all points have +-- positive y-values. +alignYMin :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignYMin = align unit_Y + +snugYMin :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugYMin = snug unit_Y + +-- | Translate the diagram along unitY so that all points have +-- negative y-values. +alignYMax :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignYMax = align unitY + +snugYMax :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugYMax = snug unitY + + +-- | Translate the diagram along unitZ so that all points have +-- positive z-values. +alignZMin :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignZMin = align unit_Z + +snugZMin :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugZMin = snug unit_Z + +-- | Translate the diagram along unitZ so that all points have +-- negative z-values. +alignZMax :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +alignZMax = align unitZ + +snugZMax :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugZMax = snug unitZ + +-- | Like 'alignX', but moving the local origin in the Z direction, with an +-- argument of @1@ corresponding to the top edge and @(-1)@ corresponding +-- to the bottom edge. +alignZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a +alignZ = alignBy unitZ + +-- | See the documentation for 'alignZ'. +snugZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, + R3 v, Fractional n) => n -> a -> a +snugZ = snugBy unitZ + + +-- | Center the local origin along the Z-axis. +centerZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerZ = alignBy unitZ 0 + +snugCenterZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugCenterZ = snugBy unitZ 0 + +-- | Center along both the X- and Z-axes. +centerXZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerXZ = centerX . centerZ + +snugCenterXZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugCenterXZ = snugCenterX . snugCenterZ + + +-- | Center along both the Y- and Z-axes. +centerYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerYZ = centerZ . centerY + +snugCenterYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugCenterYZ = snugCenterZ . snugCenterY + +-- | Center an object in three dimensions. +centerXYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerXYZ = centerX . centerY . centerZ + +snugCenterXYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a +snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Attributes +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines some common attributes relevant in +-- 3D; particular backends may also define more backend-specific +-- attributes. +-- +-- Every attribute type must have a /semigroup/ structure, that is, an +-- associative binary operation for combining two attributes into one. +-- Unless otherwise noted, all the attributes defined here use the +-- 'Last' structure, that is, combining two attributes simply keeps +-- the second one and throws away the first. This means that child +-- attributes always override parent attributes. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Attributes where + +import Control.Lens +import Data.Semigroup +import Data.Typeable + +import Data.Colour + +import Diagrams.Core + +-- | @SurfaceColor@ is the inherent pigment of an object, assumed to +-- be opaque. +newtype SurfaceColor = SurfaceColor (Last (Colour Double)) + deriving (Typeable, Semigroup, Show) + +instance AttributeClass SurfaceColor + +_SurfaceColor :: Iso' SurfaceColor (Colour Double) +_SurfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) + +-- | Set the surface color. +sc :: HasStyle d => Colour Double -> d -> d +sc = applyAttr . review _SurfaceColor + +-- | Lens onto the surface colour of a style. +_sc :: Lens' (Style v n) (Maybe (Colour Double)) +_sc = atAttr . mapping _SurfaceColor + +-- | @Diffuse@ is the fraction of incident light reflected diffusely, +-- that is, in all directions. The actual light reflected is the +-- product of this value, the incident light, and the @SurfaceColor@ +-- Attribute. For physical reasonableness, @Diffuse@ should have a +-- value between 0 and 1; this is not checked. +newtype Diffuse = Diffuse (Last Double) + deriving (Typeable, Semigroup, Show) + +instance AttributeClass Diffuse + +-- | Isomorphism between 'Diffuse' and 'Double' +_Diffuse :: Iso' Diffuse Double +_Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) + +-- | Set the diffuse reflectance. +diffuse :: HasStyle d => Double -> d -> d +diffuse = applyAttr . review _Diffuse + +-- | Lens onto the possible diffuse reflectance in a style. +_diffuse :: Lens' (Style v n) (Maybe Double) +_diffuse = atAttr . mapping _Diffuse + +-- | @Ambient@ is an ad-hoc representation of indirect lighting. The +-- product of @Ambient@ and @SurfaceColor@ is added to the light +-- leaving an object due to diffuse and specular terms. @Ambient@ can +-- be set per-object, and can be loosely thought of as the product of +-- indirect lighting incident on that object and the diffuse +-- reflectance. +newtype Ambient = Ambient (Last Double) + deriving (Typeable, Semigroup, Show) + +instance AttributeClass Ambient + +_Ambient :: Iso' Ambient Double +_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) + +-- | Set the emittance due to ambient light. +ambient :: HasStyle d => Double -> d -> d +ambient = applyAttr . review _Ambient + +-- | Lens onto the possible ambience in a style. +_ambient :: Lens' (Style v n) (Maybe Double) +_ambient = atAttr . mapping _Ambient + +-- | A specular highlight has two terms, the intensity, between 0 and +-- 1, and the size. The highlight size is assumed to be the exponent +-- in a Phong shading model (though Backends are free to use a +-- different shading model). In this model, reasonable values are +-- between 1 and 50 or so, with higher values for shinier objects. +-- Physically, the intensity and the value of @Diffuse@ must add up to +-- less than 1; this is not enforced. +data Specular = Specular + { _specularIntensity :: Double + , _specularSize :: Double + } deriving Show + +makeLenses ''Specular + +newtype Highlight = Highlight (Last Specular) + deriving (Typeable, Semigroup, Show) + +instance AttributeClass Highlight + +_Highlight :: Iso' Highlight Specular +_Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) + +-- | Set the specular highlight. +highlight :: HasStyle d => Specular -> d -> d +highlight = applyAttr . review _Highlight + +-- | Lens onto the possible specular highlight in a style +_highlight :: Lens' (Style v n) (Maybe Specular) +_highlight = atAttr . mapping _Highlight + +-- | Traversal over the highlight intensity of a style. If the style has +-- no 'Specular', setting this will do nothing. +highlightIntensity :: Traversal' (Style v n) Double +highlightIntensity = _highlight . _Just . specularSize + +-- | Traversal over the highlight size in a style. If the style has no +-- 'Specular', setting this will do nothing. +highlightSize :: Traversal' (Style v n) Double +highlightSize = _highlight . _Just . specularSize diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Camera.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Camera +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Types to specify viewpoint for 3D rendering. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Camera + ( Camera -- do not export constructor + -- These are safe to construct manually + , PerspectiveLens(..), OrthoLens(..) + , horizontalFieldOfView, verticalFieldOfView + , orthoWidth, orthoHeight + , camLoc, camForward, camUp, camRight, camLens + , facing_ZCamera, mm50Camera + , mm50, mm50Wide, mm50Narrow + , aspect, camAspect + ) + where + +import Control.Lens (makeLenses) +import Data.Monoid +import Data.Typeable + +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Direction +import Diagrams.ThreeD.Vector + +import Linear.V3 + +-- Parameterize Camera on the lens type, so that Backends can express which +-- lenses they handle. +data Camera l n = Camera + { camLoc :: Point V3 n + , forward :: V3 n + , up :: V3 n + , lens :: l n + } + deriving Typeable + +type instance V (Camera l n) = V3 +type instance N (Camera l n) = n + +class Typeable l => CameraLens l where + -- | The natural aspect ratio of the projection. + aspect :: Floating n => l n -> n + +-- | A perspective projection +data PerspectiveLens n = PerspectiveLens + { _horizontalFieldOfView :: Angle n -- ^ Horizontal field of view. + , _verticalFieldOfView :: Angle n -- ^ Vertical field of view. + } + deriving Typeable + +makeLenses ''PerspectiveLens + +type instance V (PerspectiveLens n) = V3 +type instance N (PerspectiveLens n) = n + +instance CameraLens PerspectiveLens where + aspect (PerspectiveLens h v) = angleRatio h v + +-- | An orthographic projection +data OrthoLens n = OrthoLens + { _orthoWidth :: n -- ^ Width + , _orthoHeight :: n -- ^ Height + } + deriving Typeable + +makeLenses ''OrthoLens + +type instance V (OrthoLens n) = V3 +type instance N (OrthoLens n) = n + +instance CameraLens OrthoLens where + aspect (OrthoLens h v) = h / v + +instance Num n => Transformable (Camera l n) where + transform t (Camera p f u l) = + Camera (transform t p) + (transform t f) + (transform t u) + l + +instance Num n => Renderable (Camera l n) NullBackend where + render _ _ = mempty + +-- | A camera at the origin facing along the negative Z axis, with its +-- up-axis coincident with the positive Y axis. The field of view is +-- chosen to match a 50mm camera on 35mm film. Note that Cameras take +-- up no space in the Diagram. +mm50Camera :: (Typeable n, Floating n, Ord n, Renderable (Camera PerspectiveLens n) b) + => QDiagram b V3 n Any +mm50Camera = facing_ZCamera mm50 + +-- | 'facing_ZCamera l' is a camera at the origin facing along the +-- negative Z axis, with its up-axis coincident with the positive Y +-- axis, with the projection defined by l. +facing_ZCamera :: (Floating n, Ord n, Typeable n, CameraLens l, Renderable (Camera l n) b) => + l n -> QDiagram b V3 n Any +facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) + mempty mempty mempty (Query . const . Any $ False) +{-# ANN facing_ZCamera ("HLint: ignore Use camelCase" :: String) #-} + +mm50, mm50Wide, mm50Narrow :: Floating n => PerspectiveLens n + +-- | mm50 has the field of view of a 50mm lens on standard 35mm film, +-- hence an aspect ratio of 3:2. +mm50 = PerspectiveLens (40.5 @@ deg) (27 @@ deg) + +-- | mm50blWide has the same vertical field of view as mm50, but an +-- aspect ratio of 1.6, suitable for wide screen computer monitors. +mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) + +-- | mm50Narrow has the same vertical field of view as mm50, but an +-- aspect ratio of 4:3, for VGA and similar computer resolutions. +mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) + +camForward :: Camera l n -> Direction V3 n +camForward = direction . forward + +camUp :: Camera l n -> Direction V3 n +camUp = direction . up + +camRight :: Fractional n => Camera l n -> Direction V3 n +camRight c = direction right where + right = cross (forward c) (up c) + +camLens :: Camera l n -> l n +camLens = lens + +camAspect :: (Floating n, CameraLens l) => Camera l n -> n +camAspect = aspect . camLens diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Deform.hs @@ -0,0 +1,28 @@ +module Diagrams.ThreeD.Deform + ( parallelX0, perspectiveX1, facingX + , parallelY0, perspectiveY1, facingY + , parallelZ0, perspectiveZ1, facingZ + ) where + +import Control.Lens + +import Diagrams.Deform +import Diagrams.TwoD.Deform + +import Linear.V3 +import Linear.Vector + +-- | The parallel projection onto the plane z=0 +parallelZ0 :: (R3 v, Num n) => Deformation v v n +parallelZ0 = Deformation (_z .~ 0) + +-- | The perspective division onto the plane z=1 along lines going +-- through the origin. +perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v v n +perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _z) + +facingZ :: (R3 v, Functor v, Fractional n) => Deformation v v n +facingZ = Deformation $ + \p -> let z = p ^. _z + in p ^/ z & _z .~ z + diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Light.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Render +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Types to specify lighting for 3D rendering. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Light where + +import Data.Colour +import Data.Monoid +import Data.Typeable + +import Diagrams.Core +import Diagrams.Direction +import Diagrams.ThreeD.Types + +-- | A @PointLight@ radiates uniformly in all directions from a given +-- point. +data PointLight n = PointLight (Point V3 n) (Colour Double) + deriving Typeable + +type instance V (PointLight n) = V3 +type instance N (PointLight n) = n + +-- | A @ParallelLight@ casts parallel rays in the specified direction, +-- from some distant location outside the scene. +data ParallelLight n = ParallelLight (V3 n) (Colour Double) + deriving Typeable + +type instance V (ParallelLight n) = V3 +type instance N (ParallelLight n) = n + +instance Fractional n => Transformable (PointLight n) where + transform t (PointLight p c) = PointLight (transform t p) c + +instance Transformable (ParallelLight n) where + transform t (ParallelLight v c) = ParallelLight (transform t v) c + +-- | Construct a Diagram with a single PointLight at the origin, which +-- takes up no space. +pointLight :: (Typeable n, Num n, Ord n, Renderable (PointLight n) b) + => Colour Double -- ^ The color of the light + -> QDiagram b V3 n Any +pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty + (Query . const . Any $ False) + +-- | Construct a Diagram with a single ParallelLight, which takes up no space. +parallelLight :: (Typeable n, OrderedField n, Renderable (ParallelLight n) b) + => Direction V3 n -- ^ The direction in which the light travels. + -> Colour Double -- ^ The color of the light. + -> QDiagram b V3 n Any +parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) + mempty mempty mempty (Query . const . Any $ False) diff --git a/src/Diagrams/ThreeD/Projection.hs b/src/Diagrams/ThreeD/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Projection.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Projection +-- Copyright : (c) 2014 diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- 3D projections are a way of viewing a three-dimensional objects on a +-- two-dimensional plane. +-- +-- This module can be used with the functions in "Linear.Projection". +-- +-- Disclaimer: This module should be considered experimental and is +-- likely to change. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Projection + ( -- * Orthographic projections + + -- $orthographic + -- ** Parallel projections + facingXY + , facingXZ + , facingYZ + + -- ** axonometric + -- $axonometric + + -- *** Isometric projections + -- $isometric + , isometricApply + , isometric + + , lookingAt + + -- ** Affine maps + , m44AffineApply + , m44AffineMap + , m33AffineApply + , m33AffineMap + + -- * Perspective projections + -- $perspective + -- ** Perspective deformations + , m44Deformation + , module Linear.Projection + ) where + +import Control.Lens hiding (transform) +import Data.Functor.Rep + +import Diagrams.Core +import Diagrams.Deform +import Diagrams.Direction +import Diagrams.LinearMap +import Diagrams.ThreeD.Types (P3) +import Diagrams.ThreeD.Vector + +import Linear as L +import Linear.Affine +import Linear.Projection + +------------------------------------------------------------------------ +-- Orthographic projections +------------------------------------------------------------------------ + +-- $orthographic +-- Orthographic projections are a form of parallel projections where are +-- projection lines are orthogonal to the projection plane. + +-- Parallel projections + +-- | Look at the xy-plane with y as the up direction. +facingXY :: (Epsilon n, Floating n) => AffineMap V3 V2 n +facingXY = lookingAt unitZ origin yDir + +-- | Look at the xz-plane with z as the up direction. +facingXZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n +facingXZ = lookingAt unitY origin zDir + +-- | Look at the yz-plane with z as the up direction. +facingYZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n +facingYZ = lookingAt unitX origin zDir + +-- $axonometric +-- Axonometric projections are a type of orthographic projection where +-- the object is rotated along one or more of its axes relative to the +-- plane of projection. + +-- $isometric +-- Isometric projections are when the scale along each axis of the +-- projection is the same and the angle between any axis is 120 +-- degrees. + +-- | Apply an isometric projection given the up direction +isometricApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b, Floating n, Epsilon n) + => Direction V3 n -> a -> b +isometricApply up = amap (isometric up) + +-- | Make an isometric affine map with the given up direction. +isometric :: (Floating n, Epsilon n) => Direction V3 n -> AffineMap V3 V2 n +isometric up = m44AffineMap m + where + m = lookAt (V3 1 1 1) zero (fromDirection up) + +lookingAt :: (Epsilon n, Floating n) + => P3 n -- ^ Eye + -> P3 n -- ^ Center + -> Direction V3 n -- ^ Up + -> AffineMap V3 V2 n +lookingAt (P cam) (P center) d = m44AffineMap m + where + m = lookAt cam center (d^._Dir) + +-- | Apply the affine part of a homogeneous matrix. +m44AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b) + => M44 n -> a -> b +m44AffineApply = amap . m44AffineMap + +-- | Create an 'AffineMap' from a 4x4 homogeneous matrix, ignoring any +-- perspective transforms. +m44AffineMap :: Num n => M44 n -> AffineMap V3 V2 n +m44AffineMap m = AffineMap (LinearMap f) (f v) + where + f = view _xy . (m' !*) + m' = m ^. linearTransform + v = m ^. L.translation + +-- | Apply a transformation matrix and translation. +m33AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b) + => M33 n -> V2 n -> a -> b +m33AffineApply m = amap . m33AffineMap m + +-- | Create an 'AffineMap' from a 3x3 transformation matrix and a +-- translation vector. +m33AffineMap :: Num n => M33 n -> V2 n -> AffineMap V3 V2 n +m33AffineMap m = AffineMap (LinearMap f) + where + f = view _xy . (m !*) + +-- | Extract the linear transform part of a homogeneous matrix. +linearTransform :: (Representable u, R3 v, R3 u) => Lens' (u (v n)) (M33 n) +linearTransform = column _xyz . _xyz + +------------------------------------------------------------------------ +-- Perspective transforms +------------------------------------------------------------------------ + +-- For the time being projective transforms use the deformable class. +-- Eventually we would like to replace this with a more specialised +-- method. + +-- $perspective +-- Perspective projections are when closer objects appear bigger. + +-- | Make a deformation from a 4x4 homogeneous matrix. +m44Deformation :: Fractional n => M44 n -> Deformation V3 V2 n +m44Deformation m = + Deformation (P . view _xy . normalizePoint . (m !*) . point . view _Point) + diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , MultiParamTypeClasses - , ViewPatterns - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -15,45 +18,307 @@ ----------------------------------------------------------------------------- module Diagrams.ThreeD.Shapes - ( - Ellipsoid(..) - , sphere - ) where + ( + -- * Skinned class + Skinned(..) -import Prelude hiding (minimum) -import Data.Semigroup + -- * Basic 3D shapes + , Ellipsoid(..) + , sphere -import Data.AffineSpace -import Data.Monoid.Inf (minimum) -import Data.VectorSpace + , Box(..) + , cube -import Diagrams.Core + , Frustum(..) + , frustum + , cone + , cylinder -import Diagrams.ThreeD.Types -import Diagrams.Solve + -- * Constructive solid geometry + , CSG(..) + , union + , intersection + , difference + ) where -data Ellipsoid = Ellipsoid T3 +import Control.Lens (review, (^.), _1) +import Data.Typeable -type instance V Ellipsoid = R3 +import Data.Semigroup +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Core.Trace +import Diagrams.Points +import Diagrams.Query +import Diagrams.Solve.Polynomial +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector -instance Transformable Ellipsoid where +import Linear.Affine +import Linear.Metric +import Linear.Vector + +data Ellipsoid n = Ellipsoid (Transformation V3 n) + deriving Typeable + +type instance V (Ellipsoid n) = V3 +type instance N (Ellipsoid n) = n + +instance Fractional n => Transformable (Ellipsoid n) where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) -instance IsPrim Ellipsoid +instance Fractional n => Renderable (Ellipsoid n) NullBackend where + render _ _ = mempty -instance Renderable Ellipsoid NullBackend where +instance OrderedField n => Enveloped (Ellipsoid n) where + getEnvelope (Ellipsoid tr) = transform tr . mkEnvelope $ \v -> 1 / norm v + +instance OrderedField n => Traced (Ellipsoid n) where + getTrace (Ellipsoid tr) = transform tr . mkTrace $ \(P p) v -> let + a = v `dot` v + b = 2 * (p `dot` v) + c = (p `dot` p) - 1 + in + mkSortedList $ quadForm a b c + +-- | A sphere of radius 1 with its center at the origin. +sphere :: Num n => Ellipsoid n +sphere = Ellipsoid mempty + +data Box n = Box (Transformation V3 n) + deriving Typeable + +type instance V (Box n) = V3 +type instance N (Box n) = n + +instance Fractional n => Transformable (Box n) where + transform t1 (Box t2) = Box (t1 <> t2) + +instance Fractional n => Renderable (Box n) NullBackend where render _ _ = mempty -sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 -sphere = mkQD (Prim $ Ellipsoid mempty) - (mkEnvelope sphereEnv) - (mkTrace sphereTrace) - mempty - (Query sphereQuery) - where sphereEnv v = 1 / magnitude v - sphereTrace p v = minimum (quadForm a b c) - where a = v <.> v - b = 2 *^ p' <.> v - c = p' <.> p' - 1 - p' = p .-. origin - sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 +instance OrderedField n => Enveloped (Box n) where + getEnvelope (Box tr) = transform tr . mkEnvelope $ \v -> + maximum (map (v `dot`) corners) / quadrance v where + corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] + +instance (Fractional n, Ord n) => Traced (Box n) where + getTrace (Box tr) = transform tr . mkTrace $ \p v -> let + (x0, y0, z0) = unp3 p + (vx, vy, vz) = unr3 v + intersections f d = case d of + 0 -> [] + _ -> [-f/d, (1-f)/d] + ts = concat $ zipWith intersections [x0,y0,z0] [vx,vy,vz] + atT t = p .+^ (t*^v) + range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where + (x, y, z) = unp3 u + in + -- ts gives all intersections with the planes forming the box + -- filter keeps only those actually on the box surface + mkSortedList . filter (range . atT) $ ts where + +-- | A cube with side length 1, in the positive octant, with one +-- vertex at the origin. +cube :: Num n => Box n +cube = Box mempty + +data Frustum n = Frustum n n (Transformation V3 n) + deriving Typeable + +type instance V (Frustum n) = V3 +type instance N (Frustum n) = n + +instance Fractional n => Transformable (Frustum n) where + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) + +instance Fractional n => Renderable (Frustum n) NullBackend where + render _ _ = mempty + +instance (OrderedField n, RealFloat n) => Enveloped (Frustum n) where + -- The plane containing v and the z axis intersects the frustum in a trapezoid + -- Test the four corners of this trapezoid; one must determine the Envelope + getEnvelope (Frustum r0 r1 tr) = transform tr . mkEnvelope $ \v ->let + θ = v ^. _theta + corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] + in + maximum . map (norm . project v . review r3CylindricalIso) $ corners + +instance (RealFloat n, Ord n) => Traced (Frustum n) where + -- The trace can intersect the sides of the cone or one of the end + -- caps The sides are described by a quadric equation; substitute + -- in the parametric form of the ray but disregard any + -- intersections outside z = [0,1] Similarly, find intersections + -- with the planes z=0, z=1, but disregard any r>r0, r>r1 + getTrace (Frustum r0 r1 tr) = transform tr . mkTrace $ \p v -> let + (px, py, pz) = unp3 p + (vx, vy, vz) = unr3 v + ray t = p .+^ t *^ v + dr = r1 - r0 + a = vx**2 + vy**2 - vz**2 * dr**2 + b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr * vz) + c = px**2 + py**2 - (r0 + dr*pz)**2 + zbounds t = ray t ^. _z >= 0 + && ray t ^. _z <= 1 + ends = concatMap cap [0,1] + cap z = [ t | ray t ^. lensP . r3CylindricalIso . _1 < r0 + z * dr ] + where + t = (z - pz) / vz + in + mkSortedList $ filter zbounds (quadForm a b c) ++ ends + +-- | A frustum of a right circular cone. It has height 1 oriented +-- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. +-- 'cone' and 'cylinder' are special cases. +frustum :: Num n => n -> n -> Frustum n +frustum r0 r1 = Frustum r0 r1 mempty + +-- | A cone with its base centered on the origin, with radius 1 at the +-- base, height 1, and it's apex on the positive Z axis. +cone :: Num n => Frustum n +cone = frustum 1 0 + +-- | A circular cylinder of radius 1 with one end cap centered on the +-- origin, and extending to Z=1. +cylinder :: Num n => Frustum n +cylinder = frustum 1 1 + +-- | Types which can be rendered as 3D Diagrams. +class Skinned t where + skin :: (Renderable t b, N t ~ n, TypeableFloat n) => t -> QDiagram b V3 n Any + +instance (Num n, Ord n) => HasQuery (Ellipsoid n) Any where + getQuery (Ellipsoid tr) = transform tr $ + Query $ \v -> Any $ quadrance (v .-. origin) <= 1 + +instance OrderedField n => Skinned (Ellipsoid n) where + skin s = mkQD (Prim s) (getEnvelope s) (getTrace s) mempty (getQuery s) + +instance (Num n, Ord n) => HasQuery (Box n) Any where + getQuery (Box tr) = transform tr . Query $ Any . range where + range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where + (x, y, z) = unp3 u + +instance OrderedField n => Skinned (Box n) where + skin s = mkQD (Prim s) (getEnvelope s) (getTrace s) mempty (getQuery s) + +instance (OrderedField n) => HasQuery (Frustum n) Any where + getQuery (Frustum r0 r1 tr)= transform tr $ + Query $ \p -> let + z = p^._z + r = r0 + (r1 - r0)*z + v = p .-. origin + a = norm $ projectXY v + projectXY u = u ^-^ project unitZ u + in + Any $ z >= 0 && z <= 1 && a <= r + +instance Skinned (Frustum n) where + skin s = mkQD (Prim s) (getEnvelope s) (getTrace s) mempty (getQuery s) + +-- The CSG type needs to form a tree to be useful. This +-- implementation requires Backends to support all the included +-- primitives. If that turns out to be a problem, we have several +-- options: +-- a) accept runtime errors for unsupported primitives +-- b) carry the set of primitives in a row type in the CSG type +-- c) implement CSG in Haskell, so Backends supporting triangle meshes +-- can fall back to those. +-- (c) is worth doing anyway; I'm ambivalent about the others. -DMB + +-- | A tree of Constructive Solid Geometry operations and the primitives that +-- can be used in them. +data CSG n + = CsgEllipsoid (Ellipsoid n) + | CsgBox (Box n) + | CsgFrustum (Frustum n) + | CsgUnion [CSG n] + | CsgIntersection [CSG n] + | CsgDifference (CSG n) (CSG n) + deriving Typeable + +type instance V (CSG n) = V3 +type instance N (CSG n) = n + +instance Fractional n => Transformable (CSG n) where + transform t (CsgEllipsoid p) = CsgEllipsoid $ transform t p + transform t (CsgBox p) = CsgBox $ transform t p + transform t (CsgFrustum p) = CsgFrustum $ transform t p + transform t (CsgUnion ps) = CsgUnion $ map (transform t) ps + transform t (CsgIntersection ps) = CsgIntersection $ map (transform t) ps + transform t (CsgDifference p1 p2) = CsgDifference (transform t p1) (transform t p2) + +-- | The Envelope for an Intersection or Difference is simply the +-- Envelope of the Union. This is wrong but easy to implement. +instance RealFloat n => Enveloped (CSG n) where + getEnvelope (CsgEllipsoid p) = getEnvelope p + getEnvelope (CsgBox p) = getEnvelope p + getEnvelope (CsgFrustum p) = getEnvelope p + getEnvelope (CsgUnion ps) = foldMap getEnvelope ps + getEnvelope (CsgIntersection ps) = foldMap getEnvelope ps + getEnvelope (CsgDifference p1 p2) = getEnvelope p1 <> getEnvelope p2 +-- TODO after implementing some approximation scheme, calculate +-- correct (approximate) envelopes for intersections and difference. + +instance (Floating n, Ord n) => HasQuery (CSG n) Any where + getQuery (CsgEllipsoid prim) = getQuery prim + getQuery (CsgBox prim) = getQuery prim + getQuery (CsgFrustum prim) = getQuery prim + getQuery (CsgUnion ps) = foldMap getQuery ps + getQuery (CsgIntersection ps) = + Any . getAll <$> foldMap (fmap (All . getAny) . getQuery) ps + getQuery (CsgDifference p1 p2) = inOut <$> getQuery p1 <*> getQuery p2 where + inOut (Any a) (Any b) = Any $ a && not b + +instance (RealFloat n, Ord n) => Traced (CSG n) where + getTrace (CsgEllipsoid p) = getTrace p + getTrace (CsgBox p) = getTrace p + getTrace (CsgFrustum p) = getTrace p + -- on surface of some p, and not inside any of the others + getTrace (CsgUnion []) = mempty + getTrace (CsgUnion (s:ss)) = mkTrace t where + t pt v = onSortedList (filter $ without s) (appTrace (getTrace (CsgUnion ss)) pt v) + <> onSortedList (filter $ without (CsgUnion ss)) (appTrace (getTrace s) pt v) where + newPt dist = pt .+^ v ^* dist + without prim = not . inquire prim . newPt + -- on surface of some p, and inside all the others + getTrace (CsgIntersection []) = mempty + getTrace (CsgIntersection (s:ss)) = mkTrace t where + t pt v = onSortedList (filter $ within s) (appTrace (getTrace (CsgIntersection ss)) pt v) + <> onSortedList (filter $ within (CsgIntersection ss)) (appTrace (getTrace s) pt v) where + newPt dist = pt .+^ v ^* dist + within prim = inquire prim . newPt + -- on surface of p1, outside p2, or on surface of p2, inside p1 + getTrace (CsgDifference s1 s2) = mkTrace t where + t pt v = onSortedList (filter $ not . within s2) (appTrace (getTrace s1) pt v) + <> onSortedList (filter $ within s1) (appTrace (getTrace s2) pt v) where + newPt dist = pt .+^ v ^* dist + within prim = inquire prim . newPt + +instance (RealFloat n, Ord n) => Skinned (CSG n) where + skin s = mkQD (Prim s) (getEnvelope s) (getTrace s) mempty (getQuery s) + +-- | Types which can be included in CSG trees. +class CsgPrim a where + toCsg :: a n -> CSG n + +instance CsgPrim Ellipsoid where + toCsg = CsgEllipsoid + +instance CsgPrim Box where + toCsg = CsgBox + +instance CsgPrim Frustum where + toCsg = CsgFrustum + +instance CsgPrim CSG where + toCsg = id + +union :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +union a b = CsgUnion [toCsg a, toCsg b] + +intersection :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +intersection a b = CsgIntersection [toCsg a, toCsg b] + +difference :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +difference a b = CsgDifference (toCsg a) (toCsg b) diff --git a/src/Diagrams/ThreeD/Size.hs b/src/Diagrams/ThreeD/Size.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Size.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Size +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Utilities for working with sizes of three-dimensional objects. +-- +----------------------------------------------------------------------------- +module Diagrams.ThreeD.Size + ( + -- ** Computing sizes + extentX, extentY, extentZ + + -- ** Specifying sizes + , mkSizeSpec3D + , dims3D + + ) where + +import Diagrams.Core +import Diagrams.Core.Envelope +import Diagrams.Size +import Diagrams.TwoD.Size +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + +------------------------------------------------------------ +-- Computing diagram sizes +------------------------------------------------------------ + +-- | Compute the absolute z-coordinate range of an enveloped object in +-- the form @(lo,hi)@. Return @Nothing@ for objects with an empty +-- envelope. +extentZ :: (InSpace v n a, R3 v, Enveloped a) => a -> Maybe (n, n) +extentZ = extent unitZ + +-- | Make a 'SizeSpec' from possibly-specified width and height. +mkSizeSpec3D :: Num n => Maybe n -> Maybe n -> Maybe n -> SizeSpec V3 n +mkSizeSpec3D x y z = mkSizeSpec (V3 x y z) + +-- | Make a 'SizeSpec' from a width and height. +dims3D :: n -> n -> n -> SizeSpec V3 n +dims3D x y z = dims (V3 x y z) + diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Transform.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Transform +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Transformations specific to three dimensions, with a few generic +-- transformations (uniform scaling, translation) also re-exported for +-- convenience. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Transform + ( T3 + + -- * Rotation + , aboutX, aboutY, aboutZ + , rotationAbout, rotateAbout + , pointAt, pointAt' + + -- * Scaling + , scalingX, scalingY, scalingZ + , scaleX, scaleY, scaleZ + , scaling, scale + + -- * Translation + , translationX, translateX + , translationY, translateY + , translationZ, translateZ + , translation, translate + + -- * Reflection + , reflectionX, reflectX + , reflectionY, reflectY + , reflectionZ, reflectZ + , reflectionAcross, reflectAcross + + ) where + +import Diagrams.Core +import Diagrams.Core.Transform + +import Diagrams.Angle +import Diagrams.Direction +import Diagrams.Points +import Diagrams.ThreeD.Types +import Diagrams.Transform + +import Control.Lens (view, (&), (*~), (.~), (//~)) +import Data.Semigroup +import Diagrams.TwoD.Transform + +import Linear.Affine +import Linear.Metric +import Linear.V3 (cross) +import Linear.Vector + +-- | Create a transformation which rotates by the given angle about +-- a line parallel the Z axis passing through the local origin. +-- A positive angle brings positive x-values towards the positive-y axis. +-- +-- The angle can be expressed using any type which is an +-- instance of 'Angle'. For example, @aboutZ (1\/4 \@\@ +-- 'turn')@, @aboutZ (tau\/4 \@\@ 'rad')@, and @aboutZ (90 \@\@ +-- 'deg')@ all represent the same transformation, namely, a +-- counterclockwise rotation by a right angle. For more general rotations, +-- see 'rotationAbout'. +-- +-- Note that writing @aboutZ (1\/4)@, with no type annotation, will +-- yield an error since GHC cannot figure out which sort of angle +-- you want to use. +aboutZ :: Floating n => Angle n -> Transformation V3 n +aboutZ (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 (cos θ * x - sin θ * y) + (sin θ * x + cos θ * y) + z + +-- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values +-- towards the positive z-axis. +aboutX :: Floating n => Angle n -> Transformation V3 n +aboutX (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 x + (cos θ * y - sin θ * z) + (sin θ * y + cos θ * z) + +-- | Like 'aboutZ', but rotates about the Y axis, bringing postive +-- x-values towards the negative z-axis. +aboutY :: Floating n => Angle n -> Transformation V3 n +aboutY (view rad -> a) = fromOrthogonal r where + r = rot a <-> rot (-a) + rot θ (V3 x y z) = V3 (cos θ * x + sin θ * z) + y + (-sin θ * x + cos θ * z) + +-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ +-- passing through @p@. +rotationAbout + :: Floating n + => Point V3 n -- ^ origin of rotation + -> Direction V3 n -- ^ direction of rotation axis + -> Angle n -- ^ angle of rotation + -> Transformation V3 n +rotationAbout (P t) d (view rad -> a) + = mconcat [translation (negated t), + fromOrthogonal r, + translation t] where + r = rot a <-> rot (-a) + w = fromDirection d + + rot θ v = v ^* cos θ + ^+^ cross w v ^* sin θ + ^+^ w ^* ((w `dot` v) * (1 - cos θ)) + +-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ +-- passing through @p@. +rotateAbout + :: (InSpace V3 n t, Floating n, Transformable t) + => Point V3 n -- ^ origin of rotation + -> Direction V3 n -- ^ direction of rotation axis + -> Angle n -- ^ angle of rotation + -> t -> t +rotateAbout p d theta = transform (rotationAbout p d theta) + +-- | @pointAt about initial final@ produces a rotation which brings +-- the direction @initial@ to point in the direction @final@ by first +-- panning around @about@, then tilting about the axis perpendicular +-- to @about@ and @final@. In particular, if this can be accomplished +-- without tilting, it will be, otherwise if only tilting is +-- necessary, no panning will occur. The tilt will always be between +-- ± 1/4 turn. +pointAt :: (Floating n, Ord n) + => Direction V3 n -> Direction V3 n -> Direction V3 n + -> Transformation V3 n +pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) + +-- | pointAt' has the same behavior as 'pointAt', but takes vectors +-- instead of directions. +pointAt' :: (Floating n, Ord n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final) + +-- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. +pointAtUnit :: (Floating n, Ord n) => V3 n -> V3 n -> V3 n -> Transformation V3 n +pointAtUnit about initial final = tilt <> pan where + -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v + signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v + inPanPlaneF = final ^-^ project about final + inPanPlaneI = initial ^-^ project about initial + panAngle = signedAngle about inPanPlaneI inPanPlaneF + pan = rotationAbout origin (direction about) panAngle + tiltAngle = signedAngle tiltAxis (transform pan initial) final + tiltAxis = cross final about + tilt = rotationAbout origin (direction tiltAxis) tiltAngle + +-- Scaling ------------------------------------------------- + +-- | Construct a transformation which scales by the given factor in +-- the z direction. +scalingZ :: (Additive v, R3 v, Fractional n) => n -> Transformation v n +scalingZ c = fromSymmetric $ (_z *~ c) <-> (_z //~ c) + +-- | Scale a diagram by the given factor in the z direction. To scale +-- uniformly, use 'scale'. +scaleZ :: (InSpace v n t, R3 v, Fractional n, Transformable t) => n -> t -> t +scaleZ = transform . scalingZ + +-- Translation ---------------------------------------- + +-- | Construct a transformation which translates by the given distance +-- in the z direction. +translationZ :: (Additive v, R3 v, Num n) => n -> Transformation v n +translationZ z = translation (zero & _z .~ z) + +-- | Translate a diagram by the given distance in the y +-- direction. +translateZ :: (InSpace v n t, R3 v, Transformable t) => n -> t -> t +translateZ = transform . translationZ + +-- Reflection ---------------------------------------------- + +-- | Construct a transformation which flips a diagram across z=0, +-- i.e. sends the point (x,y,z) to (x,y,-z). +reflectionZ :: (Additive v, R3 v, Num n) => Transformation v n +reflectionZ = fromSymmetric $ (_z *~ (-1)) <-> (_z *~ (-1)) + +-- | Flip a diagram across z=0, i.e. send the point (x,y,z) to +-- (x,y,-z). +reflectZ :: (InSpace v n t, R3 v, Transformable t) => t -> t +reflectZ = transform reflectionZ + +-- | @reflectionAcross p v@ is a reflection across the plane through +-- the point @p@ and normal to vector @v@. This also works as a 2D +-- transform where @v@ is the normal to the line passing through point +-- @p@. +reflectionAcross :: (Metric v, Fractional n) + => Point v n -> v n -> Transformation v n +reflectionAcross p v = + conjugate (translation (origin .-. p)) reflect + where + reflect = fromLinear t (linv t) + t = f v <-> f (negated v) + f u w = w ^-^ 2 *^ project u w + +-- | @reflectAcross p v@ reflects a diagram across the plane though +-- the point @p@ and the vector @v@. This also works as a 2D transform +-- where @v@ is the normal to the line passing through point @p@. +reflectAcross :: (InSpace v n t, Metric v, Fractional n, Transformable t) + => Point v n -> v n -> t -> t +reflectAcross p v = transform (reflectionAcross p v) diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,11 +1,4 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -21,77 +14,85 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3, r3, unr3 - , P3, p3, unp3 - , T3 + r3, unr3, mkR3 + , p3, unp3, mkP3 + , r3Iso, p3Iso, project + , r3SphericalIso, r3CylindricalIso + , V3 (..), P3, T3 + , R1 (..), R2 (..), R3 (..) ) where -import Diagrams.Coordinates -import Diagrams.TwoD.Types -import Diagrams.Core +import Control.Lens (Iso', iso, _1, _2, _3) -import Control.Newtype +import Diagrams.Angle +import Diagrams.Core +import Diagrams.Points +import Diagrams.TwoD.Types -import Data.Basis -import Data.VectorSpace +import Linear.Metric +import Linear.V3 as V ------------------------------------------------------------ -- 3D Euclidean space --- | The three-dimensional Euclidean vector space R^3. -newtype R3 = R3 { unR3 :: (Double, Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Show, Read) +-- Basic R3 types -instance Newtype R3 (Double, Double, Double) where - pack = R3 - unpack = unR3 +type P3 = Point V3 +type T3 = Transformation V3 +r3Iso :: Iso' (V3 n) (n, n, n) +r3Iso = iso unr3 r3 + -- | Construct a 3D vector from a triple of components. -r3 :: (Double, Double, Double) -> R3 -r3 = pack +r3 :: (n, n, n) -> V3 n +r3 (x,y,z) = V3 x y z +-- | Curried version of `r3`. +mkR3 :: n -> n -> n -> V3 n +mkR3 = V3 + -- | Convert a 3D vector back into a triple of components. -unr3 :: R3 -> (Double, Double, Double) -unr3 = unpack +unr3 :: V3 n -> (n, n, n) +unr3 (V3 x y z) = (x,y,z) -type instance V R3 = R3 +-- | Construct a 3D point from a triple of coordinates. +p3 :: (n, n, n) -> P3 n +p3 = P . r3 -instance VectorSpace R3 where - type Scalar R3 = Double - (*^) = over R3 . (*^) +-- | Convert a 3D point back into a triple of coordinates. +unp3 :: P3 n -> (n, n, n) +unp3 (P (V3 x y z)) = (x,y,z) -instance HasBasis R3 where - type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = R3 . basisValue - decompose = decompose . unR3 - decompose' = decompose' . unR3 +p3Iso :: Iso' (P3 n) (n, n, n) +p3Iso = iso unp3 p3 -instance InnerSpace R3 where - (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 +-- | Curried version of `r3`. +mkP3 :: n -> n -> n -> P3 n +mkP3 x y z = p3 (x, y, z) -instance Coordinates R3 where - type FinalCoord R3 = Double - type PrevDim R3 = R2 - type Decomposition R3 = Double :& Double :& Double +type instance V (V3 n) = V3 +type instance N (V3 n) = n - (coords -> x :& y) & z = r3 (x,y,z) - coords (unR3 -> (x,y,z)) = x :& y :& z +instance Transformable (V3 n) where + transform = apply --- | Points in R^3. -type P3 = Point R3 +r3SphericalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, Angle n) +r3SphericalIso = iso + (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) + (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) --- | Construct a 3D point from a triple of coordinates. -p3 :: (Double, Double, Double) -> P3 -p3 = pack . pack +r3CylindricalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, n) +r3CylindricalIso = iso + (\(V3 x y z) -> (sqrt $ x*x + y*y, atan2A y x, z)) + (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) --- | Convert a 2D point back into a triple of coordinates. -unp3 :: P3 -> (Double, Double, Double) -unp3 = unpack . unpack +instance HasR V3 where + _r = r3SphericalIso . _1 --- | Transformations in R^3. -type T3 = Transformation R3 +instance HasTheta V3 where + _theta = r3CylindricalIso . _2 -instance Transformable R3 where - transform = apply +instance HasPhi V3 where + _phi = r3SphericalIso . _3 diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Vector.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Vector +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Three-dimensional vectors. +-- +----------------------------------------------------------------------------- +module Diagrams.ThreeD.Vector + ( -- * Special 3D vectors + unitX, unitY, unitZ, unit_X, unit_Y, unit_Z + , xDir, yDir, zDir + ) where + +import Control.Lens ((&), (.~)) + +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Vector +import Diagrams.Direction + +import Linear.Vector + +-- | The unit vector in the positive Y direction. +unitZ :: (R3 v, Additive v, Num n) => v n +unitZ = zero & _z .~ 1 + +-- | The unit vector in the negative X direction. +unit_Z :: (R3 v, Additive v, Num n) => v n +unit_Z = zero & _z .~ (-1) + +-- | A 'Direction' pointing in the Z direction. +zDir :: (R3 v, Additive v, Num n) => Direction v n +zDir = dir unitZ diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -1,4 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trace @@ -27,24 +33,30 @@ ) where -import Diagrams.Core (HasLinearMap, Point, Subdiagram, - location, origin, setTrace, trace) +import Diagrams.Core (OrderedField, Point, Subdiagram, location, + origin, setTrace, trace) import Diagrams.Core.Trace import Data.Maybe -import Data.VectorSpace (Scalar, negateV) +import Data.Semigroup import Diagrams.Combinators (withTrace) +import Linear.Metric +import Linear.Vector + -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector. If there is no such -- point, the origin is returned; see also 'boundaryFromMay'. -boundaryFrom :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Point v +boundaryFrom :: (OrderedField n, Metric v, Semigroup m) + => Subdiagram b v n m -> v n -> Point v n boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector, or @Nothing@ if -- there is no such point. -boundaryFromMay :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Maybe (Point v) -boundaryFromMay s v = traceP (location s) (negateV v) s +boundaryFromMay :: (Metric v, OrderedField n, Semigroup m) + => Subdiagram b v n m -> v n -> Maybe (Point v n) +boundaryFromMay s v = traceP (location s) (negated v) s + diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -1,880 +1,1396 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Trail --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- This module defines /trails/, translationally invariant paths --- through space. Trails form a central part of the diagrams-lib API, --- so the documentation for this module merits careful study. --- --- Related modules include: --- --- * The 'TrailLike' class ("Diagrams.TrailLike") exposes a generic --- API for building a wide range of things out of trails. --- --- * 'Path's ("Diagrams.Path") are collections of 'Located' --- ("Diagrams.Located") trails. --- --- * Trails are composed of 'Segment's (see "Diagrams.Segment"), --- though most users should not need to work with segments directly. --- ------------------------------------------------------------------------------ - -module Diagrams.Trail - ( - -- * Type definitions - - -- ** Lines and loops - - Trail'(..) - - , glueLine - , closeLine - , cutLoop - - -- ** Generic trails - - , Trail(..) - , wrapTrail, wrapLine, wrapLoop - , onTrail, onLine - - , glueTrail, closeTrail, cutTrail - - -- * Constructing trails - - , emptyLine, emptyTrail - , lineFromVertices, trailFromVertices - , lineFromOffsets, trailFromOffsets - , lineFromSegments, trailFromSegments - - -- * Eliminating trails - - , withTrail', withTrail, withLine - , isLineEmpty, isTrailEmpty - , isLine, isLoop - , trailSegments, lineSegments, loopSegments - , onLineSegments - , trailOffsets, trailOffset - , lineOffsets, lineOffset, loopOffsets - , trailVertices, lineVertices, loopVertices - , fixTrail - - -- * Modifying trails - - , reverseTrail, reverseLocTrail - , reverseLine, reverseLocLine - , reverseLoop, reverseLocLoop - - -- * Internals - -- $internals - - -- ** Type tags - - , Line, Loop - - -- ** Segment trees - - , SegTree(..), trailMeasure, numSegs, offset - - ) where - -import Control.Arrow ((***)) -import Data.AffineSpace -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), - (|>)) -import qualified Data.FingerTree as FT -import qualified Data.Foldable as F -import Data.Monoid.MList -import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) -import qualified Numeric.Interval as I - -import Diagrams.Core hiding ((|>)) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment - --- $internals --- --- Most users of diagrams should not need to use anything in this --- section directly, but they are exported on the principle that we --- can't forsee what uses people might have for them. - ------------------------------------------------------------- --- FingerTree instances ------------------------------------------------------------- - -type instance V (FingerTree m a) = V a - -instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) - , FT.Measured m a, Transformable a - ) - => Transformable (FingerTree m a) where - transform = FT.fmap' . transform - ------------------------------------------------------------- --- Segment trees ----------------------------------------- ------------------------------------------------------------- - --- | A @SegTree@ represents a sequence of closed segments, stored in a --- fingertree so we can easily recover various monoidal measures of --- the segments (number of segments, arc length, envelope...) and --- also easily slice and dice them according to the measures --- (/e.g./, split off the smallest number of segments from the --- beginning which have a combined arc length of at least 5). -newtype SegTree v = SegTree - { getSegTree :: FingerTree (SegMeasure v) (Segment Closed v) } - deriving (Eq, Ord, Show) - -type instance V (SegTree v) = v - -deriving instance (OrderedField (Scalar v), InnerSpace v) - => Monoid (SegTree v) -deriving instance (OrderedField (Scalar v), InnerSpace v) - => FT.Measured (SegMeasure v) (SegTree v) -deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) - -type instance Codomain (SegTree v) = v - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (SegTree v) where - atParam t p = offset . fst $ splitAtParam t p - -instance Num (Scalar v) => DomainBounds (SegTree v) - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v), Num (Scalar v)) - => EndValues (SegTree v) - -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (SegTree v) where - splitAtParam (SegTree t) p - | p < 0 = case FT.viewl t of - EmptyL -> emptySplit - seg :< t' -> - case seg `splitAtParam` (p * tSegs) of - (seg1, seg2) -> ( SegTree $ FT.singleton seg1 - , SegTree $ seg2 <| t' - ) - | p >= 1 = case FT.viewr t of - EmptyR -> emptySplit - t' :> seg -> - case seg `splitAtParam` (1 - (1 - p)*tSegs) of - (seg1, seg2) -> ( SegTree $ t' |> seg1 - , SegTree $ FT.singleton seg2 - ) - | otherwise = case FT.viewl after of - EmptyL -> emptySplit - seg :< after' -> - case seg `splitAtParam` (snd . properFraction $ p * tSegs) of - (seg1, seg2) -> ( SegTree $ before |> seg1 - , SegTree $ seg2 <| after' - ) - where - (before, after) = FT.split ((p * tSegs <) . numSegs) t - tSegs = numSegs t - emptySplit = (SegTree t, SegTree t) - - -- XXX seems like it should be possible to collapse some of the - -- above cases into one? - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (SegTree v) where - arcLengthBounded eps t - -- Use the cached value if it is accurate enough; otherwise fall - -- back to recomputing a more accurate value - | I.width i <= eps = i - | otherwise = fun (eps / numSegs t) - where - i = trailMeasure (I.singleton 0) - (getArcLengthCached :: ArcLength v -> I.Interval (Scalar v)) - t - fun = trailMeasure (const 0) - (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) - t - - arcLengthToParam eps st@(SegTree t) l - | l < 0 = case FT.viewl t of - EmptyL -> 0 - seg :< _ -> arcLengthToParam eps seg l / tSegs - | l >= totalAL = case FT.viewr t of - EmptyR -> 0 - t' :> seg -> - let p = arcLengthToParam (eps/2) seg - (l - arcLength (eps/2) (SegTree t')) - in (p - 1)/tSegs + 1 - | otherwise = case FT.viewl after of - EmptyL -> 0 - seg :< after' -> - let p = arcLengthToParam (eps/2) seg - (l - arcLength (eps/2) (SegTree before)) - in (numSegs before + p) / tSegs - where - totalAL = arcLength eps st - tSegs = numSegs t - before, after :: FingerTree (SegMeasure v) (Segment Closed v) - (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval (Scalar v)))) t - --- | Given a default result (to be used in the case of an empty --- trail), and a function to map a single measure to a result, --- extract the given measure for a trail and use it to compute a --- result. Put another way, lift a function on a single measure --- (along with a default value) to a function on an entire trail. -trailMeasure :: ( InnerSpace v, OrderedField (Scalar v) - , SegMeasure v :>: m, FT.Measured (SegMeasure v) t - ) - => a -> (m -> a) -> t -> a -trailMeasure d f = option d f . get . FT.measure - --- | Compute the number of segments of anything measured by --- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, --- @Trail@s...) -numSegs :: ( Floating (Scalar v), Num c, Ord (Scalar v), InnerSpace v, - FT.Measured (SegMeasure v) a - ) - => a -> c -numSegs = fromIntegral . trailMeasure 0 (getSum . getSegCount) - --- | Compute the total offset of anything measured by 'SegMeasure'. -offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, - FT.Measured (SegMeasure v) t - ) - => t -> v -offset = trailMeasure zeroV (getTotalOffset . oeOffset) - ------------------------------------------------------------- --- Trails ------------------------------------------------ ------------------------------------------------------------- - --- Eventually we should use DataKinds for this, but not until we drop --- support for GHC 7.4. - --- | Type tag for trails with distinct endpoints. -data Line - --- | Type tag for \"loopy\" trails which return to their starting --- point. -data Loop - --------------------------------------------------- --- The Trail' type - --- | Intuitively, a trail is a single, continuous path through space. --- However, a trail has no fixed starting point; it merely specifies --- /how/ to move through space, not /where/. For example, \"take --- three steps forward, then turn right twenty degrees and take two --- more steps\" is an intuitive analog of a trail; these --- instructions specify a path through space from any given starting --- location. To be precise, trails are /translation-invariant/; --- applying a translation to a trail has no effect. --- --- A @'Located' Trail@, on the other hand, is a trail paired with --- some concrete starting location (\"start at the big tree on the --- corner, then take three steps forward, ...\"). See the --- "Diagrams.Located" module for help working with 'Located' values. --- --- Formally, the semantics of a trail is a continuous (though not --- necessarily differentiable) function from the real interval [0,1] --- to vectors in some vector space. (In contrast, a 'Located' trail --- is a continuous function from [0,1] to /points/ in some /affine/ --- space.) --- --- There are two types of trails: --- --- * A \"line\" (think of the \"train\", \"subway\", or \"bus\" --- variety, rather than the \"straight\" variety...) is a trail --- with two distinct endpoints. Actually, a line can have the --- same start and end points, but it is still /drawn/ as if it had --- distinct endpoints: the two endpoints will have the appropriate --- end caps, and the trail will not be filled. Lines have a --- @Monoid@ instance where @mappend@ corresponds to concatenation, --- /i.e./ chaining one line after the other. --- --- * A \"loop\" is required to end in the same place it starts (that --- is, t(0) = t(1)). Loops are filled and are drawn as one --- continuous loop, with the appropriate join at the --- start/endpoint rather than end caps. Loops do not have a --- @Monoid@ instance. --- --- To convert between lines and loops, see 'glueLine', --- 'closeLine', and 'cutLoop'. --- --- To construct trails, see 'emptyTrail', 'trailFromSegments', --- 'trailFromVertices', 'trailFromOffsets', and friends. You can --- also get any type of trail from any function which returns a --- 'TrailLike' (/e.g./ functions in "Diagrams.TwoD.Shapes", and many --- others; see "Diagrams.TrailLike"). --- --- To extract information from trails, see 'withLine', 'isLoop', --- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. - -data Trail' l v where - Line :: SegTree v -> Trail' Line v - Loop :: SegTree v -> Segment Open v -> Trail' Loop v - --- | A generic eliminator for 'Trail'', taking functions specifying --- what to do in the case of a line or a loop. -withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r -withTrail' line loop t@(Line{}) = line t -withTrail' line loop t@(Loop{}) = loop t - -deriving instance Show v => Show (Trail' l v) -deriving instance Eq v => Eq (Trail' l v) -deriving instance Ord v => Ord (Trail' l v) - -type instance V (Trail' l v) = v - -type instance Codomain (Trail' l v) = v - -instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail' Line v) where - (Line t1) <> (Line t2) = Line (t1 `mappend` t2) - --- | The empty trail is constantly the zero vector. Trails are --- composed via concatenation. Note that only lines have a monoid --- instance (and not loops). -instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail' Line v) where - mempty = emptyLine - mappend = (<>) - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Trail' l v) where - transform tr (Line t ) = Line (transform tr t) - transform tr (Loop t s) = Loop (transform tr t) (transform tr s) - --- | The envelope for a trail is based at the trail's start. -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail' l v) where - getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) - where - ftEnv :: Trail' Line v -> Envelope v - ftEnv (Line t) = trailMeasure mempty oeEnvelope $ t - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Renderable (Trail' o v) NullBackend where - render _ _ = mempty - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (Trail' l v) where - atParam t p = withTrail' - (\(Line segT) -> segT `atParam` p) - (\l -> cutLoop l `atParam` p') - t - where - pf = snd . properFraction $ p - p' | p >= 0 = pf - | otherwise = 1 + pf - -instance Num (Scalar v) => DomainBounds (Trail' l v) - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (Trail' l v) - -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (Trail' Line v) where - splitAtParam (Line t) p = (Line t1, Line t2) - where - (t1, t2) = splitAtParam t p - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (Trail' l v) where - arcLengthBounded eps = - withTrail' - (\(Line t) -> arcLengthBounded eps t) - (arcLengthBounded eps . cutLoop) - - arcLengthToParam eps tr l = - withTrail' - (\(Line t) -> arcLengthToParam eps t l) - (\lp -> arcLengthToParam eps (cutLoop lp) l) - tr - --------------------------------------------------- --- The Trail type - --- | @Trail@ is a wrapper around @Trail'@, hiding whether the --- underlying @Trail'@ is a line or loop (though which it is can be --- recovered; see /e.g./ 'withTrail'). -data Trail v where - Trail :: Trail' l v -> Trail v - -deriving instance Show v => Show (Trail v) - -instance Eq v => Eq (Trail v) where - t1 == t2 = - withTrail - (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) - (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) - t1 - -instance Ord v => Ord (Trail v) where - compare t1 t2 = - withTrail - (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) - (\lp1 -> withTrail (const GT) (\lp2 -> compare lp1 lp2) t2) - t1 - --- | Two @Trail@s are combined by first ensuring they are both lines --- (using 'cutTrail' on loops) and then concatenating them. The --- result, in general, is a line. However, there is a special case --- for the empty line, which acts as the identity (so combining the --- empty line with a loop results in a loop). -instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail v) where - (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 - t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 - t1 <> t2 = flip withLine t1 $ \l1 -> - flip withLine t2 $ \l2 -> - wrapLine (l1 <> l2) - --- | @Trail@s are combined as described in the 'Semigroup' instance; --- the empty line is the identity element, with special cases so --- that combining the empty line with a loop results in the --- unchanged loop (in all other cases loops will be cut). Note that --- this does, in fact, satisfy the monoid laws, though it is a bit --- strange. Mostly it is provided for convenience, so one can work --- directly with @Trail@s instead of working with @Trail' Line@s and --- then wrapping. -instance (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail v) where - mempty = wrapLine emptyLine - mappend = (<>) - -type instance V (Trail v) = v - -type instance Codomain (Trail v) = v - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (Trail v) where - transform t = onTrail (transform t) (transform t) - -instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where - getEnvelope = withTrail getEnvelope getEnvelope - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => Parametric (Trail v) where - atParam t p = withTrail (`atParam` p) (`atParam` p) t - -instance Num (Scalar v) => DomainBounds (Trail v) - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => EndValues (Trail v) - --- | Note that there is no @Sectionable@ instance for @Trail' Loop@, --- because it does not make sense (splitting a loop at a parameter --- results in a single line, not two loops). However, it's --- convenient to have a @Sectionable@ instance for @Trail@; if the --- @Trail@ contains a loop the loop will first be cut and then --- @splitAtParam@ called on the resulting line. This is --- semantically a bit silly, so please don't rely on it. (*E.g.* if --- this is really the behavior you want, consider first calling --- 'cutLoop' yourself.) -instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) - => Sectionable (Trail v) where - splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t - -instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) - => HasArcLength (Trail v) where - arcLengthBounded = withLine . arcLengthBounded - arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr - --------------------------------------------------- --- Constructors and eliminators for Trail - --- | A generic eliminator for 'Trail', taking functions specifying --- what to do in the case of a line or a loop. -withTrail :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail v -> r -withTrail line loop (Trail t) = withTrail' line loop t - --- | Modify a @Trail@, specifying two separate transformations for the --- cases of a line or a loop. -onTrail :: (Trail' Line v -> Trail' l1 v) -> (Trail' Loop v -> Trail' l2 v) - -> (Trail v -> Trail v) -onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) - --- | An eliminator for @Trail@ based on eliminating lines: if the --- trail is a line, the given function is applied; if it is a loop, it --- is first converted to a line with 'cutLoop'. That is, --- --- @ --- withLine f === 'withTrail' f (f . 'cutLoop') --- @ -withLine :: (InnerSpace v, OrderedField (Scalar v)) - => (Trail' Line v -> r) -> Trail v -> r -withLine f = withTrail f (f . cutLoop) - --- | Modify a @Trail@ by specifying a transformation on lines. If the --- trail is a line, the transformation will be applied directly. If --- it is a loop, it will first be cut using 'cutLoop', the --- transformation applied, and then glued back into a loop with --- 'glueLine'. That is, --- --- @ --- onLine f === onTrail f (glueLine . f . cutLoop) --- @ --- --- Note that there is no corresponding @onLoop@ function, because --- there is no nice way in general to convert a line into a loop, --- operate on it, and then convert back. -onLine :: (InnerSpace v, OrderedField (Scalar v)) - => (Trail' Line v -> Trail' Line v) -> Trail v -> Trail v -onLine f = onTrail f (glueLine . f . cutLoop) - --- | Convert a 'Trail'' into a 'Trail', hiding the type-level --- distinction between lines and loops. -wrapTrail :: Trail' l v -> Trail v -wrapTrail = Trail - --- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', --- but with a more specific type, which can occasionally be --- convenient for fixing the type of a polymorphic expression. -wrapLine :: Trail' Line v -> Trail v -wrapLine = wrapTrail - --- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', --- but with a more specific type, which can occasionally be --- convenient for fixing the type of a polymorphic expression. -wrapLoop :: Trail' Loop v -> Trail v -wrapLoop = wrapTrail - ------------------------------------------------------------- --- Constructing trails ----------------------------------- ------------------------------------------------------------- - --- | The empty line, which is the identity for concatenation of lines. -emptyLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -emptyLine = Line mempty - --- | A wrapped variant of 'emptyLine'. -emptyTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -emptyTrail = wrapLine emptyLine - --- | Construct a line from a list of closed segments. -lineFromSegments :: (InnerSpace v, OrderedField (Scalar v)) - => [Segment Closed v] -> Trail' Line v -lineFromSegments = Line . SegTree . FT.fromList - --- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for --- conveniently constructing a @Trail@ instead of a @Trail'@. -trailFromSegments :: (InnerSpace v, OrderedField (Scalar v)) - => [Segment Closed v] -> Trail v -trailFromSegments = wrapTrail . lineFromSegments - --- | Construct a line containing only linear segments from a list of --- vectors, where each vector represents the offset from one vertex --- to the next. See also 'fromOffsets'. --- --- <> --- --- > import Diagrams.Coordinates --- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 & 1, 2 & (-1), 2 & 0.5 ] -lineFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) - => [v] -> Trail' Line v -lineFromOffsets = lineFromSegments . map straight - --- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for --- conveniently constructing a @Trail@ instead of a @Trail' Line@. -trailFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) - => [v] -> Trail v -trailFromOffsets = wrapTrail . lineFromOffsets - --- | Construct a line containing only linear segments from a list of --- vertices. Note that only the relative offsets between the --- vertices matters; the information about their absolute position --- will be discarded. That is, for all vectors @v@, --- --- @ --- lineFromVertices === lineFromVertices . 'translate' v --- @ --- --- If you want to retain the position information, you should --- instead use the more general 'fromVertices' function to --- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' --- ('Trail' v)@. --- --- <> --- --- > import Diagrams.Coordinates --- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine --- > $ lineFromVertices [origin, 0 & 1, 1 & 2, 5 & 1] -lineFromVertices :: (InnerSpace v, OrderedField (Scalar v)) - => [Point v] -> Trail' Line v -lineFromVertices [] = emptyLine -lineFromVertices [_] = emptyLine -lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps - - --- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for --- conveniently constructing a @Trail@ instead of a @Trail' Line@. -trailFromVertices :: (InnerSpace v, OrderedField (Scalar v)) - => [Point v] -> Trail v -trailFromVertices = wrapTrail . lineFromVertices - ------------------------------------------------------------- --- Converting between lines and loops -------------------- ------------------------------------------------------------- - --- | Make a line into a loop by \"gluing\" the endpoint to the --- starting point. In particular, the offset of the final segment --- is modified so that it ends at the starting point of the entire --- trail. Typically, you would first construct a line which you --- know happens to end where it starts, and then call 'glueLine' to --- turn it into a loop. --- --- <> --- --- > import Diagrams.Coordinates --- > glueLineEx = pad 1.1 . hcat' with {sep = 1} --- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] --- > --- > almostClosed :: Trail' Line R2 --- > almostClosed = fromOffsets [2 & (-1), (-3) & (-0.5), (-2) & 1, 1 & 0.5] --- --- @glueLine@ is left inverse to 'cutLoop', that is, --- --- @ --- glueLine . cutLoop === id --- @ -glueLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Loop v -glueLine (Line (SegTree t)) = - case FT.viewr t of - FT.EmptyR -> Loop mempty (Linear OffsetOpen) - t' :> (Linear _) -> Loop (SegTree t') (Linear OffsetOpen) - t' :> (Cubic c1 c2 _) -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) - --- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. --- It performs 'glueLine' on lines and is the identity on loops. -glueTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v -glueTrail = onTrail glueLine id - --- | Make a line into a loop by adding a new linear segment from the --- line's end to its start. --- --- @closeLine@ does not have any particularly nice theoretical --- properties, but can be useful /e.g./ when you want to make a --- closed polygon out of a list of points where the initial point is --- not repeated at the end. To use 'glueLine', one would first have --- to duplicate the initial vertex, like --- --- @ --- 'glueLine' . 'lineFromVertices' $ ps ++ [head ps] --- @ --- --- Using @closeLine@, however, one can simply --- --- @ --- closeLine . lineFromVertices $ ps --- @ --- --- <> --- --- > closeLineEx = pad 1.1 . centerXY . hcat' with {sep = 1} --- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] -closeLine :: Trail' Line v -> Trail' Loop v -closeLine (Line t) = Loop t (Linear OffsetOpen) - --- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which --- performs 'closeLine' on lines and is the identity on loops. -closeTrail :: Trail v -> Trail v -closeTrail = onTrail closeLine id - --- | Turn a loop into a line by \"cutting\" it at the common start/end --- point, resulting in a line which just happens to start and end at --- the same place. --- --- @cutLoop@ is right inverse to 'glueLine', that is, --- --- @ --- glueLine . cutLoop === id --- @ -cutLoop :: forall v. (InnerSpace v, OrderedField (Scalar v)) - => Trail' Loop v -> Trail' Line v -cutLoop (Loop (SegTree t) c) = - case (FT.null t, c) of - (True, Linear OffsetOpen) -> emptyLine - (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) - (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) - where - offV :: v - offV = negateV . trailMeasure zeroV (getTotalOffset . oeOffset) $ t - off = OffsetClosed offV - --- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is --- the identity on lines and performs 'cutLoop' on loops. -cutTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Trail v -> Trail v -cutTrail = onTrail id cutLoop - ------------------------------------------------------------- --- Eliminating trails ------------------------------------ ------------------------------------------------------------- - --- | Test whether a line is empty. -isLineEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Bool -isLineEmpty (Line (SegTree t)) = FT.null t - --- | Test whether a trail is empty. Note that loops are never empty. -isTrailEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Bool -isTrailEmpty = withTrail isLineEmpty (const False) - --- | Determine whether a trail is a line. -isLine :: Trail v -> Bool -isLine = not . isLoop - --- | Determine whether a trail is a loop. -isLoop :: Trail v -> Bool -isLoop = withTrail (const False) (const True) - --- | Extract the segments comprising a line. -lineSegments :: Trail' Line v -> [Segment Closed v] -lineSegments (Line (SegTree t)) = F.toList t - --- | Modify a line by applying a function to its list of segments. -onLineSegments - :: (InnerSpace v, OrderedField (Scalar v)) - => ([Segment Closed v] -> [Segment Closed v]) - -> Trail' Line v -> Trail' Line v -onLineSegments f = lineFromSegments . f . lineSegments - --- | Extract the segments comprising a loop: a list of closed --- segments, and one final open segment. -loopSegments :: Trail' Loop v -> ([Segment Closed v], Segment Open v) -loopSegments (Loop (SegTree t) c) = (F.toList t, c) - --- | Extract the segments of a trail. If the trail is a loop it will --- first have 'cutLoop' applied. -trailSegments :: (InnerSpace v, OrderedField (Scalar v)) - => Trail v -> [Segment Closed v] -trailSegments = withLine lineSegments - --- | Extract the offsets of the segments of a trail. -trailOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [v] -trailOffsets = withLine lineOffsets - --- | Compute the offset from the start of a trail to the end. Satisfies --- --- @ --- trailOffset === sumV . trailOffsets --- @ --- --- but is more efficient. --- --- <> --- --- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 --- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] --- > # stroke # lc red # lw 0.05 -trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v -trailOffset = withLine lineOffset - --- | Extract the offsets of the segments of a line. -lineOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> [v] -lineOffsets = map segOffset . lineSegments - --- | Extract the offsets of the segments of a loop. -loopOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> [v] -loopOffsets = lineOffsets . cutLoop - --- | Compute the offset from the start of a line to the end. (Note, --- there is no corresponding @loopOffset@ function because by --- definition it would be constantly zero.) -lineOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v -lineOffset (Line t) = trailMeasure zeroV (getTotalOffset . oeOffset) t - --- | Extract the vertices of a concretely located trail. Note that --- for loops, the starting vertex will /not/ be repeated at the end. --- If you want this behavior, you can use 'cutTrail' to make the --- loop into a line first, which happens to repeat the same vertex --- at the start and end, /e.g./ with @trailVertices . mapLoc --- cutTrail@. --- --- Note that it does not make sense to ask for the vertices of a --- 'Trail' by itself; if you want the vertices of a trail --- with the first vertex at, say, the origin, you can use --- @trailVertices . (`at` origin)@. -trailVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [Point v] -trailVertices (viewLoc -> (p,t)) - = withTrail (lineVertices . (`at` p)) (loopVertices . (`at` p)) t - --- | Extract the vertices of a concretely located line. See --- 'trailVertices' for more information. -lineVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Line v) -> [Point v] -lineVertices (viewLoc -> (p,t)) - = segmentVertices p . lineSegments $ t - --- | Extract the vertices of a concretely located loop. Note that the --- initial vertex is not repeated at the end. See 'trailVertices' for --- more information. -loopVertices :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Loop v) -> [Point v] -loopVertices (viewLoc -> (p,t)) - = segmentVertices p . fst . loopSegments $ t - -segmentVertices :: AdditiveGroup v => Point v -> [Segment Closed v] -> [Point v] -segmentVertices p = scanl (.+^) p . map segOffset - --- | Convert a concretely located trail into a list of fixed segments. -fixTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> [FixedSegment v] -fixTrail t = zipWith ((mkFixedSeg .) . at) - (trailSegments (unLoc t)) (trailVertices t) - ------------------------------------------------------------- --- Modifying trails -------------------------------------- ------------------------------------------------------------- - --- | Reverse a trail. Semantically, if a trail given by a function t --- from [0,1] to vectors, then the reverse of t is given by t'(s) = --- t(1-s). @reverseTrail@ is an involution, that is, --- --- @ --- reverseTrail . reverseTrail === id --- @ -reverseTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v -reverseTrail = onTrail reverseLine reverseLoop - --- | Reverse a concretely located trail. The endpoint of the original --- trail becomes the starting point of the reversed trail, so the --- original and reversed trails comprise exactly the same set of --- points. @reverseLocTrail@ is an involution, /i.e./ --- --- @ --- reverseLocTrail . reverseLocTrail === id --- @ -reverseLocTrail :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail v) -> Located (Trail v) -reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) - --- | Reverse a line. See 'reverseTrail'. -reverseLine :: (InnerSpace v, OrderedField (Scalar v)) - => Trail' Line v -> Trail' Line v -reverseLine = onLineSegments (reverse . map reverseSegment) - --- | Reverse a concretely located line. See 'reverseLocTrail'. -reverseLocLine :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Line v) -> Located (Trail' Line v) -reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) - --- | Reverse a loop. See 'reverseTrail'. -reverseLoop :: (InnerSpace v, OrderedField (Scalar v)) - => Trail' Loop v -> Trail' Loop v -reverseLoop = glueLine . reverseLine . cutLoop - --- | Reverse a concretely located loop. See 'reverseLocTrail'. Note --- that this is guaranteed to preserve the location. -reverseLocLoop :: (InnerSpace v, OrderedField (Scalar v)) - => Located (Trail' Loop v) -> Located (Trail' Loop v) -reverseLocLoop = mapLoc reverseLoop +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- We have an orphan Transformable FingerTree instance here. + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Trail +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module defines /trails/, translationally invariant paths +-- through space. Trails form a central part of the diagrams-lib API, +-- so the documentation for this module merits careful study. +-- +-- Related modules include: +-- +-- * The 'TrailLike' class ("Diagrams.TrailLike") exposes a generic +-- API for building a wide range of things out of trails. +-- +-- * 'Path's ("Diagrams.Path") are collections of 'Located' +-- ("Diagrams.Located") trails. +-- +-- * Trails are composed of 'Segment's (see "Diagrams.Segment"), +-- though most users should not need to work with segments directly. +-- +----------------------------------------------------------------------------- + +module Diagrams.Trail + ( + -- * Type definitions + + -- ** Lines and loops + + Trail'(..) + + , glueLine + , closeLine + , cutLoop + + -- ** Generic trails + + , Trail(..) + , _Line, _Loop + , _LocLine, _LocLoop + , wrapTrail, wrapLine, wrapLoop + , onTrail, onLine + + , glueTrail, closeTrail, cutTrail + + -- * Constructing trails + + , emptyLine, emptyTrail + , lineFromVertices, trailFromVertices + , lineFromOffsets, trailFromOffsets + , lineFromSegments, trailFromSegments + , loopFromSegments + + -- * Eliminating trails + + , withTrail', withTrail, withLine + , isLineEmpty, isTrailEmpty + , isLine, isLoop + , trailSegments, lineSegments, loopSegments + , onLineSegments + , trailOffsets, trailOffset + , lineOffsets, lineOffset, loopOffsets + , trailPoints, linePoints, loopPoints + , trailVertices', lineVertices', loopVertices' + , trailVertices, lineVertices, loopVertices + , trailLocSegments, fixTrail, unfixTrail + + -- * Modifying trails + + , reverseTrail, reverseLocTrail + , reverseLine, reverseLocLine + , reverseLoop, reverseLocLoop + + -- * Internals + -- $internals + + -- ** Type tags + + , Line, Loop + + -- ** Segment trees + + , SegTree(..), trailMeasure, numSegs, offset + + -- ** Extracting segments + + , GetSegment(..), getSegment, GetSegmentCodomain(..) + + ) where + +import Control.Arrow ((***)) +import Control.Lens hiding (at, transform, (<|), (|>)) +import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), + viewl, (<|), (|>)) +import qualified Data.FingerTree as FT +import Data.Fixed +import qualified Data.Foldable as F +import Data.Monoid.MList +import Data.Semigroup +import qualified Numeric.Interval.Kaucher as I + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Tangent + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize + +-- $internals +-- +-- Most users of diagrams should not need to use anything in this +-- section directly, but they are exported on the principle that we +-- can't forsee what uses people might have for them. + +------------------------------------------------------------ +-- FingerTree instances +------------------------------------------------------------ + +type instance V (FingerTree m a) = V a +type instance N (FingerTree m a) = N a + +instance (FT.Measured m a, Transformable a) + => Transformable (FingerTree m a) where + transform = FT.fmap' . transform + +instance (FT.Measured m a, FT.Measured n b) + => Cons (FingerTree m a) (FingerTree n b) a b where + _Cons = prism (uncurry (FT.<|)) $ \aas -> case FT.viewl aas of + a FT.:< as -> Right (a, as) + EmptyL -> Left mempty + {-# INLINE _Cons #-} + +instance (FT.Measured m a, FT.Measured n b) + => Snoc (FingerTree m a) (FingerTree n b) a b where + _Snoc = prism (uncurry (FT.|>)) $ \aas -> case FT.viewr aas of + as FT.:> a -> Right (as, a) + EmptyR -> Left mempty + {-# INLINE _Snoc #-} + +------------------------------------------------------------ +-- Segment trees ----------------------------------------- +------------------------------------------------------------ + +-- | A @SegTree@ represents a sequence of closed segments, stored in a +-- fingertree so we can easily recover various monoidal measures of +-- the segments (number of segments, arc length, envelope...) and +-- also easily slice and dice them according to the measures +-- (/e.g./, split off the smallest number of segments from the +-- beginning which have a combined arc length of at least 5). + +newtype SegTree v n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n)) + deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n)) + +-- Only derive the Semigroup instance for versions of base that +-- include Semigroup. This is because the fingertree package has +-- similar CPP to only export a Semigroup instance for those versions +-- of base, so for GHC 7.10 and earlier we get a 'no instance found' +-- error when trying to derive the Semigroup instance for SegTree. It +-- would also be possible to depend on the 'semigroups' package in +-- order to get the Semigroup class regardless of base version, but +-- presumably fingertree didn't want to add a dependency. +#if MIN_VERSION_base(4,9,0) +deriving instance (Ord n, Floating n, Metric v) => Semigroup (SegTree v n) +#endif + +instance Wrapped (SegTree v n) where + type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n) + _Wrapped' = iso (\(SegTree x) -> x) SegTree + {-# INLINE _Wrapped' #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Cons (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where + _Cons = _Wrapped . _Cons . bimapping id _Unwrapped + {-# INLINE _Cons #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Snoc (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where + _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id + {-# INLINE _Snoc #-} + +instance Rewrapped (SegTree v n) (SegTree v' n') + +type instance V (SegTree v n) = v +type instance N (SegTree v n) = n + +type instance Codomain (SegTree v n) = v + +instance (Metric v, OrderedField n, Real n) + => Parametric (SegTree v n) where + atParam t p = offset . fst $ splitAtParam t p + +instance Num n => DomainBounds (SegTree v n) + +instance (Metric v, OrderedField n, Real n) + => EndValues (SegTree v n) + +splitAtParam' :: (Metric v, OrderedField n, Real n) + => SegTree v n -> n -> ((SegTree v n, SegTree v n), n -> n) +splitAtParam' (SegTree t) p + | tSegs == 0 = ((mempty , mempty ), id) + | otherwise = ((SegTree treeL, SegTree treeR), rescale) + where + tSegs = numSegs t + splitParam q | q < 0 = (0 , q * tSegs) + | q >= 1 = (tSegs - 1, 1 + (q - 1) * tSegs) + | otherwise = propFrac $ q * tSegs + where propFrac x = let m = mod1 x in (x - m, m) + (pSegs, pParam) = splitParam p + (before, viewl -> seg FT.:< after) = FT.split ((pSegs <) . numSegs) t + (segL, segR) = seg `splitAtParam` pParam + (treeL, treeR) | pParam == 0 = (before , seg <| after) + | pParam == 1 = (before |> seg , after) + | otherwise = (before |> segL, segR <| after) + -- section uses rescale to find the new value of p1 after the split at p2 + rescale u | pSegs' == uSegs = (uSegs + uParam / pParam' {-'1-}) / (pSegs' + 1) {-'2-} + | otherwise = u * tSegs / (pSegs' + 1) {-'3-} + where + -- param 0 on a segment is param 1 on the previous segment + (pSegs', pParam') | pParam == 0 = (pSegs-1, 1) + | otherwise = (pSegs , pParam) + (uSegs , uParam ) = splitParam u + -- '1 (pParam ≠ 0 → pParam' = pParam) ∧ (pParam = 0 → pParam' = 1) → pParam' ≠ 0 + -- '2 uSegs ≥ 0 ∧ pSegs' = uSegs → pSegs' ≥ 0 → pSegs' + 1 > 0 + -- '3 pSegs' + 1 = 0 → pSegs' = -1 → pSegs = 0 ∧ pParam = 0 → p = 0 + -- → rescale is not called + +instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where + splitAtParam tree p = fst $ splitAtParam' tree p + + reverseDomain (SegTree t) = SegTree $ FT.reverse t' + where t' = FT.fmap' reverseSegment t + + section x p1 p2 | p2 == 0 = reverseDomain . fst $ splitAtParam x p1 + | p1 <= p2 = let ((a, _), rescale) = splitAtParam' x p2 + in snd $ splitAtParam a (rescale p1) + | otherwise = reverseDomain $ section x p2 p1 + +instance (Metric v, OrderedField n, Real n) + => HasArcLength (SegTree v n) where + arcLengthBounded eps t + -- Use the cached value if it is accurate enough; otherwise fall + -- back to recomputing a more accurate value + | I.width i <= eps = i + | otherwise = fun (eps / numSegs t) + where + i = trailMeasure (I.singleton 0) + getArcLengthCached + t + fun = trailMeasure (const 0) + getArcLengthFun + t + + arcLengthToParam eps st@(SegTree t) l + | l < 0 = case FT.viewl t of + EmptyL -> 0 + seg FT.:< _ -> arcLengthToParam eps seg l / tSegs + | l >= totalAL = case FT.viewr t of + EmptyR -> 0 + t' FT.:> seg -> + let p = arcLengthToParam (eps/2) seg + (l - arcLength (eps/2) (SegTree t')) + in (p - 1)/tSegs + 1 + | otherwise = case FT.viewl after of + EmptyL -> 0 + seg FT.:< _ -> + let p = arcLengthToParam (eps/2) seg + (l - arcLength (eps/2) (SegTree before)) + in (numSegs before + p) / tSegs + where + totalAL = arcLength eps st + tSegs = numSegs t + before, after :: FingerTree (SegMeasure v n) (Segment Closed v n) + (before, after) = + FT.split ((>= l) + . trailMeasure + 0 + (I.midpoint . getArcLengthBounded eps)) + t + +-- | Given a default result (to be used in the case of an empty +-- trail), and a function to map a single measure to a result, +-- extract the given measure for a trail and use it to compute a +-- result. Put another way, lift a function on a single measure +-- (along with a default value) to a function on an entire trail. +trailMeasure :: ( SegMeasure v n :>: m, FT.Measured (SegMeasure v n) t ) + => a -> (m -> a) -> t -> a +trailMeasure d f = maybe d f . get . FT.measure + +-- | Compute the number of segments of anything measured by +-- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, +-- @Trail@s...) +numSegs :: (Num c, FT.Measured (SegMeasure v n) a) + => a -> c +numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) + +-- | Compute the total offset of anything measured by 'SegMeasure'. +offset :: ( OrderedField n, Metric v, + FT.Measured (SegMeasure v n) t + ) + => t -> v n +offset = trailMeasure zero (op TotalOffset . view oeOffset) + +------------------------------------------------------------ +-- Trails ------------------------------------------------ +------------------------------------------------------------ + +-- Eventually we should use DataKinds for this, but not until we drop +-- support for GHC 7.4. + +-- | Type tag for trails with distinct endpoints. +data Line + +-- | Type tag for \"loopy\" trails which return to their starting +-- point. +data Loop + +-------------------------------------------------- +-- The Trail' type + +-- | Intuitively, a trail is a single, continuous path through space. +-- However, a trail has no fixed starting point; it merely specifies +-- /how/ to move through space, not /where/. For example, \"take +-- three steps forward, then turn right twenty degrees and take two +-- more steps\" is an intuitive analog of a trail; these +-- instructions specify a path through space from any given starting +-- location. To be precise, trails are /translation-invariant/; +-- applying a translation to a trail has no effect. +-- +-- A @'Located' Trail@, on the other hand, is a trail paired with +-- some concrete starting location (\"start at the big tree on the +-- corner, then take three steps forward, ...\"). See the +-- "Diagrams.Located" module for help working with 'Located' values. +-- +-- Formally, the semantics of a trail is a continuous (though not +-- necessarily differentiable) function from the real interval [0,1] +-- to vectors in some vector space. (In contrast, a 'Located' trail +-- is a continuous function from [0,1] to /points/ in some /affine/ +-- space.) +-- +-- There are two types of trails: +-- +-- * A \"line\" (think of the \"train\", \"subway\", or \"bus\" +-- variety, rather than the \"straight\" variety...) is a trail +-- with two distinct endpoints. Actually, a line can have the +-- same start and end points, but it is still /drawn/ as if it had +-- distinct endpoints: the two endpoints will have the appropriate +-- end caps, and the trail will not be filled. Lines have a +-- @Monoid@ instance where @mappend@ corresponds to concatenation, +-- /i.e./ chaining one line after the other. +-- +-- * A \"loop\" is required to end in the same place it starts (that +-- is, t(0) = t(1)). Loops are filled and are drawn as one +-- continuous loop, with the appropriate join at the +-- start/endpoint rather than end caps. Loops do not have a +-- @Monoid@ instance. +-- +-- To convert between lines and loops, see 'glueLine', +-- 'closeLine', and 'cutLoop'. +-- +-- To construct trails, see 'emptyTrail', 'trailFromSegments', +-- 'trailFromVertices', 'trailFromOffsets', and friends. You can +-- also get any type of trail from any function which returns a +-- 'TrailLike' (/e.g./ functions in "Diagrams.TwoD.Shapes", and many +-- others; see "Diagrams.TrailLike"). +-- +-- To extract information from trails, see 'withLine', 'isLoop', +-- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. + +data Trail' l v n where + Line :: SegTree v n -> Trail' Line v n + Loop :: SegTree v n -> Segment Open v n -> Trail' Loop v n + +-- | A generic eliminator for 'Trail'', taking functions specifying +-- what to do in the case of a line or a loop. +withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n -> r +withTrail' line _ t@(Line{}) = line t +withTrail' _ loop t@(Loop{}) = loop t + +deriving instance Eq (v n) => Eq (Trail' l v n) +deriving instance Ord (v n) => Ord (Trail' l v n) + +instance Show (v n) => Show (Trail' l v n) where + showsPrec d (Line (SegTree ft)) = showParen (d > 10) $ + showString "lineFromSegments " . showList (F.toList ft) + + showsPrec d (Loop (SegTree ft) o) = showParen (d > 10) $ + showString "loopFromSegments " . showList (F.toList ft) . + showChar ' ' . showsPrec 11 o + +type instance V (Trail' l v n) = v +type instance N (Trail' l v n) = n + +type instance Codomain (Trail' l v n) = v + +instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where + (Line t1) <> (Line t2) = Line (t1 `mappend` t2) + +-- | The empty trail is constantly the zero vector. Trails are +-- composed via concatenation. Note that only lines have a monoid +-- instance (and not loops). +instance (Metric v, OrderedField n) => Monoid (Trail' Line v n) where + mempty = emptyLine + mappend = (<>) + +instance (Metric v, OrderedField n) => AsEmpty (Trail' Line v n) where + _Empty = nearly emptyLine isLineEmpty + +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Trail' l v n) where + transform tr (Line t ) = Line (transform tr t) + transform tr (Loop t s) = Loop (transform tr t) (transform tr s) + +-- | The envelope for a trail is based at the trail's start. +instance (Metric v, OrderedField n) => Enveloped (Trail' l v n) where + getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) + where + ftEnv :: Trail' Line v n -> Envelope v n + ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) t + +instance (HasLinearMap v, Metric v, OrderedField n) + => Renderable (Trail' o v n) NullBackend where + render _ _ = mempty + +instance (Metric v, OrderedField n, Real n) + => Parametric (Trail' l v n) where + atParam t p = withTrail' + (\(Line segT) -> segT `atParam` p) + (\l -> cutLoop l `atParam` mod1 p) + t + +instance (Parametric (GetSegment (Trail' c v n)), Additive v, Num n) + => Parametric (Tangent (Trail' c v n)) where + Tangent tr `atParam` p = + case GetSegment tr `atParam` p of + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, reparam)) -> Tangent seg `atParam` (p ^. cloneIso reparam) + +instance ( Parametric (GetSegment (Trail' c v n)) + , EndValues (GetSegment (Trail' c v n)) + , Additive v + , Num n + ) + => EndValues (Tangent (Trail' c v n)) where + atStart (Tangent tr) = + case atStart (GetSegment tr) of + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg) + atEnd (Tangent tr) = + case atEnd (GetSegment tr) of + GetSegmentCodomain Nothing -> zero + GetSegmentCodomain (Just (_, seg, _)) -> atEnd (Tangent seg) + +instance (Metric v , OrderedField n, Real n) + => Parametric (Tangent (Trail v n)) where + Tangent tr `atParam` p + = withTrail + ((`atParam` p) . Tangent) + ((`atParam` p) . Tangent) + tr + +instance (Metric v, OrderedField n, Real n) + => EndValues (Tangent (Trail v n)) where + atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr + atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr + +-- | Compute the remainder mod 1. Convenient for constructing loop +-- parameterizations that wrap around. +mod1 :: Real a => a -> a +mod1 = (`mod'` 1) + +instance Num n => DomainBounds (Trail' l v n) + +instance (Metric v, OrderedField n, Real n) + => EndValues (Trail' l v n) + +instance (Metric v, OrderedField n, Real n) + => Sectionable (Trail' Line v n) where + splitAtParam (Line t) p = (Line t1, Line t2) + where + (t1, t2) = splitAtParam t p + + section (Line t) p1 p2 = Line (section t p1 p2) + + reverseDomain = reverseLine + +instance (Metric v, OrderedField n, Real n) + => HasArcLength (Trail' l v n) where + arcLengthBounded eps = + withTrail' + (\(Line t) -> arcLengthBounded eps t) + (arcLengthBounded eps . cutLoop) + + arcLengthToParam eps tr l = + withTrail' + (\(Line t) -> arcLengthToParam eps t l) + (\lp -> arcLengthToParam eps (cutLoop lp) l) + tr + +instance Rewrapped (Trail' Line v n) (Trail' Line v' n') +instance Wrapped (Trail' Line v n) where + type Unwrapped (Trail' Line v n) = SegTree v n + _Wrapped' = iso (\(Line x) -> x) Line + {-# INLINE _Wrapped' #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Cons (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where + _Cons = _Wrapped . _Cons . bimapping id _Unwrapped + {-# INLINE _Cons #-} + +instance (Metric v, OrderedField n, Metric u, OrderedField n') + => Snoc (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where + _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id + {-# INLINE _Snoc #-} + +-- | Compose two Located trails by adding a segment joining the endpoint +-- of the first to the starting point of the second. Note, if you have +-- two located trails such that the end of the first coincides with the +-- start of the second, this will still add a trivial zero-length segment +-- between them; in that case you are probably better off with something +-- like @mapLoc (<> unLoc t2) t1@. +instance (Real n, Floating n, Metric v) + => Semigroup (Located (Trail' Line v n)) where + a@(Loc aLoc aLine) <> b@(Loc _ bLine) = + Loc aLoc (aLine <> lineFromOffsets [atStart b .-. atEnd a] <> bLine) + +-------------------------------------------------- +-- Extracting segments + +-- | A newtype wrapper around trails which exists solely for its +-- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea +-- is that if @tr@ is a trail, you can write, /e.g./ +-- +-- @ +-- getSegment tr `atParam` 0.6 +-- @ +-- +-- or +-- +-- @ +-- atStart (getSegment tr) +-- @ +-- +-- to get the segment at parameter 0.6 or the first segment in the +-- trail, respectively. +-- +-- The codomain for 'GetSegment', /i.e./ the result you get from +-- calling 'atParam', 'atStart', or 'atEnd', is +-- 'GetSegmentCodomain', which is a newtype wrapper around @Maybe +-- (v, Segment Closed v, AnIso' n n)@. @Nothing@ results if the +-- trail is empty; otherwise, you get: +-- +-- * the offset from the start of the trail to the beginning of the +-- segment, +-- +-- * the segment itself, and +-- +-- * a reparameterization isomorphism: in the forward direction, it +-- translates from parameters on the whole trail to a parameters +-- on the segment. Note that for technical reasons you have to +-- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism +-- you can use. +newtype GetSegment t = GetSegment t + +newtype GetSegmentCodomain v n = + GetSegmentCodomain + (Maybe ( v n -- offset from trail start to segment start + , Segment Closed v n -- the segment + , AnIso' n n -- reparameterization, trail <-> segment + )) + +-- | Create a 'GetSegment' wrapper around a trail, after which you can +-- call 'atParam', 'atStart', or 'atEnd' to extract a segment. +getSegment :: t -> GetSegment t +getSegment = GetSegment + +type instance V (GetSegment t) = V t +type instance N (GetSegment t) = N t + +type instance Codomain (GetSegment t) = GetSegmentCodomain (V t) + +-- | Parameters less than 0 yield the first segment; parameters +-- greater than 1 yield the last. A parameter exactly at the +-- junction of two segments yields the second segment (/i.e./ the +-- one with higher parameter values). +instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) where + atParam (GetSegment (Line (SegTree ft))) p + | p <= 0 = case FT.viewl ft of + EmptyL -> GetSegmentCodomain Nothing + seg FT.:< _ -> GetSegmentCodomain $ Just (zero, seg, reparam 0) + + | p >= 1 = case FT.viewr ft of + EmptyR -> GetSegmentCodomain Nothing + ft' FT.:> seg -> GetSegmentCodomain $ Just (offset ft', seg, reparam (n-1)) + + | otherwise + = let (before, after) = FT.split ((p*n <) . numSegs) ft + in case FT.viewl after of + EmptyL -> GetSegmentCodomain Nothing + seg FT.:< _ -> GetSegmentCodomain $ Just (offset before, seg, reparam (numSegs before)) + where + n = numSegs ft + reparam k = iso (subtract k . (*n)) + ((/n) . (+ k)) + +-- | The parameterization for loops wraps around, /i.e./ parameters +-- are first reduced \"mod 1\". +instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail' Loop v n)) where + atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) + +instance (Metric v, OrderedField n, Real n) + => Parametric (GetSegment (Trail v n)) where + atParam (GetSegment t) p + = withTrail + ((`atParam` p) . GetSegment) + ((`atParam` p) . GetSegment) + t + +instance DomainBounds t => DomainBounds (GetSegment t) where + domainLower (GetSegment t) = domainLower t + domainUpper (GetSegment t) = domainUpper t + +instance (Metric v, OrderedField n) + => EndValues (GetSegment (Trail' Line v n)) where + atStart (GetSegment (Line (SegTree ft))) + = case FT.viewl ft of + EmptyL -> GetSegmentCodomain Nothing + seg FT.:< _ -> + let n = numSegs ft + in GetSegmentCodomain $ Just (zero, seg, iso (*n) (/n)) + + atEnd (GetSegment (Line (SegTree ft))) + = case FT.viewr ft of + EmptyR -> GetSegmentCodomain Nothing + ft' FT.:> seg -> + let n = numSegs ft + in GetSegmentCodomain $ + Just (offset ft', seg, iso (subtract (n-1) . (*n)) + ((/n) . (+ (n-1))) + ) + +instance (Metric v, OrderedField n, Real n) + => EndValues (GetSegment (Trail' Loop v n)) where + atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) + atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) + +instance (Metric v, OrderedField n, Real n) + => EndValues (GetSegment (Trail v n)) where + atStart (GetSegment t) + = withTrail + (atStart . GetSegment) + (atStart . GetSegment) + t + atEnd (GetSegment t) + = withTrail + (atEnd . GetSegment) + (atEnd . GetSegment) + t + +-------------------------------------------------- +-- The Trail type + +-- | @Trail@ is a wrapper around @Trail'@, hiding whether the +-- underlying @Trail'@ is a line or loop (though which it is can be +-- recovered; see /e.g./ 'withTrail'). +data Trail v n where + Trail :: Trail' l v n -> Trail v n + +deriving instance Show (v n) => Show (Trail v n) + +instance Eq (v n) => Eq (Trail v n) where + t1 == t2 = + withTrail + (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) + (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) + t1 + +instance Ord (v n) => Ord (Trail v n) where + compare t1 t2 = + withTrail + (\ln1 -> withTrail (compare ln1) (const LT) t2) + (\lp1 -> withTrail (const GT) (compare lp1) t2) + t1 + +-- | Two @Trail@s are combined by first ensuring they are both lines +-- (using 'cutTrail' on loops) and then concatenating them. The +-- result, in general, is a line. However, there is a special case +-- for the empty line, which acts as the identity (so combining the +-- empty line with a loop results in a loop). +instance (OrderedField n, Metric v) => Semigroup (Trail v n) where + (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 + t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 + t1 <> t2 = flip withLine t1 $ \l1 -> + flip withLine t2 $ \l2 -> + wrapLine (l1 <> l2) + +-- | @Trail@s are combined as described in the 'Semigroup' instance; +-- the empty line is the identity element, with special cases so +-- that combining the empty line with a loop results in the +-- unchanged loop (in all other cases loops will be cut). Note that +-- this does, in fact, satisfy the monoid laws, though it is a bit +-- strange. Mostly it is provided for convenience, so one can work +-- directly with @Trail@s instead of working with @Trail' Line@s and +-- then wrapping. +instance (Metric v, OrderedField n) => Monoid (Trail v n) where + mempty = wrapLine emptyLine + mappend = (<>) + +instance (Metric v, OrderedField n) => AsEmpty (Trail v n) where + _Empty = nearly emptyTrail isTrailEmpty + +type instance V (Trail v n) = v +type instance N (Trail v n) = n + +type instance Codomain (Trail v n) = v + +instance (HasLinearMap v, Metric v, OrderedField n) + => Transformable (Trail v n) where + transform t = onTrail (transform t) (transform t) + +instance (Metric v, OrderedField n) => Enveloped (Trail v n) where + getEnvelope = withTrail getEnvelope getEnvelope + +instance (Metric v, OrderedField n, Real n) + => Parametric (Trail v n) where + atParam t p = withTrail (`atParam` p) (`atParam` p) t + +instance Num n => DomainBounds (Trail v n) + +instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n) + +-- | Note that there is no @Sectionable@ instance for @Trail' Loop@, +-- because it does not make sense (splitting a loop at a parameter +-- results in a single line, not two loops). However, it's +-- convenient to have a @Sectionable@ instance for @Trail@; if the +-- @Trail@ contains a loop the loop will first be cut and then +-- @splitAtParam@ called on the resulting line. This is +-- semantically a bit silly, so please don't rely on it. (*E.g.* if +-- this is really the behavior you want, consider first calling +-- 'cutLoop' yourself.) +instance (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where + splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t + + section t p1 p2 = withLine (wrapLine . (\l -> section l p1 p2)) t + + reverseDomain = reverseTrail + +instance (Metric v, OrderedField n, Real n) + => HasArcLength (Trail v n) where + arcLengthBounded = withLine . arcLengthBounded + arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr + +-- lens instrances ----------------------------------------------------- + +-- | Prism onto a 'Line'. +_Line :: Prism' (Trail v n) (Trail' Line v n) +_Line = _Wrapped' . _Left + +-- | Prism onto a 'Loop'. +_Loop :: Prism' (Trail v n) (Trail' Loop v n) +_Loop = _Wrapped' . _Right + +-- | Prism onto a 'Located' 'Line'. +_LocLine :: Prism' (Located (Trail v n)) (Located (Trail' Line v n)) +_LocLine = prism' (mapLoc Trail) $ located (preview _Line) + +-- | Prism onto a 'Located' 'Loop'. +_LocLoop :: Prism' (Located (Trail v n)) (Located (Trail' Loop v n)) +_LocLoop = prism' (mapLoc Trail) $ located (preview _Loop) + +instance Rewrapped (Trail v n) (Trail v' n') +instance Wrapped (Trail v n) where + type Unwrapped (Trail v n) = Either (Trail' Line v n) (Trail' Loop v n) + _Wrapped' = iso getTrail (either Trail Trail) + where + getTrail :: Trail v n -> Either (Trail' Line v n) (Trail' Loop v n) + getTrail (Trail t@(Line {})) = Left t + getTrail (Trail t@(Loop {})) = Right t + +-------------------------------------------------- +-- Constructors and eliminators for Trail + +-- | A generic eliminator for 'Trail', taking functions specifying +-- what to do in the case of a line or a loop. +withTrail :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r +withTrail line loop (Trail t) = withTrail' line loop t + +-- | Modify a @Trail@, specifying two separate transformations for the +-- cases of a line or a loop. +onTrail :: (Trail' Line v n -> Trail' l1 v n) -> (Trail' Loop v n -> Trail' l2 v n) + -> Trail v n -> Trail v n +onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) + +-- | An eliminator for @Trail@ based on eliminating lines: if the +-- trail is a line, the given function is applied; if it is a loop, it +-- is first converted to a line with 'cutLoop'. That is, +-- +-- @ +-- withLine f === 'withTrail' f (f . 'cutLoop') +-- @ +withLine :: (Metric v, OrderedField n) + => (Trail' Line v n -> r) -> Trail v n -> r +withLine f = withTrail f (f . cutLoop) + +-- | Modify a @Trail@ by specifying a transformation on lines. If the +-- trail is a line, the transformation will be applied directly. If +-- it is a loop, it will first be cut using 'cutLoop', the +-- transformation applied, and then glued back into a loop with +-- 'glueLine'. That is, +-- +-- @ +-- onLine f === onTrail f (glueLine . f . cutLoop) +-- @ +-- +-- Note that there is no corresponding @onLoop@ function, because +-- there is no nice way in general to convert a line into a loop, +-- operate on it, and then convert back. +onLine :: (Metric v, OrderedField n) + => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n +onLine f = onTrail f (glueLine . f . cutLoop) + +-- | Convert a 'Trail'' into a 'Trail', hiding the type-level +-- distinction between lines and loops. +wrapTrail :: Trail' l v n -> Trail v n +wrapTrail = Trail + +-- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', +-- but with a more specific type, which can occasionally be +-- convenient for fixing the type of a polymorphic expression. +wrapLine :: Trail' Line v n -> Trail v n +wrapLine = wrapTrail + +-- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', +-- but with a more specific type, which can occasionally be +-- convenient for fixing the type of a polymorphic expression. +wrapLoop :: Trail' Loop v n -> Trail v n +wrapLoop = wrapTrail + +------------------------------------------------------------ +-- Constructing trails ----------------------------------- +------------------------------------------------------------ + +-- | The empty line, which is the identity for concatenation of lines. +emptyLine :: (Metric v, OrderedField n) => Trail' Line v n +emptyLine = Line mempty + +-- | A wrapped variant of 'emptyLine'. +emptyTrail :: (Metric v, OrderedField n) => Trail v n +emptyTrail = wrapLine emptyLine + +-- | Construct a line from a list of closed segments. +lineFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Trail' Line v n +lineFromSegments = Line . SegTree . FT.fromList + +-- | Construct a loop from a list of closed segments and an open segment +-- that completes the loop. +loopFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Segment Open v n -> Trail' Loop v n +loopFromSegments segs = Loop (SegTree (FT.fromList segs)) + +-- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for +-- conveniently constructing a @Trail@ instead of a @Trail'@. +trailFromSegments :: (Metric v, OrderedField n) + => [Segment Closed v n] -> Trail v n +trailFromSegments = wrapTrail . lineFromSegments + +-- | Construct a line containing only linear segments from a list of +-- vectors, where each vector represents the offset from one vertex +-- to the next. See also 'fromOffsets'. +-- +-- <> +-- +-- > import Diagrams.Coordinates +-- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] +lineFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail' Line v n +lineFromOffsets = lineFromSegments . map straight + +-- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for +-- conveniently constructing a @Trail@ instead of a @Trail' Line@. +trailFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail v n +trailFromOffsets = wrapTrail . lineFromOffsets + +-- | Construct a line containing only linear segments from a list of +-- vertices. Note that only the relative offsets between the +-- vertices matters; the information about their absolute position +-- will be discarded. That is, for all vectors @v@, +-- +-- @ +-- lineFromVertices === lineFromVertices . 'translate' v +-- @ +-- +-- If you want to retain the position information, you should +-- instead use the more general 'fromVertices' function to +-- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' +-- ('Trail' v)@. +-- +-- <> +-- +-- > import Diagrams.Coordinates +-- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine +-- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1] +lineFromVertices :: (Metric v, OrderedField n) + => [Point v n] -> Trail' Line v n +lineFromVertices [] = emptyLine +lineFromVertices [_] = emptyLine +lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps + + +-- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for +-- conveniently constructing a @Trail@ instead of a @Trail' Line@. +trailFromVertices :: (Metric v, OrderedField n) + => [Point v n] -> Trail v n +trailFromVertices = wrapTrail . lineFromVertices + +------------------------------------------------------------ +-- Converting between lines and loops -------------------- +------------------------------------------------------------ + +-- | Make a line into a loop by \"gluing\" the endpoint to the +-- starting point. In particular, the offset of the final segment +-- is modified so that it ends at the starting point of the entire +-- trail. Typically, you would first construct a line which you +-- know happens to end where it starts, and then call 'glueLine' to +-- turn it into a loop. +-- +-- <> +-- +-- > glueLineEx = pad 1.1 . hsep 1 +-- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] +-- > +-- > almostClosed :: Trail' Line V2 Double +-- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)] +-- +-- @glueLine@ is left inverse to 'cutLoop', that is, +-- +-- @ +-- glueLine . cutLoop === id +-- @ +glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n +glueLine (Line (SegTree t)) = + case FT.viewr t of + FT.EmptyR -> Loop mempty (Linear OffsetOpen) + t' FT.:> Linear _ -> Loop (SegTree t') (Linear OffsetOpen) + t' FT.:> Cubic c1 c2 _ -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) + +-- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. +-- It performs 'glueLine' on lines and is the identity on loops. +glueTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n +glueTrail = onTrail glueLine id + +-- | Make a line into a loop by adding a new linear segment from the +-- line's end to its start. +-- +-- @closeLine@ does not have any particularly nice theoretical +-- properties, but can be useful /e.g./ when you want to make a +-- closed polygon out of a list of points where the initial point is +-- not repeated at the end. To use 'glueLine', one would first have +-- to duplicate the initial vertex, like +-- +-- @ +-- 'glueLine' . 'lineFromVertices' $ ps ++ [head ps] +-- @ +-- +-- Using @closeLine@, however, one can simply +-- +-- @ +-- closeLine . lineFromVertices $ ps +-- @ +-- +-- <> +-- +-- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1) +-- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] +closeLine :: Trail' Line v n -> Trail' Loop v n +closeLine (Line t) = Loop t (Linear OffsetOpen) + +-- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which +-- performs 'closeLine' on lines and is the identity on loops. +closeTrail :: Trail v n -> Trail v n +closeTrail = onTrail closeLine id + +-- | Turn a loop into a line by \"cutting\" it at the common start/end +-- point, resulting in a line which just happens to start and end at +-- the same place. +-- +-- @cutLoop@ is right inverse to 'glueLine', that is, +-- +-- @ +-- glueLine . cutLoop === id +-- @ +cutLoop :: forall v n. (Metric v, OrderedField n) + => Trail' Loop v n -> Trail' Line v n +cutLoop (Loop (SegTree t) c) = + case (FT.null t, c) of + (True, Linear OffsetOpen) -> emptyLine + (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) + (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) + where + offV :: v n + offV = negated . trailMeasure zero (op TotalOffset .view oeOffset) $ t + off = OffsetClosed offV + +-- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is +-- the identity on lines and performs 'cutLoop' on loops. +cutTrail :: (Metric v, OrderedField n) + => Trail v n -> Trail v n +cutTrail = onTrail id cutLoop + +------------------------------------------------------------ +-- Eliminating trails ------------------------------------ +------------------------------------------------------------ + +-- | Test whether a line is empty. +isLineEmpty :: (Metric v, OrderedField n) => Trail' Line v n -> Bool +isLineEmpty (Line (SegTree t)) = FT.null t + +-- | Test whether a trail is empty. Note that loops are never empty. +isTrailEmpty :: (Metric v, OrderedField n) => Trail v n -> Bool +isTrailEmpty = withTrail isLineEmpty (const False) + +-- | Determine whether a trail is a line. +isLine :: Trail v n -> Bool +isLine = not . isLoop + +-- | Determine whether a trail is a loop. +isLoop :: Trail v n -> Bool +isLoop = withTrail (const False) (const True) + +-- | Extract the segments comprising a line. +lineSegments :: Trail' Line v n -> [Segment Closed v n] +lineSegments (Line (SegTree t)) = F.toList t + +-- | Modify a line by applying a function to its list of segments. +onLineSegments + :: (Metric v, OrderedField n) + => ([Segment Closed v n] -> [Segment Closed v n]) + -> Trail' Line v n -> Trail' Line v n +onLineSegments f = lineFromSegments . f . lineSegments + +-- | Extract the segments comprising a loop: a list of closed +-- segments, and one final open segment. +loopSegments :: Trail' Loop v n -> ([Segment Closed v n], Segment Open v n) +loopSegments (Loop (SegTree t) c) = (F.toList t, c) + +-- | Extract the segments of a trail. If the trail is a loop it will +-- first have 'cutLoop' applied. +trailSegments :: (Metric v, OrderedField n) + => Trail v n -> [Segment Closed v n] +trailSegments = withLine lineSegments + +-- | Extract the offsets of the segments of a trail. +trailOffsets :: (Metric v, OrderedField n) => Trail v n -> [v n] +trailOffsets = withLine lineOffsets + +-- | Compute the offset from the start of a trail to the end. Satisfies +-- +-- @ +-- trailOffset === sumV . trailOffsets +-- @ +-- +-- but is more efficient. +-- +-- <> +-- +-- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 +-- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] +-- > # strokeP # lc red +trailOffset :: (Metric v, OrderedField n) => Trail v n -> v n +trailOffset = withLine lineOffset + +-- | Extract the offsets of the segments of a line. +lineOffsets :: Trail' Line v n -> [v n] +lineOffsets = map segOffset . lineSegments + +-- | Extract the offsets of the segments of a loop. +loopOffsets :: (Metric v, OrderedField n) => Trail' Loop v n -> [v n] +loopOffsets = lineOffsets . cutLoop + +-- | Compute the offset from the start of a line to the end. (Note, +-- there is no corresponding @loopOffset@ function because by +-- definition it would be constantly zero.) +lineOffset :: (Metric v, OrderedField n) => Trail' Line v n -> v n +lineOffset (Line t) = trailMeasure zero (op TotalOffset . view oeOffset) t + +-- | Extract the points of a concretely located trail, /i.e./ the points +-- where one segment ends and the next begins. Note that for loops, +-- the starting point will /not/ be repeated at the end. If you +-- want this behavior, you can use 'cutTrail' to make the loop into +-- a line first, which happens to repeat the same point at the start +-- and end, /e.g./ with @trailPoints . mapLoc cutTrail@. +-- +-- Note that it does not make sense to ask for the points of a +-- 'Trail' by itself; if you want the points of a trail +-- with the first point at, say, the origin, you can use +-- @trailPoints . (\`at\` origin)@. +-- +-- This function allows you "observe" the fact that trails are +-- implemented as lists of segments, which may be problematic if we +-- want to think of trails as parametric vector functions. This also +-- means that the behavior of this function may not be stable under +-- future changes to the implementation of trails. For an +-- unproblematic version which only yields vertices at which there +-- is a sharp corner, excluding points where the trail is +-- differentiable, see 'trailVertices'. +-- +-- This function is not re-exported from "Diagrams.Prelude"; to use +-- it, import "Diagrams.Trail". +trailPoints :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Point v n] +trailPoints (viewLoc -> (p,t)) + = withTrail (linePoints . (`at` p)) (loopPoints . (`at` p)) t + +-- | Extract the segment join points of a concretely located line. See +-- 'trailPoints' for more information. +-- +-- This function allows you "observe" the fact that lines are +-- implemented as lists of segments, which may be problematic if we +-- want to think of lines as parametric vector functions. This also +-- means that the behavior of this function may not be stable under +-- future changes to the implementation of trails. For an +-- unproblematic version which only yields vertices at which there +-- is a sharp corner, excluding points where the trail is +-- differentiable, see 'lineVertices'. +-- +-- This function is not re-exported from "Diagrams.Prelude"; to use +-- it, import "Diagrams.Trail". +linePoints :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> [Point v n] +linePoints (viewLoc -> (p,t)) + = segmentPoints p . lineSegments $ t + +-- | Extract the segment join points of a concretely located loop. Note that the +-- initial vertex is not repeated at the end. See 'trailPoints' for +-- more information. +-- +-- This function allows you "observe" the fact that lines are +-- implemented as lists of segments, which may be problematic if we +-- want to think of lines as parametric vector functions. This also +-- means that the behavior of this function may not be stable under +-- future changes to the implementation of trails. For an +-- unproblematic version which only yields vertices at which there +-- is a sharp corner, excluding points where the trail is +-- differentiable, see 'lineVertices'. +-- +-- This function is not re-exported from "Diagrams.Prelude"; to use +-- it, import "Diagrams.Trail". +loopPoints :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> [Point v n] +loopPoints (viewLoc -> (p,t)) + = segmentPoints p . fst . loopSegments $ t + +segmentPoints :: (Additive v, Num n) => Point v n -> [Segment Closed v n] -> [Point v n] +segmentPoints p = scanl (.+^) p . map segOffset + +tolerance :: OrderedField a => a +tolerance = 10e-16 + +-- | Extract the vertices of a concretely located trail. Here a /vertex/ +-- is defined as a non-differentiable point on the trail, /i.e./ a +-- sharp corner. (Vertices are thus a subset of the places where +-- segments join; if you want all joins between segments, see +-- 'trailPoints'.) The tolerance determines how close the tangents +-- of two segments must be at their endpoints to consider the +-- transition point to be differentiable. +-- +-- Note that for loops, the starting vertex will /not/ be repeated +-- at the end. If you want this behavior, you can use 'cutTrail' to +-- make the loop into a line first, which happens to repeat the same +-- vertex at the start and end, /e.g./ with @trailVertices . mapLoc +-- cutTrail@. +-- +-- It does not make sense to ask for the vertices of a 'Trail' by +-- itself; if you want the vertices of a trail with the first vertex +-- at, say, the origin, you can use @trailVertices . (\`at\` +-- origin)@. +trailVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail v n) -> [Point v n] +trailVertices' toler (viewLoc -> (p,t)) + = withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t + +-- | Like 'trailVertices'', with a default tolerance. +trailVertices :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Point v n] +trailVertices = trailVertices' tolerance + +-- | Extract the vertices of a concretely located line. See +-- 'trailVertices' for more information. +lineVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail' Line v n) -> [Point v n] +lineVertices' toler (viewLoc -> (p,t)) + = segmentVertices' toler p . lineSegments $ t + +-- | Like 'lineVertices'', with a default tolerance. +lineVertices :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> [Point v n] +lineVertices = lineVertices' tolerance + +-- | Extract the vertices of a concretely located loop. Note that the +-- initial vertex is not repeated at the end. See 'trailVertices' for +-- more information. +loopVertices' :: (Metric v, OrderedField n) + => n -> Located (Trail' Loop v n) -> [Point v n] +loopVertices' toler (viewLoc -> (p,t)) + | length segs > 1 = if far > toler then init ps else init . drop 1 $ ps + | otherwise = ps + where + far = quadrance ((signorm . tangentAtStart . head $ segs) ^-^ + (signorm . tangentAtEnd . last $ segs)) + segs = lineSegments . cutLoop $ t + ps = segmentVertices' toler p segs + +-- | Same as 'loopVertices'', with a default tolerance. +loopVertices :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> [Point v n] +loopVertices = loopVertices' tolerance + +-- | The vertices of a list of segments laid end to end. +-- The start and end points are always included in the list of +-- vertices. The other points connecting segments are included if +-- the slope at the end of a segment is not equal to the slope at +-- the beginning of the next. The 'toler' parameter is used to +-- control how close the slopes need to be in order to declare them +-- equal. +segmentVertices' :: (Metric v, OrderedField n) + => n -> Point v n -> [Segment Closed v n] -> [Point v n] +segmentVertices' toler p ts = + case ps of + (x:_:_) -> x : select (drop 1 ps) ds ++ [last ps] + _ -> ps + where + ds = zipWith far tans (drop 1 tans) + tans = [(signorm . tangentAtStart $ s + ,signorm . tangentAtEnd $ s) | s <- ts] + ps = scanl (.+^) p . map segOffset $ ts + far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler + +select :: [a] -> [Bool] -> [a] +select xs bs = map fst $ filter snd (zip xs bs) + +-- | Convert a concretely located trail into a list of fixed segments. +-- 'unfixTrail' is almost its left inverse. +fixTrail :: (Metric v, OrderedField n) + => Located (Trail v n) -> [FixedSegment v n] +fixTrail t = map mkFixedSeg (trailLocSegments t) + +-- | Convert a list of fixed segments into a located trail. Note that +-- this may lose information: it throws away the locations of all +-- but the first @FixedSegment@. This does not matter precisely +-- when each @FixedSegment@ begins where the previous one ends. +-- +-- This is almost left inverse to 'fixTrail', that is, @unfixTrail +-- . fixTrail == id@, except for the fact that @unfixTrail@ will +-- never yield a @Loop@. In the case of a loop, we instead have +-- @glueTrail . unfixTrail . fixTrail == id@. On the other hand, it +-- is not the case that @fixTrail . unfixTrail == id@ since +-- @unfixTrail@ may lose information. +unfixTrail + :: (Metric v, Ord n, Floating n) + => [FixedSegment v n] -> Located (Trail v n) +unfixTrail = mapLoc trailFromSegments . takeLoc . map fromFixedSeg + where + takeLoc [] = [] `at` origin + takeLoc xs@(x:_) = map unLoc xs `at` loc x + +-- | Convert a concretely located trail into a list of located segments. +trailLocSegments :: (Metric v, OrderedField n) + => Located (Trail v n) -> [Located (Segment Closed v n)] +trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) + +------------------------------------------------------------ +-- Modifying trails -------------------------------------- +------------------------------------------------------------ + +-- | Reverse a trail. Semantically, if a trail given by a function t +-- from [0,1] to vectors, then the reverse of t is given by t'(s) = +-- t(1-s). @reverseTrail@ is an involution, that is, +-- +-- @ +-- reverseTrail . reverseTrail === id +-- @ +reverseTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n +reverseTrail = onTrail reverseLine reverseLoop + +-- | Reverse a concretely located trail. The endpoint of the original +-- trail becomes the starting point of the reversed trail, so the +-- original and reversed trails comprise exactly the same set of +-- points. @reverseLocTrail@ is an involution, /i.e./ +-- +-- @ +-- reverseLocTrail . reverseLocTrail === id +-- @ +reverseLocTrail :: (Metric v, OrderedField n) + => Located (Trail v n) -> Located (Trail v n) +reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) + +-- | Reverse a line. See 'reverseTrail'. +reverseLine :: (Metric v, OrderedField n) + => Trail' Line v n -> Trail' Line v n +reverseLine = onLineSegments (reverse . map reverseSegment) + +-- | Reverse a concretely located line. See 'reverseLocTrail'. +reverseLocLine :: (Metric v, OrderedField n) + => Located (Trail' Line v n) -> Located (Trail' Line v n) +reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) + +-- | Reverse a loop. See 'reverseTrail'. +reverseLoop :: (Metric v, OrderedField n) + => Trail' Loop v n -> Trail' Loop v n +reverseLoop = glueLine . reverseLine . cutLoop + +-- | Reverse a concretely located loop. See 'reverseLocTrail'. Note +-- that this is guaranteed to preserve the location. +reverseLocLoop :: (Metric v, OrderedField n) + => Located (Trail' Loop v n) -> Located (Trail' Loop v n) +reverseLocLoop = mapLoc reverseLoop + +-- | Same as 'reverseLine' or 'reverseLoop'. +instance (Metric v, OrderedField n) => Reversing (Trail' l v n) where + reversing t@(Line _) = onLineSegments (reverse . map reversing) t + reversing t@(Loop _ _) = glueLine . reversing . cutLoop $ t + +-- | Same as 'reverseTrail'. +instance (Metric v, OrderedField n) => Reversing (Trail v n) where + reversing (Trail t) = Trail (reversing t) + +-- | Same as 'reverseLocLine' or 'reverseLocLoop'. +instance (Metric v, OrderedField n) => Reversing (Located (Trail' l v n)) where + reversing l@(Loc _ Line {}) = reverseLocLine l + reversing l@(Loc _ Loop {}) = reverseLocLoop l + +-- | Same as 'reverseLocTrail'. +instance (Metric v, OrderedField n) => Reversing (Located (Trail v n)) where + reversing = reverseLocTrail + +------------------------------------------------------------ +-- Serialize instances +------------------------------------------------------------ + +instance (Serialize (v n), OrderedField n, Metric v) => Serialize (Trail v n) where + {-# INLINE get #-} + get = do + isLine <- Serialize.get + case isLine of + True -> do + segTree <- Serialize.get + return (Trail (Line segTree)) + False -> do + segTree <- Serialize.get + segment <- Serialize.get + return (Trail (Loop segTree segment)) + + {-# INLINE put #-} + put (Trail (Line segTree)) = do + Serialize.put True + Serialize.put segTree + + put (Trail (Loop segTree segment)) = do + Serialize.put False + Serialize.put segTree + Serialize.put segment + +instance (OrderedField n, Metric v, Serialize (v n)) => Serialize (SegTree v n) where + {-# INLINE put #-} + put (SegTree fingerTree) = Serialize.put (F.toList fingerTree) + + {-# INLINE get #-} + get = do + fingerTree <- Serialize.get + return (SegTree (FT.fromList fingerTree)) diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -28,14 +30,17 @@ ) where -import Data.AffineSpace ((.-.)) -import Data.VectorSpace +import Control.Lens (view, _Unwrapped') import Diagrams.Core import Diagrams.Located import Diagrams.Segment import Diagrams.Trail +import Linear.Affine +import Linear.Metric +import Linear.Vector + ------------------------------------------------------------ -- TrailLike class ------------------------------------------------------------ @@ -60,42 +65,42 @@ -- course call 'trailLike' directly; more typically, one would use -- one of the provided functions like 'fromOffsets', 'fromVertices', -- 'fromSegments', or '~~'. -class (InnerSpace (V t), OrderedField (Scalar (V t))) => TrailLike t where +class (Metric (V t), OrderedField (N t)) => TrailLike t where trailLike - :: Located (Trail (V t)) -- ^ The concretely located trail. Note - -- that some trail-like things - -- (e.g. 'Trail's) may ignore the - -- location. + :: Located (Trail (V t) (N t)) -- ^ The concretely located trail. Note + -- that some trail-like things + -- (e.g. 'Trail's) may ignore the + -- location. -> t ------------------------------------------------------------ -- Instances --------------------------------------------- -- | A list of points is trail-like; this instance simply --- computes the vertices of the trail, using 'trailVertices'. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike [Point v] where - trailLike = trailVertices +-- computes the vertices of the trail, using 'trailPoints'. +instance (Metric v, OrderedField n) => TrailLike [Point v n] where + trailLike = trailPoints -- | Lines are trail-like. If given a 'Trail' which contains a loop, -- the loop will be cut with 'cutLoop'. The location is ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Line v) where +instance (Metric v, OrderedField n) => TrailLike (Trail' Line v n) where trailLike = withTrail id cutLoop . unLoc -- | Loops are trail-like. If given a 'Trail' containing a line, the -- line will be turned into a loop using 'glueLine'. The location -- is ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Loop v) where +instance (Metric v, OrderedField n) => TrailLike (Trail' Loop v n) where trailLike = withTrail glueLine id . unLoc -- | 'Trail's are trail-like; the location is simply ignored. -instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail v) where +instance (Metric v, OrderedField n) => TrailLike (Trail v n) where trailLike = unLoc -- | Translationally invariant things are trail-like as long as the -- underlying type is. instance TrailLike t => TrailLike (TransInv t) where - trailLike = TransInv . trailLike + trailLike = view _Unwrapped' . trailLike -- | 'Located' things are trail-like as long as the underlying type -- is. The location is taken to be the location of the input @@ -110,24 +115,39 @@ -- | Construct a trail-like thing from a list of segments, with the -- origin as the location. -- --- XXX example/picture -fromSegments :: TrailLike t => [Segment Closed (V t)] -> t +-- <> +-- +-- > fromSegmentsEx = fromSegments +-- > [ straight (r2 (1,1)) +-- > , bézier3 (r2 (1,1)) unitX unit_Y +-- > , straight unit_X +-- > ] +-- > # centerXY # pad 1.1 +fromSegments :: TrailLike t => [Segment Closed (V t) (N t)] -> t fromSegments = fromLocSegments . (`at` origin) -- | Construct a trail-like thing from a located list of segments. -fromLocSegments :: TrailLike t => Located [Segment Closed (V t)] -> t +fromLocSegments :: TrailLike t => Located [Segment Closed (V t) (N t)] -> t fromLocSegments = trailLike . mapLoc trailFromSegments -- | Construct a trail-like thing of linear segments from a list -- of offsets, with the origin as the location. -- --- XXX example/picture -fromOffsets :: TrailLike t => [V t] -> t +-- <> +-- +-- > fromOffsetsEx = fromOffsets +-- > [ unitX +-- > , unitX # rotateBy (1/6) +-- > , unitX # rotateBy (-1/6) +-- > , unitX +-- > ] +-- > # centerXY # pad 1.1 +fromOffsets :: TrailLike t => [Vn t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. -fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [V t] -> t +fromLocOffsets :: (V t ~ v, N t ~ n, V (v n) ~ v, N (v n) ~ n, TrailLike t) => Located [v n] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with @@ -135,23 +155,51 @@ -- vertices are given, the empty trail is used with the origin as -- the location. -- --- XXX example/picture -fromVertices :: TrailLike t => [Point (V t)] -> t +-- <> +-- +-- > import Data.List (transpose) +-- > +-- > fromVerticesEx = +-- > ( [ pentagon 1 +-- > , pentagon 1.3 # rotateBy (1/15) +-- > , pentagon 1.5 # rotateBy (2/15) +-- > ] +-- > # transpose +-- > # concat +-- > ) +-- > # fromVertices +-- > # closeTrail # strokeTrail +-- > # centerXY # pad 1.1 +fromVertices :: TrailLike t => [Point (V t) (N t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) -segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment Closed v] +segmentsFromVertices :: (Additive v, Num n) => [Point v n] -> [Segment Closed v n] segmentsFromVertices [] = [] segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- | Create a linear trail between two given points. -(~~) :: TrailLike t => Point (V t) -> Point (V t) -> t +-- +-- <> +-- +-- > twiddleEx +-- > = mconcat ((~~) <$> hexagon 1 <*> hexagon 1) +-- > # centerXY # pad 1.1 +(~~) :: (V t ~ v, N t ~ n, TrailLike t) => Point v n -> Point v n -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each -- segment into its own separate trail. Useful for (say) applying a -- different style to each segment. -explodeTrail :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [t] +-- +-- <> +-- +-- > explodeTrailEx +-- > = pentagon 1 +-- > # explodeTrail -- generate a list of diagrams +-- > # zipWith lc [orange, green, yellow, red, blue] +-- > # mconcat # centerXY # pad 1.1 +explodeTrail :: (V t ~ v, N t ~ n, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -1,7 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform --- Copyright : (c) 2011-13 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-15 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -11,6 +19,7 @@ -- ----------------------------------------------------------------------------- + module Diagrams.Transform ( -- * Transformations Transformation, inv, transl, apply, papply @@ -22,7 +31,7 @@ , translation, translate, moveTo, place, scaling, scale -- * Miscellaneous transformation-related utilities - , conjugate, under + , conjugate, underT, transformed, translated, movedTo, movedFrom -- * The HasOrigin class @@ -30,27 +39,90 @@ ) where +import Control.Lens hiding (transform) import Data.Semigroup import Diagrams.Core +import Linear.Vector + -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the -- inverse of @t1@. -conjugate :: HasLinearMap v => Transformation v -> Transformation v -> Transformation v -conjugate t1 t2 = inv t1 <> t2 <> t1 +conjugate :: (Additive v, Num n) + => Transformation v n -> Transformation v n -> Transformation v n +conjugate t1 t2 = inv t1 <> t2 <> t1 --- | Carry out some transformation \"under\" another one: @f ``under`` +-- | Carry out some transformation \"under\" another one: @f ``underT`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For --- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: Turn)@ +-- example, @'scaleX' 2 ``underT`` 'rotation' (-1/8 \@\@ Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- -- Note that -- --- @ --- (transform t2) `under` t1 == transform (conjugate t1 t2) --- @ +-- @ +-- (transform t2) `underT` t1 == transform (conjugate t1 t2) +-- @ -- -- for all transformations @t1@ and @t2@. -under :: Transformable a => (a -> a) -> Transformation (V a) -> a -> a -f `under` t = transform (inv t) . f . transform t +-- +-- See also the isomorphisms like 'transformed', 'movedTo', +-- 'movedFrom', and 'translated'. +underT :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) + => (a -> b) -> Transformation v n -> a -> b +f `underT` t = transform (inv t) . f . transform t + +-- | Use a 'Transformation' to make an 'Iso' between an object +-- transformed and untransformed. This is useful for carrying out +-- functions 'under' another transform: +-- +-- @ +-- under (transformed t) f == transform (inv t) . f . transform t +-- under (transformed t1) (transform t2) == transform (conjugate t1 t2) +-- transformed t ## a == transform t a +-- a ^. transformed t == transform (inv t) a +-- @ +transformed :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) + => Transformation v n -> Iso a b a b +transformed t = iso (transform $ inv t) (transform t) + +-- | Use a 'Point' to make an 'Iso' between an object +-- moved to and from that point: +-- +-- @ +-- under (movedTo p) f == moveTo (-p) . f . moveTo p +-- over (movedTo p) f == moveTo p . f . moveTo (-p) +-- movedTo p == from (movedFrom p) +-- movedTo p ## a == moveTo p a +-- a ^. movedTo p == moveOriginTo p a +-- @ +movedTo :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) + => Point v n -> Iso a b a b +movedTo p = iso (moveTo (negated p)) (moveTo p) + +-- | Use a 'Transformation' to make an 'Iso' between an object +-- transformed and untransformed. We have +-- +-- @ +-- under (movedFrom p) f == moveTo p . f . moveTo (-p) +-- movedFrom p == from (movedTo p) +-- movedFrom p ## a == moveOriginTo p a +-- a ^. movedFrom p == moveTo p a +-- over (movedFrom p) f == moveTo (-p) . f . moveTo p +-- @ +movedFrom :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) + => Point v n -> Iso a b a b +movedFrom p = iso (moveOriginTo (negated p)) (moveOriginTo p) + +-- | Use a vector to make an 'Iso' between an object translated and +-- untranslated. +-- +-- @ +-- under (translated v) f == translate (-v) . f . translate v +-- translated v ## a == translate v a +-- a ^. translated v == translate (-v) a +-- over (translated v) f == translate v . f . translate (-v) +-- @ +translated :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) + => v n -> Iso a b a b +translated v = transformed $ translation v diff --git a/src/Diagrams/Transform/Matrix.hs b/src/Diagrams/Transform/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Transform/Matrix.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Transform.Matrix +-- Copyright : (c) 2014 diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Functions for converting between 'Transformation's and matricies. +-- +----------------------------------------------------------------------------- + +module Diagrams.Transform.Matrix where + +import Control.Arrow ((&&&)) +import Control.Lens +import Data.Distributive +import qualified Data.Foldable as F +import Data.Functor.Rep + +import Diagrams.Core.Transform as D +import Diagrams.ThreeD.Types +import Diagrams.TwoD.Types + +import Linear.Matrix +import Linear.Vector + +-- | Build a matrix from a 'Transformation', ignoring the translation. +mkMat :: (HasBasis v, Num n) => Transformation v n -> v (v n) +mkMat t = distribute . tabulate $ apply t . unit . (\x -> el x) + +-- | Build a 3D transformation matrix in homogeneous coordinates from +-- a 'Transformation V3'. +mkMatHomo :: Num n => Transformation V3 n -> M44 n +mkMatHomo t = mkTransformationMat (mkMat t) (transl t) + +-- | Make a 2D transformation from a 2x2 transform matrix and a +-- translation vector. Does not check if the matrix is not invertible +-- (in which case the 'T2' will be invalid). +fromMat22 :: Floating n => M22 n -> V2 n -> T2 n +fromMat22 m v = fromMatWithInv m (inv22 m) v + +-- | Make a 3D transformation from a 3x3 transform matrix and a +-- translation vector. Does not check if the matrix is not invertible +-- (in which case the 'T3' will be invalid). +fromMat33 :: Floating n => M33 n -> V3 n -> T3 n +fromMat33 m v = fromMatWithInv m (inv33 m) v + +-- | Build a transform with a maxtrix along with its inverse. +fromMatWithInv :: (Additive v, Distributive v, F.Foldable v, Num n) + => v (v n) -- ^ matrix + -> v (v n) -- ^ inverse + -> v n -- ^ translation + -> Transformation v n +fromMatWithInv m m_ v = + Transformation ((m !*) <-> (m_ !*)) + ((distribute m !*) <-> (distribute m_ !*)) + v + +-- | Prism onto a 2D transformation from a 2x2 transform matrix and +-- translation vector. Does not check if the matrix is invertible (in +-- which case the 'T2' will be invalid). +mat22 :: Floating n => Iso' (M22 n, V2 n) (T2 n) +mat22 = iso (uncurry fromMat22) (mkMat &&& transl) + +-- | Prism onto a 3D transformation from a 3x3 transform matrix and +-- translation vector. Does not check if the matrix is invertible +-- (in which case the 'T3' will be invalid). +mat33 :: Floating n => Iso' (M33 n, V3 n) (T3 n) +mat33 = iso (uncurry fromMat33) (mkMat &&& transl) diff --git a/src/Diagrams/Transform/ScaleInv.hs b/src/Diagrams/Transform/ScaleInv.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Transform/ScaleInv.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Transform.ScaleInv +-- Copyright : (c) 2012-2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Wrapper for creating scale-invariant objects in two dimensions. +-- +----------------------------------------------------------------------------- + +module Diagrams.Transform.ScaleInv + ( ScaleInv(..) + , scaleInvObj, scaleInvDir, scaleInvLoc + , scaleInv, scaleInvPrim) + where + +import Control.Lens (makeLenses, view, (^.)) +import Data.Typeable + +import Diagrams.Angle +import Diagrams.Core +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types + +import Linear.Affine +import Linear.Vector + +-- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ +-- objects. Intuitively, a scale-invariant object is affected by +-- transformations like translations and rotations, but not by scales. +-- +-- However, this is problematic when it comes to /non-uniform/ +-- scales (/e.g./ @scaleX 2 . scaleY 3@) since they can introduce a +-- perceived rotational component. The prototypical example is an +-- arrowhead on the end of a path, which should be scale-invariant. +-- However, applying a non-uniform scale to the path but not the +-- arrowhead would leave the arrowhead pointing in the wrong +-- direction. +-- +-- Moreover, for objects whose local origin is not at the local +-- origin of the parent diagram, any scale can result in a +-- translational component as well. +-- +-- The solution is to also store a point (indicating the location, +-- /i.e./ the local origin) and a unit vector (indicating the +-- /direction/) along with a scale-invariant object. A +-- transformation to be applied is decomposed into rotational and +-- translational components as follows: +-- +-- * The transformation is applied to the direction vector, and the +-- difference in angle between the original direction vector and its +-- image under the transformation determines the rotational +-- component. The rotation is applied with respect to the stored +-- location, rather than the global origin. +-- +-- * The vector from the location to the image of the location under +-- the transformation determines the translational component. + +data ScaleInv t = + ScaleInv + { _scaleInvObj :: t + , _scaleInvDir :: Vn t + , _scaleInvLoc :: Point (V t) (N t) + } + deriving Typeable + +deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t) + +makeLenses ''ScaleInv + +-- | Create a scale-invariant object pointing in the given direction, +-- located at the origin. +scaleInv :: (V t ~ v, N t ~ n, Additive v, Num n) => t -> v n -> ScaleInv t +scaleInv t d = ScaleInv t d origin + +type instance V (ScaleInv t) = V t +type instance N (ScaleInv t) = N t + +instance (V t ~ v, N t ~ n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where + moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) + +instance (V t ~ V2, N t ~ n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where + transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' + where + angle = transform tr v ^. _theta + + rot :: (V k ~ V t, N k ~ N t, Transformable k) => k -> k + rot = rotateAround l angle + + l' = transform tr l + + trans = translate (l' .-. l) + +{- Proof that the above satisfies the monoid action laws. + + 1. transform mempty (ScaleInv t v l) + = ScaleInv (trans . rot $ t) (rot v) l' + { l' = transform mempty l = l } + { trans = translate (l' .-. l) + = translate (l .-. l) + = translate zeroV + = id + } + { rot = rotateAround l angle + = rotateAround l (direction (transform mempty v) - direction v) + = rotateAround l (direction v - direction v) + = rotateAround l 0 + = id + } + = ScaleInv t v l + + 2. transform t1 (transform t2 (ScaleInv t v l)) + = let angle = direction (transform t2 v) - direction v + rot = rotateAround l angle + l' = transform t2 l + trans = translate (l' .-. l) + in + transform t1 (ScaleInv (trans . rot $ t) (rot v) l') + + = let angle = direction (transform t2 v) - direction v + rot = rotateAround l angle + l' = transform t2 l + trans = translate (l' .-. l) + angle2 = direction (transform t1 (rot v)) - direction (rot v) + rot2 = rotateAround l' angle2 + l'2 = transform t1 l' + trans2 = translate (l'2 .-. l') + in + ScaleInv (trans2 . rot2 . trans . rot $ t) (rot2 . rot $ v) l'2 + + { l'2 = transform t1 l' + = transform t1 (transform t2 l) + = transform (t1 <> t2) l + } + { trans2 = translate (l'2 .-. l') + = translate (transform (t1 <> t2) l .-. transform t2 l) + = translate (transform t1 l .-. l) + } + { rot v = rotateAround l angle v + = rotate angle `under` translation (origin .-. l) $ v + = rotate angle v + } + { angle2 = direction (transform t1 (rot v)) - direction (rot v) + = direction (transform t1 (rotate angle v)) - direction (rotate angle v) + = direction (transform t1 (rotate angle v)) - direction v - angle + } + { rot2 = rotateAround l' angle2 + = ??? + } + +-} + +instance (V t ~ V2, N t ~ n, RealFloat n, Renderable t b) => Renderable (ScaleInv t) b where + render b = render b . view scaleInvObj + +-- | Create a diagram from a single scale-invariant primitive. The +-- vector argument specifies the direction in which the primitive is +-- \"pointing\" (for the purpose of keeping it rotated correctly +-- under non-uniform scaling). The primitive is assumed to be +-- \"located\" at the origin (for the purpose of translating it +-- correctly under scaling). +-- +-- Note that the resulting diagram will have an /empty/ envelope, +-- trace, and query. The reason is that the envelope, trace, and +-- query cannot be cached---applying a transformation would cause +-- the cached envelope, etc. to get \"out of sync\" with the +-- scale-invariant object. The intention, at any rate, is that +-- scale-invariant things will be used only as \"decorations\" (/e.g./ +-- arrowheads) which should not affect the envelope, trace, and +-- query. +scaleInvPrim :: (V t ~ V2, N t ~ n, RealFloat n, Typeable t, Renderable t b, Monoid m) + => t -> V2 n -> QDiagram b (V t) (N t) m +scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -25,10 +25,17 @@ -- specialized to two dimensions (see also "Diagrams.Combinators" -- for more general combining). -- +-- * "Diagrams.TwoD.Attributes" defines attributes specific to two +-- dimensions, *e.g.* fill color, line color, and gradients. +-- -- * "Diagrams.TwoD.Transform" defines R^2-specific transformations -- such as rotation by an angle, and scaling, translation, and -- reflection in the X and Y directions. -- +-- * "Diagrams.TwoD.Deform" defines some non-affine transformations +-- specific to two dimensions, *e.g.* parallel and perspective +-- projections. +-- -- * "Diagrams.TwoD.Ellipse" defines circles and ellipses. -- -- * "Diagrams.TwoD.Arc" defines circular arcs. @@ -42,6 +49,10 @@ -- * "Diagrams.TwoD.Shapes" defines other two-dimensional shapes, -- e.g. various polygons. -- +-- * "Diagrams.TwoD.Arrow" contains tools for drawing arrows between +-- things, and "Diagrams.TwoD.Arrowheads" defines a collection of +-- arrowheads. +-- -- * "Diagrams.TwoD.Text" defines primitive text diagrams. -- -- * "Diagrams.TwoD.Image" allows importing external images into diagrams. @@ -58,27 +69,38 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - R2, r2, unr2 - , P2, p2, unp2 - , T2 + V2 (..), R1 (..), R2 (..) + , P2, T2 + , r2, unr2, mkR2 + , p2, unp2, mkP2 , unitX, unitY, unit_X, unit_Y - , direction, fromDirection, e + , perp, leftTurn + , xDir, yDir -- * Angles , tau - , Angle(..) - , Turn(..), CircleFrac, Rad(..), Deg(..) - , fullCircle, convertAngle + , angleV + , angleDir + , signedAngleBetween , signedAngleBetweenDirs + -- * Polar Coördinates + , HasR(..), r2PolarIso + -- * Paths -- ** Stroking - , stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop - , strokeLocT, strokeLocLine, strokeLocLoop - , FillRule(..), fillRule - , StrokeOpts(..) + , stroke, stroke' + , strokePath, strokeP, strokePath', strokeP' + , strokeTrail, strokeT, strokeTrail', strokeT' + , strokeLine, strokeLoop + , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop + , FillRule(..), fillRule, _fillRule + , StrokeOpts(..), vertexNames, queryFillRule + , intersectPoints, intersectPoints' + , intersectPointsP, intersectPointsP' + , intersectPointsT, intersectPointsT' -- ** Clipping - , clipBy + , clipBy, clipTo, clipped, _Clip, _clip -- * Shapes -- ** Rules @@ -92,11 +114,15 @@ , arc , arc' , arcCW + , arcCCW , wedge + , arcBetween + , annularWedge -- ** General polygons , polygon, polyTrail - , PolygonOpts(..), PolyType(..), PolyOrientation(..) + , PolygonOpts(..), polyType, polyOrient, polyCenter + , PolyType(..), PolyOrientation(..) -- ** Star polygons , StarOpts(..), star @@ -108,6 +134,7 @@ , square , pentagon , hexagon + , heptagon , septagon , octagon , nonagon @@ -121,19 +148,60 @@ -- ** Other shapes , roundedRect, roundedRect' - , RoundedRectOpts(..) + , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR + -- ** Arrows + , arrowV, arrowV' + , arrowAt, arrowAt' + , arrowBetween, arrowBetween' + , connect, connect' + , connectPerim, connectPerim' + , connectOutside, connectOutside' + , arrow, arrow' + , straightShaft + , module Diagrams.TwoD.Arrowheads + + , ArrowOpts(..) + + , arrowHead + , arrowTail + , arrowShaft + , headGap + , tailGap + , gaps, gap + , headTexture + , headStyle + , tailTexture + , tailStyle + , shaftTexture + , shaftStyle + , headLength + , tailLength + , lengths + -- * Text , text, topLeftText, alignedText, baselineText - , font, fontSize, italic, oblique, bold + , font, italic, oblique, fontSize + , bold, bolder, lighter, thinWeight + , ultraLight, light, mediumWeight, heavy, semiBold, ultraBold + , _font, _fontSizeR, _fontSize + , fontSizeO, fontSizeL, fontSizeN, fontSizeG -- * Images + , DImage(..), ImageData(..) + , Embedded, External, Native , image + , loadImageEmb + , loadImageExt + , uncheckedImageRef + , raster + , rasterDia -- * Transformations -- ** Rotation - , rotation, rotate, rotateBy - , rotationAbout, rotateAbout + , rotation, rotate, rotateBy, rotated + , rotationAround, rotateAround + , rotationTo, rotateTo -- ** Scaling , scalingX, scaleX , scalingY, scaleY @@ -144,60 +212,100 @@ , translationX, translateX , translationY, translateY , translation, translate + -- ** Conformal affine maps + , scalingRotationTo, scaleRotateTo -- ** Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- ** Shears , shearingX, shearX , shearingY, shearY + -- * Deformations - non-affine transforms + , parallelX0, perspectiveX1, parallelY0, perspectiveY1 + , facingX, facingY + -- * Combinators -- ** Combining multiple diagrams - , (===), (|||), atAngle - , hcat, hcat' - , vcat, vcat' + , (===), (|||) + , hcat, hcat', hsep + , vcat, vcat', vsep + -- ** Spacing and envelopes , strutX, strutY , padX, padY , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , view + , rectEnvelope, crop -- ** Background - , boundingRect, bg + , boundingRect, bg, bgFrame -- * Alignment , alignL, alignR, alignT, alignB, alignTL, alignTR, alignBL, alignBR , alignX, alignY , centerX, centerY, centerXY + -- * Snugging + , snugL, snugR, snugT, snugB + , snugX, snugY + , snugCenterX, snugCenterY, snugCenterXY + -- * Size -- ** Computing size - , width, height, size2D, sizeSpec2D - , extentX, extentY, center2D + , width, height + , extentX, extentY -- ** Specifying size - , SizeSpec2D(..) - , mkSizeSpec + , mkSizeSpec2D + , mkWidth + , mkHeight + , dims2D - -- ** Adjusting size - , sized, sizedAs + -- * Textures + , Texture(..), solid + , SpreadMethod(..), GradientStop(..) + , _FillTexture, fillTexture, _fillTexture, getFillTexture + , _LineTexture, lineTexture, _lineTexture, lineTextureA, getLineTexture + , stopFraction, stopColor, mkStops + , LGradient(..), _LG, lGradStops, lGradTrans, lGradStart, lGradEnd + , lGradSpreadMethod, defaultLG, mkLinearGradient + + , RGradient(..) + , rGradStops, rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 + , rGradTrans, rGradSpreadMethod, defaultRG, _RG, mkRadialGradient + + -- ** Colors + , fillColor, _SC, _AC, fc, fcA, recommendFillColor + , lineColor, lc, lcA + -- * Visual aids for understanding the internal model , showOrigin , showOrigin' - , OriginOpts(..) + , OriginOpts(..), oColor, oScale, oMinSize + , showEnvelope + , showEnvelope' + , EnvelopeOpts(..), eColor, eLineWidth, ePoints + , showTrace + , showTrace' + , TraceOpts(..), tColor, tScale, tMinSize, tPoints , showLabels ) where import Diagrams.TwoD.Align import Diagrams.TwoD.Arc +import Diagrams.TwoD.Arrow +import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes import Diagrams.TwoD.Combinators +import Diagrams.TwoD.Deform import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image import Diagrams.TwoD.Model diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE ViewPatterns - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Adjust @@ -14,105 +19,85 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD.Adjust - ( - setDefault2DAttributes - , adjustDiaSize2D + ( setDefault2DAttributes + , adjustSize2D , adjustDia2D - , adjustSize -- for backwards compatibility - , requiredScale -- re-exported for backwards compatibility ) where -import Diagrams.Core +import Diagrams.Attributes +import Diagrams.BoundingBox +import Diagrams.Core +import Diagrams.Size +import Diagrams.TwoD.Attributes (lineTextureA) +import Diagrams.TwoD.Types +import Diagrams.Util (( # )) -import Diagrams.Attributes (lineWidthA, lineColorA, lineCap - , lineJoin, lineMiterLimitA - ) -import Diagrams.Util ((#)) +import Control.Lens (Lens', set, (^.)) +import Data.Default +import Data.Semigroup -import Diagrams.TwoD.Types (R2, p2) -import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) - , requiredScaleT, requiredScale - ) -import Diagrams.TwoD.Text (fontSizeA) -import Data.AffineSpace ((.-.)) -import Data.Semigroup - -import Data.Default.Class - -import Data.Colour.Names (black) - -- | Set default attributes of a 2D diagram (in case they have not -- been set): -- --- * Line width 0.01 --- --- * Line color black +-- * 'LineWidth': 0.01 -- --- * Font size 1 +-- * 'LineTexture': solid black -- --- * Line cap LineCapButt +-- * 'LineCap': LineCapButt -- --- * line join miter +-- * 'LineJoin': miter -- --- * Miter limit 10 -setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m -setDefault2DAttributes d = d # lineWidthA def # lineColorA def # fontSizeA def - # lineCap def # lineJoin def # lineMiterLimitA def +-- * 'MiterLimit': 10 +setDefault2DAttributes :: (TypeableFloat n, Semigroup m) + => QDiagram b V2 n m -> QDiagram b V2 n m +setDefault2DAttributes d + = d # lineWidthM def + # lineTextureA def + # lineCap def + # lineJoin def + # lineMiterLimitA def -- | Adjust the size and position of a 2D diagram to fit within the --- requested size. The first two arguments specify a method for --- extracting the requested output size from the rendering options, --- and a way of updating the rendering options with a new (more --- specific) size. -adjustDiaSize2D :: Monoid' m - => (Options b R2 -> SizeSpec2D) - -> (SizeSpec2D -> Options b R2 -> Options b R2) - -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, QDiagram b R2 m) -adjustDiaSize2D getSize setSize _ opts d = - ( case spec of - Dims _ _ -> opts - _ -> setSize (uncurry Dims . scale s $ size) opts - - , d # scale s - # translate tr - ) - where spec = getSize opts - size = size2D d - s = requiredScale spec size - finalSz = case spec of - Dims w h -> (w,h) - _ -> scale s size - tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) +-- requested size. The first argument is a lens into the output +-- size contained in the rendering options. Returns an updated +-- options record, any transformation applied to the diagram (the +-- inverse of which can be used, say, to translate output/device +-- coordinates back into local diagram coordinates), and the +-- modified diagram itself. +adjustSize2D + :: (TypeableFloat n, Monoid' m) + => Lens' (Options b V2 n) (SizeSpec V2 n) + -> b + -> Options b V2 n + -> QDiagram b V2 n m + -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) +adjustSize2D szL _ opts d = (set szL spec opts, t, d # transform t) + where + spec = dims sz + (sz, t) = sizeAdjustment (opts ^. szL) (boundingBox d) -- | @adjustDia2D@ provides a useful default implementation of -- the 'adjustDia' method from the 'Backend' type class. -- --- As its first two arguments it requires a method for extracting --- the requested output size from the rendering options, and a way --- of updating the rendering options with a new (more specific) size. +-- As its first argument it requires a lens into the output size +-- contained in the rendering options. -- -- It then performs the following adjustments: -- -- * Set default attributes (see 'setDefault2DAttributes') -- --- * Freeze the diagram in its final form --- -- * Scale and translate the diagram to fit within the requested -- size (see 'adjustDiaSize2D') -- --- * Also return the actual adjusted size of the diagram. -adjustDia2D :: Monoid' m - => (Options b R2 -> SizeSpec2D) - -> (SizeSpec2D -> Options b R2 -> Options b R2) - -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, QDiagram b R2 m) -adjustDia2D getSize setSize b opts d - = adjustDiaSize2D getSize setSize b opts (d # setDefault2DAttributes # freeze) +-- It returns an updated options record, any transformation applied +-- to the diagram (the inverse of which can be used, say, to +-- translate output/device coordinates back into local diagram +-- coordinates), and the modified diagram itself. +adjustDia2D :: (TypeableFloat n, Monoid' m) + => Lens' (Options b V2 n) (SizeSpec V2 n) + -> b -> Options b V2 n -> QDiagram b V2 n m + -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) +adjustDia2D szL b opts d + = adjustSize2D szL b opts (d # setDefault2DAttributes) -{-# DEPRECATED adjustSize "Use Diagrams.TwoD.Size.requiredScaleT instead." #-} --- | Re-export 'requiredScaleT' with the name 'adjustSize' for --- backwards compatibility. -adjustSize :: SizeSpec2D -> (Double, Double) -> Transformation R2 -adjustSize = requiredScaleT diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Align @@ -12,86 +13,122 @@ -- "Diagrams.Align" for more general alignment combinators. -- -- The basic idea is that alignment is achieved by moving diagrams' --- local origins relative to their envelopes. For example, to align --- several diagrams along their tops, we first move their local --- origins to the upper edge of their envelopes (using e.g. @map --- 'alignTop'@), and then put them together with their local origins --- along a horizontal line (using e.g. 'hcat' from --- "Diagrams.TwoD.Combinators"). +-- local origins relative to their envelopes or traces (or some other +-- sort of boundary). For example, to align several diagrams along +-- their tops, we first move their local origins to the upper edge of +-- their boundary (using e.g. @map 'alignTop'@), and then put them +-- together with their local origins along a horizontal line (using +-- e.g. 'hcat' from "Diagrams.TwoD.Combinators"). -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Align ( -- * Absolute alignment + -- ** Align by envelope alignL, alignR, alignT, alignB , alignTL, alignTR, alignBL, alignBR + -- ** Align by trace + , snugL, snugR, snugT, snugB + -- * Relative alignment - , alignX, alignY + , alignX, snugX, alignY, snugY -- * Centering , centerX, centerY, centerXY + , snugCenterX, snugCenterY, snugCenterXY ) where -import Diagrams.Core - -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Align +import Diagrams.Core -import Data.VectorSpace +import Diagrams.Align +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. -alignL :: (Alignable a, V a ~ R2) => a -> a -alignL = align (negateV unitX) +alignL :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a +alignL = align unit_X +snugL :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugL = snug unit_X + -- | Align along the right edge. -alignR :: (Alignable a, V a ~ R2) => a -> a +alignR :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignR = align unitX +snugR :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugR = snug unitX + + -- | Align along the top edge. -alignT :: (Alignable a, V a ~ R2) => a -> a +alignT :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignT = align unitY +snugT:: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugT = snug unitY + -- | Align along the bottom edge. -alignB :: (Alignable a, V a ~ R2) => a -> a -alignB = align (negateV unitY) +alignB :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a +alignB = align unit_Y -alignTL, alignTR, alignBL, alignBR :: (Alignable a, V a ~ R2) => a -> a +snugB :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugB = snug unit_Y + +alignTL, alignTR, alignBL, alignBR :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR --- | @alignX@ moves the local origin horizontally as follows: +-- | @alignX@ and @snugX@ move the local origin horizontally as follows: -- --- * @alignX (-1)@ moves the local origin to the left edge of the envelope; +-- * @alignX (-1)@ moves the local origin to the left edge of the boundary; -- -- * @align 1@ moves the local origin to the right edge; -- -- * any other argument interpolates linearly between these. For -- example, @alignX 0@ centers, @alignX 2@ moves the origin one -- \"radius\" to the right of the right edge, and so on. -alignX :: (Alignable a, V a ~ R2) => Double -> a -> a +-- +-- * @snugX@ works the same way. + +alignX :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a alignX = alignBy unitX +-- | See the documentation for 'alignX'. +snugX :: (InSpace v n a, R1 v, Fractional n, Alignable a, Traced a, HasOrigin a) => n -> a -> a +snugX = snugBy unitX + -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, V a ~ R2) => Double -> a -> a +alignY :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a alignY = alignBy unitY +-- | See the documentation for 'alignY'. +snugY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => n -> a -> a +snugY = snugBy unitY + -- | Center the local origin along the X-axis. -centerX :: (Alignable a, V a ~ R2) => a -> a -centerX = alignBy unitX 0 +centerX :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerX = alignBy unitX 0 +snugCenterX :: (InSpace v n a, R1 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugCenterX = snugBy unitX 0 + -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, V a ~ R2) => a -> a -centerY = alignBy unitY 0 +centerY :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a +centerY = alignBy unitY 0 +snugCenterY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugCenterY = snugBy unitY 0 + -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, V a ~ R2) => a -> a +centerXY :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerXY = centerX . centerY + +snugCenterXY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a +snugCenterXY = snugCenterX . snugCenterY diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -1,5 +1,12 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -14,56 +21,63 @@ module Diagrams.TwoD.Arc ( arc , arc' - , arcCW , arcT + + , arcCCW + , arcCW + , bezierFromSweep , wedge + , arcBetween + , annularWedge ) where -import Diagrams.Coordinates +import Diagrams.Angle import Diagrams.Core +import Diagrams.Direction import Diagrams.Located (at) -import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unitX) -import Diagrams.Util (tau, ( # )) +import Diagrams.TwoD.Vector (e, unitX, unitY, unit_Y) +import Diagrams.Util (( # )) -import Data.Semigroup ((<>)) -import Data.VectorSpace (negateV, (*^), (^-^)) +import Control.Lens ((&), (<>~), (^.)) +import Data.Semigroup +import Linear.Affine +import Linear.Metric +import Linear.Vector + -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf -- | @bezierFromSweepQ1 s@ constructs a 'Cubic' segment that starts in --- the positive y direction and sweeps counterclockwise through @s@ --- radians. The approximation is only valid for angles in the first --- quadrant. -bezierFromSweepQ1 :: Rad -> Segment Closed R2 -bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 - where p0@(coords -> x :& y) = rotate (s/2) v - c1 = ((4-x)/3) & ((1-x)*(3-x)/(3*y)) - c2 = reflectY c1 - v = unitX +-- the positive y direction and sweeps counterclockwise through an +-- angle @s@. The approximation is only valid for angles in the +-- first quadrant. +bezierFromSweepQ1 :: Floating n => Angle n -> Segment Closed V2 n +bezierFromSweepQ1 s = mapSegmentVectors (^-^ unitX) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 + where p0@(V2 x y) = e (s ^/ 2) + c1 = V2 ((4-x)/3) ((1-x)*(3-x)/(3*y)) + c2 = reflectY c1 -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise --- through @s@ radians. If @s@ is negative, it will start in the +-- through the angle @s@. If @s@ is negative, it will start in the -- negative y direction and sweep clockwise. When @s@ is less than --- 0.0001 the empty list results. If the sweep is greater than tau --- then it is truncated to tau. -bezierFromSweep :: Rad -> [Segment Closed R2] +-- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ +-- later segments will overlap earlier segments. +bezierFromSweep :: OrderedField n => Angle n -> [Segment Closed V2 n] bezierFromSweep s - | s > tau = bezierFromSweep tau - | s < 0 = fmap reflectY . bezierFromSweep $ (-s) - | s < 0.0001 = [] - | s < tau/4 = [bezierFromSweepQ1 s] - | otherwise = bezierFromSweepQ1 (tau/4) - : map (rotateBy (1/4)) (bezierFromSweep (max (s - tau/4) 0)) + | s < zero = fmap reflectY . bezierFromSweep $ negated s + | s < 0.0001 @@ rad = [] + | s < fullTurn^/4 = [bezierFromSweepQ1 s] + | otherwise = bezierFromSweepQ1 (fullTurn^/4) + : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zero)) {- ~~~~ Note [segment spacing] @@ -85,54 +99,124 @@ the approximation error. -} --- | Given a start angle @s@ and an end angle @e@, @'arcT' s e@ is the --- 'Trail' of a radius one arc counterclockwise between the two angles. -arcT :: Angle a => a -> a -> Trail R2 -arcT start end - | e < s = arcT s (e + fromIntegral d) - | otherwise = (if sweep >= tau then glueTrail else id) - $ trailFromSegments bs - where sweep = convertAngle $ end - start - bs = map (rotate start) . bezierFromSweep $ sweep +-- | Given a start direction @d@ and a sweep angle @s@, @'arcT' d s@ +-- is the 'Trail' of a radius one arc starting at @d@ and sweeping out +-- the angle @s@ counterclockwise (for positive s). The resulting +-- @Trail@ is allowed to wrap around and overlap itself. +arcT :: OrderedField n => Direction V2 n -> Angle n -> Trail V2 n +arcT start sweep = trailFromSegments bs + where + bs = map (rotateTo start) . bezierFromSweep $ sweep - -- We want to compare the start and the end and in case - -- there isn't some law about 'Angle' ordering, we use a - -- known 'Angle' for that. - s = convertAngle start :: Turn - e = convertAngle end - d = ceiling (s - e) :: Integer +-- | Given a start direction @d@ and a sweep angle @s@, @'arc' d s@ is the +-- path of a radius one arc starting at @d@ and sweeping out the angle +-- @s@ counterclockwise (for positive s). The resulting +-- @Trail@ is allowed to wrap around and overlap itself. +arc :: (InSpace V2 n t, OrderedField n, TrailLike t) => Direction V2 n -> Angle n -> t +arc start sweep = trailLike $ arcT start sweep `at` P (fromDirection start) --- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the --- path of a radius one arc counterclockwise between the two angles. +-- | Given a radus @r@, a start direction @d@ and an angle @s@, +-- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at +-- @d@ and sweeping out the angle @s@ counterclockwise (for positive +-- s). The origin of the arc is its center. +-- +-- <> +-- +-- > arc'Ex = mconcat [ arc' r xDir (1/4 @@ turn) | r <- [0.5,-1,1.5] ] +-- > # centerXY # pad 1.1 +arc' :: (InSpace V2 n t, OrderedField n, TrailLike t) => n -> Direction V2 n -> Angle n -> t +arc' (abs -> r) start sweep = trailLike $ scale r ts `at` P (r *^ fromDirection start) + where ts = arcT start sweep + +arcCCWT :: RealFloat n => Direction V2 n -> Direction V2 n -> Trail V2 n +arcCCWT start end = trailFromSegments bs + where + bs = map (rotateTo start) . bezierFromSweep $ sweep + sweep = normalizeAngle $ end ^. _theta ^-^ start ^. _theta + +-- | Given a start direction @s@ and end direction @e@, @arcCCW s e@ is the +-- path of a radius one arc counterclockwise between the two directions. -- The origin of the arc is its center. -arc :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t -arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0)) +arcCCW :: (InSpace V2 n t, RealFloat n, TrailLike t) => Direction V2 n -> Direction V2 n -> t +arcCCW start end = trailLike $ arcCCWT start end `at` P (fromDirection start) --- | Like 'arc' but clockwise. -arcCW :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t +-- | Like 'arcAngleCCW' but clockwise. +arcCW :: (InSpace V2 n t, RealFloat n, TrailLike t) => Direction V2 n -> Direction V2 n -> t arcCW start end = trailLike $ - -- flipped arguments to get the path we want - -- then reverse the trail to get the cw direction. - (reverseTrail $ arcT end start) - `at` - (rotate start $ p2 (1,0)) - -- We could just have `arcCW = reversePath . flip arc` - -- but that wouldn't be `TrailLike`. - --- | Given a radus @r@, a start angle @s@ and an end angle @e@, --- @'arc'' r s e@ is the path of a radius @(abs r)@ arc between --- the two angles. If a negative radius is given, the arc will --- be clockwise, otherwise it will be counterclockwise. The origin --- of the arc is its center. -arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p -arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) - where ts | r < 0 = reverseTrail $ arcT end start - | otherwise = arcT start end + -- flipped arguments to get the path we want + -- then reverse the trail to get the cw direction. + reverseTrail (arcCCWT end start) `at` P (fromDirection start) -- | Create a circular wedge of the given radius, beginning at the --- first angle and extending counterclockwise to the second. -wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p -wedge r a1 a2 = trailLike . (`at` origin) . wrapLine - $ fromOffsets [r *^ e a1] - <> arc a1 a2 # scale r - <> fromOffsets [r *^ negateV (e a2)] +-- given direction and extending through the given angle. +-- +-- <> +-- +-- > wedgeEx = hcat' (with & sep .~ 0.5) +-- > [ wedge 1 xDir (1/4 @@ turn) +-- > , wedge 1 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) +-- > , wedge 1 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) +-- > ] +-- > # fc blue +-- > # centerXY # pad 1.1 +wedge :: (InSpace V2 n t, OrderedField n, TrailLike t) => n -> Direction V2 n -> Angle n -> t +wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine + $ fromOffsets [r *^ fromDirection d] + <> arc d s # scale r + <> fromOffsets [r *^ negated (rotate s $ fromDirection d)] + +-- | @arcBetween p q height@ creates an arc beginning at @p@ and +-- ending at @q@, with its midpoint at a distance of @abs height@ +-- away from the straight line from @p@ to @q@. A positive value of +-- @height@ results in an arc to the left of the line from @p@ to +-- @q@; a negative value yields one to the right. +-- +-- <> +-- +-- > arcBetweenEx = mconcat +-- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] +-- > # centerXY # pad 1.1 +arcBetween :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => Point V2 n -> Point V2 n -> n -> t +arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) + where + h = abs ht + isStraight = h < 0.00001 + v = q .-. p + d = norm (q .-. p) + th = acosA ((d*d - 4*h*h)/(d*d + 4*h*h)) + r = d/(2*sinA th) + mid | ht >= 0 = direction unitY + | otherwise = direction unit_Y + st = mid & _theta <>~ negated th + a | isStraight + = fromOffsets [d *^ unitX] + | otherwise + = arc st (2 *^ th) + # scale r + # translateY ((if ht > 0 then negate else id) (r - h)) + # translateX (d/2) + # (if ht > 0 then reverseLocTrail else id) + +-- | Create an annular wedge of the given radii, beginning at the +-- first direction and extending through the given sweep angle. +-- The radius of the outer circle is given first. +-- +-- <> +-- +-- > annularWedgeEx = hsep 0.50 +-- > [ annularWedge 1 0.5 xDir (1/4 @@ turn) +-- > , annularWedge 1 0.3 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) +-- > , annularWedge 1 0.7 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) +-- > ] +-- > # fc blue +-- > # centerXY # pad 1.1 +annularWedge :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => + n -> n -> Direction V2 n -> Angle n -> t +annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine + $ fromOffsets [(r1' - r2') *^ fromDirection d1] + <> arc d1 s # scale r1' + <> fromOffsets [(r1' - r2') *^ negated (fromDirection d2)] + <> arc d2 (negated s) # scale r2' + where o = origin # translate (r2' *^ fromDirection d1) + d2 = d1 & _theta <>~ s + diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Arrow.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Arrow +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Drawing arrows in two dimensions. For a tutorial on drawing arrows +-- using this module, see the diagrams website: +-- . +-- +----------------------------------------------------------------------------- + + +module Diagrams.TwoD.Arrow + ( -- * Examples + -- ** Example 1 +-- | <> +-- +-- > -- Connecting two diagrams at their origins. +-- > +-- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick +-- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right") +-- > +-- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)]) +-- > +-- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill +-- > & arrowShaft .~ shaft +-- > & headLength .~ huge & tailLength .~ veryLarge) +-- > "left" "right" # pad 1.1 + + -- ** Example 2 + +-- | <> +-- +-- > -- Comparing connect, connectPerim, and arrowAt. +-- > +-- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin +-- > dias = oct # named "first" ||| strut 3 ||| oct # named "second" +-- > +-- > -- Connect two diagrams and two points on their trails. +-- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second" +-- > # connectPerim' (with & lengths .~ veryLarge) +-- > "first" "second" (15/16 @@ turn) (9/16 @@ turn) +-- > +-- > -- Place an arrow at (0,0) the size and direction of (0,1). +-- > ex3 = arrowAt origin unit_Y +-- > +-- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 + + -- * Creating arrows + arrowV + , arrowV' + , arrowAt + , arrowAt' + , arrowBetween + , arrowBetween' + , connect + , connect' + , connectPerim + , connectPerim' + , connectOutside + , connectOutside' + + , arrow + , arrow' + + , arrowFromLocatedTrail + , arrowFromLocatedTrail' + + -- * Options + , ArrowOpts(..) + + , arrowHead + , arrowTail + , arrowShaft + , headGap + , tailGap + , gaps, gap + , headTexture + , headStyle + , headLength + , tailTexture + , tailStyle + , tailLength + , lengths + , shaftTexture + , shaftStyle + , straightShaft + + -- | See "Diagrams.TwoD.Arrowheads" for a list of standard + -- arrowheads and help creating your own. + , module Diagrams.TwoD.Arrowheads + ) where + +import Control.Lens (Lens', Traversal', + generateSignatures, lensRules, + makeLensesWith, view, (%~), (&), + (.~), (^.)) +import Data.Default +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup +import Data.Typeable + +import Data.Colour hiding (atop) +import Diagrams.Core +import Diagrams.Core.Style (unmeasureAttrs) +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') + +import Diagrams.Angle +import Diagrams.Attributes +import Diagrams.Direction hiding (dir) +import Diagrams.Located (Located (..), unLoc) +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Solve.Polynomial (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Trail +import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (reflectY, translateX) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X) +import Diagrams.Util (( # )) + +import Linear.Affine +import Linear.Metric +import Linear.Vector + + +data ArrowOpts n + = ArrowOpts + { _arrowHead :: ArrowHT n + , _arrowTail :: ArrowHT n + , _arrowShaft :: Trail V2 n + , _headGap :: Measure n + , _tailGap :: Measure n + , _headStyle :: Style V2 n + , _headLength :: Measure n + , _tailStyle :: Style V2 n + , _tailLength :: Measure n + , _shaftStyle :: Style V2 n + } + +-- | Straight line arrow shaft. +straightShaft :: OrderedField n => Trail V2 n +straightShaft = trailFromOffsets [unitX] + +instance TypeableFloat n => Default (ArrowOpts n) where + def = ArrowOpts + { _arrowHead = dart + , _arrowTail = noTail + , _arrowShaft = straightShaft + , _headGap = none + , _tailGap = none + + -- See note [Default arrow style attributes] + , _headStyle = mempty + , _headLength = normal + , _tailStyle = mempty + , _tailLength = normal + , _shaftStyle = mempty + } + +makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts + +-- | A shape to place at the head of the arrow. +arrowHead :: Lens' (ArrowOpts n) (ArrowHT n) + +-- | A shape to place at the tail of the arrow. +arrowTail :: Lens' (ArrowOpts n) (ArrowHT n) + +-- | The trail to use for the arrow shaft. +arrowShaft :: Lens' (ArrowOpts n) (Trail V2 n) + +-- | Distance to leave between the head and the target point. +headGap :: Lens' (ArrowOpts n) (Measure n) + +-- | Distance to leave between the starting point and the tail. +tailGap :: Lens' (ArrowOpts n) (Measure n) + +-- | Set both the @headGap@ and @tailGap@ simultaneously. +gaps :: Traversal' (ArrowOpts n) (Measure n) +gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) + <$> f (opts ^. headGap) + <*> f (opts ^. tailGap) + +-- | Same as gaps, provided for backward compatiiblity. +gap :: Traversal' (ArrowOpts n) (Measure n) +gap = gaps + +-- | Style to apply to the head. @headStyle@ is modified by using the lens +-- combinator @%~@ to change the current style. For example, to change +-- an opaque black arrowhead to translucent orange: +-- @(with & headStyle %~ fc orange . opacity 0.75)@. +headStyle :: Lens' (ArrowOpts n) (Style V2 n) + +-- | Style to apply to the tail. See `headStyle`. +tailStyle :: Lens' (ArrowOpts n) (Style V2 n) + +-- | Style to apply to the shaft. See `headStyle`. +shaftStyle :: Lens' (ArrowOpts n) (Style V2 n) + +-- | The length from the start of the joint to the tip of the head. +headLength :: Lens' (ArrowOpts n) (Measure n) + +-- | The length of the tail plus its joint. +tailLength :: Lens' (ArrowOpts n) (Measure n) + +-- | Set both the @headLength@ and @tailLength@ simultaneously. +lengths :: Traversal' (ArrowOpts n) (Measure n) +lengths f opts = + (\h t -> opts & headLength .~ h & tailLength .~ t) + <$> f (opts ^. headLength) + <*> f (opts ^. tailLength) + +-- | A lens for setting or modifying the texture of an arrowhead. For +-- example, one may write @... (with & headTexture .~ grad)@ to get an +-- arrow with a head filled with a gradient, assuming grad has been +-- defined. Or @... (with & headTexture .~ solid blue@ to set the head +-- color to blue. For more general control over the style of arrowheads, +-- see 'headStyle'. +headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +headTexture = headStyle . _fillTexture + +-- | A lens for setting or modifying the texture of an arrow +-- tail. This is *not* a valid lens (see 'committed'). +tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +tailTexture = tailStyle . _fillTexture + +-- | A lens for setting or modifying the texture of an arrow +-- shaft. +shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) +shaftTexture = shaftStyle . _lineTexture + +-- Set the default shaft style of an `ArrowOpts` record by applying the +-- default style after all other styles have been applied. +-- The semigroup stucture of the lw attribute will insure that the default +-- is only used if it has not been set in @opts@. +shaftSty :: ArrowOpts n -> Style V2 n +shaftSty opts = opts^.shaftStyle + +-- Set the default head style. See `shaftSty`. +headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n +headSty opts = fc black (opts^.headStyle) + +-- Set the default tail style. See `shaftSty`. +tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n +tailSty opts = fc black (opts^.tailStyle) + +-- | Calculate the length of the portion of the horizontal line that passes +-- through the origin and is inside of p. +xWidth :: Floating n => (Traced t, V t ~ V2, N t ~ n) => t -> n +xWidth p = a + b + where + a = fromMaybe 0 (norm <$> traceV origin unitX p) + b = fromMaybe 0 (norm <$> traceV origin unit_X p) + +-- | Get the line color from the shaft to use as the fill color for the joint. +-- And set the opacity of the shaft to the current opacity. +colorJoint :: TypeableFloat n => Style V2 n -> Style V2 n +colorJoint sStyle = + let c = fmap getLineTexture . getAttr $ sStyle + o = fmap getOpacity . getAttr $ sStyle + in + case (c, o) of + (Nothing, Nothing) -> fillColor black mempty + (Just t, Nothing) -> fillTexture t mempty + (Nothing, Just o') -> opacity o' . fillColor black $ mempty + (Just t, Just o') -> opacity o' . fillTexture t $ mempty + +-- | Get line width from a style. +widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n +widthOfJoint sStyle gToO nToO = + fromMaybe + (fromMeasured gToO nToO medium) -- should be same as default line width + (fmap getLineWidth . getAttr . unmeasureAttrs gToO nToO $ sStyle) + +-- | Combine the head and its joint into a single scale invariant diagram +-- and move the origin to the attachment point. Return the diagram +-- and its width. +mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkHead = mkHT unit_X arrowHead headSty + +mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => + n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkTail = mkHT unitX arrowTail tailSty + +mkHT + :: (TypeableFloat n, Renderable (Path V2 n) b) + => V2 n -> Lens' (ArrowOpts n) (ArrowHT n) -> (ArrowOpts n -> Style V2 n) + -> n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) +mkHT xDir htProj styProj sz opts gToO nToO reflect + = ( (j <> ht) + # (if reflect then reflectY else id) + # moveOriginBy (jWidth *^ xDir) # lwO 0 + , htWidth + jWidth + ) + where + (ht', j') = (opts^.htProj) sz + (widthOfJoint (shaftSty opts) gToO nToO) + htWidth = xWidth ht' + jWidth = xWidth j' + ht = stroke ht' # applyStyle (styProj opts) + j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) + +-- | @spine tr tw hw sz@ makes a trail with the same angles and offset +-- as an arrow with tail width @t@w, head width @hw@ and shaft @tr@, +-- such that the magnitude of the shaft offset is @sz@. Used for +-- calculating the offset of an arrow. +spine :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n +spine tr tw hw sz = tS <> tr # scale sz <> hS + where + tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw + hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw + hS = if hw > 0 then hSpine else mempty + tS = if tw > 0 then tSpine else mempty + +-- | @scaleFactor tr tw hw t@ calculates the amount required to scale +-- a shaft trail @tr@ so that an arrow with head width @hw@ and tail +-- width @tw@ has offset @t@. +scaleFactor :: TypeableFloat n => Trail V2 n -> n -> n -> n -> n +scaleFactor tr tw hw t + + -- Let tv be a vector representing the tail width, i.e. a vector + -- of length tw tangent to the trail's start; similarly for hv. + -- Let v be the vector offset of the trail. + -- + -- Then we want to find k such that + -- + -- || tv + k*v + hv || = t. + -- + -- We can solve by squaring both sides and expanding the LHS as a + -- dot product, resulting in a quadratic in k. + + = case quadForm + (quadrance v) + (2* (v `dot` (tv ^+^ hv))) + (quadrance (tv ^+^ hv) - t*t) + of + [] -> 1 -- no scale works, just return 1 + [s] -> s -- single solution + ss -> maximum ss + -- we will usually get both a positive and a negative solution; + -- return the maximum (i.e. positive) solution + where + tv = tw *^ (tangentAtStart tr # signorm) + hv = hw *^ (tangentAtEnd tr # signorm) + v = trailOffset tr + +-- Calculate the approximate envelope of a horizontal arrow +-- as if the arrow were made only of a shaft. +arrowEnv :: TypeableFloat n => ArrowOpts n -> n -> Envelope V2 n +arrowEnv opts len = getEnvelope horizShaft + where + horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) + m = norm v + v = trailOffset shaft + shaft = opts ^. arrowShaft + +-- | @arrow len@ creates an arrow of length @len@ with default +-- parameters, starting at the origin and ending at the point +-- @(len,0)@. +arrow :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> QDiagram b V2 n Any +arrow = arrow' def + +-- | @arrow' opts len@ creates an arrow of length @len@ using the +-- given options, starting at the origin and ending at the point +-- @(len,0)@. In particular, it scales the given 'arrowShaft' so +-- that the entire arrow has length @len@. +arrow' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> QDiagram b V2 n Any +arrow' opts len = mkQD' (DelayedLeaf delayedArrow) + + -- Currently we approximate the envelope of an arrow by using the + -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty. + (arrowEnv opts len) mempty mempty mempty + + where + + -- Once we learn the global transformation context (da) and the two scale + -- factors, normal to output (n) and global to output (g), this arrow is + -- drawn in, we can apply it to the origin and (len,0) to find out + -- the actual final points between which this arrow should be + -- drawn. We need to know this to draw it correctly, since the + -- head and tail are scale invariant, and hence the precise points + -- between which we need to draw the shaft do not transform + -- uniformly as the transformation applied to the entire arrow. + -- See https://github.com/diagrams/diagrams-lib/issues/112. + delayedArrow da g n = + let (trans, globalSty) = maybe mempty untangle . fst $ da + in dArrow globalSty trans len g n + + -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). + dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) + # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) + # rotate (((q .-. p)^._theta) ^-^ (dir^._theta)) + # moveTo p + where + + p = origin # transform tr + q = origin # translateX ln # transform tr + + -- Use the existing line color for head, tail, and shaft by + -- default (can be overridden by explicitly setting headStyle, + -- tailStyle, or shaftStyle). Also use existing global line width + -- for shaft if not explicitly set in shaftStyle. + globalLC = getLineTexture <$> getAttr sty + opts' = opts + & headStyle %~ maybe id fillTexture globalLC + & tailStyle %~ maybe id fillTexture globalLC + & shaftStyle %~ applyStyle sty . transform tr + + -- The head size, tail size, head gap, and tail gap are obtained + -- from the style and converted to output units. + scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr) + hSize = scaleFromMeasure $ opts ^. headLength + tSize = scaleFromMeasure $ opts ^. tailLength + hGap = scaleFromMeasure $ opts ^. headGap + tGap = scaleFromMeasure $ opts ^. tailGap + + -- Make the head and tail and save their widths. + (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr) + (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) + + rawShaftTrail = opts^.arrowShaft + shaftTrail + = rawShaftTrail + -- rotate it so it is pointing in the positive X direction + # rotate (negated . view _theta . trailOffset $ rawShaftTrail) + -- apply the context transformation -- in case it includes + -- things like flips and shears (the possibility of shears + -- is why we must rotate it to a neutral position first) + # transform tr + + -- Adjust the head width and tail width to take gaps into account + tWidth = tWidth' + tGap + hWidth = hWidth' + hGap + + -- Calculate the angles that the head and tail should point. + tAngle = tangentAtStart shaftTrail ^. _theta + hAngle = tangentAtEnd shaftTrail ^. _theta + + -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire + -- arrow will be of length len. Then apply it to the shaft and make the + -- shaft into a Diagram with using its style. + sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) + shaftTrail' = shaftTrail # scale sf + shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') + + -- Adjust the head and tail to point in the directions of the shaft ends. + h' = h # rotate hAngle + # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') + t' = t # rotate tAngle + + -- Find out what direction the arrow is pointing so we can set it back + -- to point in the direction unitX when we are done. + dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) + +-- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ +-- with default parameters. +arrowBetween :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> Point V2 n -> QDiagram b V2 n Any +arrowBetween = arrowBetween' def + +-- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to +-- @e@ using the given options. In particular, it scales and +-- rotates @arrowShaft@ to go between @s@ and @e@, taking head, +-- tail, and gaps into account. +arrowBetween' + :: (TypeableFloat n, Renderable (Path V2 n) b) => + ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any +arrowBetween' opts s e = arrowAt' opts s (e .-. s) + +-- | Create an arrow starting at s with length and direction determined by +-- the vector v. +arrowAt :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> QDiagram b V2 n Any +arrowAt = arrowAt' def + +arrowAt' + :: (TypeableFloat n, Renderable (Path V2 n) b) => + ArrowOpts n -> Point V2 n -> V2 n -> QDiagram b V2 n Any +arrowAt' opts s v = arrow' opts len + # rotate dir # moveTo s + where + len = norm v + dir = v ^. _theta + +-- | @arrowV v@ creates an arrow with the direction and norm of +-- the vector @v@ (with its tail at the origin), using default +-- parameters. +arrowV :: (TypeableFloat n, Renderable (Path V2 n) b) => V2 n -> QDiagram b V2 n Any +arrowV = arrowV' def + +-- | @arrowV' v@ creates an arrow with the direction and norm of +-- the vector @v@ (with its tail at the origin). +arrowV' + :: (TypeableFloat n, Renderable (Path V2 n) b) + => ArrowOpts n -> V2 n -> QDiagram b V2 n Any +arrowV' opts = arrowAt' opts origin + +-- | Turn a located trail into a default arrow by putting an +-- arrowhead at the end of the trail. +arrowFromLocatedTrail + :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) + => Located (Trail V2 n) -> QDiagram b V2 n Any +arrowFromLocatedTrail = arrowFromLocatedTrail' def + +-- | Turn a located trail into an arrow using the given options. +arrowFromLocatedTrail' + :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) + => ArrowOpts n -> Located (Trail V2 n) -> QDiagram b V2 n Any +arrowFromLocatedTrail' opts trail = arrowBetween' opts' start end + where + opts' = opts & arrowShaft .~ unLoc trail + start = atStart trail + end = atEnd trail + +-- | Connect two diagrams with a straight arrow. +connect + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connect = connect' def + +-- | Connect two diagrams with an arbitrary arrow. +connect' + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connect' opts n1 n2 = + withName n1 $ \sub1 -> + withName n2 $ \sub2 -> + let [s,e] = map location [sub1, sub2] + in atop (arrowBetween' opts s e) + +-- | Connect two diagrams at point on the perimeter of the diagrams, choosen +-- by angle. +connectPerim + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> Angle n -> Angle n + -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectPerim = connectPerim' def + +connectPerim' + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n + -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectPerim' opts n1 n2 a1 a2 = + withName n1 $ \sub1 -> + withName n2 $ \sub2 -> + let [os, oe] = map location [sub1, sub2] + s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1) + e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2) + in atop (arrowBetween' opts s e) + +-- | Draw an arrow from diagram named "n1" to diagram named "n2". The +-- arrow lies on the line between the centres of the diagrams, but is +-- drawn so that it stops at the boundaries of the diagrams, using traces +-- to find the intersection points. +connectOutside + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectOutside = connectOutside' def + +connectOutside' + :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) + => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any +connectOutside' opts n1 n2 = + withName n1 $ \b1 -> + withName n2 $ \b2 -> + let v = location b2 .-. location b1 + midpoint = location b1 .+^ (v ^/ 2) + s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1 + e' = fromMaybe (location b2) $ traceP midpoint v b2 + in + atop (arrowBetween' opts s' e') diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Arrowheads +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Standard arrowheads and tails. Each arrowhead or tail is designed +-- to be drawn filled, with a line width of 0, and is normalized to +-- fit inside a circle of diameter 1. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Arrowheads + ( + -- * Arrowheads + -- ** Standard arrowheads + tri + , dart + , halfDart + , spike + , thorn + , lineHead + , noHead + + -- ** Configurable arrowheads + -- | Creates arrowheads of the same shape as the standard heads but + -- where the angle parameter is used to specify the angle to the top + -- left point of the arrowhead. + , arrowheadTriangle + , arrowheadDart + , arrowheadHalfDart + , arrowheadSpike + , arrowheadThorn + + -- * Arrow tails + -- ** Standard arrow tails + , tri' + , dart' + , halfDart' + , spike' + , thorn' + , lineTail + , noTail + , quill + , block + + -- ** Configurable arrow tails + + , arrowtailQuill + , arrowtailBlock + + -- * Internals + , ArrowHT + ) where + +import Control.Lens ((&), (.~), (<>~), (^.)) +import Data.Default +import Data.Monoid (mempty, (<>)) + +import Diagrams.Angle +import Diagrams.Core + +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike (fromOffsets) +import Diagrams.TwoD.Align +import Diagrams.TwoD.Arc (arc') +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, unit_X, xDir) +import Diagrams.Util (( # )) + +import Linear.Affine +import Linear.Metric +import Linear.Vector + +----------------------------------------------------------------------------- + +type ArrowHT n = n -> n -> (Path V2 n, Path V2 n) + +closedPath :: OrderedField n => Trail V2 n -> Path V2 n +closedPath = pathFromTrail . closeTrail + +-- Heads ------------------------------------------------------------------ +-- > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw none +-- > & headLength .~ local 0.5) +-- > origin (r2 (1, 0)) +-- > <> square 0.5 # alignL # lw none # frame 0.1 + +-- | Isoceles triangle style. The above example specifies an angle of `2/5 Turn`. + +-- | <> + +-- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn) +-- > & shaftStyle %~ lw none & headLength .~ local 0.5) +-- > origin (r2 (0.5, 0)) +-- > <> square 0.6 # alignL # lw none # frame 0.1 +arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n +arrowheadTriangle theta = aHead + where + aHead len _ = (p, mempty) + where + psi = pi - (theta ^. rad) + r = len / (1 + cos psi) + p = polygon (def & polyType .~ PolyPolar [theta, (-2) *^ theta] + (repeat r) & polyOrient .~ NoOrient) # alignL + + +-- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. +arrowheadDart :: RealFloat n => Angle n -> ArrowHT n +arrowheadDart theta len shaftWidth = (hd # scale sz, jt) + where + hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] + v = rotate theta unitX + (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v) + [b1, b2] = map (reflectY . negated) [t1, t2] + psi = pi - negated t2 ^. _theta . rad + jLength = shaftWidth / (2 * tan psi) + + -- If the shaft is too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) + +-- | Top half of an 'arrowheadDart'. +arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n +arrowheadHalfDart theta len shaftWidth = (hd, jt) + where + hd = fromOffsets [t1, t2] + # closeTrail # pathFromTrail + # translateX 1.5 # scale sz + # translateY (-shaftWidth/2) + # snugL + jt = snugR . translateY (-shaftWidth/2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth] + v = rotate theta unitX + (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v) + psi = pi - negated t2 ^. _theta . rad + jLength = shaftWidth / tan psi + + -- If the shaft is too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) + +-- | Isoceles triangle with curved concave base. Inkscape type 2. +arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n +arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) + where + hd = snugL . closedPath $ l1 <> c <> l2 + jt = alignR . centerY . pathFromTrail + . closeTrail $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi) + l1 = trailFromSegments [straight $ unit_X ^+^ v] + l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)] + c = arc' 1 (rotate α xDir) ((-2) *^ α) + α = (1/2 @@ turn) ^-^ theta + v = rotate theta unitX + + -- The length of the head without its joint is, -2r cos theta and + -- the length of the joint is r - sqrt (r^2 - y^2). So the total + -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2). + -- Solving the quadratic gives two roots, we want the larger one. + + -- 1/4 turn < theta < 2/3 turn. + a = 1 - 2 * cos (theta ^. rad) + y = shaftWidth / 2 + + -- If the shaft is too wide for the head, we default the radius r to + -- 2/3 * len by setting d=1 and phi=pi/2. + d = max 1 (len**2 + (1 - a**2) * y**2) + r = (a * len + sqrt d) / (a**2 -1) + phi = asinA (min 1 (y/r)) + +-- | Curved sides, linear concave base. Illustrator CS5 #3 +arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n +arrowheadThorn theta len shaftWidth = (hd # scale sz, jt) + where + hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop + hTop = closeTrail . trailFromSegments $ [c, l] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] + c = curvedSide theta + v = rotate theta unitX + l = reverseSegment . straight $ t + t = v ^-^ V2 (-0.5) 0 + psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta) + jLength = shaftWidth / (2 * tanA psi) + + -- If the shaft if too wide, set the size to a default value of 1. + sz = max 1 ((len - jLength) / 1.5) + +-- | Make a side for the thorn head. +curvedSide :: Floating n => Angle n -> Segment Closed V2 n +curvedSide theta = bezier3 ctrl1 ctrl2 end + where + v0 = unit_X + v1 = rotate theta unitX + ctrl1 = v0 + ctrl2 = v0 ^+^ v1 + end = v0 ^+^ v1 + +-- Standard heads --------------------------------------------------------- +-- | A line the same width as the shaft. +lineHead :: RealFloat n => ArrowHT n +lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) + +noHead :: ArrowHT n +noHead _ _ = (mempty, mempty) + +-- | <> + +-- > triEx = drawHead tri +tri :: RealFloat n => ArrowHT n +tri = arrowheadTriangle (1/3 @@ turn) + +-- | <> + +-- > spikeEx = drawHead spike +spike :: RealFloat n => ArrowHT n +spike = arrowheadSpike (3/8 @@ turn) + +-- | <> + +-- > thornEx = drawHead thorn +thorn :: RealFloat n => ArrowHT n +thorn = arrowheadThorn (3/8 @@ turn) + +-- | <> + +-- > dartEx = drawHead dart +dart :: RealFloat n => ArrowHT n +dart = arrowheadDart (2/5 @@ turn) + +-- | <> + +-- > halfDartEx = drawHead halfDart +halfDart :: RealFloat n => ArrowHT n +halfDart = arrowheadHalfDart (2/5 @@ turn) + +-- Tails ------------------------------------------------------------------ +-- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none +-- > & arrowHead .~ noHead & tailLength .~ local 0.5) +-- > origin (r2 (1, 0)) +-- > <> square 0.5 # alignL # lw none # frame 0.1 + +-- | Utility function to convert any arrowhead to an arrowtail, i.e. +-- attached at the start of the trail. +headToTail :: OrderedField n => ArrowHT n -> ArrowHT n +headToTail hd = tl + where + tl sz shaftWidth = (t, j) + where + (t', j') = hd sz shaftWidth + t = reflectX t' + j = reflectX j' + +arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n +arrowtailBlock theta = aTail + where + aTail len _ = (t, mempty) + where + t = rect len (len * x) # alignR + a' :: V2 n + a' = rotate theta unitX + a = a' ^-^ reflectY a' + x = norm a + +-- | The angle is where the top left corner intersects the circle. +arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n +arrowtailQuill theta = aTail + where + aTail len shaftWidth = (t, j) + where + t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) + # scale sz # alignR + sz = len / 0.6 + v0 = p2 (0.5, 0) + v2 = origin .+^ (rotate theta unitX # scale 0.5) + v1 = v2 # translateX (5/8) + v3 = p2 (-0.1, 0) + v4 = v2 # reflectY + v5 = v4 # translateX (5/8) + s = 1 - shaftWidth / norm (v1 .-. v5) + n1 = v0 # translateY (0.5 * shaftWidth) + n2 = v1 .-^ ((v1 .-. v0) # scale s) + n3 = v5 .-^ ((v5 .-. v0) # scale s) + n4 = n1 # reflectY + j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] + +-- Standard tails --------------------------------------------------------- +-- | A line the same width as the shaft. +lineTail :: RealFloat n => ArrowHT n +lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) + +noTail :: ArrowHT n +noTail _ _ = (mempty, mempty) + +-- | <> + +-- > tri'Ex = drawTail tri' +tri' :: RealFloat n => ArrowHT n +tri' = headToTail tri + +-- | <> + +-- > spike'Ex = drawTail spike' +spike' :: RealFloat n => ArrowHT n +spike' = headToTail spike + +-- | <> + +-- > thorn'Ex = drawTail thorn' +thorn' :: RealFloat n => ArrowHT n +thorn' = headToTail thorn + +-- | <> + +-- > dart'Ex = drawTail dart' +dart' :: RealFloat n => ArrowHT n +dart' = headToTail dart + +-- | <> + +-- > halfDart'Ex = drawTail halfDart' +halfDart' :: RealFloat n => ArrowHT n +halfDart' = headToTail halfDart + +-- | <> + +-- > quillEx = drawTail quill +quill :: (Floating n, Ord n) => ArrowHT n +quill = arrowtailQuill (2/5 @@ turn) + +-- | <> + +-- > blockEx = drawTail block +block :: RealFloat n => ArrowHT n +block = arrowtailBlock (7/16 @@ turn) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Attributes.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Attributes +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines /Textures/ (Gradients and Colors) in two +-- dimensions. Like the attributes defined in the Diagrams.Attributes module, +-- all attributes defined here use the 'Last' or 'Recommend' /semigroup/ structure. +-- 'FillColor' and 'LineColor' attributes are provided so that backends that +-- don't support gradients need not be concerned with using textures. Backends +-- should only implement color attributes or textures attributes, not both. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Attributes ( + -- * Textures + Texture(..), solid, _SC, _AC, _LG, _RG, defaultLG, defaultRG + , GradientStop(..), stopColor, stopFraction, mkStops + , SpreadMethod(..), lineLGradient, lineRGradient + + -- ** Linear Gradients + , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd + , lGradSpreadMethod, mkLinearGradient + + -- ** Radial Gradients + , RGradient(..), rGradStops, rGradTrans + , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 + , rGradSpreadMethod, mkRadialGradient + + -- ** Line texture + , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA + , mkLineTexture, _lineTexture + + -- ** Line color + , lineColor, lc, lcA + + -- ** Fill texture + , FillTexture(..), _FillTexture, getFillTexture, fillTexture + , mkFillTexture, _fillTexture, _fillTextureR + + -- ** Fill color + , fillColor, fc, fcA, recommendFillColor + + -- * Compilation utilities + , splitTextureFills + + ) where + +import Control.Lens hiding (transform) +import Data.Colour hiding (AffineSpace, over) +import Data.Data +import Data.Default +import Data.Monoid.Recommend +import Data.Semigroup + +import Diagrams.Attributes +import Diagrams.Attributes.Compile +import Diagrams.Core +import Diagrams.Core.Types (RTree) +import Diagrams.Located (unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Trail (isLoop) +import Diagrams.TwoD.Types +import Diagrams.Util + + +----------------------------------------------------------------- +-- Gradients -------------------------------------------------- +----------------------------------------------------------------- + +-- | A gradient stop contains a color and fraction (usually between 0 and 1) +data GradientStop d = GradientStop + { _stopColor :: SomeColor + , _stopFraction :: d + } + +makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop + +-- | A color for the stop. +stopColor :: Lens' (GradientStop n) SomeColor + +-- | The fraction for stop. +stopFraction :: Lens' (GradientStop n) n + +-- | The 'SpreadMethod' determines what happens before 'lGradStart' and after +-- 'lGradEnd'. 'GradPad' fills the space before the start of the gradient +-- with the color of the first stop and the color after end of the gradient +-- with the color of the last stop. 'GradRepeat' restarts the gradient and +-- 'GradReflect' restarts the gradient with the stops in reverse order. +data SpreadMethod = GradPad | GradReflect | GradRepeat + +-- | Linear Gradient +data LGradient n = LGradient + { _lGradStops :: [GradientStop n] + , _lGradStart :: Point V2 n + , _lGradEnd :: Point V2 n + , _lGradTrans :: Transformation V2 n + , _lGradSpreadMethod :: SpreadMethod } + +type instance V (LGradient n) = V2 +type instance N (LGradient n) = n + +makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient + +instance Fractional n => Transformable (LGradient n) where + transform = over lGradTrans . transform + +-- | A list of stops (colors and fractions). +lGradStops :: Lens' (LGradient n) [GradientStop n] + +-- | A transformation to be applied to the gradient. Usually this field will +-- start as the identity transform and capture the transforms that are applied +-- to the gradient. +lGradTrans :: Lens' (LGradient n) (Transformation V2 n) + +-- | The starting point for the first gradient stop. The coordinates are in +-- 'local' units and the default is (-0.5, 0). +lGradStart :: Lens' (LGradient n) (Point V2 n) + +-- | The ending point for the last gradient stop.The coordinates are in +-- 'local' units and the default is (0.5, 0). +lGradEnd :: Lens' (LGradient n) (Point V2 n) + +-- | For setting the spread method. +lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod + +-- | Radial Gradient +data RGradient n = RGradient + { _rGradStops :: [GradientStop n] + , _rGradCenter0 :: Point V2 n + , _rGradRadius0 :: n + , _rGradCenter1 :: Point V2 n + , _rGradRadius1 :: n + , _rGradTrans :: Transformation V2 n + , _rGradSpreadMethod :: SpreadMethod } + +makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient + +type instance V (RGradient n) = V2 +type instance N (RGradient n) = n + +instance Fractional n => Transformable (RGradient n) where + transform = over rGradTrans . transform + +-- | A list of stops (colors and fractions). +rGradStops :: Lens' (RGradient n) [GradientStop n] + +-- | The center point of the inner circle. +rGradCenter0 :: Lens' (RGradient n) (Point V2 n) + +-- | The radius of the inner cirlce in 'local' coordinates. +rGradRadius0 :: Lens' (RGradient n) n + +-- | The center of the outer circle. +rGradCenter1 :: Lens' (RGradient n) (Point V2 n) + +-- | The radius of the outer circle in 'local' coordinates. +rGradRadius1 :: Lens' (RGradient n) n + +-- | A transformation to be applied to the gradient. Usually this field will +-- start as the identity transform and capture the transforms that are applied +-- to the gradient. +rGradTrans :: Lens' (RGradient n) (Transformation V2 n) + +-- | For setting the spread method. +rGradSpreadMethod :: Lens' (RGradient n) SpreadMethod + +----------------------------------------------------------------- +-- Textures --------------------------------------------------- +----------------------------------------------------------------- + +-- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'. +-- An object can have only one texture which is determined by the 'Last' +-- semigroup structure. +data Texture n = SC SomeColor | LG (LGradient n) | RG (RGradient n) + deriving Typeable + +type instance V (Texture n) = V2 +type instance N (Texture n) = n + +makePrisms ''Texture + +-- | Prism onto an 'AlphaColour' 'Double' of a 'SC' texture. +_AC :: Prism' (Texture n) (AlphaColour Double) +_AC = _SC . _SomeColor + +instance Floating n => Transformable (Texture n) where + transform t (LG lg) = LG $ transform t lg + transform t (RG rg) = RG $ transform t rg + transform _ sc = sc + +-- | Convert a solid colour into a texture. +solid :: Color a => a -> Texture n +solid = SC . SomeColor + +-- | A default is provided so that linear gradients can easily be created using +-- lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that +-- no default value is provided for @lGradStops@, this must be set before +-- the gradient value is used, otherwise the object will appear transparent. +defaultLG :: Fractional n => Texture n +defaultLG = LG LGradient + { _lGradStops = [] + , _lGradStart = mkP2 (-0.5) 0 + , _lGradEnd = mkP2 0.5 0 + , _lGradTrans = mempty + , _lGradSpreadMethod = GradPad + } + +-- | A default is provided so that radial gradients can easily be created using +-- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that +-- no default value is provided for @rGradStops@, this must be set before +-- the gradient value is used, otherwise the object will appear transparent. +defaultRG :: Fractional n => Texture n +defaultRG = RG RGradient + { _rGradStops = [] + , _rGradCenter0 = mkP2 0 0 + , _rGradRadius0 = 0.0 + , _rGradCenter1 = mkP2 0 0 + , _rGradRadius1 = 0.5 + , _rGradTrans = mempty + , _rGradSpreadMethod = GradPad + } + +-- | A convenient function for making gradient stops from a list of triples. +-- (An opaque color, a stop fraction, an opacity). +mkStops :: [(Colour Double, d, Double)] -> [GradientStop d] +mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) + +-- | Make a linear gradient texture from a stop list, start point, end point, +-- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity +-- transfrom, to change it use the 'lGradTrans' lens. +mkLinearGradient :: Num n => [GradientStop n] -> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n +mkLinearGradient stops start end spreadMethod + = LG (LGradient stops start end mempty spreadMethod) + +-- | Make a radial gradient texture from a stop list, radius, start point, +-- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity +-- transfrom, to change it use the 'rGradTrans' lens. +mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n + -> Point V2 n -> n -> SpreadMethod -> Texture n +mkRadialGradient stops c0 r0 c1 r1 spreadMethod + = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) + +-- Line Texture -------------------------------------------------------- + +-- | The texture with which lines are drawn. Note that child +-- textures always override parent textures. +-- More precisely, the semigroup structure on line texture attributes +-- is that of 'Last'. +newtype LineTexture n = LineTexture (Last (Texture n)) + deriving (Typeable, Semigroup) +instance (Typeable n) => AttributeClass (LineTexture n) + +type instance V (LineTexture n) = V2 +type instance N (LineTexture n) = n + +_LineTexture :: Iso (LineTexture n) (LineTexture n') + (Texture n) (Texture n') +_LineTexture = iso getLineTexture (LineTexture . Last) + +-- Only gradients get transformed. The transform is applied to the gradients +-- transform field. Colors are left unchanged. +instance Floating n => Transformable (LineTexture n) where + transform t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx) + +instance Default (LineTexture n) where + def = _LineTexture . _SC ## SomeColor black + +mkLineTexture :: Texture n -> LineTexture n +mkLineTexture = LineTexture . Last + +getLineTexture :: LineTexture n -> Texture n +getLineTexture (LineTexture (Last t)) = t + +lineTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a +lineTexture = applyTAttr . LineTexture . Last + +lineTextureA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LineTexture n -> a -> a +lineTextureA = applyTAttr + +_lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) +_lineTexture = atTAttr . anon def isDef . _LineTexture + where + isDef = anyOf (_LineTexture . _AC) (== opaque black) + +-- | Set the line (stroke) color. This function is polymorphic in the +-- color type (so it can be used with either 'Colour' or +-- 'AlphaColour'), but this can sometimes create problems for type +-- inference, so the 'lc' and 'lcA' variants are provided with more +-- concrete types. +lineColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a +lineColor = lineTexture . SC . SomeColor + +-- | A synonym for 'lineColor', specialized to @'Colour' Double@ +-- (i.e. opaque colors). See comment in 'lineColor' about backends. +lc :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Colour Double -> a -> a +lc = lineColor + +-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ +-- (i.e. colors with transparency). See comment in 'lineColor' +-- about backends. +lcA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => AlphaColour Double -> a -> a +lcA = lineColor + +-- | Apply a linear gradient. +lineLGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LGradient n -> a -> a +lineLGradient g = lineTexture (LG g) + +-- | Apply a radial gradient. +lineRGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => RGradient n -> a -> a +lineRGradient g = lineTexture (RG g) + +-- Fill Texture -------------------------------------------------------- + +-- | The texture with which objects are filled. +-- The semigroup structure on fill texture attributes +-- is that of 'Recommed . Last'. +newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) + deriving (Typeable, Semigroup) + +instance Typeable n => AttributeClass (FillTexture n) + +_FillTexture :: Iso' (FillTexture n) (Recommend (Texture n)) +_FillTexture = iso getter setter + where + getter (FillTexture (Recommend (Last t))) = Recommend t + getter (FillTexture (Commit (Last t))) = Commit t + setter (Recommend t) = FillTexture (Recommend (Last t)) + setter (Commit t) = FillTexture (Commit (Last t)) + -- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped + -- -- once we depend on monoid-extras-0.4 + +type instance V (FillTexture n) = V2 +type instance N (FillTexture n) = n + +-- Only gradients get transformed. The transform is applied to the gradients +-- transform field. Colors are left unchanged. +instance Floating n => Transformable (FillTexture n) where + transform = over (_FillTexture . _recommend) . transform + +instance Default (FillTexture n) where + def = mkFillTexture $ _AC ## transparent + +getFillTexture :: FillTexture n -> Texture n +getFillTexture (FillTexture tx) = getLast . getRecommend $ tx + +fillTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a +fillTexture = applyTAttr . mkFillTexture + +mkFillTexture :: Texture n -> FillTexture n +mkFillTexture = FillTexture . Commit . Last + +-- | Lens onto the 'Recommend' of a fill texture in a style. +_fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) +_fillTextureR = atTAttr . anon def isDef . _FillTexture + where + isDef = anyOf (_FillTexture . _Recommend . _AC) (== transparent) + +-- | Commit a fill texture in a style. This is /not/ a valid setter +-- because it doesn't abide the functor law (see 'committed'). +_fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) +_fillTexture = _fillTextureR . committed + +-- | Set the fill color. This function is polymorphic in the color +-- type (so it can be used with either 'Colour' or 'AlphaColour'), +-- but this can sometimes create problems for type inference, so the +-- 'fc' and 'fcA' variants are provided with more concrete types. +fillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a +fillColor = fillTexture . SC . SomeColor + +-- | Set a \"recommended\" fill color, to be used only if no explicit +-- calls to 'fillColor' (or 'fc', or 'fcA') are used. +-- See comment after 'fillColor' about backends. +recommendFillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a +recommendFillColor = + applyTAttr . FillTexture . Recommend . Last . SC . SomeColor + +-- | A synonym for 'fillColor', specialized to @'Colour' Double@ +-- (i.e. opaque colors). See comment after 'fillColor' about backends. +fc :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => Colour Double -> a -> a +fc = fillColor + +-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ +-- (i.e. colors with transparency). See comment after 'fillColor' about backends. +fcA :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => AlphaColour Double -> a -> a +fcA = fillColor + +-- Split fills --------------------------------------------------------- + +data FillTextureLoops n = FillTextureLoops + +instance Typeable n => SplitAttribute (FillTextureLoops n) where + type AttrType (FillTextureLoops n) = FillTexture n + type PrimType (FillTextureLoops n) = Path V2 n + + primOK _ = all (isLoop . unLoc) . pathTrails + +-- | Push fill attributes down until they are at the root of subtrees +-- containing only loops. This makes life much easier for backends, +-- which typically have a semantics where fill attributes are +-- applied to lines/non-closed paths as well as loops/closed paths, +-- whereas in the semantics of diagrams, fill attributes only apply +-- to loops. +splitTextureFills + :: forall b v n a. ( + Typeable n) => RTree b v n a -> RTree b v n a +splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -18,11 +23,11 @@ ( -- * Binary combinators - (===), (|||), atAngle + (===), (|||) -- * n-ary combinators - , hcat, hcat' - , vcat, vcat' + , hcat, hcat', hsep + , vcat, vcat', vsep -- * Spacing/envelopes , strutR2 @@ -31,36 +36,38 @@ , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , view + , rectEnvelope, crop - , boundingRect, bg + , boundingRect, bg, bgFrame ) where -import Data.AffineSpace +import Control.Lens ((&), (.~)) import Data.Colour -import Data.Default.Class +import Data.Default import Data.Semigroup -import Data.VectorSpace import Diagrams.Core -import Diagrams.Attributes (fc, lw) +import Diagrams.Attributes (lwO) import Diagrams.BoundingBox import Diagrams.Combinators -import Diagrams.Coordinates import Diagrams.Path +import Diagrams.Query (value) import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Path () -import Diagrams.TwoD.Segment +import Diagrams.TwoD.Attributes (fc) +import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Transform (scaleX, scaleY) +import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) -import Diagrams.Util (( # )) +import Diagrams.TwoD.Vector +import Diagrams.Util (( # )) +import Linear.Affine +import Linear.Metric +import Linear.Vector infixl 6 === infixl 6 ||| @@ -79,26 +86,18 @@ -- combined diagram is the same as the local origin of the first. -- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a -(===) = beside (negateV unitY) +(===) :: (InSpace V2 n a, Juxtaposable a, Semigroup a) => a -> a -> a +(===) = beside unit_Y -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of -- the second. The local origin of the resulting combined diagram --- is the same as the local origin of the first. @(===)@ is +-- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. -(|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a +(|||) :: (InSpace V2 n a, Juxtaposable a, Semigroup a) => a -> a -> a (|||) = beside unitX --- | Place two diagrams (or other juxtaposable objects) adjacent to one --- another, with the second diagram placed along a line at angle --- 'th' from the first. The local origin of the resulting combined --- diagram is the same as the local origin of the first. --- See the documentation of 'beside' for more information. -atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a, Angle b) => b -> a -> a -> a -atAngle th = beside (fromDirection th) - -- | Lay out a list of juxtaposable objects in a row from left to right, -- so that their local origins lie along a single horizontal line, -- with successive envelopes tangent to one another. @@ -110,17 +109,24 @@ -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. -hcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +hcat :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a hcat = hcat' def -- | A variant of 'hcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of --- the possibilities. -hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => CatOpts R2 -> [a] -> a +-- the possibilities. For the common case of setting just a +-- separation amount, see 'hsep'. +hcat' :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) + => CatOpts n -> [a] -> a hcat' = cat' unitX +-- | A convenient synonym for horizontal concatenation with +-- separation: @hsep s === hcat' (with & sep .~ s)@. +hsep :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) + => n -> [a] -> a +hsep s = hcat' (def & sep .~ s) + -- | Lay out a list of juxtaposable objects in a column from top to -- bottom, so that their local origins lie along a single vertical -- line, with successive envelopes tangent to one another. @@ -132,24 +138,31 @@ -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. -vcat :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) +vcat :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a vcat = vcat' def -- | A variant of 'vcat' taking an extra 'CatOpts' record to control --- the spacing. See the 'cat'' documentation for a description of the --- possibilities. -vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) - => CatOpts R2 -> [a] -> a -vcat' = cat' (negateV unitY) +-- the spacing. See the 'cat'' documentation for a description of +-- the possibilities. For the common case of setting just a +-- separation amount, see 'vsep'. +vcat' :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) + => CatOpts n -> [a] -> a +vcat' = cat' unit_Y +-- | A convenient synonym for vertical concatenation with +-- separation: @vsep s === vcat' (with & sep .~ s)@. +vsep :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) + => n -> [a] -> a +vsep s = vcat' (def & sep .~ s) + -- | @strutR2 v@ is a two-dimensional diagram which produces no -- output, but with respect to alignment, envelope, /and trace/ acts -- like a 1-dimensional segment oriented along the vector @v@, with -- local origin at its center. If you don't care about the trace -- then there's no difference between @strutR2@ and the more general -- 'strut'. -strutR2 :: (Backend b R2, Monoid' m) => R2 -> QDiagram b R2 m +strutR2 :: (RealFloat n, Monoid' m) => V2 n -> QDiagram b V2 n m strutR2 v = phantom seg where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) @@ -157,14 +170,14 @@ -- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. -strutX :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m -strutX d = strut (d & 0) +strutX :: (Metric v, R1 v, OrderedField n) => n -> QDiagram b v n m +strutX d = strut (zero & _x .~ d) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. -strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m -strutY d = strut (0 & d) +strutY :: (Metric v, R2 v, OrderedField n) => n -> QDiagram b v n m +strutY d = strut (zero & _y .~ d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its -- envelope horizontally by a factor of @s@ (factors between 0 and 1 @@ -173,8 +186,8 @@ -- centered horizontally the padding may appear \"uneven\". If this -- is not desired, the origin can be centered (using 'centerX') -- before applying @padX@. -padX :: ( Backend b R2, Monoid' m ) - => Double -> QDiagram b R2 m -> QDiagram b R2 m +padX :: (Metric v, R2 v, OrderedField n, Monoid' m) + => n -> QDiagram b v n m -> QDiagram b v n m padX s d = withEnvelope (d # scaleX s) d -- | @padY s@ \"pads\" a diagram in the y-direction, expanding its @@ -184,8 +197,8 @@ -- so if the origin is not centered vertically the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using 'centerY') before applying @padY@. -padY :: ( Backend b R2, Monoid' m ) - => Double -> QDiagram b R2 m -> QDiagram b R2 m +padY :: (Metric v, R2 v, Monoid' m, OrderedField n) + => n -> QDiagram b v n m -> QDiagram b v n m padY s d = withEnvelope (d # scaleY s) d -- | @extrudeLeft s@ \"extrudes\" a diagram in the negative x-direction, @@ -193,6 +206,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeLeft :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s @@ -202,6 +216,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeRight :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -211,6 +226,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeBottom :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s @@ -220,28 +236,44 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeTop :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s --- | @view p v@ sets the envelope of a diagram to a rectangle whose +-- | @rectEnvelope p v@ sets the envelope of a diagram to a rectangle whose -- lower-left corner is at @p@ and whose upper-right corner is at @p -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. -view :: ( Backend b R2, Monoid' m ) - => P2 -> R2 -> QDiagram b R2 m -> QDiagram b R2 m -view p (coords -> w :& h) = withEnvelope (rect w h # alignBL # moveTo p :: D R2) +rectEnvelope :: forall b n m. (OrderedField n, Monoid' m) + => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m +rectEnvelope p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: Path V2 n) +-- | A synonym for 'rectEnvelope'. +crop :: forall b n m. (OrderedField n, Monoid' m) + => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m +crop = rectEnvelope + -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. -boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ R2 - , Enveloped a, V a ~ R2 - ) +boundingRect :: ( InSpace V2 n a, SameSpace a t + , Enveloped t, Transformable t, TrailLike t, Monoid t + , Enveloped a) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (Renderable (Path R2) b) => Colour Double -> Diagram b R2 -> Diagram b R2 -bg c d = d <> boundingRect d # lw 0 # fc c +-- The background does not change the result of queries. +bg :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' q) + => Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q +bg c d = d <> boundingRect d # lwO 0 # fc c # value mempty + +-- | Similar to 'bg' but makes the colored background rectangle larger than +-- the diagram. The first parameter is used to set how far the background +-- extends beyond the diagram. +-- The background does not change the result of queries. +bgFrame :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' q) + => n -> Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q +bgFrame f c d = d <> boundingRect (frame f d) # lwO 0 # fc c # value mempty diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -19,19 +19,16 @@ , squaredRadiusOfCurvature ) where -import Data.AffineSpace +import Control.Lens (over) +import Control.Monad import Data.Monoid.Inf -import Data.VectorSpace -import Control.Arrow (first, second) -import Control.Monad (join) - -import Diagrams.Core - import Diagrams.Segment +import Diagrams.Tangent import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector +import Linear.Vector + -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car -- along the curve. When the wheel is held straight there is zero curvature. @@ -51,19 +48,19 @@ -- -- Lets consider the following curve: -- --- <> +-- <> -- -- The curve starts with positive curvature, -- --- <> +-- <> -- -- approaches zero curvature -- --- <> +-- <> -- -- then has negative curvature -- --- <> +-- <> -- -- > {-# LANGUAGE GADTs #-} -- > @@ -71,70 +68,72 @@ -- > import Data.Monoid.Inf -- > import Diagrams.Coordinates -- > --- > segmentA = Cubic (12 & 0) (8 & 10) (OffsetClosed (20 & 8)) +-- > segmentA :: Segment Closed V2 Double +-- > segmentA = Cubic (12 ^& 0) (8 ^& 10) (OffsetClosed (20 ^& 8)) -- > --- > curveA = lw 0.1 . stroke . fromSegments $ [segmentA] +-- > curveA = lw thick . strokeP . fromSegments $ [segmentA] -- > -- > diagramA = pad 1.1 . centerXY $ curveA -- > -- > diagramPos = diagramWithRadius 0.2 -- > --- > diagramZero = diagramWithRadius 0.5 +-- > diagramZero = diagramWithRadius 0.45 -- > -- > diagramNeg = diagramWithRadius 0.8 -- > -- > diagramWithRadius t = pad 1.1 . centerXY -- > $ curveA -- > <> showCurvature segmentA t --- > # withEnvelope (curveA :: D R2) --- > # lw 0.05 # lc red +-- > # withEnvelope (curveA :: D V2 Double) +-- > # lc red -- > +-- > showCurvature :: Segment Closed V2 Double -> Double -> Diagram SVG -- > showCurvature bez@(Cubic b c (OffsetClosed d)) t --- > | v == 0 = mempty --- > | otherwise = go (radiusOfCurvature bez t) +-- > | v == (0,0) = mempty +-- > | otherwise = go (radiusOfCurvature bez t) -- > where -- > v@(x,y) = unr2 $ firstDerivative b c d t --- > vp = (-y) & x +-- > vp = (-y) ^& x -- > -- > firstDerivative b c d t = let tt = t*t in (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d -- > -- > go Infinity = mempty -- > go (Finite r) = (circle (abs r) # translate vpr --- > <> stroke (origin ~~ (origin .+^ vpr))) +-- > <> strokeP (origin ~~ (origin .+^ vpr))) -- > # moveTo (origin .+^ atParam bez t) -- > where --- > vpr = r2 (normalized vp ^* r) +-- > vpr = signorm vp ^* r -- > -- -curvature :: Segment Closed R2 -- ^ Segment to measure on. - -> Double -- ^ Parameter to measure at. - -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite curvature or zero radius of curvature. -curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 +curvature :: RealFloat n + => Segment Closed V2 n -- ^ Segment to measure on. + -> n -- ^ Parameter to measure at. + -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite curvature or zero radius of curvature. +curvature s = toPosInf . over _y sqrt . curvaturePair s -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. -squaredCurvature :: Segment Closed R2 -> Double -> PosInf Double -squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 - +squaredCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n +squaredCurvature s = toPosInf . over _x (join (*)) . curvaturePair s -- | Reciprocal of @curvature@. -radiusOfCurvature :: Segment Closed R2 -- ^ Segment to measure on. - -> Double -- ^ Parameter to measure at. - -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents - -- infinite radius of curvature or zero curvature. -radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) +radiusOfCurvature :: RealFloat n + => Segment Closed V2 n -- ^ Segment to measure on. + -> n -- ^ Parameter to measure at. + -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents + -- infinite radius of curvature or zero curvature. +radiusOfCurvature s = toPosInf . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s -- | Reciprocal of @squaredCurvature@ -squaredRadiusOfCurvature :: Segment Closed R2 -> Double -> PosInf Double -squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) - +squaredRadiusOfCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n +squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (p * p))) . curvaturePair s -- Package up problematic values with the appropriate infinity. -toPosInf :: RealFloat a => (a,a) -> PosInf a -toPosInf (_,0) = Infinity -toPosInf (p,q) +toPosInf :: RealFloat a => V2 a -> PosInf a +toPosInf (V2 _ 0) = Infinity +toPosInf (V2 p q) | isInfinite r || isNaN r = Infinity | otherwise = Finite r where r = p / q @@ -142,22 +141,26 @@ -- Internal function that is not quite curvature or squaredCurvature but lets -- us get there by either taking the square root of the numerator or squaring -- the denominator respectively. -curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) - => Segment Closed (t, t) -> Scalar t -> (t, t) -curvaturePair (Linear _) t = (0,1) -- Linear segments always have zero curvature (infinite radius). -curvaturePair (Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) +curvaturePair :: Num n + => Segment Closed V2 n -> n -> V2 n +curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). +curvaturePair seg@(Cubic b c (OffsetClosed d)) t + = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Int)) where - (x' ,y' ) = firstDerivative b c d t -- TODO: Use the generalized unr2 - (x'',y'') = secondDerivative b c d t - - firstDerivative b c d t = (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d - where - tt = t * t - - secondDerivative b c d t = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d + (V2 x' y' ) = seg `tangentAtParam` t + (V2 x'' y'') = secondDerivative + secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d -- TODO: We should be able to generalize this to higher dimensions. See -- -- -- TODO: I'm not sure what the best way to generalize squaredCurvature to other spaces is. +-- curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) +-- => Segment Closed (t, t) -> Scalar t -> (t, t) +-- curvaturePair (Linear _) _ = (0,1) -- Linear segments always have zero curvature (infinite radius). +-- curvaturePair seg@(Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) +-- where +-- (x' ,y' ) = seg `tangentAtParam` t +-- (x'',y'') = secondDerivative +-- secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Deform.hs @@ -0,0 +1,41 @@ +module Diagrams.TwoD.Deform where + +import Control.Lens + +import Diagrams.Deform + +import Linear.V2 +import Linear.Vector + +-- | The parallel projection onto the plane x=0 +parallelX0 :: (R1 v, Num n) => Deformation v v n +parallelX0 = Deformation (_x .~ 0) + +-- | The perspective division onto the plane x=1 along lines going +-- through the origin. +perspectiveX1 :: (R1 v, Functor v, Fractional n) => Deformation v v n +perspectiveX1 = Deformation $ \p -> p ^/ (p ^. _x) + +-- | The parallel projection onto the plane y=0 +parallelY0 :: (R2 v, Num n) => Deformation v v n +parallelY0 = Deformation (_y .~ 0) + +-- | The perspective division onto the plane y=1 along lines going +-- through the origin. +perspectiveY1 :: (R2 v, Functor v, Floating n) => Deformation v v n +perspectiveY1 = Deformation $ \p -> p ^/ (p ^. _y) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asDeformation (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: (R1 v, Functor v, Fractional n) => Deformation v v n +facingX = Deformation $ + \p -> let x = p ^. _x + in p ^/ x & _x .~ x + +facingY :: (R2 v, Functor v, Fractional n) => Deformation v v n +facingY = Deformation $ + \p -> let y = p ^. _y + in p ^/ y & _y .~ y + diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | @@ -24,27 +25,29 @@ import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) -import Diagrams.Path +import Diagrams.Trail (glueTrail) import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. -unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ arcT 0 (tau::Rad) `at` (p2 (1,0)) +unitCircle :: (TrailLike t, V t ~ V2, N t ~ n) => t +unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). -circle :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t +circle :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). -ellipse :: (TrailLike t, V t ~ R2, Transformable t) => Double -> t +ellipse :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." @@ -52,5 +55,5 @@ -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. -ellipseXY :: (TrailLike t, V t ~ R2, Transformable t) => Double -> Double -> t +ellipseXY :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> n -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,7 +1,12 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , MultiParamTypeClasses - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Image @@ -9,73 +14,155 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Importing external images into diagrams. --- +-- Importing external images into diagrams. Usage example: To create +-- a diagram from an embedded image with width 1 and height set +-- according to the aspect ratio, use @image img # scaleUToX 1@, where +-- @img@ is a value of type @DImage n e@, created with a function like +-- 'loadImageEmb', 'loadImageExt', or 'raster'. ----------------------------------------------------------------------------- module Diagrams.TwoD.Image ( - Image(..) + DImage(..), ImageData(..) + , Embedded, External, Native , image + , embeddedImage + , loadImageEmb + , loadImageEmbBS + , loadImageExt + , uncheckedImageRef + , raster + , rasterDia ) where -import Diagrams.Core +import Codec.Picture -import Diagrams.Path -import Diagrams.TwoD.Types -import Diagrams.TwoD.Path -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Size (SizeSpec2D(..)) +import Data.Colour (AlphaColour) +import Data.Kind (Type) +import Data.Semigroup +import Data.Typeable (Typeable) -import Data.AffineSpace ((.-.)) +import Diagrams.Core -import Data.Semigroup +import Diagrams.Attributes (colorToSRGBA) +import Diagrams.Path (Path) +import Diagrams.Query +import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.TwoD.Shapes (rect) +import Diagrams.TwoD.Types --- | An external image primitive, representing an image the backend --- should import from another file when rendering. -data Image = Image { imgFile :: FilePath - , imgSize :: SizeSpec2D - , imgTransf :: T2 - } +import Data.ByteString -type instance V Image = R2 +import Linear.Affine -instance Transformable Image where - transform t1 (Image file sz t2) = Image file sz (t1 <> t2) +data Embedded deriving Typeable +data External deriving Typeable +data Native (t :: Type) deriving Typeable -instance IsPrim Image +-- | 'ImageData' is either a JuicyPixels @DynamicImage@ tagged as 'Embedded' or +-- a reference tagged as 'External'. Additionally 'Native' is provided for +-- external libraries to hook into. +data ImageData :: Type -> Type where + ImageRaster :: DynamicImage -> ImageData Embedded + ImageRef :: FilePath -> ImageData External + ImageNative :: t -> ImageData (Native t) -instance HasOrigin Image where +------------------------------------------------------------------------------- +-- | An image primitive, the two ints are width followed by height. +-- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, +-- will handle setting the width and height to the actual width and height +-- of the image. +data DImage :: Type -> Type -> Type where + DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t + deriving Typeable + +type instance V (DImage n a) = V2 +type instance N (DImage n a) = n + +instance RealFloat n => HasQuery (DImage n a) Any where + getQuery (DImage _ w h _) = -- transform t $ + Query $ \p -> Any (isInsideEvenOdd r p) + where + r = rectPath (fromIntegral w) (fromIntegral h) + +instance Fractional n => Transformable (DImage n a) where + transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) + +instance Fractional n => HasOrigin (DImage n a) where moveOriginTo p = translate (origin .-. p) -instance Renderable Image NullBackend where - render _ _ = mempty +-- | Make a 'DImage' into a 'Diagram'. +image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b) + => DImage n a -> QDiagram b V2 n Any +image img + = mkQD (Prim img) + (getEnvelope r) + (getTrace r) + mempty + (Query $ \p -> Any (isInsideEvenOdd r p)) + where + r = rectPath (fromIntegral w) (fromIntegral h) + -- should we use the transform here? + DImage _ w h _ = img --- See Note [Image size specification] +rectPath :: RealFloat n => n -> n -> Path V2 n +rectPath = rect --- | Take an external image from the specified file and turn it into a --- diagram with the specified width and height, centered at the --- origin. Note that the image's aspect ratio will be preserved; if --- the specified width and height have a different ratio than the --- image's aspect ratio, there will be extra space in one dimension. -image :: (Renderable Image b) => FilePath -> Double -> Double -> Diagram b R2 -image file w h = mkQD (Prim (Image file (Dims w h) mempty)) - (getEnvelope r) - (getTrace r) - mempty - (Query $ \p -> Any (isInsideEvenOdd p r)) - where r :: Path R2 - r = rect w h +-- | Read a JuicyPixels @DynamicImage@ and wrap it in a 'DImage'. +-- The width and height of the image are set to their actual values. +embeddedImage :: Num n => DynamicImage -> DImage n Embedded +embeddedImage img = DImage (ImageRaster img) w h mempty + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img -{- ~~~~ Note [Image size specification] +-- | Use JuicyPixels to read a file in any format and wrap it in a 'DImage'. +-- The width and height of the image are set to their actual values. +loadImageEmb :: Num n => FilePath -> IO (Either String (DImage n Embedded)) +loadImageEmb path = fmap embeddedImage `fmap` readImage path -It's tempting to make 'image' take a SizeSpec2D instead of two -Doubles. For example, if I know I want the image to be x units wide -but I don't know the original aspect ratio of the image, I'd like to -be able to just say "make it x units wide". The problem is that -diagrams would then not know how tall the image is until rendering -time (at least, not without unsafePerformIO yuckiness). A more -general solution will have to wait until we can specify constraints -and solve them later. +-- | A pure variant of 'loadImageEmb' +loadImageEmbBS :: Num n => ByteString -> Either String (DImage n Embedded) +loadImageEmbBS bs = embeddedImage `fmap` decodeImage bs --} +-- | Check that a file exists, and use JuicyPixels to figure out +-- the right size, but save a reference to the image instead +-- of the raster data +loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External)) +loadImageExt path = do + dImg <- readImage path + return $ case dImg of + Left msg -> Left msg + Right img -> Right $ DImage (ImageRef path) w h mempty + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img + +-- | Make an "unchecked" image reference; have to specify a +-- width and height. Unless the aspect ratio of the external +-- image is the w :: h, then the image will be distorted. +uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External +uncheckedImageRef path w h = DImage (ImageRef path) w h mempty + +-- | Crate a diagram from raw raster data. +rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b) + => (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any +rasterDia f w h = image $ raster f w h + +-- | Create an image "from scratch" by specifying the pixel data +raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded +raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty + where + img = generateImage g w h + g x y = fromAlphaColour $ f x y + +fromAlphaColour :: AlphaColour Double -> PixelRGBA8 +fromAlphaColour c = PixelRGBA8 r g b a + where + (r, g, b, a) = (int r', int g', int b', int a') + (r', g', b', a') = colorToSRGBA c + int x = round (255 * x) + +instance Fractional n => (Renderable (DImage n a) NullBackend) where + render _ _ = mempty + diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -8,80 +11,163 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Tools for visualizing diagrams' internal model: local origins, --- envelopes, /etc./ +-- envelopes, traces, /etc./ -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Model ( -- * Showing the local origin showOrigin , showOrigin' - , OriginOpts(..) + , OriginOpts(..), oColor, oScale, oMinSize + + -- * Showing an approximation of the envelope + , showEnvelope + , showEnvelope' + , EnvelopeOpts(..), eColor, eLineWidth, ePoints + + -- * Showing an approximation of the trace + , showTrace + , showTrace' + , TraceOpts(..), tColor, tScale, tMinSize, tPoints + + -- * Showing labels of all named subdiagrams , showLabels ) where +import Control.Arrow (second) +import Control.Lens (makeLenses, (^.)) +import Data.Colour (Colour) +import Data.Colour.Names +import Data.Default +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Semigroup + +import Diagrams.Attributes +import Diagrams.Combinators (atPoints) import Diagrams.Core import Diagrams.Core.Names - +import Diagrams.CubicSpline import Diagrams.Path - -import Diagrams.Attributes +import Diagrams.TwoD.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path -import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text +import Diagrams.TwoD.Transform (rotateBy) import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX) import Diagrams.Util -import Control.Arrow (second) -import Data.AffineSpace ((.-.)) -import Data.Default.Class -import Data.Semigroup -import Data.VectorSpace ((^*)) - -import qualified Data.Map as M - -import Data.Colour (Colour) -import Data.Colour.Names +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ +data OriginOpts n = OriginOpts + { _oColor :: Colour Double + , _oScale :: n + , _oMinSize :: n + } + +makeLenses ''OriginOpts + +instance Fractional n => Default (OriginOpts n) where + def = OriginOpts red (1/50) 0.001 + +data EnvelopeOpts n = EnvelopeOpts + { _eColor :: Colour Double + , _eLineWidth :: Measure n + , _ePoints :: Int + } + +makeLenses ''EnvelopeOpts + +instance OrderedField n => Default (EnvelopeOpts n) where + def = EnvelopeOpts red medium 32 + +data TraceOpts n = TraceOpts + { _tColor :: Colour Double + , _tScale :: n + , _tMinSize :: n + , _tPoints :: Int + } + +makeLenses ''TraceOpts + +instance Floating n => Default (TraceOpts n) where + def = TraceOpts red (1/100) 0.001 64 + -- | Mark the origin of a diagram by placing a red dot 1/50th its size. -showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m) - => QDiagram b R2 m -> QDiagram b R2 m +showOrigin :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) + => QDiagram b V2 n m -> QDiagram b V2 n m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. -showOrigin' :: (Renderable (Path R2) b, Backend b R2, Monoid' m) - => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m +showOrigin' :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) + => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d - where o = stroke (circle sz) - # fc (oColor oo) - # lw 0 - # fmap (const mempty) - (w,h) = size2D d ^* oScale oo - sz = maximum [w, h, oMinSize oo] + where o = strokeP (circle sz) + # fc (oo^.oColor) + # lw none + # fmap (const mempty) + V2 w h = oo^.oScale *^ size d + sz = maximum [w, h, oo^.oMinSize] -data OriginOpts = OriginOpts { oColor :: Colour Double - , oScale :: Double - , oMinSize :: Double - } +-- | Mark the envelope with an approximating cubic spline with control +-- over the color, line width and number of points. +showEnvelope' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) + => EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +showEnvelope' opts d = cubicSpline True pts # lc (opts^.eColor) + # lw w <> d + where + pts = catMaybes [envelopePMay v d | v <- map (`rotateBy` unitX) [0,inc..top]] + w = opts ^. eLineWidth + inc = 1 / fromIntegral (opts^.ePoints) + top = 1 - inc -instance Default OriginOpts where - def = OriginOpts red (1/50) 0.001 +-- | Mark the envelope with an approximating cubic spline +-- using 32 points, medium line width and red line color. +showEnvelope :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) + => QDiagram b V2 n Any -> QDiagram b V2 n Any +showEnvelope = showEnvelope' def +-- | Mark the trace of a diagram, with control over colour and scale +-- of marker dot and the number of points on the trace. +showTrace' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) + => TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +showTrace' opts d = atPoints ps (repeat pt) <> d + where + ps = concatMap p ts + ts = zip rs vs + p (r, v) = [origin .+^ (s *^ v) | s <- r] + vs = map (`rotateBy` unitX) [0, inc..top] + rs = [getSortedList $ (appTrace . getTrace) d origin v | v <- vs] + pt = circle sz # fc (opts^.tColor) # lw none + V2 w h = opts^.tScale *^ size d + sz = maximum [w, h, opts^.tMinSize] + inc = 1 / fromIntegral (opts^.tPoints) + top = 1 - inc + +-- | Mark the trace of a diagram by placing 64 red dots 1/100th its size +-- along the trace. +showTrace :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) + => QDiagram b V2 n Any -> QDiagram b V2 n Any +showTrace = showTrace' def + ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ -showLabels :: (Renderable Text b, Backend b R2) - => QDiagram b R2 m -> QDiagram b R2 Any +showLabels :: (TypeableFloat n, Renderable (Text n) b, Semigroup m) + => QDiagram b V2 n m -> QDiagram b V2 n Any showLabels d = ( mconcat - . map (\(n,p) -> text (show n) # translate (p .-. origin)) + . map (\(n,p) -> text (simpleName n) # translate (p .-. origin)) . concatMap (\(n,ps) -> zip (repeat n) ps) . (map . second . map) location . M.assocs @@ -89,4 +175,6 @@ ) <> fmap (const (Any False)) d where - SubMap m = subMap d + SubMap m = d^.subMap + simpleName (Name ns) = intercalate " .> " $ map simpleAName ns + simpleAName (AName n) = show n diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,43 +1,88 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset --- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Compute offsets to segments in two dimensions. --- +-- Compute offsets to segments in two dimensions. More details can be +-- found in the manual at +-- . +-- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Offset - ( offsetSegment +module Diagrams.TwoD.Offset + ( + -- * Offsets + + offsetSegment + + , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon + , offsetTrail + , offsetTrail' + , offsetPath + , offsetPath' + + -- * Expansions + + , ExpandOpts(..), expandJoin, expandMiterLimit, expandCap, expandEpsilon + , expandTrail + , expandTrail' + , expandPath + , expandPath' + ) where -import Data.AffineSpace -import Data.Monoid.Inf -import Data.VectorSpace +import Control.Applicative +import Control.Lens hiding (at) +import Prelude -import Diagrams.Core +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Monoid.Inf -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TwoD.Curvature -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types +import Data.Default -perp :: R2 -> R2 -perp v = rotateBy (-1/4) v +import Diagrams.Core -unitPerp :: R2 -> R2 -unitPerp = normalized . perp +import Diagrams.Attributes +import Diagrams.Direction +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail hiding (isLoop, offset) +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Curvature +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector hiding (e) -perpAtParam :: Segment Closed R2 -> Double -> R2 -perpAtParam (Linear (OffsetClosed a)) t = unitPerp a -perpAtParam s@(Cubic _ _ _) t = unitPerp a +import Linear.Affine +import Linear.Metric +import Linear.Vector + +unitPerp :: OrderedField n => V2 n -> V2 n +unitPerp = signorm . perp + +perpAtParam :: OrderedField n => Segment Closed V2 n -> n -> V2 n +perpAtParam (Linear (OffsetClosed a)) _ = negated $ unitPerp a +perpAtParam cubic t = negated $ unitPerp a where - (Cubic a _ _) = snd $ splitAtParam s t + (Cubic a _ _) = snd $ splitAtParam cubic t -- | Compute the offset of a segment. Given a segment compute the offset -- curve that is a fixed distance from the original curve. For linear @@ -46,7 +91,9 @@ -- length. -- -- Cubic segments require a search for a subdivision of cubic segments that --- gives an approximation of the offset within the given epsilon tolerance. +-- gives an approximation of the offset within the given epsilon factor +-- (the given epsilon factor is applied to the radius giving a concrete epsilon +-- value). -- We must do this because the offset of a cubic is not a cubic itself (the -- degree of the curve increases). Cubics do, however, approach constant -- curvature as we subdivide. In light of this we scale the handles of @@ -57,39 +104,100 @@ -- In the following example the blue lines are the original segments and -- the alternating green and red lines are the resulting offset trail segments. -- --- <> +-- <> -- -- Note that when the original curve has a cusp, the offset curve forms a -- radius around the cusp, and when there is a loop in the original curve, -- there can be two cusps in the offset curve. -- -offsetSegment :: Double -- ^ Epsilon value that represents the maximum + +-- | Options for specifying line join and segment epsilon for an offset +-- involving multiple segments. +data OffsetOpts d = OffsetOpts + { _offsetJoin :: LineJoin + , _offsetMiterLimit :: d + , _offsetEpsilon :: d + } + +deriving instance Eq d => Eq (OffsetOpts d) +deriving instance Show d => Show (OffsetOpts d) + +makeLensesWith (lensRules & generateSignatures .~ False) ''OffsetOpts + +-- | Specifies the style of join for between adjacent offset segments. +offsetJoin :: Lens' (OffsetOpts d) LineJoin + +-- | Specifies the miter limit for the join. +offsetMiterLimit :: Lens' (OffsetOpts d) d + +-- | Epsilon perimeter for 'offsetSegment'. +offsetEpsilon :: Lens' (OffsetOpts d) d + +-- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a +-- miter limit of 10, and epsilon factor of 0.01. +instance Fractional d => Default (OffsetOpts d) where + def = OffsetOpts def 10 0.01 + +-- | Options for specifying how a 'Trail' should be expanded. +data ExpandOpts d = ExpandOpts + { _expandJoin :: LineJoin + , _expandMiterLimit :: d + , _expandCap :: LineCap + , _expandEpsilon :: d + } deriving (Eq, Show) + +makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts + +-- | Specifies the style of join for between adjacent offset segments. +expandJoin :: Lens' (ExpandOpts d) LineJoin + +-- | Specifies the miter limit for the join. +expandMiterLimit :: Lens' (ExpandOpts d) d + +-- | Specifies how the ends are handled. +expandCap :: Lens' (ExpandOpts d) LineCap + +-- | Epsilon perimeter for 'offsetSegment'. +expandEpsilon :: Lens' (ExpandOpts d) d + + + +-- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), +-- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon factor +-- of 0.01. +instance (Fractional d) => Default (ExpandOpts d) where + def = ExpandOpts def 10 def 0.01 + +offsetSegment :: RealFloat n + => n -- ^ Epsilon factor that when multiplied to the + -- absolute value of the radius gives a + -- value that represents the maximum -- allowed deviation from the true offset. In -- the current implementation each result segment -- should be bounded by arcs that are plus or - -- minus epsilon from the radius of curvature of + -- minus epsilon factor from the radius of curvature of -- the offset. - -> Double -- ^ Offset from the original segment, positive is + -> n -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. - -> Segment Closed R2 -- ^ Original segment - -> (Point R2, Trail R2) -- ^ Resulting offset point and trail. -offsetSegment _ r s@(Linear (OffsetClosed a)) = (origin .+^ va, trailFromSegments [s]) - where va = r *^ unitPerp a + -> Segment Closed V2 n -- ^ Original segment + -> Located (Trail V2 n) -- ^ Resulting located (at the offset) trail. +offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va + where va = (-r) *^ unitPerp a -offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = (origin .+^ va, t) +offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va where t = trailFromSegments (go (radiusOfCurvature s 0.5)) -- Perpendiculars to handles. - va = r *^ unitPerp a - vc = r *^ unitPerp (c - b) + va = (-r) *^ unitPerp a + vc = (-r) *^ unitPerp (c ^-^ b) -- Split segments. - ss = (\(a,b) -> [a,b]) $ splitAtParam s 0.5 - subdivided = concatMap (trailSegments . snd . offsetSegment epsilon r) ss + ss = (\(x,y) -> [x,y]) $ splitAtParam s 0.5 + subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss -- Offset with handles scaled based on curvature. - offset factor = bezier3 (a^*factor) ((b - c)^*factor + c + vc - va) (c + vc - va) - + offset factor = bezier3 (a^*factor) ((b ^-^ c)^*factor ^+^ c ^+^ vc ^-^ va) (c ^+^ vc ^-^ va) + -- We observe a corner. Subdivide right away. go (Finite 0) = subdivided -- We have some curvature @@ -104,30 +212,355 @@ -- o = offset $ case roc of Infinity -> 1 -- Do the right thing. - Finite sr -> 1 + r / sr + Finite sr -> 1 + r / sr - close = and [epsilon > (magnitude (p o + va - p s - pp s)) - | t <- [0.25, 0.5, 0.75] - , let p = (`atParam` t) - , let pp = (r *^) . (`perpAtParam` t) + close = and [epsilon * abs r > norm (p o ^+^ va ^-^ p s ^-^ pp s) + | t' <- [0.25, 0.5, 0.75] + , let p = (`atParam` t') + , let pp = (r *^) . (`perpAtParam` t') ] -- > import Diagrams.TwoD.Offset -- > --- > showExample :: Segment R2 -> Diagram SVG R2 --- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 +-- > showExample :: Segment Closed V2 Double -> Diagram SVG +-- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw thick <> d' # lw thick -- > where --- > d = stroke $ Path [(origin, Trail [s] False)] --- > d' = mconcat . zipWith lc colors . map stroke . uncurry explodeTrail +-- > d = strokeP . fromSegments $ [s] +-- > d' = mconcat . zipWith lc colors . map strokeP . explodeTrail -- > $ offsetSegment 0.1 (-1) s --- > +-- > -- > colors = cycle [green, red] --- > --- > cubicOffsetExample :: Diagram SVG R2 +-- > +-- > cubicOffsetExample :: Diagram SVG -- > cubicOffsetExample = hcat . map showExample $ --- > [ Cubic (10 & 0) ( 5 & 18) (10 & 20) --- > , Cubic ( 0 & 20) ( 10 & 10) ( 5 & 10) --- > , Cubic (10 & 20) ( 0 & 10) (10 & 0) --- > , Cubic (10 & 20) ((-5) & 10) (10 & 0) +-- > [ bezier3 (10 ^& 0) ( 5 ^& 18) (10 ^& 20) +-- > , bezier3 ( 0 ^& 20) ( 10 ^& 10) ( 5 ^& 10) +-- > , bezier3 (10 ^& 20) ( 0 ^& 10) (10 ^& 0) +-- > , bezier3 (10 ^& 20) ((-5) ^& 10) (10 ^& 0) -- > ] + +-- Similar to (=<<). This is when we want to map a function across something +-- located, but the result of the mapping will be transformable so we can +-- collapse the Located into the result. This assumes that Located has the +-- meaning of merely taking something that cannot be translated and lifting +-- it into a space with translation. +bindLoc :: (Transformable b, V a ~ V b, N a ~ N b, V a ~ V2, N a ~ n, Num n) => (a -> b) -> Located a -> b +bindLoc f = join' . mapLoc f + where + join' (viewLoc -> (p,a)) = translate (p .-. origin) a + +-- While we build offsets and expansions we will use the [Located (Segment Closed v)] +-- and [Located (Trail V2 n)] intermediate representations. +locatedTrailSegments :: OrderedField n + => Located (Trail V2 n) -> [Located (Segment Closed V2 n)] +locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) + +-- | Offset a 'Trail' with options and by a given radius. This generates a new +-- trail that is always radius 'r' away from the given 'Trail' (depending on +-- the line join option) on the right. +-- +-- The styles applied to an outside corner can be seen here (with the original +-- trail in blue and the result of 'offsetTrail'' in green): +-- +-- <> +-- +-- When a negative radius is given, the offset trail will be on the left: +-- +-- <> +-- +-- When offseting a counter-clockwise loop a positive radius gives an outer loop +-- while a negative radius gives an inner loop (both counter-clockwise). +-- +-- <> +-- +offsetTrail' :: RealFloat n + => OffsetOpts n + -> n -- ^ Radius of offset. A negative value gives an offset on + -- the left for a line and on the inside for a counter-clockwise + -- loop. + -> Located (Trail V2 n) + -> Located (Trail V2 n) +offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t + where + eps = opts^.offsetEpsilon + offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments + ends | isLoop = (\(a:as) -> as ++ [a]) . trailPoints $ t + | otherwise = tail . trailPoints $ t + j = fromLineJoin (opts^.offsetJoin) + + isLoop = withTrail (const False) (const True) (unLoc t) + +-- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. +offsetTrail :: RealFloat n => n -> Located (Trail V2 n) -> Located (Trail V2 n) +offsetTrail = offsetTrail' def + +-- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. +offsetPath' :: RealFloat n => OffsetOpts n -> n -> Path V2 n -> Path V2 n +offsetPath' opts r = mconcat + . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) + . op Path + +-- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. +offsetPath :: RealFloat n => n -> Path V2 n -> Path V2 n +offsetPath = offsetPath' def + +-- TODO: Include arrowheads on examples to indicate direction so the "left" and +-- "right" make sense. +-- +-- > import Diagrams.TwoD.Offset +-- > import Data.Default +-- > +-- > corner :: (OrderedField n) => Located (Trail V2 n) +-- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin +-- > +-- > offsetTrailExample :: Diagram SVG +-- > offsetTrailExample = pad 1.1 . centerXY . lwO 3 . hcat' (def & sep .~ 1 ) +-- > . map (uncurry showStyle) +-- > $ [ (LineJoinMiter, "LineJoinMiter") +-- > , (LineJoinRound, "LineJoinRound") +-- > , (LineJoinBevel, "LineJoinBevel") +-- > ] +-- > where +-- > showStyle j s = centerXY (trailLike corner # lc blue +-- > <> trailLike (offsetTrail' (def & offsetJoin .~ j) 2 corner) # lc green) +-- > === (strutY 3 <> text s # font "Helvetica" # bold) +-- > +-- > offsetTrailLeftExample :: Diagram SVG +-- > offsetTrailLeftExample = pad 1.1 . centerXY . lwO 3 +-- > $ (trailLike c # lc blue) +-- > <> (lc green . trailLike +-- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) (-2) $ c) +-- > where +-- > c = reflectY corner +-- > +-- > offsetTrailOuterExample :: Diagram SVG +-- > offsetTrailOuterExample = pad 1.1 . centerXY . lwO 3 +-- > $ (trailLike c # lc blue) +-- > <> (lc green . trailLike +-- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) 2 $ c) +-- > where +-- > c = hexagon 5 + +withTrailL :: (Located (Trail' Line V2 n) -> r) -> (Located (Trail' Loop V2 n) -> r) -> Located (Trail V2 n) -> r +withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) + where + p = loc l + +-- | Expand a 'Trail' with the given options and radius 'r' around a given 'Trail'. +-- Expanding can be thought of as generating the loop that, when filled, represents +-- stroking the trail with a radius 'r' brush. +-- +-- The cap styles applied to an outside corner can be seen here (with the original +-- trail in white and the result of 'expandTrail'' filled in green): +-- +-- <> +-- +-- Loops result in a path with an inner and outer loop: +-- +-- <> +-- +expandTrail' :: (OrderedField n, RealFloat n, RealFrac n) + => ExpandOpts n + -> n -- ^ Radius of offset. Only non-negative values allowed. + -- For a line this gives a loop of the offset. For a + -- loop this gives two loops, the outer counter-clockwise + -- and the inner clockwise. + -> Located (Trail V2 n) + -> Path V2 n +expandTrail' o r t + | r < 0 = error "expandTrail' with negative radius" + -- TODO: consider just reversing the path instead of this error. + | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t + +expandLine :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) +expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) + where + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends + . offset r' $ t + ends = tail . trailPoints $ t + s = atStart t + e = atEnd t + cap = fromLineCap (opts^.expandCap) + +expandLoop :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n +expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . reverseDomain . f $ -r) + where + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends + . offset r' $ t + ends = (\(a:as) -> as ++ [a]) . trailPoints $ t + +-- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. +expandTrail :: RealFloat n => n -> Located (Trail V2 n) -> Path V2 n +expandTrail = expandTrail' def + +-- | Expand a 'Path' using 'expandTrail'' on each trail in the path. +expandPath' :: RealFloat n => ExpandOpts n -> n -> Path V2 n -> Path V2 n +expandPath' opts r = mconcat + . map (bindLoc (expandTrail' opts r) . (`at` origin)) + . op Path + +-- | Expand a 'Path' with the given radius and default options. See 'expandPath''. +expandPath :: RealFloat n => n -> Path V2 n -> Path V2 n +expandPath = expandPath' def + +-- > import Diagrams.TwoD.Offset +-- > import Data.Default +-- > +-- > expandTrailExample :: Diagram SVG +-- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) +-- > . map (uncurry showStyle) +-- > $ [ (LineCapButt, "LineCapButt") +-- > , (LineCapRound, "LineCapRound") +-- > , (LineCapSquare, "LineCapSquare") +-- > ] +-- > where +-- > showStyle c s = centerXY (trailLike corner # lc white # lw veryThick +-- > <> stroke (expandTrail' +-- > (def & expandJoin .~ LineJoinRound +-- > & expandCap .~ c +-- > ) 2 corner) +-- > # lw none # fc green) +-- > === (strutY 3 <> text s # font "Helvetica" # bold) +-- > +-- > expandLoopExample :: Diagram SVG +-- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw veryThick # lc white) +-- > <> (stroke t' # lw none # fc green)) +-- > where +-- > t = mapLoc glueTrail $ fromVertices (map p2 [(0, 0), (5, 0), (10, 5), (10, 10), (0, 0)]) +-- > t' = expandTrail' (def & expandJoin .~ LineJoinRound) 1 t + + +-- | When we expand a line (the original line runs through the center of offset +-- lines at r and -r) there is some choice in what the ends will look like. +-- If we are using a circle brush we should see a half circle at each end. +-- Similar caps could be made for square brushes or simply stopping exactly at +-- the end with a straight line (a perpendicular line brush). +-- +-- caps takes the radius and the start and end points of the original line and +-- the offset trails going out and coming back. The result is a new list of +-- trails with the caps included. +caps :: RealFloat n => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) + -> n -> Point V2 n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Located (Trail V2 n) +caps cap r s e fs bs = mapLoc glueTrail $ mconcat + [ cap r s (atStart bs) (atStart fs) + , unLoc fs + , cap r e (atEnd fs) (atEnd bs) + , reverseDomain (unLoc bs) + ] `at` atStart bs + +-- | Take a LineCap style and give a function for building the cap from +fromLineCap :: RealFloat n => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +fromLineCap c = case c of + LineCapButt -> capCut + LineCapRound -> capArc + LineCapSquare -> capSquare + +-- | Builds a cap that directly connects the ends. +capCut :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capCut _r _c a b = fromSegments [straight (b .-. a)] + +-- | Builds a cap with a square centered on the end. +capSquare :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] + where + v = perp (a .-. c) + +-- | Builds an arc to fit with a given radius, center, start, and end points. +-- A Negative r means a counter-clockwise arc +capArc :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n +capArc r c a b = trailLike . moveTo c $ fs + where + fs | r < 0 = scale (-r) $ arcCW (dirBetween c a) (dirBetween c b) + | otherwise = scale r $ arcCCW (dirBetween c a) (dirBetween c b) + +-- | Join together a list of located trails with the given join style. The +-- style is given as a function to compute the join given the local information +-- of the original vertex, the previous trail, and the next trail. The result +-- is a single located trail. A join radius is also given to aid in arc joins. +-- +-- Note: this is not a general purpose join and assumes that we are joining an +-- offset trail. For instance, a fixed radius arc will not fit between arbitrary +-- trails without trimming or extending. +joinSegments :: RealFloat n + => n + -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) + -> Bool + -> n + -> n + -> [Point V2 n] + -> [Located (Trail V2 n)] + -> Located (Trail V2 n) +joinSegments _ _ _ _ _ _ [] = mempty `at` origin +joinSegments _ _ _ _ _ [] _ = mempty `at` origin +joinSegments epsilon j isLoop ml r es ts@(t:_) = t' + where + t' | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t + | otherwise = mapLoc (<> f (ss es ts)) t + ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + test a b tj + | atStart b `distance` atEnd a > epsilon = Just tj + | otherwise = Nothing + f = mconcat . catMaybes + +-- | Take a join style and give the join function to be used by joinSegments. +fromLineJoin + :: RealFloat n => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +fromLineJoin j = case j of + LineJoinMiter -> joinSegmentIntersect + LineJoinRound -> joinSegmentArc + LineJoinBevel -> joinSegmentClip + +-- TODO: The joinSegmentCut option is not in our standard line joins. I don't know +-- how useful it is graphically, I mostly had it as it was useful for debugging +{- +-- | Join with segments going back to the original corner. +joinSegmentCut :: (OrderedField n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentCut _ _ e a b = fromSegments + [ straight (e .-. atEnd a) + , straight (atStart b .-. e) + ] +-} + +-- | Join by directly connecting the end points. On an inside corner this +-- creates negative space for even-odd fill. Here is where we would want to +-- use an arc or something else in the future. +joinSegmentClip :: RealFloat n + => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] + +-- | Join with a radius arc. On an inside corner this will loop around the interior +-- of the offset trail. With a winding fill this will not be visible. +joinSegmentArc :: RealFloat n + => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) + +-- | Join to the intersection of the incoming trails projected tangent to their ends. +-- If the intersection is beyond the miter limit times the radius, stop at the limit. +joinSegmentIntersect + :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n +joinSegmentIntersect miterLimit r e a b = + if cross < 0.000001 + then clip + else case traceP pa va t of + -- clip join when we excede the miter limit. We could instead + -- Join at exactly the miter limit, but standard behavior seems + -- to be clipping. + Nothing -> clip + Just p + -- If trace gave us garbage... + | p `distance` pb > abs (miterLimit * r) -> clip + | otherwise -> unLoc $ fromVertices [ pa, p, pb ] + where + t = straight (miter vb) `at` pb + va = unitPerp (pa .-. e) + vb = negated $ unitPerp (pb .-. e) + pa = atEnd a + pb = atStart b + miter v = abs (miterLimit * r) *^ v + clip = joinSegmentClip miterLimit r e a b + cross = let (xa,ya) = unr2 va; (xb,yb) = unr2 vb in abs (xa * yb - xb * ya) diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,15 +1,23 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Path --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -21,48 +29,66 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD.Path - ( -- * Constructing path-based diagrams + ( -- * Constructing path-based diagrams - stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop - , strokeLocT, strokeLocLine, strokeLocLoop + stroke, stroke' + , strokePath, strokeP, strokePath', strokeP' + , strokeTrail, strokeT, strokeTrail', strokeT' + , strokeLine, strokeLoop + , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop - -- ** Stroke options + -- ** Stroke options - , FillRule(..) - , FillRuleA(..), getFillRule, fillRule - , StrokeOpts(..) + , FillRule(..) + , getFillRule, fillRule, _fillRule + , StrokeOpts(..), vertexNames, queryFillRule - -- ** Inside/outside testing + -- ** Inside/outside testing - , isInsideWinding, isInsideEvenOdd + , Crossings (..) + , isInsideWinding + , isInsideEvenOdd - -- * Clipping + -- * Clipping - , Clip(..), clipBy - ) where + , Clip(..), _Clip, _clip + , clipBy, clipTo, clipped -import Control.Applicative (liftA2) -import qualified Data.Foldable as F + -- * Intersections + + , intersectPoints, intersectPoints' + , intersectPointsP, intersectPointsP' + , intersectPointsT, intersectPointsT' + ) where + +import Control.Applicative (liftA2) +import Control.Lens hiding (at, transform) +import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable -import Data.AffineSpace -import Data.Default.Class -import Data.VectorSpace +import Data.Default -import Diagrams.Coordinates +import Diagrams.Angle +import Diagrams.Combinators (withEnvelope, withTrace) import Diagrams.Core -import Diagrams.Located (Located, mapLoc, unLoc) +import Diagrams.Core.Trace +import Diagrams.Located (Located, mapLoc, unLoc) import Diagrams.Parametric import Diagrams.Path +import Diagrams.Query import Diagrams.Segment -import Diagrams.Solve +import Diagrams.Solve.Polynomial import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Segment import Diagrams.TwoD.Types -import Diagrams.Util (tau) +import Diagrams.TwoD.Vector +import Diagrams.Util (tau) +import Linear.Affine +import Linear.Vector + ------------------------------------------------------------ -- Trail and path traces --------------------------------- ------------------------------------------------------------ @@ -71,219 +97,304 @@ -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. -instance Traced (Trail R2) where +instance RealFloat n => Traced (Trail V2 n) where getTrace = withLine $ foldr - (\seg bds -> moveOriginBy (negateV . atEnd $ seg) bds <> getTrace seg) + (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments -instance Traced (Path R2) where - getTrace = F.foldMap getTrace . pathTrails +instance RealFloat n => Traced (Path V2 n) where + getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- ------------------------------------------------------------ --- | Convert a path into a diagram. The resulting diagram has the +-- | Enumeration of algorithms or \"rules\" for determining which +-- points lie in the interior of a (possibly self-intersecting) +-- path. +data FillRule + = Winding -- ^ Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + | EvenOdd -- ^ Interior points are those where a ray + -- extended infinitely in a particular direction crosses + -- the path an odd number of times. See + -- . + deriving (Show, Typeable, Eq, Ord) + +instance AttributeClass FillRule +instance Semigroup FillRule where + _ <> b = b + +instance Default FillRule where + def = Winding + +-- | A record of options that control how a path is stroked. +-- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ +-- records can be created using @'with' { ... }@ notation. +data StrokeOpts a + = StrokeOpts + { _vertexNames :: [[a]] + + , _queryFillRule :: FillRule + + } + +makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts + +-- | Atomic names that should be assigned to the vertices of the path so that +-- they can be referenced later. If there are not enough names, the extra +-- vertices are not assigned names; if there are too many, the extra names +-- are ignored. Note that this is a /list of lists/ of names, since paths +-- can consist of multiple trails. The first list of names are assigned to +-- the vertices of the first trail, the second list to the second trail, and +-- so on. +-- +-- The default value is the empty list. + +vertexNames :: Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] + +-- | The fill rule used for determining which points are inside the path. +-- The default is 'Winding'. NOTE: for now, this only affects the resulting +-- diagram's 'Query', /not/ how it will be drawn! To set the fill rule +-- determining how it is to be drawn, use the 'fillRule' function. +queryFillRule :: Lens' (StrokeOpts a) FillRule + +instance Default (StrokeOpts a) where + def = StrokeOpts + { _vertexNames = [] + , _queryFillRule = def + } + +-- | Convert a 'ToPath' object into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices. -- -- See also 'stroke'', which takes an extra options record allowing --- its behavior to be customized. +-- its behaviour to be customized. -- --- Note that a bug in GHC 7.0.1 causes a context stack overflow when --- inferring the type of @stroke@. The solution is to give a type --- signature to expressions involving @stroke@, or (recommended) --- upgrade GHC (the bug is fixed in 7.0.2 onwards). -stroke :: Renderable (Path R2) b - => Path R2 -> Diagram b R2 -stroke = stroke' (def :: StrokeOpts ()) - -instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where - trailLike = stroke . trailLike +-- @ +-- 'stroke' :: 'Path' 'V2' 'Double' -> 'Diagram' b +-- 'stroke' :: 'Located' ('Trail' 'V2' 'Double') -> 'Diagram' b +-- 'stroke' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Diagram' b +-- 'stroke' :: 'Located' ('Trail'' 'Line' 'V2' 'Double') -> 'Diagram' b +-- @ +stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) + => t -> QDiagram b V2 n Any +stroke = strokeP . toPath -- | A variant of 'stroke' that takes an extra record of options to --- customize its behavior. In particular: +-- customize its behaviour. In particular: -- -- * Names can be assigned to the path's vertices -- --- 'StrokeOpts' is an instance of 'Default', so @stroke' 'with' { --- ... }@ syntax may be used. -stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 -stroke' opts path - | null (pathTrails p1) = mkP p2 - | null (pathTrails p2) = mkP p1 - | otherwise = mkP p1 <> mkP p2 +-- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & +-- ... )@ syntax may be used. +stroke' :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> t -> QDiagram b V2 n Any +stroke' opts = strokeP' opts . toPath + +-- | 'stroke' specialised to 'Path'. +strokeP :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any +strokeP = strokeP' (def :: StrokeOpts ()) + +-- | 'stroke' specialised to 'Path'. +strokePath :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any +strokePath = strokeP + +instance (TypeableFloat n, Renderable (Path V2 n) b) + => TrailLike (QDiagram b V2 n Any) where + trailLike = strokeP . trailLike + +-- | 'stroke'' specialised to 'Path'. +strokeP' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any +strokeP' opts path + | null (pLines ^. _Wrapped') = mkP pLoops + | null (pLoops ^. _Wrapped') = mkP pLines + | otherwise = mkP pLines <> mkP pLoops where - (p1,p2) = partitionPath (isLine . unLoc) path + (pLines,pLoops) = partitionPath (isLine . unLoc) path mkP p = mkQD (Prim p) (getEnvelope p) (getTrace p) (fromNames . concat $ - zipWith zip (vertexNames opts) ((map . map) subPoint (pathVertices p)) + zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) ) - (Query $ Any . flip (runFillRule (queryFillRule opts)) p) - --- | A record of options that control how a path is stroked. --- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ --- records can be created using @'with' { ... }@ notation. -data StrokeOpts a - = StrokeOpts - { vertexNames :: [[a]] -- ^ Atomic names that should be assigned - -- to the vertices of the path so that - -- they can be referenced later. If - -- there are not enough names, the extra - -- vertices are not assigned names; if - -- there are too many, the extra names - -- are ignored. Note that this is a - -- /list of lists/ of names, since paths - -- can consist of multiple trails. The - -- first list of names are assigned to - -- the vertices of the first trail, the - -- second list to the second trail, and - -- so on. - -- - -- The default value is the empty list. + (Query $ Any . (runFillRule (opts^.queryFillRule)) p) - , queryFillRule :: FillRule - -- ^ The fill rule used for determining - -- which points are inside the path. - -- The default is 'Winding'. NOTE: for - -- now, this only affects the resulting - -- diagram's 'Query', /not/ how it will - -- be drawn! To set the fill rule - -- determining how it is to be drawn, - -- use the 'fillRule' function. - } +-- | 'stroke'' specialised to 'Path'. +strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any +strokePath' = strokeP' -instance Default (StrokeOpts a) where - def = StrokeOpts - { vertexNames = [] - , queryFillRule = Winding - } +-- | 'stroke' specialised to 'Trail'. +strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail V2 n -> QDiagram b V2 n Any +strokeTrail = stroke . pathFromTrail --- | A composition of 'stroke' and 'pathFromTrail' for conveniently --- converting a trail directly into a diagram. --- --- Note that a bug in GHC 7.0.1 causes a context stack overflow when --- inferring the type of 'stroke' and hence of @strokeT@ as well. --- The solution is to give a type signature to expressions involving --- @strokeT@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 --- onwards). -strokeT :: (Renderable (Path R2) b) - => Trail R2 -> Diagram b R2 -strokeT = stroke . pathFromTrail +-- | 'stroke' specialised to 'Trail'. +strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail V2 n -> QDiagram b V2 n Any +strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -strokeT' :: (Renderable (Path R2) b, IsName a) - => StrokeOpts a -> Trail R2 -> Diagram b R2 -strokeT' opts = stroke' opts . pathFromTrail +strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any +strokeTrail' opts = stroke' opts . pathFromTrail +-- | Deprecated synonym for 'strokeTrail''. +strokeT' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any +strokeT' = strokeTrail' + -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. -strokeLine :: (Renderable (Path R2) b) => Trail' Line R2 -> Diagram b R2 +strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail' Line V2 n -> QDiagram b V2 n Any strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. -strokeLoop :: (Renderable (Path R2) b) => Trail' Loop R2 -> Diagram b R2 +strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) + => Trail' Loop V2 n -> QDiagram b V2 n Any strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly --- into a diagram; @strokeLocT = stroke . trailLike@. -strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 -strokeLocT = stroke . trailLike +-- into a diagram; @strokeLocTrail = stroke . trailLike@. +strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail V2 n) -> QDiagram b V2 n Any +strokeLocTrail = strokeP . trailLike +-- | Deprecated synonym for 'strokeLocTrail'. +strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail V2 n) -> QDiagram b V2 n Any +strokeLocT = strokeLocTrail + -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. -strokeLocLine :: (Renderable (Path R2) b) => Located (Trail' Line R2) -> Diagram b R2 -strokeLocLine = stroke . trailLike . mapLoc wrapLine +strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail' Line V2 n) -> QDiagram b V2 n Any +strokeLocLine = strokeP . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. -strokeLocLoop :: (Renderable (Path R2) b) => Located (Trail' Loop R2) -> Diagram b R2 -strokeLocLoop = stroke . trailLike . mapLoc wrapLoop +strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) + => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any +strokeLocLoop = strokeP . trailLike . mapLoc wrapLoop ------------------------------------------------------------ -- Inside/outside testing ------------------------------------------------------------ --- | Enumeration of algorithms or \"rules\" for determining which --- points lie in the interior of a (possibly self-intersecting) --- closed path. -data FillRule = Winding -- ^ Interior points are those with a nonzero - -- /winding/ /number/. See - -- . - | EvenOdd -- ^ Interior points are those where a ray - -- extended infinitely in a particular - -- direction crosses the path an odd number - -- of times. See - -- . - deriving (Eq) - -runFillRule :: FillRule -> P2 -> Path R2 -> Bool +runFillRule :: RealFloat n => FillRule -> Path V2 n -> Point V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd -newtype FillRuleA = FillRuleA (Last FillRule) - deriving (Typeable, Semigroup) -instance AttributeClass FillRuleA - -- | Extract the fill rule from a 'FillRuleA' attribute. -getFillRule :: FillRuleA -> FillRule -getFillRule (FillRuleA (Last r)) = r +getFillRule :: FillRule -> FillRule +getFillRule = id -- | Specify the fill rule that should be used for determining which -- points are inside a path. fillRule :: HasStyle a => FillRule -> a -> a -fillRule = applyAttr . FillRuleA . Last +fillRule = applyAttr -cross :: R2 -> R2 -> Double -cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' +-- | Lens onto the fill rule of a style. +_fillRule :: Lens' (Style V2 n) FillRule +_fillRule = atAttr . non def --- XXX link to more info on this +-- | The sum of /signed/ crossings of a path as we travel in the +-- positive x direction from a given point. +-- +-- - A point is filled according to the 'Winding' fill rule, if the +-- number of 'Crossings' is non-zero (see 'isInsideWinding'). +-- +-- - A point is filled according to the 'EvenOdd' fill rule, if the +-- number of 'Crossings' is odd (see 'isInsideEvenOdd'). +-- +-- This is the 'HasQuery' result for 'Path's, 'Located' 'Trail's and +-- 'Located' 'Loops'. +-- +-- @ +-- 'sample' :: 'Path' 'V2' 'Double' -> 'Point' 'V2' 'Double' -> 'Crossings' +-- 'sample' :: 'Located' ('Trail' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Crossings' +-- 'sample' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Crossings' +-- @ +-- +-- Note that 'Line's have no inside or outside, so don't contribute +-- crossings +newtype Crossings = Crossings Int + deriving (Show, Eq, Ord, Num, Enum, Real, Integral) --- | Test whether the given point is inside the given (closed) path, +instance Semigroup Crossings where + Crossings a <> Crossings b = Crossings (a + b) + +instance Monoid Crossings where + mempty = Crossings 0 + mappend = (<>) + +instance RealFloat n => HasQuery (Located (Trail V2 n)) Crossings where + getQuery trail = Query $ \p -> trailCrossings p trail + +instance RealFloat n => HasQuery (Located (Trail' l V2 n)) Crossings where + getQuery trail' = getQuery (mapLoc Trail trail') + +instance RealFloat n => HasQuery (Path V2 n) Crossings where + getQuery = foldMapOf each getQuery + +-- | Test whether the given point is inside the given path, -- by testing whether the point's /winding number/ is nonzero. Note --- that @False@ is /always/ returned for /open/ paths, regardless of --- the winding number. -isInsideWinding :: P2 -> Path R2 -> Bool -isInsideWinding p = (/= 0) . crossings p +-- that @False@ is /always/ returned for paths consisting of lines +-- (as opposed to loops), regardless of the winding number. +-- +-- @ +-- 'isInsideWinding' :: 'Path' 'V2' 'Double' -> 'Point' 'V2' 'Double' -> 'Bool' +-- 'isInsideWinding' :: 'Located' ('Trail' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Bool' +-- 'isInsideWinding' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Bool' +-- @ +isInsideWinding :: HasQuery t Crossings => t -> Point (V t) (N t) -> Bool +isInsideWinding t = (/= 0) . sample t --- | Test whether the given point is inside the given (closed) path, +-- | Test whether the given point is inside the given path, -- by testing whether a ray extending from the point in the positive -- x direction crosses the path an even (outside) or odd (inside) -- number of times. Note that @False@ is /always/ returned for --- /open/ paths, regardless of the number of crossings. -isInsideEvenOdd :: P2 -> Path R2 -> Bool -isInsideEvenOdd p = odd . crossings p - --- | Compute the sum of /signed/ crossings of a path as we travel in the --- positive x direction from a given point. -crossings :: P2 -> Path R2 -> Int -crossings p = F.sum . map (trailCrossings p) . pathTrails +-- paths consisting of lines (as opposed to loops), regardless of +-- the number of crossings. +-- +-- @ +-- 'isInsideEvenOdd' :: 'Path' 'V2' 'Double' -> 'Point' 'V2' 'Double' -> 'Bool' +-- 'isInsideEvenOdd' :: 'Located' ('Trail' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Bool' +-- 'isInsideEvenOdd' :: 'Located' ('Trail'' 'Loop' 'V2' 'Double') -> 'Point' 'V2' 'Double' -> 'Bool' +-- @ +isInsideEvenOdd :: HasQuery t Crossings => t -> Point (V t) (N t) -> Bool +isInsideEvenOdd t = odd . sample t -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. -trailCrossings :: P2 -> Located (Trail R2) -> Int +trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Crossings -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 trailCrossings p@(unp2 -> (x,y)) tr - = sum . map test $ fixTrail tr + = F.foldMap test $ fixTrail tr where test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 | by <= y && ay > y && isLeft a b < 0 = -1 | otherwise = 0 - test c@(FCubic (unp2 -> x1@(_,x1y)) - (unp2 -> c1@(_,c1y)) - (unp2 -> c2@(_,c2y)) - (unp2 -> x2@(_,x2y)) + test c@(FCubic (P x1@(V2 _ x1y)) + (P c1@(V2 _ c1y)) + (P c2@(V2 _ c2y)) + (P x2@(V2 _ x2y)) ) = sum . map testT $ ts where ts = filter (liftA2 (&&) (>=0) (<=1)) @@ -294,15 +405,15 @@ testT t = let (unp2 -> (px,_)) = c `atParam` t in if px > x then signFromDerivAt t else 0 signFromDerivAt t = - let (dx,dy) = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) - ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) - ^+^ ((-3)*^x1 ^+^ 3*^c1) - ang = atan2 dy dx + let v = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) + ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) + ^+^ ((-3)*^x1 ^+^ 3*^c1) + ang = v ^. _theta . rad in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 | -tau/2 < ang && ang < 0 && t > 0 -> -1 | otherwise -> 0 - isLeft a b = cross (b .-. a) (p .-. a) + isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ---------------------------------------------- @@ -313,25 +424,108 @@ -- concatenation, so applying multiple clipping paths is sensible. -- The clipping region is the intersection of all the applied -- clipping paths. -newtype Clip = Clip { getClip :: [Path R2] } +newtype Clip n = Clip [Path V2 n] deriving (Typeable, Semigroup) -instance AttributeClass Clip -type instance V Clip = R2 +makeWrapped ''Clip -instance Transformable Clip where +instance Typeable n => AttributeClass (Clip n) + +instance AsEmpty (Clip n) where + _Empty = _Clip . _Empty + +type instance V (Clip n) = V2 +type instance N (Clip n) = n + +instance (OrderedField n) => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) +-- | A point inside a clip if the point is in 'All' invididual clipping +-- paths. +instance RealFloat n => HasQuery (Clip n) All where + getQuery (Clip paths) = Query $ \p -> + F.foldMap (All . flip isInsideWinding p) paths + +_Clip :: Iso (Clip n) (Clip n') [Path V2 n] [Path V2 n'] +_Clip = _Wrapped + +-- | Lens onto the Clip in a style. An empty list means no clipping. +_clip :: (Typeable n, OrderedField n) => Lens' (Style V2 n) [Path V2 n] +_clip = atTAttr . non' _Empty . _Clip + -- | Clip a diagram by the given path: -- -- * Only the parts of the diagram which lie in the interior of the -- path will be drawn. -- -- * The envelope of the diagram is unaffected. -clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a +clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a clipBy = applyTAttr . Clip . (:[]) --- XXX Should include a 'clipTo' function which clips a diagram AND --- restricts its envelope. It will have to take a *pointwise minimum* --- of the diagram's current envelope and the path's envelope. Not --- sure of the best way to do this at the moment. +-- | Clip a diagram to the given path setting its envelope to the +-- pointwise minimum of the envelopes of the diagram and path. The +-- trace consists of those parts of the original diagram's trace +-- which fall within the clipping path, or parts of the path's trace +-- within the original diagram. +clipTo :: TypeableFloat n + => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d + where + envP = appEnvelope . getEnvelope $ p + envD = appEnvelope . getEnvelope $ d + toEnvelope = case (envP, envD) of + (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) + (_, _) -> id + intersectionTrace = Trace traceIntersections + traceIntersections pt v = + -- on boundary of d, inside p + onSortedList (filter pInside) (appTrace (getTrace d) pt v) <> + -- or on boundary of p, inside d + onSortedList (filter dInside) (appTrace (getTrace p) pt v) where + newPt dist = pt .+^ v ^* dist + pInside dDist = runFillRule Winding p (newPt dDist) + dInside pDist = getAny . sample d $ newPt pDist + +-- | Clip a diagram to the clip path taking the envelope and trace of the clip +-- path. +clipped :: TypeableFloat n + => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipped p = withTrace p . withEnvelope p . clipBy p + +------------------------------------------------------------ +-- Intersections ----------------------------------------- +------------------------------------------------------------ + +-- | Find the intersect points of two objects that can be converted to a path. +intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) + => t -> s -> [P2 n] +intersectPoints = intersectPoints' 1e-8 + +-- | Find the intersect points of two objects that can be converted to a path +-- within the given tolerance. +intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) + => n -> t -> s -> [P2 n] +intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) + +-- | Compute the intersect points between two paths. +intersectPointsP :: OrderedField n => Path V2 n -> Path V2 n -> [P2 n] +intersectPointsP = intersectPointsP' 1e-8 + +-- | Compute the intersect points between two paths within given tolerance. +intersectPointsP' :: OrderedField n => n -> Path V2 n -> Path V2 n -> [P2 n] +intersectPointsP' eps as bs = do + a <- pathTrails as + b <- pathTrails bs + intersectPointsT' eps a b + +-- | Compute the intersect points between two located trails. +intersectPointsT :: OrderedField n => Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] +intersectPointsT = intersectPointsT' 1e-8 + +-- | Compute the intersect points between two located trails within the given +-- tolerance. +intersectPointsT' :: OrderedField n => n -> Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] +intersectPointsT' eps as bs = do + a <- fixTrail as + b <- fixTrail bs + intersectPointsS' eps a b diff --git a/src/Diagrams/TwoD/Points.hs b/src/Diagrams/TwoD/Points.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Points.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ConstraintKinds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Points +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Special functions for points in R2. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.TwoD.Points where + +import Data.List + +import Diagrams.Core +import Diagrams.TwoD.Vector +import Diagrams.TwoD.Types (P2) + +import Linear.Affine + +-- | Find the convex hull of a list of points using Andrew's monotone chain +-- algorithm O(n log n). +-- +-- Returns clockwise list of points starting from the left-most point. +convexHull2D :: OrderedField n => [P2 n] -> [P2 n] +convexHull2D ps = init upper ++ reverse (tail lower) + where + (upper, lower) = sortedConvexHull (sort ps) + +-- | Find the convex hull of a set of points already sorted in the x direction. +-- The first list of the tuple is the upper hull going clockwise from +-- left-most to right-most point. The second is the lower hull from +-- right-most to left-most in the anti-clockwise direction. +sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n]) +sortedConvexHull ps = (chain True ps, chain False ps) + where + chain upper (p1_:p2_:rest_) = + case go (p2_ .-. p1_) p2_ rest_ of + Right l -> p1_:l + Left l -> chain upper (p1_:l) + where + test = if upper then (>0) else (<0) + -- find the convex hull by comparing the angles of the vectors with + -- the cross product and backtracking if necessary + go dir p1 l@(p2:rest) + -- backtrack if the direction is outward + | test $ dir `cross2` dir' = Left l + | otherwise = + case go dir' p2 rest of + Left m -> go dir p1 m + Right m -> Right (p1:m) + where + dir' = p2 .-. p1 + go _ p1 p = Right (p1:p) + + chain _ l = l diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -20,7 +22,7 @@ -- * Polygons PolyType(..) , PolyOrientation(..) - , PolygonOpts(..) + , PolygonOpts(..), polyType, polyOrient, polyCenter , polygon , polyTrail @@ -44,36 +46,34 @@ ) where -import Control.Monad (forM, liftM) -import Control.Monad.ST (ST, runST) -import Data.Array.ST (STUArray, newArray, readArray, - writeArray) -import qualified Data.Foldable as F -import Data.List (maximumBy, minimumBy) -import qualified Data.List.NonEmpty as NEL -import Data.Maybe (catMaybes) -import Data.Monoid (mconcat, mempty) -import Data.Ord (comparing) - -import Data.AffineSpace ((.+^), (.-.)) -import Data.Default.Class -import Data.VectorSpace (magnitude, normalized, project, (<.>), - (^*)) +import Control.Lens (Lens', generateSignatures, lensRules, + makeLensesWith, view, (.~), (^.)) +import Control.Monad (forM, liftM) +import Control.Monad.ST (ST, runST) +import Data.Array.ST (STUArray, newArray, readArray, + writeArray) +import Data.Default +import Data.List (maximumBy, minimumBy) +import Data.Maybe (catMaybes) +import Data.Ord (comparing) +import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path -import Diagrams.Points (centroid) -import Diagrams.Segment +import Diagrams.Points (centroid) import Diagrams.Trail import Diagrams.TrailLike -import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) -import Diagrams.Util (tau, ( # )) +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, ( # )) +import Linear.Affine +import Linear.Metric +import Linear.Vector + -- | Method used to determine the vertices of a polygon. -data PolyType = forall a. Angle a => PolyPolar [a] [Double] +data PolyType n = PolyPolar [Angle n] [n] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -90,21 +90,21 @@ -- circle) can be constructed using a second -- argument of @(repeat r)@. - | forall a. Angle a => PolySides [a] [Double] + | PolySides [Angle n] [n] -- ^ A polygon determined by the distance between - -- successive vertices and the angles formed by - -- each three successive vertices. In other + -- successive vertices and the external angles formed + -- by each three successive vertices. In other -- words, a polygon specified by \"turtle -- graphics\": go straight ahead x1 units; turn by - -- angle a1; go straght ahead x2 units; turn by - -- angle a2; etc. The polygon will be centered at - -- the /centroid/ of its vertices. + -- external angle a1; go straight ahead x2 units; turn by + -- external angle a2; etc. The polygon will be centered + -- at the /centroid/ of its vertices. -- -- * The first argument is a list of /vertex/ - -- /angles/, giving the angle at each vertex + -- /angles/, giving the external angle at each vertex -- from the previous vertex to the next. The - -- first angle in the list is the angle at the - -- /second/ vertex; the first edge always starts + -- first angle in the list is the external angle at + -- the /second/ vertex; the first edge always starts -- out heading in the positive y direction from -- the first vertex. -- @@ -115,69 +115,73 @@ -- angles and /n-1/ edge lengths. Extra angles or -- lengths are ignored. - | PolyRegular Int Double + | PolyRegular Int n -- ^ A regular polygon with the given number of -- sides (first argument) and the given radius -- (second argument). -- | Determine how a polygon should be oriented. -data PolyOrientation = NoOrient -- ^ No special orientation; the first - -- vertex will be at (1,0). - -- This is the default. - | OrientH -- ^ Orient /horizontally/, so the - -- bottommost edge is parallel to - -- the x-axis. - | OrientV -- ^ Orient /vertically/, so the - -- leftmost edge is parallel to the - -- y-axis. - | OrientTo R2 -- ^ Orient so some edge is - -- /facing/ /in/ /the/ /direction/ - -- /of/, that is, perpendicular - -- to, the given vector. - deriving (Eq, Ord, Show, Read) +data PolyOrientation n = NoOrient -- ^ No special orientation; the first + -- vertex will be at (1,0). + | OrientH -- ^ Orient /horizontally/, so the + -- bottommost edge is parallel to + -- the x-axis. + -- This is the default. + | OrientV -- ^ Orient /vertically/, so the + -- leftmost edge is parallel to the + -- y-axis. + | OrientTo (V2 n) -- ^ Orient so some edge is + -- /facing/ /in/ /the/ /direction/ + -- /of/, that is, perpendicular + -- to, the given vector. + deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. -data PolygonOpts = PolygonOpts - { polyType :: PolyType - -- ^ Specification for the polygon's vertices. +data PolygonOpts n = PolygonOpts + { _polyType :: PolyType n + , _polyOrient :: PolyOrientation n + , _polyCenter :: Point V2 n + } - , polyOrient :: PolyOrientation - -- ^ Should a rotation be applied to the - -- polygon in order to orient it in a - -- particular way? +makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts - , polyCenter :: P2 - -- ^ Should a translation be applied to the - -- polygon in order to place the center at a - -- particular location? - } +-- | Specification for the polygon's vertices. +polyType :: Lens' (PolygonOpts n) (PolyType n) +-- | Should a rotation be applied to the polygon in order to orient it in a +-- particular way? +polyOrient :: Lens' (PolygonOpts n) (PolyOrientation n) + +-- | Should a translation be applied to the polygon in order to place the center +-- at a particular location? +polyCenter :: Lens' (PolygonOpts n) (Point V2 n) + -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. -instance Default PolygonOpts where +instance Num n => Default (PolygonOpts n) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. -polyTrail :: PolygonOpts -> Located (Trail R2) +polyTrail :: OrderedField n => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr where - tr = case polyType po of + tr = case po^.polyType of PolyPolar ans szs -> polyPolarTrail ans szs PolySides ans szs -> polySidesTrail ans szs PolyRegular n r -> polyRegularTrail n r - ori = case polyOrient po of - OrientH -> orient unit_Y tr - OrientV -> orient unitX tr - OrientTo v -> orient v tr - NoOrient -> mempty + ori = case po^.polyOrient of + OrientH -> orient unit_Y tr + OrientV -> orient unitX tr + OrientTo v -> orient v tr + NoOrient -> mempty -- | Generate the polygon described by the given options. -polygon :: (TrailLike t, V t ~ R2) => PolygonOpts -> t +polygon :: (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -186,51 +190,57 @@ tr = closeTrail . trailFromVertices $ zipWith (\a l -> rotate a . scale l $ p2 (1,0)) - (scanl (+) 0 ans) + (scanl (^+^) zero ans) (r:rs) -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where - ans' = scanl (+) 0 ans + ans' = scanl (^+^) zero ans offsets = zipWith rotate ans' (map (unitY ^*) ls) ps = scanl (.+^) origin offsets tr = closeTrail . trailFromOffsets $ offsets -- | Generate the vertices of a regular polygon. See 'PolyRegular'. -polyRegularTrail :: Int -> Double -> Located (Trail R2) +polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n) polyRegularTrail n r = polyPolarTrail - (take (n-1) . repeat $ (tau::Rad) / fromIntegral n) + (replicate (n - 1) $ fullTurn ^/ fromIntegral n) (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ -- generates the smallest rotation such that one of the segments -- adjacent to the vertex furthest in the direction of @v@ is -- perpendicular to @v@. -orient :: R2 -> Located (Trail R2) -> T2 +orient :: OrderedField n => V2 n -> Located (Trail V2 n) -> Transformation V2 n orient v = orientPoints v . trailVertices -orientPoints :: R2 -> [P2] -> T2 +orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n +orientPoints _ [] = mempty +orientPoints _ [_] = mempty orientPoints v xs = rotation a where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail (cycle xs)) xs (last xs : init xs)) - distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) - sndOf3 (_,x,_) = x - a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] - v' = normalized v + distAlong w ((.-. origin) -> p) = signum (w `dot` p) * norm (project w p) + sndOf3 (_,b,_) = b + -- a :: Angle (Scalar v) + a = minimumBy (comparing $ abs . view rad) + . map (angleFromNormal . (.-. x)) $ [n1,n2] + v' = signorm v + -- angleFromNormal :: v -> Angle (Scalar v) angleFromNormal o | leftTurn o' v' = phi - | otherwise = negate phi + | otherwise = negated phi where - o' = normalized o - theta = acos (v' <.> o') + o' = signorm o + theta = acos (v' `dot` o') + -- phi :: Angle (Scalar v) phi - | theta <= tau/4 = Rad $ tau/4 - theta - | otherwise = Rad $ theta - tau/4 + | theta <= tau/4 = tau/4 - theta @@ rad + | otherwise = theta - tau/4 @@ rad ------------------------------------------------------------ -- Function graphs @@ -267,10 +277,10 @@ markRho :: Int -> STUArray s Int Bool -> ST s [Int] markRho i marks = do isMarked <- readArray marks i - case isMarked of - True -> return [] - False -> writeArray marks i True >> - liftM (i:) (markRho (f_n i) marks) + if isMarked + then return [] + else writeArray marks i True >> + liftM (i:) (markRho (f_n i) marks) splitParts :: [Int] -> [GraphPart Int] splitParts tr = hair ++ cyc @@ -309,13 +319,13 @@ -- | Create a generalized /star/ /polygon/. The 'StarOpts' are used -- to determine in which order the given vertices should be -- connected. The intention is that the second argument of type --- @[P2]@ could be generated by a call to 'polygon', 'regPoly', or +-- @[Point v]@ could be generated by a call to 'polygon', 'regPoly', or -- the like, since a list of vertices is 'TrailLike'. But of course --- the list can be generated any way you like. A @'Path' 'R2'@ is +-- the list can be generated any way you like. A @'Path' 'v'@ is -- returned (instead of any 'TrailLike') because the resulting path -- may have more than one component, for example if the vertices are -- to be connected in several disjoint cycles. -star :: StarOpts -> [P2] -> Path R2 +star :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n star sOpts vs = graphToPath $ mkGraph f vs where f = case sOpts of StarFun g -> g diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,7 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Orphan Traced instances for Segment Closed V2 and FixedSegment V2. +-- They can't go in Traced; but they shouldn't really go in +-- Diagrams.Segment either because we only have Traced instances for +-- the special case of R2. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Segment @@ -14,90 +22,358 @@ -- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Segment where +module Diagrams.TwoD.Segment + ( -- * Segment intersections -import Control.Applicative (liftA2) + intersectPointsS + , intersectPointsS' -import Data.AffineSpace -import Data.Monoid.Inf hiding (minimum) -import Data.VectorSpace + -- * Closest point on a segment + , closestPoint + , closestPoint' + , closestDistance + , closestDistance' + , closestParam + , closestParam' + + -- ** Low level functions + , segmentSegment + , lineSegment + ) + where + +import Control.Lens hiding (at, contains, transform, ( # )) +import Data.Maybe + import Diagrams.Core -import Diagrams.Core.Trace +import Diagrams.Direction import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Diagrams.Solve +import Diagrams.TwoD.Points +import Diagrams.TwoD.Segment.Bernstein import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types +import Diagrams.TwoD.Types hiding (p2) import Diagrams.TwoD.Vector -import Diagrams.Util -instance Traced (Segment Closed R2) where +import Linear.Affine +import Linear.Metric + +{- All instances of Traced should maintain the invariant that the list of + traces is sorted in increasing order. +-} + +instance OrderedField n => Traced (Segment Closed V2 n) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance Traced (FixedSegment R2) where +instance OrderedField n => Traced (FixedSegment V2 n) where + getTrace seg = mkTrace $ \p v -> + mkSortedList . map (view _1) $ lineSegment defEps (v `at` p) seg -{- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of - intersection in 2D is given by +defEps :: Fractional n => n +defEps = 1e-8 - t_i = (v_(1-i)^ . (p1 - p0)) / (v1^ . v0) +-- | Compute the intersections between two fixed segments. +intersectPointsS :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] +intersectPointsS = intersectPointsS' defEps - where v^ denotes the perpendicular to v, i.e. v rotated by - -tau/4. +-- | Compute the intersections between two segments using the given tolerance. +intersectPointsS' :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] +intersectPointsS' eps s1 s2 = map (view _3) $ segmentSegment eps s1 s2 - This can be derived by starting with the parametric equation +-- | Get the closest distance(s) from a point to a 'FixedSegment'. +closestDistance :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] +closestDistance = closestDistance' defEps - p0 + v0 t0 = p1 + v1 t1 +-- | Get the closest distance(s) from a point to a 'FixedSegment' within given +-- tolerance. +closestDistance' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] +closestDistance' eps seg p = map (distanceA p) $ closestPoint' eps seg p - and rearranging to get the matrix equation +-- | Get the closest point(s) on a 'FixedSegment' from a point. +closestPoint :: OrderedField n => FixedSegment V2 n -> P2 n -> [P2 n] +closestPoint = closestPoint' defEps - [v0 -v1] [ t0 ] = (p1 - p0) - [ t1 ] +-- | Get the closest point(s) on a 'FixedSegment' from a point within given +-- tolerance. +closestPoint' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [P2 n] +closestPoint' eps seg = map (seg `atParam`) . closestParam' eps seg - Working out the product of the inverse of [v0 -v1] with (p1 - p0) - results in the above formulas for t_i. --} +-- | Find the closest value(s) on the Bêzier to the given point. +closestParam :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] +closestParam = closestParam' defEps - getTrace (FLinear p0 p0') = mkTrace $ \p1 v1 -> - let - v0 = p0' .-. p0 - det = perp v1 <.> v0 - perp v = rotateBy (-1/4) v - p = p1 .-. p0 - t0 = (perp v1 <.> p) / det - t1 = (perp v0 <.> p) / det - in - if det == 0 || t0 < 0 || t0 > 1 - then Infinity - else Finite t1 +-- | Find the closest value(s) on the Bêzier to the given point within given +-- tolerance. +closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] +closestParam' _ (FLinear p0 p1) p + | t < 0 = [0] + | t > 1 = [1] + | otherwise = [t] + where + vp = p .-. p0 + v = p1 .-. p0 + dp = vp `dot` v + t = dp / quadrance v +closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1 + where + (bx, by) = bezierToBernstein cb + bx' = bernsteinDeriv bx + by' = bernsteinDeriv by + poly = (bx - listToBernstein [px, px, px, px]) * bx' + + (by - listToBernstein [py, py, py, py]) * by' -{- To do intersection of a line with a cubic Bezier, we first rotate - and scale everything so that the line has parameters (origin, unitX); - then we find the intersection(s) of the Bezier with the x-axis. +------------------------------------------------------------------------ +-- Low level +------------------------------------------------------------------------ - XXX could we speed this up by first checking whether all the - control point y-coordinates lie on the same side of the x-axis (if so, - there can't possibly be any intersections)? Need to set up some - benchmarks. --} +-- | Return the intersection points with the parameters at which each segment +-- intersects. +segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)] +segmentSegment eps s1 s2 = + case (s1,s2) of + (FCubic{}, FCubic{}) -> map (\(t1,t2) -> (t1,t2, s1 `atParam` t1)) + $ bezierClip eps s1 s2 + (FCubic{}, FLinear{}) -> map flip12 $ linearSeg (segLine s2) s1 + _ -> linearSeg (segLine s1) s2 -- s1 is linear + where + linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s + flip12 (a,b,c) = (b,a,c) - getTrace bez@(FCubic {}) = mkTrace $ \p1 v1 -> - let - bez'@(FCubic x1 c1 c2 x2) = - bez # moveOriginTo p1 - # rotateBy (negate (direction v1)) - # scale (1/magnitude v1) - [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] - a = -y0 + 3*y1 - 3*y2 + y3 - b = 3*y0 - 6*y1 + 3*y2 - c = -3*y0 + 3*y1 - d = y0 - ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d) - xs = map (fst . unp2 . atParam bez') ts - in - case xs of - [] -> Infinity - _ -> Finite (minimum xs) +-- | Return the intersection points with the parameters at which the line and segment +-- intersect. +lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)] +lineSegment _ l1 p@(FLinear p0 p1) + = map (\(tl,tp) -> (tl, tp, p `atParam` tp)) + . filter (inRange . snd) . maybeToList $ lineLine l1 (mkLine p0 p1) +lineSegment eps (viewLoc -> (p,r)) cb = map addPoint params + where + params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1 + cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb + -- + addPoint bt = (lt, bt, intersect) + where + intersect = cb `atParam` bt + lt = (cb' `atParam` bt) ^. _x / norm r + +-- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier + +-- | Use the Bêzier clipping algorithm to return the parameters at which the +-- Bêzier curves intersect. +bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)] +bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN + $ go p_ q_ 0 1 0 1 0 False + where + go p q tmin tmax umin umax clip revCurves + | isNothing chopInterval = [] + + -- This check happens before the subdivision + -- test to avoid non-termination as values + -- transition to within epsilon. + | max (umax - umin) (tmax' - tmin') < eps = + if revCurves -- return parameters in correct order + then [ (avg umin umax, avg tmin' tmax') ] + else [ (avg tmin' tmax', avg umin umax ) ] + + -- split the curve if there isn't enough reduction + | clip > 0.8 && clip' > 0.8 = + if tmax' - tmin' > umax - umin -- split the longest segment + then let (pl, pr) = p' `splitAtParam` 0.5 + tmid = avg tmin' tmax' + in go q pl umin umax tmin' tmid clip' (not revCurves) ++ + go q pr umin umax tmid tmax' clip' (not revCurves) + else let (ql, qr) = q `splitAtParam` 0.5 + umid = avg umin umax + in go ql p' umin umid tmin' tmax' clip' (not revCurves) ++ + go qr p' umid umax tmin' tmax' clip' (not revCurves) + + -- iterate with the curves reversed. + | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves) + where + chopInterval = chopCubics p q + Just (tminChop, tmaxChop) = chopInterval + p' = section p tminChop tmaxChop + clip' = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) + +-- | Find the zero of a 1D Bêzier curve of any degree. Note that this +-- can be used as a Bernstein polynomial root solver by converting from +-- the power basis to the Bernstein basis. +bezierFindRoot :: OrderedField n + => n -- ^ The accuracy + -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial + -> n -- ^ The lower bound of the interval + -> n -- ^ The upper bound of the interval + -> [n] -- ^ The roots found +bezierFindRoot eps p tmin tmax + -- If we generated the max number of roots and tmax is also a root + -- (which is not among the generated ones), there must in fact be an + -- infinite number of roots, so just include tmax. + | length roots == bernsteinDegree p && last roots /= tmax && abs (evaluateBernstein p tmax) <= eps + = roots ++ [tmax] + | otherwise = roots + where + -- Lazily take a number of roots at most the degree of the bernstein + -- polynomial, to avoid generating a ton of roots in the case of a + -- straight Bezier segment along the x-axis. See https://github.com/diagrams/diagrams-contrib/issues/91 . + roots = take (bernsteinDegree p) $ go p tmin tmax + go p tmin tmax + | isNothing chopInterval = [] + | tmax' - tmin' < eps = [avg tmin' tmax'] + | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 + tmid = tmin' + (tmax' - tmin') / 2 + in go p1 tmin' tmid ++ + go p2 tmid tmax' + | otherwise = bezierFindRoot eps newP tmin' tmax' + where + chopInterval = chopYs (bernsteinCoeffs p) + Just (tminChop, tmaxChop) = chopInterval + newP = section p tminChop tmaxChop + clip = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) + +------------------------------------------------------------------------ +-- Internal +------------------------------------------------------------------------ + +-- | An approximation of the fat line for a cubic Bêzier segment. Returns +-- @(0,0)@ for a linear segment. +fatLine :: OrderedField n => FixedSegment V2 n -> (n,n) +fatLine (FCubic p0 p1 p2 p3) + = case (d1 > 0, d2 > 0) of + (True, True) -> (0, 0.75 * max d1 d2) + (False, False) -> (0.75 * min d1 d2, 0 ) + (True, False) -> (4/9 * d2, 4/9 * d1 ) + (False, True) -> (4/9 * d1, 4/9 * d2 ) + where + d = lineDistance p0 p3 + d1 = d p1; d2 = d p2 +fatLine _ = (0,0) + +chopYs :: OrderedField n => [n] -> Maybe (n, n) +chopYs ds = chopHull 0 0 points + where + points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0..n]] ds + n = length ds - 1 + +chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n,n) +chopCubics p q@(FCubic q0 _ _ q3) + = chopHull dmin dmax dps + where + dps = zipWith mkP2 [0, 1/3, 2/3, 1] ds + ds = p ^.. each . to d + d = lineDistance q0 q3 + -- + (dmin,dmax) = fatLine q +chopCubics _ _ = Nothing + +-- Reduce the interval which the intersection is known to lie in using the fat +-- line of one curve and convex hull of the points formed from the distance to +-- the thin line of the other +chopHull :: OrderedField n => n -> n -> [P2 n] -> Maybe (n, n) +chopHull dmin dmax dps = do + tL <- testBelow upper $ testBetween (head upper) $ testAbove lower + tR <- testBelow (reverse upper) $ testBetween (last upper) $ testAbove (reverse lower) + Just (tL, tR) + where + (upper, lower) = sortedConvexHull dps + + testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue + | y1 >= dmin = continue + | y1 > y2 = Nothing + | y2 < dmin = testBelow (p2:ps) continue + | otherwise = Just $ intersectPt dmin p1 p2 + testBelow _ _ = Nothing + + testBetween (P (V2 x y)) continue + | y <= dmax = Just x + | otherwise = continue + + testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) + | y1 < y2 = Nothing + | y2 > dmax = testAbove (p2:ps) + | y2 - y1 == 0 = Nothing -- Check this condition to prevent + -- division by zero in `intersectPt`. + | otherwise = Just $ intersectPt dmax p1 p2 + testAbove _ = Nothing + + -- find the x value where the line through the two points + -- intersect the line y=d. Note that `y2 - y1 != 0` due + -- to checks above. + intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = + x1 + (d - y1) * (x2 - x1) / (y2 - y1) + + + +bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n) +bezierToBernstein seg = + (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) + where coeffs = toListOf each seg + +------------------------------------------------------------------------ +-- Lines +------------------------------------------------------------------------ + +-- Could split this into a separate module. + +-- | Returns @(a, b, c, d)@ such that @ax + by + c = 0@ is the line going through +-- @p1@ and @p2@ with @(a^2)/d + (b^2)/d = 1@. We delay the division by +-- @d@ as it may not be needed in all cases and @d@ may be zero. +lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n, n) +lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c, d) + where + c = -(x1*a + y1*b) + a = y1 - y2 + b = x2 - x1 + d = a*a + b*b + +-- | Return the distance from a point to the line. +lineDistance :: (Ord n, Floating n) => P2 n -> P2 n -> P2 n -> n +lineDistance p1 p2 p3@(P (V2 x y)) + -- I have included the check that d' <= 0 in case + -- there exists some d > 0 where sqrt d == 0. I don't + -- think this can happen as sqrt is at least recommended + -- to be within one value of correct for sqrt and near + -- zero values get bigger. + | d <= 0 || d' <= 0 = norm (p1 .-. p3) + | otherwise = (a*x + b*y + c) / d' + where + (a, b, c, d) = lineEquation p1 p2 + d' = sqrt d + +-- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool +-- clockwise a b = a `cross2` b <= 0 + +avg :: Fractional n => n -> n -> n +avg a b = (a + b)/2 + +lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n,n) +lineLine (viewLoc -> (p,r)) (viewLoc -> (q,s)) + | x1 == 0 && x2 /= 0 = Nothing -- parallel + | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear + where + x1 = r × s + x2 = v × r + x3 = v × s + v = q .-. p + +(×) :: Num n => V2 n -> V2 n -> n +(×) = cross2 + +mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n) +mkLine p0 p1 = (p1 .-. p0) `at` p0 + +segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n) +segLine (FLinear p0 p1) = mkLine p0 p1 +segLine (FCubic p0 _ _ p3) = mkLine p0 p3 + +-- This function uses `defEps`, but is used in functions +-- above that take an epsilon parameter. It would be nice +-- to clearify the meaning of each of these epsilons. +inRange :: (Fractional n, Ord n) => n -> Bool +inRange x = x < (1+defEps) && x > (-defEps) diff --git a/src/Diagrams/TwoD/Segment/Bernstein.hs b/src/Diagrams/TwoD/Segment/Bernstein.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Segment/Bernstein.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Segment.Bernstein +-- Copyright : (c) 2014-2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Bernstein polynomials, used internally by code to find +-- intersections of paths. This module is probably not of any +-- relevance to most users of diagrams. +----------------------------------------------------------------------------- +module Diagrams.TwoD.Segment.Bernstein + ( BernsteinPoly (..) + , listToBernstein + , evaluateBernstein + + , degreeElevate + , bernsteinDeriv + , evaluateBernsteinDerivs + ) where + +import Data.List (tails) +import Diagrams.Core.V +import Diagrams.Parametric +import Linear.V1 + +-- | Compute the binomial coefficients of degree n. +binomials :: Num n => Int -> [n] +binomials n = map fromIntegral $ scanl (\x m -> x * (n - m+1) `quot` m) 1 [1..n] + +data BernsteinPoly n = BernsteinPoly + { bernsteinDegree :: Int + , bernsteinCoeffs :: [n] + } deriving (Show, Functor) + +type instance V (BernsteinPoly n) = V1 +type instance N (BernsteinPoly n) = n +type instance Codomain (BernsteinPoly n) = V1 + +-- | Create a bernstein polynomial from a list of coëfficients. +listToBernstein :: Fractional n => [n] -> BernsteinPoly n +listToBernstein [] = 0 +listToBernstein l = BernsteinPoly (length l - 1) l + +-- | Degree elevate a bernstein polynomial a number of times. +degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n +degreeElevate b 0 = b +degreeElevate (BernsteinPoly lp p) times = + degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1) + where + n = fromIntegral lp + + inner [] _ = [0] + inner [a] _ = [a] + inner (a:b:rest) i = (i*a/(n+1) + b*(1 - i/(n+1))) : inner (b:rest) (i+1) + +-- | Evaluate the bernstein polynomial. +evaluateBernstein :: Fractional n => BernsteinPoly n -> n -> n +evaluateBernstein (BernsteinPoly _ []) _ = 0 +evaluateBernstein (BernsteinPoly _ [b]) _ = b +evaluateBernstein (BernsteinPoly lp (b':bs)) t = go t n (b'*u) 2 bs + where + u = 1-t + n = fromIntegral lp + + go tn bc tmp _ [b] = tmp + tn*bc*b + go tn bc tmp i (b:rest) = + go (tn*t) -- tn + (bc*(n - i+1)/i) -- bc + ((tmp + tn*bc*b)*u) -- tmp + (i+1) -- i + rest + go _ _ _ _ [] = error "evaluateBernstein: impossible" + +-- | Evaluate the bernstein polynomial and its derivatives. +evaluateBernsteinDerivs :: Fractional n => BernsteinPoly n -> n -> [n] +evaluateBernsteinDerivs b t + | bernsteinDegree b == 0 = [evaluateBernstein b t] + | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t + +-- | Find the derivative of a bernstein polynomial. +bernsteinDeriv :: Fractional n => BernsteinPoly n -> BernsteinPoly n +bernsteinDeriv (BernsteinPoly 0 _) = 0 +bernsteinDeriv (BernsteinPoly lp p) = + -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (tail p) p + BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p + +instance Fractional n => Parametric (BernsteinPoly n) where + atParam b = V1 . evaluateBernstein b +instance Num n => DomainBounds (BernsteinPoly n) +instance Fractional n => EndValues (BernsteinPoly n) +instance Fractional n => Sectionable (BernsteinPoly n) where + splitAtParam = bernsteinSplit + reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) + +-- | Split a bernstein polynomial. +bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) +bernsteinSplit (BernsteinPoly lp p) t = + (BernsteinPoly lp $ map head controls, + BernsteinPoly lp $ reverse $ map last controls) + where + interp a b = (1-t)*a + t*b + + terp [_] = [] + terp l = let ctrs = zipWith interp l (tail l) + in ctrs : terp ctrs + controls = p : terp p + +instance Fractional n => Num (BernsteinPoly n) where + ba@(BernsteinPoly la a) + bb@(BernsteinPoly lb b) + | la < lb = BernsteinPoly lb $ zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b + | la > lb = BernsteinPoly la $ zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb) + | otherwise = BernsteinPoly la $ zipWith (+) a b + + ba@(BernsteinPoly la a) - bb@(BernsteinPoly lb b) + | la < lb = BernsteinPoly lb $ zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b + | la > lb = BernsteinPoly la $ zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) + | otherwise = BernsteinPoly la $ zipWith (-) a b + + (BernsteinPoly la a) * (BernsteinPoly lb b) = + BernsteinPoly (la+lb) $ + zipWith (flip (/)) (binomials (la + lb)) $ + init $ map sum $ + map (zipWith (*) a') (down b') ++ + map (zipWith (*) (reverse b')) (tail $ tails a') + -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b') + where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ... + a' = zipWith (*) a (binomials la) + b' = zipWith (*) b (binomials lb) + + fromInteger a = BernsteinPoly 0 [fromInteger a] + + signum (BernsteinPoly _ []) = 0 + signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a] + + abs = fmap abs diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Shapes @@ -25,6 +30,7 @@ , square , pentagon , hexagon + , heptagon , septagon , octagon , nonagon @@ -39,13 +45,17 @@ -- * Other shapes , roundedRect - , RoundedRectOpts(..) + , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR , roundedRect' ) where +import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) +import Data.Default +import Data.Semigroup + import Diagrams.Core -import Diagrams.Coordinates +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment @@ -55,56 +65,54 @@ import Diagrams.TwoD.Polygons import Diagrams.TwoD.Transform import Diagrams.TwoD.Types - +import Diagrams.TwoD.Vector import Diagrams.Util -import Data.Default.Class -import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. -- --- <> +-- <> -- --- > hruleEx = vcat' with {sep = 0.2} (map hrule [1..5]) +-- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 -hrule :: (TrailLike t, V t ~ R2) => Double -> t -hrule d = trailLike $ trailFromSegments [straight (d & 0)] `at` (p2 (-d/2,0)) +hrule :: (InSpace V2 n t, TrailLike t) => n -> t +hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) -- | Create a centered vertical (T-B) line of the given length. -- --- <> +-- <> -- --- > vruleEx = hcat' with {sep = 0.2} (map vrule [1, 1.2 .. 2]) +-- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 -vrule :: (TrailLike t, V t ~ R2) => Double -> t -vrule d = trailLike $ trailFromSegments [straight (0 & (-d))] `at` (p2 (0,d/2)) +vrule :: (InSpace V2 n t, TrailLike t) => n -> t +vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- --- <> -unitSquare :: (TrailLike t, V t ~ R2) => t -unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) - , polyOrient = OrientH } +-- <> +unitSquare :: (InSpace V2 n t, TrailLike t) => t +unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) + & polyOrient .~ OrientH) -- > unitSquareEx = unitSquare # pad 1.1 # showOrigin -- | A square with its center at the origin and sides of the given -- length, oriented parallel to the axes. -- --- <> -square :: (TrailLike t, Transformable t, V t ~ R2) => Double -> t +-- <> +square :: (InSpace V2 n t, TrailLike t) => n -> t square d = rect d d --- > squareEx = hcat' with {sep = 0.5} [square 1, square 2, square 3] --- > # centerXY # pad 1.1 # lw 0.03 +-- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] +-- > # centerXY # pad 1.1 -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. -- --- <> -rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t -rect w h = trailLike . head . pathTrails $ unitSquare # scaleX w # scaleY h +-- <> +rect :: (InSpace V2 n t, TrailLike t) => n -> n -> t +rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 @@ -135,19 +143,19 @@ -- polygons of a given /radius/). -- -- The polygon will be oriented with one edge parallel to the x-axis. -regPoly :: (TrailLike t, V t ~ R2) => Int -> Double -> t -regPoly n l = polygon with { polyType = +regPoly :: (InSpace V2 n t, TrailLike t) => Int -> n -> t +regPoly n l = polygon (def & polyType .~ PolySides - (repeat (1/ fromIntegral n :: Turn)) + (repeat (1/fromIntegral n @@ turn)) (replicate (n-1) l) - , polyOrient = OrientH - } + & polyOrient .~ OrientH + ) -- > shapeEx sh = sh 1 # pad 1.1 -- > triangleEx = shapeEx triangle -- > pentagonEx = shapeEx pentagon -- > hexagonEx = shapeEx hexagon --- > septagonEx = shapeEx septagon +-- > heptagonEx = shapeEx heptagon -- > octagonEx = shapeEx octagon -- > nonagonEx = shapeEx nonagon -- > decagonEx = shapeEx decagon @@ -155,76 +163,92 @@ -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. -eqTriangle :: (TrailLike t, V t ~ R2) => Double -> t +eqTriangle :: (InSpace V2 n t, TrailLike t) => n -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- --- <> -triangle :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +triangle :: (InSpace V2 n t, TrailLike t) => n -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -pentagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +pentagon :: (InSpace V2 n t, TrailLike t) => n -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -hexagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +hexagon :: (InSpace V2 n t, TrailLike t) => n -> t hexagon = regPoly 6 --- | A regular septagon, with sides of the given length and base +-- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -septagon :: (TrailLike t, V t ~ R2) => Double -> t -septagon = regPoly 7 +-- <> +heptagon :: (InSpace V2 n t, TrailLike t) => n -> t +heptagon = regPoly 7 +-- | A synonym for 'heptagon'. It is, however, completely inferior, +-- being a base admixture of the Latin /septum/ (seven) and the +-- Greek γωνία (angle). +septagon :: (InSpace V2 n t, TrailLike t) => n -> t +septagon = heptagon + -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -octagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +octagon :: (InSpace V2 n t, TrailLike t) => n -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -nonagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +nonagon :: (InSpace V2 n t, TrailLike t) => n -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -decagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +decagon :: (InSpace V2 n t, TrailLike t) => n -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -hendecagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +hendecagon :: (InSpace V2 n t, TrailLike t) => n -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> -dodecagon :: (TrailLike t, V t ~ R2) => Double -> t +-- <> +dodecagon :: (InSpace V2 n t, TrailLike t) => n -> t dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ +data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d + , _radiusTR :: d + , _radiusBL :: d + , _radiusBR :: d + } +makeLenses ''RoundedRectOpts + +instance (Num d) => Default (RoundedRectOpts d) where + def = RoundedRectOpts 0 0 0 0 + -- | @roundedRect w h r@ generates a closed trail, or closed path -- centered at the origin, of an axis-aligned rectangle with width -- @w@, height @h@, and circular rounded corners of radius @r@. If @@ -236,30 +260,30 @@ -- a different radius for each corner individually, use -- 'roundedRect'' instead. -- --- <> +-- <> -- --- > roundedRectEx = pad 1.1 . centerXY $ hcat' with { sep = 0.2 } +-- > roundedRectEx = pad 1.1 . centerXY $ hcat' (with & sep .~ 0.2) -- > [ roundedRect 0.5 0.4 0.1 -- > , roundedRect 0.5 0.4 (-0.1) --- > , roundedRect' 0.7 0.4 with { radiusTL = 0.2 --- > , radiusTR = -0.2 --- > , radiusBR = 0.1 } +-- > , roundedRect' 0.7 0.4 (with & radiusTL .~ 0.2 +-- > & radiusTR .~ -0.2 +-- > & radiusBR .~ 0.1) -- > ] -roundedRect :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> t -roundedRect w h r = roundedRect' w h (with { radiusTL = r, - radiusBR = r, - radiusTR = r, - radiusBL = r}) +roundedRect :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> n -> t +roundedRect w h r = roundedRect' w h (def & radiusTL .~ r + & radiusBR .~ r + & radiusTR .~ r + & radiusBL .~ r) -- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. -roundedRect' :: (TrailLike t, V t ~ R2) => Double -> Double -> RoundedRectOpts -> t +roundedRect' :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> RoundedRectOpts n -> t roundedRect' w h opts = trailLike - . (`at` (p2 (w/2, abs rBR - h/2))) + . (`at` p2 (w/2, abs rBR - h/2)) . wrapTrail . glueLine $ seg (0, h - abs rTR - abs rBR) @@ -279,7 +303,7 @@ rBL = clampCnr radiusBR radiusTL radiusTR radiusBL rTR = clampCnr radiusTL radiusBR radiusBL radiusTR rBR = clampCnr radiusBL radiusTR radiusTL radiusBR - clampCnr rx ry ro r = let (rx',ry',ro',r') = (rx opts, ry opts, ro opts, r opts) + clampCnr rx ry ro r = let (rx',ry',ro',r') = (opts^.rx, opts^.ry, opts^.ro, opts^.r) in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r' -- prevent curves of adjacent corners from overlapping clampAdj len adj r = if abs r > len/2 @@ -291,14 +315,8 @@ else r sign n = if n < 0 then -1 else 1 mkCorner k r | r == 0 = mempty - | r < 0 = doArc 3 2 + | r < 0 = doArc 3 (-1) | otherwise = doArc 0 1 - where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn) - -data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double - , radiusTR :: Double - , radiusBL :: Double - , radiusBR :: Double - } -instance Default RoundedRectOpts where - def = RoundedRectOpts 0 0 0 0 + where + doArc d s = + arc' r (xDir & _theta <>~ ((k+d)/4 @@ turn)) (s/4 @@ turn) diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Size @@ -12,132 +14,65 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD.Size ( - -- * Size and extent of diagrams in R2 -- ** Computing sizes - width, height, size2D, sizeSpec2D - , extentX, extentY, center2D + width, height + , extentX, extentY -- ** Specifying sizes - , SizeSpec2D(..) - , mkSizeSpec - - , requiredScaleT, requiredScale + , mkSizeSpec2D + , mkWidth + , mkHeight + , dims2D - -- ** Changing the size of things - , sized, sizedAs ) where import Diagrams.Core +import Diagrams.Core.Envelope +import Diagrams.Size import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Applicative (liftA2, (<$>)) -import Control.Arrow ((&&&), (***)) - ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -width :: (Enveloped a, V a ~ R2) => a -> Double -width = maybe 0 (negate . uncurry (-)) . extentX +-- +-- Note this is just @diameter unitX@. +width :: (InSpace V2 n a, Enveloped a) => a -> n +width = diameter unitX -- | Compute the height of an enveloped object. -height :: (Enveloped a, V a ~ R2) => a -> Double -height = maybe 0 (negate . uncurry (-)) . extentY - --- | Compute the width and height of an enveloped object. -size2D :: (Enveloped a, V a ~ R2) => a -> (Double, Double) -size2D = width &&& height - --- | Compute the size of an enveloped object as a 'SizeSpec2D' value. -sizeSpec2D :: (Enveloped a, V a ~ R2) => a -> SizeSpec2D -sizeSpec2D = uncurry Dims . size2D +height :: (InSpace V2 n a, Enveloped a) => a -> n +height = diameter unitY --- | Compute the absolute x-coordinate range of an enveloped object in --- R2, in the form (lo,hi). Return @Nothing@ for objects with an --- empty envelope. -extentX :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) -extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) +-- | Compute the absolute x-coordinate range of an enveloped object in +-- the form @(lo,hi)@. Return @Nothing@ for objects with an empty +-- envelope. +-- +-- Note this is just @extent unitX@. +extentX :: (InSpace v n a, R1 v, Enveloped a) => a -> Maybe (n, n) +extentX = extent unitX -- | Compute the absolute y-coordinate range of an enveloped object in --- R2, in the form (lo,hi). -extentY :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) -extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) - --- | Compute the point at the center (in the x- and y-directions) of a --- enveloped object. Return the origin for objects with an empty +-- the form @(lo,hi)@. Return @Nothing@ for objects with an empty -- envelope. -center2D :: (Enveloped a, V a ~ R2) => a -> P2 -center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) - where mm = uncurry (liftA2 (,)) - mid = (/2) . uncurry (+) - ------------------------------------------------------------- --- Size specifications ------------------------------------------------------------- - --- | A specification of a (requested) rectangular size. -data SizeSpec2D = Width Double -- ^ Specify an explicit - -- width. The height should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Height Double -- ^ Specify an explicit - -- height. The width should be - -- determined automatically (so - -- as to preserve aspect ratio). - | Dims Double Double -- ^ An explicit specification - -- of a width and height. - | Absolute -- ^ Absolute size: use whatever - -- size an object already has; - -- do not rescale. - deriving (Eq, Ord, Show) +extentY :: (InSpace v n a, R2 v, Enveloped a) => a -> Maybe (n, n) +extentY = extent unitY --- | Create a size specification from a possibly-specified width and --- height. -mkSizeSpec :: Maybe Double -> Maybe Double -> SizeSpec2D -mkSizeSpec Nothing Nothing = Absolute -mkSizeSpec (Just w) Nothing = Width w -mkSizeSpec Nothing (Just h) = Height h -mkSizeSpec (Just w) (Just h) = Dims w h +-- | Make a 'SizeSpec' from possibly-specified width and height. +mkSizeSpec2D :: Num n => Maybe n -> Maybe n -> SizeSpec V2 n +mkSizeSpec2D x y = mkSizeSpec (V2 x y) --- | @requiredScaleT spec sz@ returns a transformation (a uniform scale) --- which can be applied to something of size @sz@ to make it fit the --- requested size @spec@, without changing the aspect ratio. -requiredScaleT :: SizeSpec2D -> (Double, Double) -> Transformation R2 -requiredScaleT spec size = scaling (requiredScale spec size) +-- | Make a 'SizeSpec' from a width and height. +dims2D :: n -> n -> SizeSpec V2 n +dims2D x y = dims (V2 x y) --- | @requiredScale spec sz@ returns a scaling factor necessary to --- make something of size @sz@ fit the requested size @spec@, --- without changing the aspect ratio. Hence an explicit --- specification of both dimensions may not be honored if the aspect --- ratios do not match; in that case the scaling will be as large as --- possible so that the object still fits within the requested size. -requiredScale :: SizeSpec2D -> (Double, Double) -> Double -requiredScale Absolute _ = 1 -requiredScale (Width wSpec) (w,_) - | wSpec == 0 || w == 0 = 1 - | otherwise = wSpec / w -requiredScale (Height hSpec) (_,h) - | hSpec == 0 || h == 0 = 1 - | otherwise = hSpec / h -requiredScale (Dims wSpec hSpec) (w,h) = s - where xscale = wSpec / w - yscale = hSpec / h - s' = min xscale yscale - s | isInfinite s' = 1 - | otherwise = s' +-- | Make a 'SizeSpec' with only width defined. +mkWidth :: Num n => n -> SizeSpec V2 n +mkWidth w = dims (V2 w 0) --- | Uniformly scale any enveloped object so that it fits within the --- given size. -sized :: (Transformable a, Enveloped a, V a ~ R2) - => SizeSpec2D -> a -> a -sized spec a = transform (requiredScaleT spec (size2D a)) a +-- | Make a 'SizeSpec' with only height defined. +mkHeight :: Num n => n -> SizeSpec V2 n +mkHeight h = dims (V2 0 h) --- | Uniformly scale an enveloped object so that it \"has the same --- size as\" (fits within the width and height of) some other --- object. -sizedAs :: ( Transformable a, Enveloped a, V a ~ R2 - , Enveloped b, V b ~ R2) - => b -> a -> a -sizedAs other = sized (sizeSpec2D other) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable - , GeneralizedNewtypeDeriving - , FlexibleContexts - , TypeFamilies - , MultiParamTypeClasses - #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -19,66 +23,99 @@ -- * Creating text diagrams Text(..), TextAlignment(..) , text, topLeftText, alignedText, baselineText + , mkText, mkText' -- * Text attributes + -- ** Font family - , Font(..), getFont, font - -- ** Font size - , FontSize(..), getFontSize, fontSize, fontSizeA - -- ** Font slant - , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique - -- ** Font weight - , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold - ) where + , Font(..), _Font + , getFont, font, _font -import Diagrams.Attributes -import Diagrams.Core -import Diagrams.TwoD.Types + -- ** Font size + , FontSize(..), _FontSize + , fontSize, recommendFontSize + , fontSizeN, fontSizeO, fontSizeL, fontSizeG + , getFontSize, fontSizeM + , _fontSizeR, _fontSize, _fontSizeU -import Data.AffineSpace ((.-.)) + -- ** Font slant + , FontSlant(..) + , getFontSlant, fontSlant, italic, oblique, _fontSlant -import Data.Semigroup + -- ** Font weight + , FontWeight(..) + , getFontWeight, fontWeight, bold, bolder, lighter, _fontWeight + , thinWeight, ultraLight, light, mediumWeight, heavy, semiBold, ultraBold -import Data.Colour + ) where -import Data.Default.Class +import Control.Lens hiding (transform) +import Diagrams.Attributes (committed) +import Diagrams.Core +import Diagrams.Core.Envelope (pointEnvelope) +import Diagrams.TwoD.Attributes (recommendFillColor) +import Diagrams.TwoD.Types +import Data.Colour hiding (over) +import Data.Default +import Data.Monoid.Recommend +import Data.Semigroup import Data.Typeable +import Linear.Affine + ------------------------------------------------------------ -- Text diagrams ------------------------------------------------------------ --- | A text primitive consists of the string contents and alignment --- specification, along with a transformation mapping from the local --- vector space of the text to the vector space in which it is --- embedded. -data Text = Text T2 TextAlignment String - -type instance V Text = R2 +-- | A 'Text' primitive consists of the string contents, text alignment +-- and the transformation to be applied. The transformation is scale +-- invarient, the average scale of the transform should always be 1. +-- All text scaling is obtained from the 'FontSize' attribute. +-- +-- This constructor should not be used directly. Use 'text', +-- 'alignedText' or 'baselineText'. +data Text n = Text (T2 n) (TextAlignment n) String + deriving Typeable -instance Transformable Text where - transform t (Text tt a s) = Text (t <> tt) a s +type instance V (Text n) = V2 +type instance N (Text n) = n -instance IsPrim Text +instance Floating n => Transformable (Text n) where + transform t (Text tt a s) = Text (t <> tt <> t') a s + where t' = scaling (1 / avgScale t) -instance HasOrigin Text where +instance Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p) -instance Renderable Text NullBackend where +instance Floating n => Renderable (Text n) NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. -data TextAlignment = BaselineText | BoxAlignedText Double Double +data TextAlignment n = BaselineText | BoxAlignedText n n -mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 -mkText a t = recommendFillColor black -- See Note [recommendFillColor] - $ mkQD (Prim (Text mempty a t)) - mempty - mempty - mempty - mempty +-- | Make a text from a 'TextAlignment', recommending a fill colour of +-- 'black' and 'fontSize' of @'local' 1@. +mkText :: (TypeableFloat n, Renderable (Text n) b) + => TextAlignment n -> String -> QDiagram b V2 n Any +mkText a = recommendFillColor black + -- See Note [recommendFillColor] + . recommendFontSize (local 1) + -- See Note [recommendFontSize] + . mkText' a +-- | Make a text from a 'TextAlignment' without any default size or fill +-- colour. This is useful is you want to recommend your own using +-- 'recommendFillColor' or 'recommendFontSize'. +mkText' :: (TypeableFloat n, Renderable (Text n) b) + => TextAlignment n -> String -> QDiagram b V2 n Any +mkText' a t = mkQD (Prim $ Text mempty a t) + (pointEnvelope origin) + mempty + mempty + mempty + + -- ~~~~ Note [recommendFillColor] -- The reason we "recommend" a fill color of black instead of setting @@ -101,12 +138,16 @@ -- recommendation; normally, the innermost occurrence of an attribute -- would override all outer occurrences. +-- ~~~~ Note [recommendFontSize] +-- The reason we "recommend" a font size is so any local scales get +-- recorded. + -- | Create a primitive text diagram from the given string, with center -- alignment, equivalent to @'alignedText' 0.5 0.5@. -- -- Note that it /takes up no space/, as text size information is not -- available. -text :: Renderable Text b => String -> Diagram b R2 +text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any text = alignedText 0.5 0.5 -- | Create a primitive text diagram from the given string, origin at @@ -114,19 +155,21 @@ -- @'alignedText' 0 1@. -- -- Note that it /takes up no space/. -topLeftText :: Renderable Text b => String -> Diagram b R2 +topLeftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any topLeftText = alignedText 0 1 -- | Create a primitive text diagram from the given string, with the -- origin set to a point interpolated within the bounding box. The -- first parameter varies from 0 (left) to 1 (right), and the second --- parameter from 0 (bottom) to 1 (top). +-- parameter from 0 (bottom) to 1 (top). Some backends do not +-- implement this and instead snap to closest corner or the center. -- -- The height of this box is determined by the font's potential ascent -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. -alignedText :: Renderable Text b => Double -> Double -> String -> Diagram b R2 +alignedText :: (TypeableFloat n, Renderable (Text n) b) + => n -> n -> String -> QDiagram b V2 n Any alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the @@ -135,7 +178,8 @@ -- graphics library. -- -- Note that it /takes up no space/. -baselineText :: Renderable Text b => String -> Diagram b R2 +baselineText :: (TypeableFloat n, Renderable (Text n) b) + => String -> QDiagram b V2 n Any baselineText = mkText BaselineText ------------------------------------------------------------ @@ -149,6 +193,10 @@ -- @Font@ attributes override outer ones. newtype Font = Font (Last String) deriving (Typeable, Semigroup, Eq) + +_Font :: Iso' Font String +_Font = iso getFont (Font . Last) + instance AttributeClass Font -- | Extract the font family name from a @Font@ attribute. @@ -159,58 +207,123 @@ font :: HasStyle a => String -> a -> a font = applyAttr . Font . Last +-- | Lens onto the font name of a style. +_font :: Lens' (Style v n) (Maybe String) +_font = atAttr . mapping _Font + -------------------------------------------------- -- Font size -- | The @FontSize@ attribute specifies the size of a font's --- em-square, measured with respect to the current local vector space. --- Inner @FontSize@ attributes override outer ones. -newtype FontSize = FontSize (Last Double) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass FontSize +-- em-square. Inner @FontSize@ attributes override outer ones. +newtype FontSize n = FontSize (Recommend (Last n)) + deriving (Typeable, Semigroup) -instance Default FontSize where - def = FontSize (Last 1) +-- not sure why this can't be derived +instance Functor FontSize where + fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a))) + fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a))) +_FontSize :: Iso' (FontSize n) (Recommend n) +_FontSize = iso getter setter + where getter (FontSize (Recommend (Last a))) = Recommend a + getter (FontSize (Commit (Last a))) = Commit a + setter (Recommend a) = FontSize $ Recommend (Last a) + setter (Commit a) = FontSize $ Commit (Last a) + -- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped + -- once we depend on monoid-extras-0.4 + +_FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n)) +_FontSizeM = mapping _FontSize + +type FontSizeM n = Measured n (FontSize n) + +instance Typeable n => AttributeClass (FontSize n) + +instance Num n => Default (FontSizeM n) where + def = FontSize . Recommend . Last <$> local 1 + -- | Extract the size from a @FontSize@ attribute. -getFontSize :: FontSize -> Double -getFontSize (FontSize (Last s)) = s +getFontSize :: FontSize n -> n +getFontSize (FontSize (Recommend (Last s))) = s +getFontSize (FontSize (Commit (Last s))) = s -- | Set the font size, that is, the size of the font's em-square as --- measured within the current local vector space. The default size --- is @1@. -fontSize :: HasStyle a => Double -> a -> a -fontSize = applyAttr . FontSize . Last +-- measured within the current local vector space. The default size +-- is @local 1@ (which is applied by 'recommendFontSize'). +fontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a +fontSize = applyMAttr . fmap (FontSize . Commit . Last) +-- | 'Recommend' a font size. Any use of 'fontSize' above this will +-- overwrite any recommended size. This should only be used with +-- 'mkText'', other text functions already has a recommended font +-- size so this will be ignored. +recommendFontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a +recommendFontSize = applyMAttr . fmap (FontSize . Recommend . Last) + +-- | A convenient synonym for 'fontSize (Global w)'. +fontSizeG :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a +fontSizeG = fontSize . global + +-- | A convenient synonym for 'fontSize (Normalized w)'. +fontSizeN :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a +fontSizeN = fontSize . normalized + +-- | A convenient synonym for 'fontSize (Output w)'. +fontSizeO :: (N a ~ n, Typeable n, HasStyle a) => n -> a -> a +fontSizeO = fontSize . output + +-- | A convenient sysnonym for 'fontSize (Local w)'. +fontSizeL :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a +fontSizeL = fontSize . local + -- | Apply a 'FontSize' attribute. -fontSizeA :: HasStyle a => FontSize -> a -> a -fontSizeA = applyAttr +fontSizeM :: (N a ~ n, Typeable n, HasStyle a) => FontSizeM n -> a -> a +fontSizeM = applyMAttr +_fontSizeR :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) +_fontSizeR = atMAttr . anon def (const False) . _FontSizeM + +-- | Lens to commit a font size. This is *not* a valid lens (see +-- 'commited'. +_fontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) +_fontSize = _fontSizeR . mapping committed + +_fontSizeU :: (Typeable n) => Lens' (Style v n) (Maybe n) +_fontSizeU = atAttr . mapping (_FontSize . committed) + -------------------------------------------------- -- Font slant +-- | The @FontSlantA@ attribute specifies the slant (normal, italic, +-- or oblique) that should be used for all text within a diagram. +-- Inner @FontSlantA@ attributes override outer ones. data FontSlant = FontSlantNormal | FontSlantItalic | FontSlantOblique - deriving (Eq) + deriving (Eq, Show, Typeable, Ord) --- | The @FontSlantA@ attribute specifies the slant (normal, italic, --- or oblique) that should be used for all text within a diagram. --- Inner @FontSlantA@ attributes override outer ones. -newtype FontSlantA = FontSlantA (Last FontSlant) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass FontSlantA +instance AttributeClass FontSlant where +instance Semigroup FontSlant where + _ <> b = b +instance Default FontSlant where + def = FontSlantNormal + -- | Extract the font slant from a 'FontSlantA' attribute. -getFontSlant :: FontSlantA -> FontSlant -getFontSlant (FontSlantA (Last s)) = s +getFontSlant :: FontSlant -> FontSlant +getFontSlant = id -- | Specify the slant (normal, italic, or oblique) that should be -- used for all text within a diagram. See also 'italic' and -- 'oblique' for useful special cases. fontSlant :: HasStyle a => FontSlant -> a -> a -fontSlant = applyAttr . FontSlantA . Last +fontSlant = applyAttr +-- | Lens onto the font slant in a style. +_fontSlant :: Lens' (Style v n) FontSlant +_fontSlant = atAttr . non def + -- | Set all text in italics. italic :: HasStyle a => a -> a italic = fontSlant FontSlantItalic @@ -222,27 +335,82 @@ -------------------------------------------------- -- Font weight -data FontWeight = FontWeightNormal - | FontWeightBold - deriving (Eq) - -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner -- @FontWeightA@ attributes override outer ones. -newtype FontWeightA = FontWeightA (Last FontWeight) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass FontWeightA +data FontWeight = FontWeightNormal + | FontWeightBold + | FontWeightBolder + | FontWeightLighter + | FontWeightThin + | FontWeightUltraLight + | FontWeightLight + | FontWeightMedium + | FontWeightSemiBold + | FontWeightUltraBold + | FontWeightHeavy + deriving (Eq, + Ord, Show, Typeable) --- | Extract the font weight from a 'FontWeightA' attribute. -getFontWeight :: FontWeightA -> FontWeight -getFontWeight (FontWeightA (Last w)) = w +instance AttributeClass FontWeight --- | Specify the weight (normal or bold) that should be +-- | Last semigroup structure +instance Semigroup FontWeight where + _ <> b = b + +instance Default FontWeight where + def = FontWeightNormal + +-- | Extract the font weight. +getFontWeight :: FontWeight -> FontWeight +getFontWeight = id + +-- | Specify the weight (normal, bolder, lighter or bold) that should be -- used for all text within a diagram. See also 'bold' -- for a useful special case. fontWeight :: HasStyle a => FontWeight -> a -> a -fontWeight = applyAttr . FontWeightA . Last +fontWeight = applyAttr -- | Set all text using a bold font weight. bold :: HasStyle a => a -> a bold = fontWeight FontWeightBold + +-- | Set all text using a thin font weight. +thinWeight :: HasStyle a => a -> a +thinWeight = fontWeight FontWeightThin + +-- | Set all text using a extra light font weight. +ultraLight :: HasStyle a => a -> a +ultraLight = fontWeight FontWeightUltraLight + +-- | Set all text using a light font weight. +light :: HasStyle a => a -> a +light = fontWeight FontWeightLight + +-- | Set all text using a medium font weight. +mediumWeight :: HasStyle a => a -> a +mediumWeight = fontWeight FontWeightMedium + +-- | Set all text using a semi-bold font weight. +semiBold :: HasStyle a => a -> a +semiBold = fontWeight FontWeightSemiBold + +-- | Set all text using an ultra-bold font weight. +ultraBold :: HasStyle a => a -> a +ultraBold = fontWeight FontWeightUltraBold + +-- | Set all text using a heavy/black font weight. +heavy :: HasStyle a => a -> a +heavy = fontWeight FontWeightHeavy + +-- | Set all text to be bolder than the inherited font weight. +bolder :: HasStyle a => a -> a +bolder = fontWeight FontWeightBolder + +-- | Set all text to be lighter than the inherited font weight. +lighter :: HasStyle a => a -> a +lighter = fontWeight FontWeightLighter + +-- | Lens onto the font weight in a style. +_fontWeight :: Lens' (Style v n) FontWeight +_fontWeight = atAttr . non def diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,12 +1,19 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -18,10 +25,11 @@ module Diagrams.TwoD.Transform ( + T2 -- * Rotation - rotation, rotate, rotateBy - - , rotationAbout, rotateAbout + , rotation, rotate, rotateBy, rotated + , rotationAround, rotateAround + , rotationTo, rotateTo -- * Scaling , scalingX, scaleX @@ -36,323 +44,262 @@ , translationY, translateY , translation, translate + -- * Conformal affine maps + , scalingRotationTo, scaleRotateTo + -- * Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- * Shears , shearingX, shearX , shearingY, shearY - -- * Scale invariance - , ScaleInv(..), scaleInv, scaleInvPrim - - -- * component-wise - , onBasis ) where +import Diagrams.Angle import Diagrams.Core -import qualified Diagrams.Core.Transform as T - -import Control.Newtype (over) - -import Diagrams.Coordinates +import Diagrams.Core.Transform +import Diagrams.Direction import Diagrams.Transform -import Diagrams.TwoD.Size (height, width) +import Diagrams.Transform.Matrix import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction) +import Diagrams.TwoD.Vector +import Control.Lens hiding (at, transform) import Data.Semigroup -import Data.AffineSpace - -import Control.Arrow (first, second) +import Linear.Affine +import Linear.Metric +import Linear.V2 +import Linear.Vector -- Rotation ------------------------------------------------ --- | Create a transformation which performs a rotation about the local --- origin by the given angle. See also 'rotate'. -rotation :: Angle a => a -> T2 -rotation ang = fromLinear r (linv r) - where - r = rot theta <-> rot (-theta) - Rad theta = convertAngle ang - rot th (coords -> x :& y) = (cos th * x - sin th * y) & (sin th * x + cos th * y) +-- For the definitions of 'rotation' and 'rotate', see Diagrams.Angle. --- | Rotate about the local origin by the given angle. Positive angles --- correspond to counterclockwise rotation, negative to --- clockwise. The angle can be expressed using any type which is an --- instance of 'Angle'. For example, @rotate (1\/4 :: --- 'Turn')@, @rotate (tau\/4 :: 'Rad')@, and @rotate (90 :: --- 'Deg')@ all represent the same transformation, namely, a --- counterclockwise rotation by a right angle. To rotate about some --- point other than the local origin, see 'rotateAbout'. --- --- Note that writing @rotate (1\/4)@, with no type annotation, will --- yield an error since GHC cannot figure out which sort of angle --- you want to use. In this common situation you can use --- 'rotateBy', which is specialized to take a 'Turn' argument. -rotate :: (Transformable t, V t ~ R2, Angle a) => a -> t -> t -rotate = transform . rotation +-- | A synonym for 'rotate', interpreting its argument in units of +-- turns; it can be more convenient to write @rotateBy (1\/4)@ than +-- @'rotate' (1\/4 \@\@ 'turn')@. +rotateBy :: (InSpace V2 n t, Transformable t, Floating n) => n -> t -> t +rotateBy = transform . rotation . review turn --- | A synonym for 'rotate', specialized to only work with --- @Turn@ arguments; it can be more convenient to write --- @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'Turn')@. -rotateBy :: (Transformable t, V t ~ R2) => Turn -> t -> t -rotateBy = transform . rotation +-- | Use an 'Angle' to make an 'Iso' between an object +-- rotated and unrotated. This us useful for performing actions +-- 'under' a rotation: +-- +-- @ +-- under (rotated t) f = rotate (negated t) . f . rotate t +-- rotated t ## a = rotate t a +-- a ^. rotated t = rotate (-t) a +-- over (rotated t) f = rotate t . f . rotate (negated t) +-- @ +rotated :: (InSpace V2 n a, Floating n, SameSpace a b, Transformable a, Transformable b) + => Angle n -> Iso a b a b +rotated a = transformed $ rotation a -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: Angle a => P2 -> a -> T2 -rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) +rotationAround :: Floating n => P2 n -> Angle n -> T2 n +rotationAround p theta = + conjugate (translation (origin .-. p)) (rotation theta) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (Transformable t, V t ~ R2, Angle a) => P2 -> a -> t -> t -rotateAbout p angle = rotate angle `under` translation (origin .-. p) +rotateAround :: (InSpace V2 n t, Transformable t, Floating n) + => P2 n -> Angle n -> t -> t +rotateAround p theta = transform (rotationAround p theta) +-- | The rotation that aligns the x-axis with the given direction. +rotationTo :: OrderedField n => Direction V2 n -> T2 n +rotationTo (view _Dir -> V2 x y) = rotation (atan2A' y x) + +-- | Rotate around the local origin such that the x axis aligns with the +-- given direction. +rotateTo :: (InSpace V2 n t, OrderedField n, Transformable t) => Direction V2 n -> t -> t +rotateTo = transform . rotationTo + -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. -scalingX :: Double -> T2 -scalingX c = fromLinear s s - where s = (over r2 . first) (*c) <-> (over r2 . first) (/c) +scalingX :: (Additive v, R1 v, Fractional n) => n -> Transformation v n +scalingX c = fromSymmetric $ (_x *~ c) <-> (_x //~ c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. -scaleX :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleX :: (InSpace v n t, R2 v, Fractional n, Transformable t) => n -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. -scalingY :: Double -> T2 -scalingY c = fromLinear s s - where s = (over r2 . second) (*c) <-> (over r2 . second) (/c) +scalingY :: (Additive v, R2 v, Fractional n) => n -> Transformation v n +scalingY c = fromSymmetric $ (_y *~ c) <-> (_y //~ c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. -scaleY :: (Transformable t, V t ~ R2) => Double -> t -> t +scaleY :: (InSpace v n t, R2 v, Fractional n, Transformable t) + => n -> t -> t scaleY = transform . scalingY -- | @scaleToX w@ scales a diagram in the x (horizontal) direction by -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. -scaleToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t -scaleToX w d = scaleX (w / width d) d +scaleToX :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t +scaleToX w d = scaleX (w / diameter unitX d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. -scaleToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t -scaleToY h d = scaleY (h / height d) d +scaleToY :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t +scaleToY h d = scaleY (h / diameter unitY d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. -scaleUToX :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t -scaleUToX w d = scale (w / width d) d +scaleUToX :: (InSpace v n t, R1 v, Enveloped t, Transformable t) => n -> t -> t +scaleUToX w d = scale (w / diameter unitX d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. -scaleUToY :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t -scaleUToY h d = scale (h / height d) d +scaleUToY :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t +scaleUToY h d = scale (h / diameter unitY d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. -translationX :: Double -> T2 -translationX x = translation (x & 0) +translationX :: (Additive v, R1 v, Num n) => n -> Transformation v n +translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. -translateX :: (Transformable t, V t ~ R2) => Double -> t -> t +translateX :: (InSpace v n t, R1 v, Transformable t) => n -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. -translationY :: Double -> T2 -translationY y = translation (0 & y) +translationY :: (Additive v, R2 v, Num n) => n -> Transformation v n +translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. -translateY :: (Transformable t, V t ~ R2) => Double -> t -> t +translateY :: (InSpace v n t, R2 v, Transformable t) + => n -> t -> t translateY = transform . translationY +-- Conformal affine maps ----------------------------------- + +-- | The angle-preserving linear map that aligns the x-axis unit vector +-- with the given vector. See also 'scaleRotateTo'. +scalingRotationTo :: (Floating n) => V2 n -> T2 n +scalingRotationTo v = fromMatWithInv (conf v) (conf w) zero + where + w = reflectY (v ^/ quadrance v) + conf (V2 a b) = (V2 (V2 a (-b)) (V2 b a)) + +-- | Rotate and uniformly scale around the local origin such that the +-- x-axis aligns with the given vector. This satisfies the equation +-- +-- @ +-- scaleRotateTo v = rotateTo (dir v) . scale (norm v) +-- @ +-- +-- up to floating point rounding errors, but is more accurate and +-- performant since it avoids cancellable uses of trigonometric functions. +scaleRotateTo :: (InSpace V2 n t, Transformable t, Floating n) + => V2 n -> t -> t +scaleRotateTo = transform . scalingRotationTo + -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). -reflectionX :: T2 -reflectionX = scalingX (-1) +reflectionX :: (Additive v, R1 v, Num n) => Transformation v n +reflectionX = fromSymmetric $ (_x *~ (-1)) <-> (_x *~ (-1)) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). -reflectX :: (Transformable t, V t ~ R2) => t -> t +reflectX :: (InSpace v n t, R1 v, Transformable t) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). -reflectionY :: T2 -reflectionY = scalingY (-1) +reflectionY :: (Additive v, R2 v, Num n) => Transformation v n +reflectionY = fromSymmetric $ (_y *~ (-1)) <-> (_y *~ (-1)) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). -reflectY :: (Transformable t, V t ~ R2) => t -> t +reflectY :: (InSpace v n t, R2 v, Transformable t) => t -> t reflectY = transform reflectionY --- | @reflectionAbout p v@ is a reflection in the line determined by --- the point @p@ and vector @v@. -reflectionAbout :: P2 -> R2 -> T2 -reflectionAbout p v = - conjugate (rotation (-direction v :: Rad) <> translation (origin .-. p)) +-- | Construct a transformation which flips the diagram about x=y, i.e. +-- sends the point (x,y) to (y,x). +reflectionXY :: (Additive v, R2 v, Num n) => Transformation v n +reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) + +-- | Flips the diagram about x=y, i.e. send the point (x,y) to (y,x). +reflectXY :: (InSpace v n t, R2 v, Transformable t) => t -> t +reflectXY = transform reflectionXY + +-- | @reflectionAbout p d@ is a reflection in the line determined by +-- the point @p@ and direction @d@. +reflectionAbout :: OrderedField n => P2 n -> Direction V2 n -> T2 n +reflectionAbout p d = + conjugate (rotationTo (reflectY d) <> translation (origin .-. p)) reflectionY --- | @reflectAbout p v@ reflects a diagram in the line determined by --- the point @p@ and the vector @v@. -reflectAbout :: (Transformable t, V t ~ R2) => P2 -> R2 -> t -> t + + + +-- | @reflectAbout p d@ reflects a diagram in the line determined by +-- the point @p@ and direction @d@. +reflectAbout :: (InSpace V2 n t, OrderedField n, Transformable t) + => P2 n -> Direction V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- +-- auxiliary functions for shearingX/shearingY +sh :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n +sh f g k (V2 x y) = V2 (f k x y) (g k x y) + +sh' :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n +sh' f g k = swap . sh f g k . swap + +swap :: V2 n -> V2 n +swap (V2 x y) = V2 y x +{-# INLINE swap #-} + -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. -shearingX :: Double -> T2 -shearingX d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) - (over r2 (sh' d) <-> over r2 (sh' (-d))) - where sh k (x, y) = (x+k*y, y) - sh' k = swap . sh k . swap - swap (x,y) = (y,x) +shearingX :: Num n => n -> T2 n +shearingX d = fromLinear (sh f g d <-> sh f g (-d)) + (sh' f g d <-> sh' f g (-d)) + where + f k x y = x + k*y + g _ _ y = y -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. -shearX :: (Transformable t, V t ~ R2) => Double -> t -> t +shearX :: (InSpace V2 n t, Transformable t) => n -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. -shearingY :: Double -> T2 -shearingY d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) - (over r2 (sh' d) <-> over r2 (sh' (-d))) - where sh k (x,y) = (x, y+k*x) - sh' k = swap . sh k . swap - swap (x,y) = (y,x) +shearingY :: Num n => n -> T2 n +shearingY d = fromLinear (sh f g d <-> sh f g (-d)) + (sh' f g d <-> sh' f g (-d)) + where + f _ x _ = x + g k x y = y + k*x -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. -shearY :: (Transformable t, V t ~ R2) => Double -> t -> t +shearY :: (InSpace V2 n t, Transformable t) => n -> t -> t shearY = transform . shearingY - - --- Scale invariance ---------------------------------------- - --- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ --- objects. Intuitively, a scale-invariant object is affected by --- transformations like translations and rotations, but not by scales. --- --- However, this is problematic when it comes to /non-uniform/ --- scales (/e.g./ @scaleX 2 . scaleY 3@) since they can introduce a --- perceived rotational component. The prototypical example is an --- arrowhead on the end of a path, which should be scale-invariant. --- However, applying a non-uniform scale to the path but not the --- arrowhead would leave the arrowhead pointing in the wrong --- direction. --- --- Moreover, for objects whose local origin is not at the local --- origin of the parent diagram, any scale can result in a --- translational component as well. --- --- The solution is to also store a point (indicating the location, --- /i.e./ the local origin) and a unit vector (indicating the --- /direction/) along with a scale-invariant object. A --- transformation to be applied is decomposed into rotational and --- translational components as follows: --- --- * The transformation is applied to the direction vector, and the --- difference in angle between the original direction vector and its --- image under the transformation determines the rotational --- component. The rotation is applied with respect to the stored --- location, rather than the global origin. --- --- * The vector from the location to the image of the location under --- the transformation determines the translational component. - -data ScaleInv t = - ScaleInv - { unScaleInv :: t - , scaleInvDir :: R2 - , scaleInvLoc :: P2 - } - deriving (Show) - --- | Create a scale-invariant object pointing in the given direction, --- located at the origin. -scaleInv :: t -> R2 -> ScaleInv t -scaleInv t d = ScaleInv t d origin - -type instance V (ScaleInv t) = R2 - -instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where - moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) - -instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where - transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' - where - angle :: Rad - angle = direction (transform tr v) - direction v - rot :: (Transformable t, V t ~ R2) => t -> t - rot = rotateAbout l angle - l' = transform tr l - trans = translate (l' .-. l) - --- This is how we handle freezing properly with ScaleInv wrappers. --- Normal transformations are applied ignoring scaling; "frozen" --- transformations (i.e. transformations applied after a freeze) are --- applied directly to the underlying object, scales and all. We must --- take care to transform the reference point and direction vector --- appropriately. -instance (V t ~ R2, Transformable t) => IsPrim (ScaleInv t) where - transformWithFreeze t1 t2 s = ScaleInv t'' d'' origin'' - where - -- first, apply t2 normally, i.e. ignoring scaling - s'@(ScaleInv t' _ _) = transform t2 s - - -- now apply t1 to get the new direction and origin - (ScaleInv _ d'' origin'') = transform t1 s' - - -- but apply t1 directly to the underlying thing, scales and all. - t'' = transform t1 t' - -instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where - render b = render b . unScaleInv - --- | Create a diagram from a single scale-invariant primitive. The --- vector argument specifies the direction in which the primitive is --- \"pointing\" (for the purpose of keeping it rotated correctly --- under non-uniform scaling). The primitive is assumed to be --- \"located\" at the origin (for the purpose of translating it --- correctly under scaling). --- --- Note that the resulting diagram will have an /empty/ envelope, --- trace, and query. The reason is that the envelope, trace, and --- query cannot be cached---applying a transformation would cause --- the cached envelope, etc. to get \"out of sync\" with the --- scale-invariant object. The intention, at any rate, is that --- scale-invariant things will be used only as \"decorations\" (/e.g./ --- arrowheads) which should not affect the envelope, trace, and --- query. -scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) - => t -> R2 -> QDiagram b R2 m -scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty - --- | Get the matrix equivalent of the linear transform, --- (as a pair of columns) and the translation vector. This --- is mostly useful for implementing backends. -onBasis :: Transformation R2 -> ((R2, R2), R2) -onBasis t = ((x, y), v) - where ((x:y:[]), v) = T.onBasis t diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types @@ -21,204 +15,80 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - R2, r2, unr2 - , P2, p2, unp2 - , T2 - - -- * Angles - , Angle(..) - , Turn(..), CircleFrac, Rad(..), Deg(..) - , fullCircle, convertAngle + V2 (..), R1 (..), R2 (..) + , P2, T2 + , r2, unr2, mkR2, r2Iso + , p2, mkP2, unp2, p2Iso + , r2PolarIso + , HasR (..) ) where -import Diagrams.Coordinates -import Diagrams.Core -import Diagrams.Util (tau) - -import Control.Newtype - -import Data.Basis -import Data.NumInstances.Tuple () -import Data.VectorSpace - -import Data.Typeable - ------------------------------------------------------------- --- 2D Euclidean space - --- | The two-dimensional Euclidean vector space R^2. This type is --- intentionally abstract. --- --- * To construct a vector, use 'r2', or '&' (from "Diagrams.Coordinates"): --- --- @ --- r2 (3,4) :: R2 --- 3 & 4 :: R2 --- @ --- --- Note that "Diagrams.Coordinates" is not re-exported by --- "Diagrams.Prelude" and must be explicitly imported. --- --- * To construct the vector from the origin to a point @p@, use --- @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a vector @v@ into the point obtained by following --- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a vector back into a pair of components, use 'unv2' --- or 'coords' (from "Diagrams.Coordinates"). These are typically --- used in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unr2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ +import Control.Lens (Iso', Lens', iso, _1, _2) -newtype R2 = R2 { unR2 :: (Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Typeable, Num, Fractional) +import Diagrams.Angle +import Diagrams.Points -instance Show R2 where - showsPrec p (R2 (x,y)) = showParen (p >= 7) $ - showCoord x . showString " & " . showCoord y - where - showCoord x | x < 0 = showParen True (shows x) - | otherwise = shows x +import Diagrams.Core.Transform +import Diagrams.Core.V +import Linear.Metric +import Linear.V2 -instance Read R2 where - readsPrec d r = readParen (d > app_prec) - (\r -> [ (R2 (x,y), r''') - | (x,r') <- readsPrec (amp_prec + 1) r - , ("&",r'') <- lex r' - , (y,r''') <- readsPrec (amp_prec + 1) r'' - ]) - r - where - app_prec = 10 - amp_prec = 7 +type P2 = Point V2 +type T2 = Transformation V2 -instance Newtype R2 (Double, Double) where - pack = R2 - unpack = unR2 +type instance V (V2 n) = V2 +type instance N (V2 n) = n -- | Construct a 2D vector from a pair of components. See also '&'. -r2 :: (Double, Double) -> R2 -r2 = pack +r2 :: (n, n) -> V2 n +r2 = uncurry V2 -- | Convert a 2D vector back into a pair of components. See also 'coords'. -unr2 :: R2 -> (Double, Double) -unr2 = unpack - -type instance V R2 = R2 - -instance VectorSpace R2 where - type Scalar R2 = Double - (*^) = over R2 . (*^) - -instance HasBasis R2 where - type Basis R2 = Either () () -- = Basis (Double, Double) - basisValue = R2 . basisValue - decompose = decompose . unR2 - decompose' = decompose' . unR2 - -instance InnerSpace R2 where - (unR2 -> vec1) <.> (unR2 -> vec2) = vec1 <.> vec2 - -instance Coordinates R2 where - type FinalCoord R2 = Double - type PrevDim R2 = Double - type Decomposition R2 = Double :& Double +unr2 :: V2 n -> (n, n) +unr2 (V2 x y) = (x, y) - x & y = r2 (x,y) - coords (unR2 -> (x,y)) = x :& y +-- | Curried form of `r2`. +mkR2 :: n -> n -> V2 n +mkR2 = V2 --- | Points in R^2. This type is intentionally abstract. --- --- * To construct a point, use 'p2', or '&' (see --- "Diagrams.Coordinates"): --- --- @ --- p2 (3,4) :: P2 --- 3 & 4 :: P2 --- @ --- --- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. --- --- * To convert a point @p@ into the vector from the origin to @p@, --- use @p 'Data.AffineSpace..-.' 'origin'@. --- --- * To convert a point back into a pair of coordinates, use 'unp2', --- or 'coords' (from "Diagrams.Coordinates"). It's common to use --- these in conjunction with the @ViewPatterns@ extension: --- --- @ --- foo (unp2 -> (x,y)) = ... --- foo (coords -> x :& y) = ... --- @ -type P2 = Point R2 +r2Iso :: Iso' (V2 n) (n, n) +r2Iso = iso unr2 r2 --- | Construct a 2D point from a pair of coordinates. See also '&'. -p2 :: (Double, Double) -> P2 -p2 = pack . pack +-- | Construct a 2D point from a pair of coordinates. See also '^&'. +p2 :: (n, n) -> P2 n +p2 = P . uncurry V2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. -unp2 :: P2 -> (Double, Double) -unp2 = unpack . unpack - --- | Transformations in R^2. -type T2 = Transformation R2 - -instance Transformable R2 where - transform = apply - ------------------------------------------------------------- --- Angles - --- | Newtype wrapper used to represent angles as fractions of a --- circle. For example, 1\/3 turn = tau\/3 radians = 120 degrees. -newtype Turn = Turn { getTurn :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) - --- | Deprecated synonym for 'Turn', retained for backwards compatibility. -type CircleFrac = Turn - --- | Newtype wrapper for representing angles in radians. -newtype Rad = Rad { getRad :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) - --- | Newtype wrapper for representing angles in degrees. -newtype Deg = Deg { getDeg :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) +unp2 :: P2 n -> (n,n) +unp2 (P (V2 x y)) = (x,y) --- | Type class for types that measure angles. -class Num a => Angle a where - -- | Convert to a turn, /i.e./ a fraction of a circle. - toTurn :: a -> Turn +-- | Curried form of `p2`. +mkP2 :: n -> n -> P2 n +mkP2 x y = P (V2 x y) - -- | Convert from a turn, /i.e./ a fraction of a circle. - fromTurn :: Turn -> a +p2Iso :: Iso' (Point V2 n) (n, n) +p2Iso = iso unp2 p2 -instance Angle Turn where - toTurn = id - fromTurn = id +instance Transformable (V2 n) where + transform = apply --- | tau radians = 1 full turn. -instance Angle Rad where - toTurn = Turn . (/tau) . getRad - fromTurn = Rad . (*tau) . getTurn +r2PolarIso :: RealFloat n => Iso' (V2 n) (n, Angle n) +r2PolarIso = iso (\v@(V2 x y) -> (norm v, atan2A y x)) + (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) +{-# INLINE r2PolarIso #-} --- | 360 degrees = 1 full turn. -instance Angle Deg where - toTurn = Turn . (/360) . getDeg - fromTurn = Deg . (*360) . getTurn +-- | A space which has magnitude '_r' that can be calculated numerically. +class HasR t where + _r :: RealFloat n => Lens' (t n) n --- | An angle representing one full turn. -fullTurn :: Angle a => a -fullTurn = fromTurn 1 +instance HasR v => HasR (Point v) where + _r = lensP . _r + {-# INLINE _r #-} --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle a => a -fullCircle = fullTurn +instance HasR V2 where + _r = r2PolarIso . _1 + {-# INLINE _r #-} --- | Convert between two angle representations. -convertAngle :: (Angle a, Angle b) => a -> b -convertAngle = fromTurn . toTurn +instance HasTheta V2 where + _theta = r2PolarIso . _2 + {-# INLINE _theta #-} diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -14,57 +11,82 @@ module Diagrams.TwoD.Vector ( -- * Special 2D vectors unitX, unitY, unit_X, unit_Y + , xDir, yDir -- * Converting between vectors and angles - , direction, fromDirection, e + , angleV, angleDir, e, signedAngleBetween, signedAngleBetweenDirs -- * 2D vector utilities - , perp, leftTurn + , perp, leftTurn, cross2 + ) where -import Data.VectorSpace ((<.>)) -import Diagrams.Coordinates +import Control.Lens (view, (&), (.~), (^.)) + +import Diagrams.Angle +import Diagrams.Direction import Diagrams.TwoD.Types -import Diagrams.Util (( # )) --- | The unit vector in the positive X direction. -unitX :: R2 -unitX = 1 & 0 +import Linear.Metric +import Linear.V2 +import Linear.Vector --- | The unit vector in the positive Y direction. -unitY :: R2 -unitY = 0 & 1 +-- | The unit vector in the positive X direction. +unitX :: (R1 v, Additive v, Num n) => v n +unitX = zero & _x .~ 1 -- | The unit vector in the negative X direction. -unit_X :: R2 -unit_X = (-1) & 0 +unit_X :: (R1 v, Additive v, Num n) => v n +unit_X = zero & _x .~ (-1) +-- | The unit vector in the positive Y direction. +unitY :: (R2 v, Additive v, Num n) => v n +unitY = zero & _y .~ 1 + -- | The unit vector in the negative Y direction. -unit_Y :: R2 -unit_Y = 0 & (-1) +unit_Y :: (R2 v, Additive v, Num n) => v n +unit_Y = zero & _y .~ (-1) --- | Compute the direction of a vector, measured counterclockwise from --- the positive x-axis as a fraction of a full turn. The zero --- vector is arbitrarily assigned the direction 0. -direction :: Angle a => R2 -> a -direction (coords -> x :& y) = convertAngle . Rad $ atan2 y x +-- | A 'Direction' pointing in the X direction. +xDir :: (R1 v, Additive v, Num n) => Direction v n +xDir = dir unitX --- | Convert an angle into a unit vector pointing in that direction. -fromDirection :: Angle a => a -> R2 -fromDirection a = cos a' & sin a' - where Rad a' = convertAngle a +-- | A 'Direction' pointing in the Y direction. +yDir :: (R2 v, Additive v, Num n) => Direction v n +yDir = dir unitY --- | A convenient synonym for 'fromDirection'. -e :: Angle a => a -> R2 -e = fromDirection +-- | A direction at a specified angle counter-clockwise from the 'xDir'. +angleDir :: Floating n => Angle n -> Direction V2 n +angleDir = dir . angleV --- | @perp v@ is perpendicular to and has the same magnitude as @v@. --- In particular @perp v == rotateBy (1/4) v@. -perp :: R2 -> R2 -perp (coords -> x :& y) = (-y) & x +-- | A unit vector at a specified angle counter-clockwise from the +-- positive x-axis +angleV :: Floating n => Angle n -> V2 n +angleV = angle . view rad +-- | A unit vector at a specified angle counter-clockwise from the +-- positive X axis. +e :: Floating n => Angle n -> V2 n +e = angleV + -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). -leftTurn :: R2 -> R2 -> Bool -leftTurn v1 v2 = (v1 <.> perp v2) < 0 +leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool +leftTurn v1 v2 = (v1 `dot` perp v2) < 0 + +-- | Cross product on vectors in R2. +cross2 :: Num n => V2 n -> V2 n -> n +cross2 (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2 + +-- | Signed angle between two vectors. Currently defined as +-- +-- @ +-- signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) +-- @ +signedAngleBetween :: RealFloat n => V2 n -> V2 n -> Angle n +signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) + +-- | Same as 'signedAngleBetween' but for 'Directions's. +signedAngleBetweenDirs :: RealFloat n => Direction V2 n -> Direction V2 n -> Angle n +signedAngleBetweenDirs u v = (u ^. _theta) ^-^ (v ^. _theta) diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Util --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -10,24 +12,44 @@ ----------------------------------------------------------------------------- module Diagrams.Util - ( -- * Utilities for users + ( -- * Utilities for users - with - , applyAll - , (#) + with + , applyAll + , (#) + , (##) - , iterateN + , iterateN - , tau + , tau - -- * Internal utilities - , Proxy(..) - , foldB + -- * Finding files + , findHsFile - ) where + -- * Finding sandboxes + , findSandbox + , globalPackage -import Data.Default.Class + -- * Internal utilities + , foldB + + ) where + +import Control.Applicative +import Control.Lens hiding (( # )) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import Data.Default +import Data.List +import Data.Maybe import Data.Monoid +import System.Directory +import System.Environment +import System.FilePath +import System.FilePath.Lens +import System.Process -- | Several functions exported by the diagrams library take a number -- of arguments giving the user control to \"tweak\" various aspects @@ -68,6 +90,13 @@ (#) :: a -> (a -> b) -> b (#) = flip ($) +-- | A replacement for lenses' 'Control.Lens.Review.#' operator. +(##) :: AReview t b -> b -> t +(##) = review +{-# INLINE (##) #-} +infixr 8 ## + + -- | @iterateN n f x@ returns the list of the first @n@ iterates of -- @f@ starting at @x@, that is, the list @[x, f x, f (f x), ...]@ -- of length @n@. (Note that the last element of the list will be @@ -87,10 +116,6 @@ tau :: Floating a => a tau = 2*pi --- | A value of @Proxy a@ carries no information; it's used only to --- fix the type @a@. -data Proxy a = Proxy - -- | Given an associative binary operation and a default value to use -- in the case of an empty list, perform a /balanced/ fold over a -- list. For example, @@ -107,3 +132,127 @@ go [] = [] go [x] = [x] go (x1:x2:xs) = f x1 x2 : go xs + +------------------------------------------------------------------------ +-- Files +------------------------------------------------------------------------ + +-- | Given some file (no extension or otherwise) try to find a haskell +-- source file. +findHsFile :: FilePath -> IO (Maybe FilePath) +findHsFile file = runMaybeT $ hs <|> lhs + where + hs = check (addExtension file "hs") + lhs = check (addExtension file "lhs") + check f = do + lift (doesFileExist f) >>= guard + pure f + +------------------------------------------------------------------------ +-- Sandbox +------------------------------------------------------------------------ + +-- | Parse cabal config file to find the location of the package +-- database. +parseConfig :: FilePath -> MaybeT IO FilePath +parseConfig file = do + config <- maybeIO $ readFile file + hoistMaybe $ config ^? lined . prefixed "package-db: " + +-- | Seach the given directory and all parent directories until a cabal +-- config file is found. First search for \"cabal.config\", then +-- \"cabal.sandbox.config\". Return the location of the package +-- database in the config file. +configSearch :: FilePath -> MaybeT IO FilePath +configSearch p0 = do + p0' <- maybeIO $ canonicalizePath p0 + + let mkPaths p + | all isPathSeparator p || p == "." + = [] + | otherwise = (p "cabal.sandbox.config") + : mkPaths (p ^. directory) + + foldMaybeT parseConfig (mkPaths p0') + +-- | Check if the folder is a database, or if it contains a database. +-- Returns the database location if it's found. +isDB :: FilePath -> MaybeT IO FilePath +isDB path = + if isConf path + then return path + else maybeIO (getDirectoryContents path) >>= hoistMaybe . find isConf + where + isConf = isSuffixOf ".conf.d" + +-- | Search for a sandbox in the following order: +-- +-- * Test given FilePaths if they point directly to a database or +-- contain a cabal config file (or any parent directory containing a +-- config file). +-- +-- * Same test for @DIAGRAMS_SANDBOX@ environment value +-- +-- * Environment values of @GHC_PACKAGE_PATH@, @HSENV@ and +-- @PACKAGE_DB_FOR_GHC@ that point to a database. +-- +-- * Test for config file (cabal.sandbox.config) in the current +-- directory and its parents. +-- +findSandbox :: [FilePath] -> IO (Maybe FilePath) +findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig + where + -- first path in environment + lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv + envDB = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"] + + -- test if path points directly to db or contains a config file + test x = isDB x <|> configSearch x + pathsTest = foldMaybeT test paths + diaSB = lookEnv "DIAGRAMS_SANDBOX" >>= test + wdConfig = maybeIO getCurrentDirectory >>= configSearch + +-- -- | Use the given path for the sandbox in the @GHC_PACKAGE_PATH@ +-- -- environment (appending the ghc global package database from @ghc +-- -- --info@. @GHC_PACKAGE_PATH@ if the variable ghc and other tools use +-- -- to find the package database. (This is what @cabal exec@ sets) +-- ghcPackagePath :: FilePath -> IO () +-- ghcPackagePath db = do +-- gdb <- globalPackage +-- let dbs = intercalate [searchPathSeparator] [db,gdb] +-- setEnv "GHC_PACKAGE_PATH" dbs +-- -- setEnv is only in base > 4.7, either need to use setenv package or +-- -- -package-db flag + +-- | Find ghc's global package database. Throws an error if it isn't +-- found. +globalPackage :: IO FilePath +globalPackage = do + info <- read <$> readProcess "ghc" ["--info"] "" + return $ fromMaybe (error "Unable to parse ghc --info.") + (lookup "Global Package DB" info) + +-- MaybeT utilities + +-- | Lift an 'IO' action. If any exceptions are raised, return Nothing. +maybeIO :: (MonadCatch m, MonadIO m) => IO a -> MaybeT m a +maybeIO io = liftIO io `catchAll` const mzero + +-- hoistMaybe is exported from transformers as of version 0.6 +#if MIN_VERSION_transformers(0,6,0) +#else +-- | Lift a maybe value to a MaybeT of any monad. +hoistMaybe :: Monad m => Maybe a -> MaybeT m a +hoistMaybe = MaybeT . return +#endif + +-- | Fold a list of 'MaybeT's that short-circuits as soon as a Just value +-- is found (instead going through the whole list). +foldMaybeT :: Monad m => (a -> MaybeT m b) -> [a] -> MaybeT m b +foldMaybeT _ [] = mzero +foldMaybeT f (a:as) = MaybeT $ do + x <- runMaybeT (f a) + if isJust x + then return x + else runMaybeT (foldMaybeT f as) + diff --git a/src/Linear/Vector/Compat.hs b/src/Linear/Vector/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Linear/Vector/Compat.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Linear.Vector.Compat +-- Copyright : (c) 2024 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Compatibility layer for working with versions of linear both before +-- (< 1.23) and after (>= 1.23) the interpolation direction of `lerp` +-- was reversed. +module Linear.Vector.Compat (lerp) where + +import qualified Linear.Vector as V + +-- | Linearly interpolate between two vectors, such that @lerp 0 x y = +-- x@ and @lerp 1 x y = 1@. +lerp :: (V.Additive f, Num a) => a -> f a -> f a -> f a +lerp = +#if MIN_VERSION_linear(1,23,0) + V.lerp +#else + V.lerp . (1-) +#endif diff --git a/test/Diagrams/Test/Angle.hs b/test/Diagrams/Test/Angle.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Angle.hs @@ -0,0 +1,29 @@ +-- | + +module Diagrams.Test.Angle where + + +import Test.Tasty +import Test.Tasty.QuickCheck +import Diagrams.Prelude +import Instances + +tests :: TestTree +tests = testGroup "Angle" [ + testProperty "2π radians per turn" $ + \θ -> θ^.rad =~ θ^.turn*2*(pi :: Double) + , testProperty "360 degrees per turn" $ + \θ -> θ^.deg =~ θ^.turn*(360 :: Double) + , testProperty "Angle vector addition is commutative" $ + \θ φ -> (θ :: Angle Double) ^+^ φ =~ φ ^+^ θ + , testProperty "Angle subtraction is the inverse of addition" $ + \θ φ -> (θ :: Angle Double) ^+^ φ ^-^ φ =~ θ + , testProperty "Angle vector negation squared is identity" $ + \θ -> negated (negated (θ :: Angle Double)) =~ θ + , testProperty "A negated angle is the additive inverse of the original" $ + \θ -> (θ :: Angle Double) ^+^ (negated θ) =~ 0@@turn + , testProperty "A negated angle is the additive inverse of the original" $ + \θ -> (θ :: Angle Double) ^+^ (negated θ) =~ 0@@turn + + + ] diff --git a/test/Diagrams/Test/Direction.hs b/test/Diagrams/Test/Direction.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Direction.hs @@ -0,0 +1,34 @@ +-- | + +module Diagrams.Test.Direction where + + +import Diagrams.Direction +import Diagrams.Prelude +import Instances +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = testGroup "Direction" [ + testProperty "Length does not effect from direction" $ + \(Positive f) (NonZero v) -> fromDirection(dir ((v :: V2 Double) ^* (f+0.001))) =~ fromDirection(dir v) + , testProperty "HasTheta subtraction yeilds same result as anglebetween" $ + (anglebetsub) + , testProperty "anglebetweenDirs is commutative" $ + \a b -> angleBetweenDirs (a :: Direction V2 Double) b =~ angleBetweenDirs b a + , testProperty "fromdirection does not effect angleBetweenDirs" $ + \a b -> angleBetween (fromDirection (a :: Direction V2 Double)) (fromDirection b) =~ angleBetweenDirs a b + + + + ] + +if' :: Bool -> a -> a -> a +if' True x _ = x +if' False _ y = y + +anglebetsub :: Direction V2 Double -> Direction V2 Double -> Bool +anglebetsub a b = (if' (abs (a ^. _theta^.rad - b ^. _theta^.rad) < pi) + (abs ((a ^. _theta ^-^ b ^. _theta)^.rad)) + (2*pi - abs (a ^. _theta^.rad - b ^. _theta^.rad) ) =~ angleBetweenDirs a b ^.rad) diff --git a/test/Diagrams/Test/Trail.hs b/test/Diagrams/Test/Trail.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Trail.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.Test.Trail where + +import Diagrams.Prelude +import Instances +import Test.Tasty +import Test.Tasty.QuickCheck + +import Data.Fixed +import Data.List + +tests :: TestTree +tests = testGroup "Trail" + [ let wrap :: Trail' Line V2 Double -> Located (Trail V2 Double) + wrap = (`at` origin) . wrapLine + in + testProperty "unfixTrail . fixTrail == id for lines" $ + \l -> (unfixTrail . fixTrail $ wrap l) =~ (wrap l) + + , testProperty "glueLine . cutLoop == id" $ + \loop -> (glueLine . cutLoop $ loop) =~ (loop :: Trail' Loop V2 Double) + + , testProperty "trailOffset == sumV . trailOffsets" $ + \t -> trailOffset t =~ (sumV . trailOffsets $ (t :: Trail V2 Double)) + + , testProperty "reverseTrail . reverseTrail == id" $ + \t -> (reverseTrail . reverseTrail $ t) =~ (t :: Trail V2 Double) + + , testProperty "reverseLocTrail . reverseLocTrail == id" $ + \t -> (reverseLocTrail . reverseLocTrail $ t) =~ + (t :: Located (Trail V2 Double)) + + , testProperty "reverseLine . reverseLine == id" $ + \t -> (reverseLine . reverseLine $ t) =~ + (t :: Trail' Line V2 Double) + + , testProperty "reverseLocLine . reverseLocLine == id" $ + \t -> (reverseLocLine . reverseLocLine $ t) =~ + (t :: Located (Trail' Line V2 Double)) + + , testProperty "reverseLoop . reverseLoop == id" $ + \t -> (reverseLoop . reverseLoop $ t) =~ + (t :: Trail' Loop V2 Double) + + , testProperty "reverseLocLoop . reverseLocLoop == id" $ + \t -> (reverseLocLoop . reverseLocLoop $ t) =~ + (t :: Located (Trail' Loop V2 Double)) + + , testProperty "section on Trail' Line endpoints match paramaters" $ + \t (Param a) (Param b) -> + let s = section (t :: Located (Trail' Line V2 Double)) a b + in t `atParam` a =~ s `atParam` 0 && + t `atParam` b =~ s `atParam` 1 + + , testProperty "section on Trail' Line where a paramater is 0 or 1" $ + \t (Param a) -> + let l = section (t :: Located (Trail' Line V2 Double)) 0 a + r = section (t :: Located (Trail' Line V2 Double)) a 1 + in t `atParam` 0 =~ l `atParam` 0 && + t `atParam` a =~ l `atParam` 1 && + t `atParam` a =~ r `atParam` 0 && + t `atParam` 1 =~ r `atParam` 1 + + , testProperty "section on Trail' Line where a segment paramater is 0 or 1" $ + \t (Param a) i -> + let st = unLoc t # \(Line st') -> st' :: SegTree V2 Double + b | (numSegs st :: Word) > 0 = (fromIntegral (i `mod` (numSegs st + 1) :: Word)) / numSegs st + | otherwise = 0 + s = section (t :: Located (Trail' Line V2 Double)) a b + in t `atParam` a =~ s `atParam` 0 && + t `atParam` b =~ s `atParam` 1 + + , testProperty "section on Trail' Line matches section on FixedSegment" $ + \t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b + + ] + +data Param = Param Double deriving Show + +instance Arbitrary Param where + arbitrary = Param <$> choose (-0.5, 1.5) + +sectionTrailSectionFixedSegment :: Located (Trail' Line V2 Double) -> Double -> Double -> Bool +sectionTrailSectionFixedSegment t k1 k2 + | null segs = t == t' + | otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS + where + a = min k1 k2 + b = max k1 k2 + t' = section t a b + + segs = fixTrail $ mapLoc wrapLine t + segs' = fixTrail $ mapLoc wrapLine t' + + aSecT = head segs' + bSecT = last segs' + + (aSegIx, a') = splitParam a + (bSegIx, b') = splitParam b + + aSecFS = section (segs !! floor aSegIx) a' x + where x = if aSegIx == bSegIx then b' else 1 + bSecFS = section (segs !! floor bSegIx) x b' + where x = if aSegIx == bSegIx then a' else 0 + + splitParam p | p < 0 = (0 , p * n) + | p >= 1 = (n - 1, 1 + (p - 1) * n) + | otherwise = propFrac $ p * n + where + propFrac x = let m = x `mod'` 1 in (x - m, m) + n = genericLength segs diff --git a/test/Diagrams/Test/Transform.hs b/test/Diagrams/Test/Transform.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Transform.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + + +module Diagrams.Test.Transform where + +import Test.Tasty +import Test.Tasty.QuickCheck +import Diagrams.Prelude +import Diagrams.Direction +import Instances + +tests :: TestTree +tests = testGroup "Transform" [ + + testProperty "rotating a vector by a number then its additive inverse will yield the original vector" $ + \θ a -> rotate ((θ * (-1)) @@ deg) (rotate ((θ :: Double) @@ deg) (a :: V2 Double)) =~ a + , testProperty "under rotated allows scaling along an angle" $ + \θ f a -> under (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (negated (θ @@ deg)) . (scaleX f) . rotate (θ @@ deg)) a + , testProperty "a rotation of 0 does nothing" $ + \a -> rotate (0 @@ deg) (a :: V2 Double) =~ a + , testProperty "adding 360 degrees to a turn does nothing" $ + \c a -> rotate (((c :: Double) + 360) @@ deg) (a :: V2 Double) =~ rotate (c @@ deg) a + , testProperty "over rotated allows scaling along x of a rotated shape" $ + \θ f a -> over (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (θ @@ deg) . (scaleX f) . rotate (negated (θ @@ deg))) a + , testProperty "scaleX" $ + \f a b -> (scaleX (f :: Double)) (V2 (a :: Double) b) =~ V2 (a * f) b + , testProperty "scaleY" $ + \f a b -> (scaleY (f :: Double)) (V2 (a :: Double) b) =~ V2 a (f * b) + , testProperty "reflectX" $ + \a b -> reflectX (V2 (a :: Double) b) =~ V2 (a * (-1)) b + , testProperty "reflectY" $ + \a b -> reflectY (V2 (a :: Double) b) =~ V2 a ((-1) * b) + , testProperty "reflectXY" $ + \a b -> reflectXY (V2 (a :: Double) b) =~ V2 b a + , testProperty "translate" $ + \a b c d -> translateX (a :: Double) (translateY b (P (V2 c d ))) =~ P (V2 (a + c) (b + d)) + , testProperty "shear" $ + \a b c d -> shearX (a :: Double) (shearY b (V2 c d)) =~ V2 ((c*b + d) * a + c) (c*b + d) + , testProperty "(1,0) rotateTo some dir will return normalised dir" $ + \(NonZero a) b -> rotateTo (dir (V2 (a :: Double) b)) (V2 1 0) =~ signorm (V2 a b) + , testProperty "rotates" $ + \a c -> rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate'' ((a :: Double)@@ deg) (c :: V2 Double) && rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate' ((a :: Double)@@ deg) (c :: V2 Double) + , testProperty "reflectAbout works for a vector" $ + \a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (V2 e f) =~ over (rotated (atan2A' d c)) reflectY (V2 e f) + , testProperty "reflectAbout works for a point" $ + \a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (P (V2 e f)) =~ translate (V2 a b) ((over (rotated (atan2A' d c)) reflectY) ((translate (V2 (-a) (-b)) ) (P (V2 e f)))) + + + ] + +--the original " '' " and a secondary " ' " rotate function for testing + +rotation'' :: Floating n => Angle n -> T2 n +rotation'' theta = fromLinear r (linv r) + where + r = rot theta <-> rot (negated theta) + rot th (V2 x y) = V2 (cosA th * x - sinA th * y) + (sinA th * x + cosA th * y) + +rotate'' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t +rotate'' = transform . rotation'' + +rotation' :: Floating n => Angle n -> T2 n +rotation' theta = fromLinear r (linv r) + where + r = rot theta <-> rot (negated theta) + rot th (V2 x y) = V2 (c * x - s * y) + (s * x + c * y) + where + c = cosA th + s = sinA th + +rotate' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t +rotate' = transform . rotation' diff --git a/test/Diagrams/Test/Transform/Matrix.hs b/test/Diagrams/Test/Transform/Matrix.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Transform/Matrix.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | + +module Diagrams.Test.Transform.Matrix where + + +import Test.Tasty +import Test.Tasty.QuickCheck +import Diagrams.Transform.Matrix +import Diagrams.Prelude +import Data.Distributive (distribute) + +import Instances + +tests :: TestTree +tests = testGroup "Transform.Matrix" + [ + testProperty "mkMat column vectors (2D)" $ + \(Blind (t :: T2 Double)) -> distribute (mkMat t) =~ V2 (transform t unitX) (transform t unitY) + , testProperty "mkMat / fromMat22" $ + \(m :: V2 (V2 Double)) -> mkMat (fromMat22 m zero) =~ m + + , testProperty "mkMat / fromMat33" $ + \(m :: V3 (V3 Double)) -> mkMat (fromMat33 m zero) =~ m + ] diff --git a/test/Diagrams/Test/TwoD.hs b/test/Diagrams/Test/TwoD.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/TwoD.hs @@ -0,0 +1,65 @@ +-- | + +module Diagrams.Test.TwoD where + +import Diagrams.Prelude +import qualified Diagrams.Query as Query (sample) +import Diagrams.Trail (linePoints) +import Instances +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +newtype SmallAngle = SmallAngle (Angle Double) + deriving (Eq, Ord, Show) + +-- Generate random angles within a reasonably small range (+/- 5 +-- turns). +instance Arbitrary SmallAngle where + arbitrary = SmallAngle . (@@turn) <$> choose (-5, 5) + +tests :: TestTree +tests = testGroup "TwoD" + [ testGroup "TwoD.Arc" [ + testProperty "arc start point is at radius 1 in the starting direction" $ \d (SmallAngle a) -> + pathVertices (arc d a :: Path V2 Double) ^? _head . _head =~ Just (origin .+^ fromDirection d ) + , testProperty "arc end point is at radius 1 in the ending direction" $ \d (SmallAngle a) -> + pathVertices (arc d a :: Path V2 Double) ^? _head . _last =~ Just (origin .+^ fromDirection (rotate a d)) + ] + , testGroup "TwoD.Types" [ + testProperty "R2 vector addition is commutative" $ + \u v -> (u :: V2 Double) ^+^ v =~ v ^+^ u + , testProperty "R2 subtraction is the inverse of addition" $ + \u v -> u ^+^ v ^-^ v =~ (u :: V2 Double) + , testProperty "R2 vector negation squared is identity" $ + \u -> negated (negated (u :: V2 Double)) =~ u + ] + , testGroup "cubicSpline" [ + testProperty "Open cubic spline interpolates all points" $ + \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline False pts :: [P2 Double])) + , testProperty "Closed cubic spline interpolates all points" $ + \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline True pts :: [P2 Double])) + ] + , testGroup "Trail" [ + testProperty "glueLine . cutLoop === id" $ + \l -> glueLine (cutLoop l :: Trail' Line V2 Double) =~ l + , testProperty "cutLoop ends at starting point" $ + \l -> let ps = linePoints (cutLoop (l :: Trail' Loop V2 Double) `at` origin) in (ps ^? _head) =~ (ps ^? _last) + , testProperty "cutTrail makes a Line" $ + \t -> isLine (cutTrail (t :: Trail V2 Double)) + , testProperty "fromSegments . lineSegments === id" $ + \l -> fromSegments (lineSegments l) =~ (l :: Trail' Line V2 Double) + , testProperty "lineSegments . fromSegments === id" $ + \segs -> lineSegments (fromSegments segs) =~ (segs :: [Segment Closed V2 Double]) + ] + , testGroup "Queries and Backgrounds" + (let dia :: QDiagram NullBackend V2 Double [Int] + dia = circle 5 # scaleX 2 # rotateBy (1/14) # value [1] + <> + circle 2 # scaleX 5 # rotateBy (-4/14) # value [2] + in [ + testProperty "sample dia pt === sample (dia # bg color) pt" $ + \pt -> Query.sample dia pt QC.=== Query.sample (dia # bg orange) pt + , testProperty "sample dia pt === sample (dia # bgFrame 0.1 color) pt" $ + \pt -> Query.sample dia pt QC.=== Query.sample (dia # bgFrame 0.1 green) pt + ]) + ] diff --git a/test/Diagrams/Test/TwoD/Offset.hs b/test/Diagrams/Test/TwoD/Offset.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/TwoD/Offset.hs @@ -0,0 +1,48 @@ +module Diagrams.Test.TwoD.Offset + ( + tests + ) where + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit + +import Diagrams.Prelude +import Diagrams.TwoD.Offset + +tests :: [TestTree] +tests = + [ testCase "line" + (offsetTrailVertices + [p2 (0, 0), p2 (1, 0)] + [p2 (0, -1), p2 (1, -1)]) + , testCase "square" + (offsetTrailVertices + [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] + [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) + , testCase "square loop" + (offsetTrailLoopVertices + [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] + [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) + , testCase "redundant line" + (offsetTrailVertices + [p2 (0, 0), p2 (0.5, 0), p2 (1, 0)] + [p2 (0, -1), p2 (1, -1)]) + , testCase "redundant square" + (offsetTrailVertices + [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] + [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) + , testCase "redundant square loop" + (offsetTrailLoopVertices + [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] + [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) + ] + +offsetTrailVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion +offsetTrailVertices orig off = + (trailVertices . offsetTrail 1 . fromVertices $ orig) @?= off + +offsetTrailLoopVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion +offsetTrailLoopVertices orig off = + (trailVertices . offsetTrail 1 . loopTrailFromVertices $ orig) @?= off + where + loopTrailFromVertices = (`at` origin) . wrapTrail . glueLine . lineFromVertices diff --git a/test/Diagrams/Test/TwoD/Segment.hs b/test/Diagrams/Test/TwoD/Segment.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/TwoD/Segment.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Diagrams.Test.TwoD.Segment + ( + tests + ) where + +import qualified Test.QuickCheck.Property as Q +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck + +import Diagrams.Prelude +import Diagrams.TwoD.Segment + +newtype InBox = InBox { unInBox :: Double } + +instance Arbitrary InBox where + arbitrary = InBox <$> choose (-1, 1) + +instance Arbitrary (Point V2 Double) where + arbitrary = curry p2 <$> (unInBox <$> arbitrary) + <*> (unInBox <$> arbitrary) + +instance Arbitrary (FixedSegment V2 Double) where + arbitrary = oneof [FLinear <$> arbitrary <*> arbitrary, FCubic <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary] + +epsT, epsE :: Double +epsT = 1.0e-9 -- parameter space epsilon +epsE = 1.0e-8 -- Euclidean space epsilon + +(.=~.) :: P2 Double -> P2 Double -> Bool +x .=~. y = norm (x .-. y) < epsE + +tests :: [TestTree] +tests = + [ testProperty "segmentSegment" $ + \a b -> validateIntersections a b (segmentSegment epsT a b) + ] + +validateIntersections :: FixedSegment V2 Double -> FixedSegment V2 Double -> [(Double, Double, P2 Double)] -> Q.Result +validateIntersections _ _ [] = Q.rejected -- TODO: check for false negatives (rasterize both and look for overlap?) +validateIntersections a b isects = go isects + where + go [] = Q.succeeded + go ((ta,tb,p):is) + | and [ 0 <= ta && ta <= 1 + , 0 <= tb && tb <= 1 + , a `atParam` ta .=~. p + , b `atParam` tb .=~. p + ] = go is + | otherwise = Q.failed diff --git a/test/Instances.hs b/test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Instances.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | instances for QuickCheck Arbitrary and approximate equality + +module Instances where + +import Diagrams.Prelude +import Numeric.Extras +import Test.Tasty.QuickCheck (Arbitrary (..), Gen) +import qualified Test.Tasty.QuickCheck as QC + +------------------------------------------------------------ + -- Approximate Comparison for Doubles, Points + +epsilon :: Double +epsilon = 0.001 + +class Approx a where + (=~) :: a -> a -> Bool + +infix 4 =~ + +--instance (Fractional a, Ord a) => Approx a where +instance Approx Double where + (=~) a b = abs (a - b) < epsilon + +instance Approx Float where + (=~) a b = abs (a - b) < 0.001 + +instance Approx n => Approx (V2 n) where + z1 =~ z2 = (z1^._x) =~ (z2^._x) && (z1^._y) =~ (z2^._y) + +instance Approx n => Approx (V3 n) where + z1 =~ z2 = (z1^._x) =~ (z2^._x) && (z1^._y) =~ (z2^._y) && (z1^._z) =~ (z2^._z) + +instance Approx (v n) => Approx (Point v n) where + p =~ q = view _Point p =~ view _Point q + +instance (Approx n, RealExtras n) => Approx (Angle n) where + a =~ b = normA (a^.rad) =~ normA (b^.rad) where + normA ang = let ang' = ang `fmod` pi in if ang' >= 0 then ang' else ang'+pi + +instance Approx n => Approx (Offset Closed V2 n) where + OffsetClosed v0 =~ OffsetClosed v1 = v0 =~ v1 + +instance Approx n => Approx (Segment Closed V2 n) where + Linear o0 =~ Linear o1 = o0 =~ o1 + Cubic c0 d0 o0 =~ Cubic c1 d1 o1 = c0 =~ c1 && d0 =~ d1 && o0 =~ o1 + _ =~ _ = False + -- The above is conservative: + -- Cubic never equals Linear even if they describe the same points + +instance Approx n => Approx (FixedSegment V2 n) where + FLinear a0 b0 =~ FLinear a1 b1 = a0 =~ a1 && b0 =~ b1 + FCubic a0 b0 c0 d0 =~ FCubic a1 b1 c1 d1 = a0 =~ a1 && b0 =~ b1 && c0 =~ c1 && d0 =~ d1 + _ =~ _ = False + +instance Approx n => Approx (Trail' Line V2 n) where + l0 =~ l1 = and $ zipWith (=~) (lineSegments l0) (lineSegments l1) + +instance Approx n => Approx (Trail' Loop V2 n) where + l0 =~ l1 = fst (loopSegments l0) =~ fst (loopSegments l1) + +instance (Approx n, Floating n, Ord n) => Approx (Trail V2 n) where + t0 =~ t1 = and $ zipWith (=~) (trailSegments t0) (trailSegments t1) + +instance (Approx a, Approx (Vn a), Num (N a), Additive (V a)) => + Approx (Located a) where + a0 =~ a1 = (loc a0 .-. origin) =~ (loc a1 .-. origin) && unLoc a0 =~ unLoc a1 + +instance Approx a => Approx (Maybe a) where + Nothing =~ Nothing = True + Nothing =~ Just _ = False + Just _ =~ Nothing = False + Just l =~ Just r = l =~ r + +-- These may be too general +instance Approx a => Approx [a] where + a =~ b = and $ zipWith (=~) a b + +instance (Approx a, Approx b) => Approx (a, b) where + (a0, b0) =~ (a1,b1) = (a0 =~ a1) && (b0 =~ b1) + +------------------------------------------------------------ +-- Arbitrary instances for Points, Paths + +instance Arbitrary n => Arbitrary (V2 n) where + arbitrary = (^&) <$> arbitrary <*> arbitrary + shrink (coords -> x :& y) = (^&) <$> shrink x <*> shrink y + +instance Arbitrary n => Arbitrary (V3 n) where + arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary + shrink (coords -> x :& y :& z) = V3 <$> shrink x <*> shrink y <*> shrink z + +instance Arbitrary (v n) => Arbitrary (Point v n) where + arbitrary = P <$> arbitrary + shrink (P v) = P <$> shrink v + +instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Transformation V2 n) where + arbitrary = QC.sized arbT + where + arbT 0 = return mempty + arbT n = QC.oneof + [ rotation <$> arbitrary + , scaling <$> arbitrary + , translation <$> arbitrary + , reflectionAbout <$> arbitrary <*> arbitrary + , (<>) <$> arbT (n `div` 2) <*> arbT (n `div` 2) + ] + +instance Arbitrary n => Arbitrary (Angle n) where + arbitrary = review rad <$> arbitrary + +instance (Arbitrary n, Floating n) => Arbitrary (Direction V2 n) where + arbitrary = rotate <$> arbitrary <*> pure xDir + +-- -- | Not a valid Show instance because not valid Haskell input +-- instance (Show n, RealFloat n) => Show (Direction V2 n) where +-- show d = "Dir" <> ( show $ d ^. _theta . turn ) + +-- NOTE on shrinks: Adding definitions of 'shrink' below seems to work +-- in simple tests, but test case failures hang for a very long time +-- (presumably trying lots and lots of expensive shrinks). Not sure +-- how to make shrinking more tractable. + +instance (Arbitrary a, Arbitrary (Vn a)) => Arbitrary (Located a) where + arbitrary = at <$> arbitrary <*> arbitrary +-- shrink (viewLoc -> (p,a)) = uncurry at <$> shrink (a,p) + +instance Arbitrary n => Arbitrary (Offset Closed V2 n) where + arbitrary = OffsetClosed <$> arbitrary +-- shrink (OffsetClosed x) = OffsetClosed <$> shrink x + +instance Arbitrary n => Arbitrary (Segment Closed V2 n) where + arbitrary = QC.oneof [Linear <$> arbitrary, Cubic <$> arbitrary <*> arbitrary <*> arbitrary] + -- shrink (Linear x) = Linear <$> shrink x + -- shrink (Cubic x y z) = Linear z + -- : [Cubic x' y' z' | (x',y',z') <- shrink (x,y,z)] + +instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail' Line V2 n) where + arbitrary = lineFromSegments <$> arbitrary +-- shrink (lineSegments -> segs) = lineFromSegments <$> shrink segs + +instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail' Loop V2 n) where + arbitrary = closeLine <$> arbitrary +-- shrink (cutLoop -> l) = closeLine <$> shrink l + +instance (Arbitrary n, Floating n, Ord n) => Arbitrary (Trail V2 n) where + arbitrary = QC.oneof [Trail <$> (arbitrary :: Gen (Trail' Loop V2 n)), Trail <$> (arbitrary :: Gen (Trail' Line V2 n))] + diff --git a/test/Speed.hs b/test/Speed.hs new file mode 100644 --- /dev/null +++ b/test/Speed.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Criterion +import Criterion.Main (defaultMain) + +import Diagrams.Prelude + + +main :: IO () +main = defaultMain + [ bgroup "rotates" + [ bench "rotate" $ whnf (rotate (90 @@ deg :: Angle Double)) (V2 3 3) + ,bench "rotate1" $ whnf (rotate' (90 @@ deg :: Angle Double)) (V2 3 3) + ,bench "rotate2" $ whnf (rotate'' (90 @@ deg :: Angle Double)) (V2 3 3) + ] + ] + +--the original " '' " and a secondary " ' " rotate function for comparing speed testing +--note: function time changes dramatically when function is in this file rather than imported + + +rotation' :: Floating n => Angle n -> T2 n +rotation' theta = fromLinear r (linv r) + where + r = rot theta <-> rot (negated theta) + rot th (V2 x y) = V2 (c * x - s * y) + (s * x + c * y) + where + c = cosA th + s = sinA th + +rotate' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t +rotate' = transform . rotation' + +rotation'' :: Floating n => Angle n -> T2 n +rotation'' theta = fromLinear r (linv r) + where + r = rot theta <-> rot (negated theta) + rot th (V2 x y) = V2 (cosA th * x - sinA th * y) + (sinA th * x + cosA th * y) + +rotate'' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t +rotate'' = transform . rotation'' diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,26 @@ +import Test.Tasty (TestTree, defaultMain, testGroup) + +import qualified Diagrams.Test.Angle as Angle +import qualified Diagrams.Test.Direction as Direction +import qualified Diagrams.Test.Transform as Transform +import qualified Diagrams.Test.Transform.Matrix as TransformMatrix +import qualified Diagrams.Test.TwoD as TwoD +import qualified Diagrams.Test.TwoD.Offset as TwoD.Offset +import qualified Diagrams.Test.TwoD.Segment as TwoD.Segment + +import qualified Diagrams.Test.Trail as Trail + +tests :: TestTree +tests = testGroup "unit tests" + [ testGroup "TwoD.Offset" TwoD.Offset.tests + , testGroup "TwoD.Segment" TwoD.Segment.tests + , TwoD.tests + , Angle.tests + , Direction.tests + , Transform.tests + , TransformMatrix.tests + , Trail.tests + ] + +main :: IO () +main = defaultMain tests