diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,309 @@ +## [v1.6](https://github.com/diagrams/diagrams-lib/tree/v1.6) (2026-08-06) + +- Fix a ton of warnings + - Remove redundant `Typable` derivations + - Use safer function variants, `NonEmpty`, etc. + - Redefine `Diagrams.CubicSpline.Boehm.BSpline` as `NonEmpty (Point v n)` + - New module `Diagrams.CubicSpline.Nonsingleton` for lists with at + least two elements, needed for safe operation of `CubicSpline` + methods +- Dependency updates + - Allow `base-4.22` and test on GHC 9.14 + - Remove support for GHC 8.4 + - Depend on `diagrams-solve-0.3` + - Allow `containers-0.8` + - Remove unused dependencies `semigroups`, `tagged`, `text`, + `profunctors`, `fail`, `deepseq` +- Fix documentation for `splitTextureFills` (thanks to @kostmo) + +## [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` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,35 @@ -Copyright (c) 2011-2015 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://travis-ci.org/diagrams/diagrams-lib.png?branch=master)](https://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/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 1.3.1.4 +Version: 1.6 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 @@ -9,8 +9,8 @@ creating diagrams. To get started using it, see the "Diagrams" module, and refer to the tutorials and documentation on the diagrams website, - . -Homepage: http://projects.haskell.org/diagrams + . +Homepage: http://diagrams.github.io License: BSD3 License-file: LICENSE Author: Brent Yorgey @@ -18,10 +18,10 @@ Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics Build-type: Simple -Cabal-version: >=1.10 -Extra-source-files: CHANGELOG.md, README.markdown, diagrams/*.svg -Extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 +Cabal-version: 1.18 +Extra-source-files: diagrams/*.svg +Extra-doc-files: CHANGELOG.md, README.markdown, diagrams/*.svg +Tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 || ==9.14.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git @@ -40,7 +40,9 @@ Diagrams.Combinators, Diagrams.Coordinates, Diagrams.CubicSpline, + Diagrams.CubicSpline.Boehm, Diagrams.CubicSpline.Internal, + Diagrams.CubicSpline.NonSingleton, Diagrams.Deform Diagrams.Direction, Diagrams.Envelope, @@ -99,38 +101,36 @@ Diagrams.TwoD.Types, Diagrams.TwoD.Vector, Diagrams.Util - Build-depends: base >= 4.2 && < 4.10, - containers >= 0.3 && < 0.6, + other-modules: Linear.Vector.Compat + Build-depends: base >= 4.9 && < 4.23, + base-compat >= 0.9, + containers >= 0.3 && < 0.9, array >= 0.3 && < 0.6, - semigroups >= 0.3.4 && < 0.19, - monoid-extras >= 0.3 && < 0.5, + monoid-extras >= 0.6 && < 0.8, dual-tree >= 0.2 && < 0.3, - diagrams-core >= 1.3 && < 1.4, - diagrams-solve >= 0.1 && < 0.2, + diagrams-core >= 1.4 && < 1.6, + diagrams-solve >= 0.3 && < 0.4, active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, - data-default-class < 0.2, + data-default >= 0.8 && < 0.9, fingertree >= 0.1 && < 0.2, - intervals >= 0.7 && < 0.8, - lens >= 4.6 && < 4.15, - tagged >= 0.7, - optparse-applicative >= 0.11 && < 0.14, - filepath, - JuicyPixels >= 3.1.5 && < 3.3, - hashable >= 1.1 && < 1.3, - linear >= 1.20.1 && < 1.21, + intervals >= 0.7 && < 0.10, + lens >= 5.1 && < 5.4, + 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.5, - fsnotify >= 0.2.1 && < 0.3, - directory >= 1.2 && < 1.3, + process >= 1.1 && < 1.7, + directory >= 1.2 && < 1.4, unordered-containers >= 0.2 && < 0.3, - text >= 0.7.1 && < 1.3, - mtl >= 2.0 && < 2.3, - transformers >= 0.3.0 && < 0.6.0, - exceptions >= 0.6 && < 1.0 - if impl(ghc < 7.6) - Build-depends: ghc-prim + mtl >= 2.0 && < 2.3 || >= 2.3.1 && < 2.4, + transformers >= 0.3.0 && < 0.7.0, + exceptions >= 0.6 && < 1.0, + cereal >=0.4.1.1 && <0.6, + bytestring >=0.9 && <0.13 Hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 @@ -144,10 +144,32 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs - other-modules: Diagrams.TwoD.OffsetTest + 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 >= 4.2 && < 4.10, - tasty >= 0.10, - tasty-hunit >= 0.9.2, - diagrams-lib + build-depends: base, + tasty >= 0.10 && < 1.6, + tasty-hunit >= 0.9.2 && < 0.11, + tasty-quickcheck >= 0.8 && < 0.12, + QuickCheck >= 2.7, + diagrams-lib, + distributive, + numeric-extras 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-lib 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 --- a/diagrams/src_Diagrams_Combinators_appendsEx.svg +++ b/diagrams/src_Diagrams_Combinators_appendsEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Combinators_besideEx.svg b/diagrams/src_Diagrams_Combinators_besideEx.svg --- a/diagrams/src_Diagrams_Combinators_besideEx.svg +++ b/diagrams/src_Diagrams_Combinators_besideEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Combinators_positionEx.svg b/diagrams/src_Diagrams_Combinators_positionEx.svg --- a/diagrams/src_Diagrams_Combinators_positionEx.svg +++ b/diagrams/src_Diagrams_Combinators_positionEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Combinators_strutEx.svg b/diagrams/src_Diagrams_Combinators_strutEx.svg --- a/diagrams/src_Diagrams_Combinators_strutEx.svg +++ b/diagrams/src_Diagrams_Combinators_strutEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg --- a/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg +++ b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg @@ -1,3 +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 --- a/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg +++ b/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg --- a/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg +++ b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg --- a/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg +++ b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg --- a/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg +++ b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg --- a/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg +++ b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TrailLike_twiddleEx.svg b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg --- a/diagrams/src_Diagrams_TrailLike_twiddleEx.svg +++ b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Trail_closeLineEx.svg b/diagrams/src_Diagrams_Trail_closeLineEx.svg --- a/diagrams/src_Diagrams_Trail_closeLineEx.svg +++ b/diagrams/src_Diagrams_Trail_closeLineEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Trail_glueLineEx.svg b/diagrams/src_Diagrams_Trail_glueLineEx.svg --- a/diagrams/src_Diagrams_Trail_glueLineEx.svg +++ b/diagrams/src_Diagrams_Trail_glueLineEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg --- a/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg +++ b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg --- a/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg +++ b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_Trail_trailOffsetEx.svg b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg --- a/diagrams/src_Diagrams_Trail_trailOffsetEx.svg +++ b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg --- a/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg --- a/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg --- a/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example1.svg b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg --- a/diagrams/src_Diagrams_TwoD_Arrow_example1.svg +++ b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example2.svg b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg --- a/diagrams/src_Diagrams_TwoD_Arrow_example2.svg +++ b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg --- a/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg --- a/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg --- a/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg --- a/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg --- a/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg @@ -1,3 +1,1 @@ - -LineCapSquareLineCapRoundLineCapButt +LineCapSquareLineCapRoundLineCapButt diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg @@ -1,3 +1,1 @@ - -LineJoinBevelLineJoinRoundLineJoinMiter +LineJoinBevelLineJoinRoundLineJoinMiter diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg --- a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg --- a/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg +++ b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg @@ -1,3 +1,1 @@ - - + diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -50,7 +52,8 @@ import Linear.Affine import Linear.Metric -import Linear.Vector +import Linear.Vector (negated) +import Linear.Vector.Compat (lerp) -- | Class of things which can be aligned. class Alignable a where @@ -76,8 +79,8 @@ 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 v a) (boundary (negated v) a) + (boundary v a) ) a {-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-} @@ -94,7 +97,7 @@ :: (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 (quadrance . (.-. origin) . b v)) fa + = b v $ F.maximumBy (comparing (dot v . (.-.origin) . b v)) fa instance (Metric v, OrderedField n) => Alignable (Envelope v n) where defaultBoundary = envelopeBoundary diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle @@ -33,19 +38,26 @@ -- ** Classes , HasTheta(..) , HasPhi(..) + + -- * Rotation + , rotation, rotate ) where import Control.Applicative -import Control.Lens (AReview, Iso', Lens', iso, over, review, (^.)) +import Control.Lens (AReview, Iso', Lens', iso, over, + review, (^.)) import Data.Fixed -import Data.Monoid hiding ((<>)) +import Data.Monoid hiding ((<>)) +import Data.Monoid.Action import Data.Semigroup -import Text.Read import Prelude +import Text.Read -import Diagrams.Core (OrderedField) +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 @@ -197,15 +209,58 @@ infixl 5 @@ --- | Compute the positive angle between the two vectors in their common plane. +-- | 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) => v n -> v n -> Angle n -angleBetween v1 v2 = acosA (signorm v1 `dot` signorm v2) +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 diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -31,10 +31,6 @@ ) where import Data.Active -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -import Data.Foldable (foldMap) -#endif import Data.Semigroup import Diagrams.Core @@ -50,7 +46,7 @@ -- | 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 n m = Active (QDiagram b v n m) 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -37,10 +36,6 @@ ----------------------------------------------------------------------------- module Diagrams.Animation.Active where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (pure, (<$>)) -#endif import Diagrams.Core import Diagrams.TrailLike diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} @@ -8,6 +8,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -55,6 +56,12 @@ , Opacity, _Opacity , getOpacity, opacity, _opacity + , FillOpacity, _FillOpacity + , getFillOpacity, fillOpacity, _fillOpacity + + , StrokeOpacity, _StrokeOpacity + , getStrokeOpacity, strokeOpacity, _strokeOpacity + -- ** Converting colors , colorToSRGBA, colorToRGBA @@ -81,14 +88,11 @@ ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Lens hiding (none, over) import Data.Colour import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) -import Data.Default.Class +import Data.Default import Data.Distributive import Data.Monoid.Recommend import Data.Semigroup @@ -127,7 +131,7 @@ -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last n) - deriving (Typeable, Semigroup) + deriving (Semigroup) _LineWidth :: Iso' (LineWidth n) n _LineWidth = iso getLineWidth (LineWidth . Last) @@ -190,7 +194,7 @@ -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [n] n - deriving (Functor, Typeable, Eq) + deriving (Functor, Eq) instance Semigroup (Dashing n) where _ <> b = b @@ -264,7 +268,6 @@ -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c - deriving Typeable instance Show SomeColor where showsPrec d (colorToSRGBA -> (r,g,b,a)) = @@ -326,7 +329,7 @@ -- words, for example, @opacity 0.8@ means \"decrease this diagram's -- opacity to 80% of its previous opacity\". newtype Opacity = Opacity (Product Double) - deriving (Typeable, Semigroup) + deriving (Semigroup) instance AttributeClass Opacity _Opacity :: Iso' Opacity Double @@ -345,6 +348,58 @@ _opacity :: Lens' (Style v n) Double _opacity = atAttr . mapping _Opacity . non 1 +-- 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 (Semigroup) +instance AttributeClass FillOpacity + +_FillOpacity :: Iso' FillOpacity Double +_FillOpacity = iso getFillOpacity (FillOpacity . Product) + +getFillOpacity :: FillOpacity -> Double +getFillOpacity (FillOpacity (Product d)) = d + +-- | 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 + +-- | Lens onto the fill opacity in a style. +_fillOpacity :: Lens' (Style v n) Double +_fillOpacity = atAttr . mapping _FillOpacity . non 1 + +-- 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 (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 ------------------------------------------------------------------------ @@ -357,7 +412,7 @@ -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints. - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show) instance Default LineCap where def = LineCapButt @@ -387,7 +442,7 @@ | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms? - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show) instance AttributeClass LineJoin @@ -414,7 +469,7 @@ -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) - deriving (Typeable, Semigroup, Eq, Ord) + deriving (Semigroup, Eq, Ord) instance AttributeClass LineMiterLimit _LineMiterLimit :: Iso' LineMiterLimit Double diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -2,6 +2,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes.Compile @@ -21,8 +25,9 @@ import Control.Arrow (second) import Control.Lens ((%~), (&), _Wrapping') +import Data.Kind (Type) import qualified Data.HashMap.Strict as HM -import Data.Semigroup ((<>)) +import Data.Semigroup import Data.Tree (Tree (..)) import Diagrams.Core @@ -35,8 +40,8 @@ -- splitFills; it's done this way to facilitate testing. class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where - type AttrType code :: * - type PrimType code :: * + type AttrType code :: Type + type PrimType code :: Type primOK :: code -> PrimType code -> Bool diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ + -- | -- Module : Diagrams.Backend.CmdLine -- Copyright : (c) 2013 Diagrams team (see LICENSE) @@ -22,202 +23,178 @@ -- 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 - - -- ** Loop options - , DiagramLoopOpts(..) - , diagramLoopOpts - , loop - , src - , interval - - -- * Parsing - , Parseable(..) - , readHexColor +-- . +module Diagrams.Backend.CmdLine ( + -- * Options - -- * Command-line programs (@Mainable@) - -- ** Arguments, rendering, and entry point - , Mainable(..) + -- ** Standard options + DiagramOpts (..), + diagramOpts, + width, + height, + output, - -- ** General currying - , ToResult(..) + -- ** Multi-diagram options + DiagramMultiOpts (..), + diagramMultiOpts, + selection, + list, - -- ** helper functions for implementing @mainRender@ - , defaultAnimMainRender - , defaultMultiMainRender - , defaultLoopRender - ) where + -- ** Animation options + DiagramAnimOpts (..), + diagramAnimOpts, + fpu, -import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) -import Diagrams.Animation -import Diagrams.Attributes -import Diagrams.Core hiding (output, value) -import Diagrams.Util + -- * Parsing + Parseable (..), + readHexColor, -import Options.Applicative -import Options.Applicative.Types (readerAsk) + -- * Command-line programs (@Mainable@) -import Control.Monad (forM_, forever, unless, when) + -- ** Arguments, rendering, and entry point + Mainable (..), -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.IORef -import Data.List (delete) -import Data.Maybe (fromMaybe) -import Data.Monoid -import Numeric + -- ** General currying + ToResult (..), -import Control.Concurrent (threadDelay) -import System.Directory (canonicalizePath) -import System.Environment (getArgs, getProgName) -import System.Exit (ExitCode (..)) -import System.FilePath (addExtension, dropExtension, - replaceExtension, splitExtension, - takeDirectory, takeFileName, ()) -import System.FSNotify (WatchConfig (..), defaultConfig, - eventTime, watchDir, - withManagerConf) -import System.FSNotify.Devel (existsEvents) -import System.Info (os) -import System.IO (hFlush, stdout) -import System.Process (readProcessWithExitCode) + -- ** helper functions for implementing @mainRender@ + defaultAnimMainRender, + defaultMultiMainRender, +) where -import Text.Printf +import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) +import Control.Monad (forM_) +import Control.Monad.Fail.Compat (MonadFail) +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 Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Core hiding (output) +import Numeric +import Options.Applicative +import Options.Applicative.Types (readerAsk) +import System.Environment (getProgName) +import System.FilePath (addExtension, splitExtension) +import Text.Printf +import Prelude hiding (MonadFail) -- | 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. + { _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) + deriving (Show, Data) 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. + { _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) + deriving (Show, Data) makeLenses ''DiagramMultiOpts -- | Extra options for animations. data DiagramAnimOpts = DiagramAnimOpts - { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation. + { _fpu :: Double + -- ^ Number of frames per unit time to generate for the animation. } - deriving (Show, Data, Typeable) + deriving (Show, Data) makeLenses ''DiagramAnimOpts --- | Extra options for command-line looping. -data DiagramLoopOpts = DiagramLoopOpts - { _loop :: Bool -- ^ Flag to indicate that the program should loop creation. - , _src :: Maybe FilePath -- ^ File path for the source file to recompile. - , _interval :: Int -- ^ Interval in seconds at which to check for recompilation. - } - -makeLenses ''DiagramLoopOpts - -- | 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") +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") +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)") - --- | CommandLine parser for 'DiagramLoopOpts' --- Loop is @--loop@ or @-l@. --- Source is @--src@ or @-s@. --- Interval is @-i@ defaulting to one second. -diagramLoopOpts :: Parser DiagramLoopOpts -diagramLoopOpts = DiagramLoopOpts - <$> switch (long "loop" <> short 'l' <> help "Run in a self-recompiling loop") - <*> (optional . strOption) - ( long "src" <> short 's' - <> help "Source file to watch") - <*> option auto - ( long "interval" <> short 'i' - <> value 1 - <> metavar "INTERVAL" - <> help "When running in a loop, check for changes every INTERVAL seconds.") +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 ShowHelpText $ mconcat - [ long "help" - , short '?' - , help "Show this help text" - ] +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 @@ -225,10 +202,13 @@ defaultOpts :: Parser a -> IO a defaultOpts optsParser = do prog <- getProgName - let p = info (helper' <*> optsParser) - ( fullDesc - <> progDesc "Command-line diagram generation." - <> header prog) + 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 @@ -271,29 +251,24 @@ instance Parseable DiagramAnimOpts where parser = diagramAnimOpts --- | Parse 'DiagramLoopOpts' using the 'diagramLoopOpts' parser. -instance Parseable DiagramLoopOpts where - parser = diagramLoopOpts - - -- | 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? + 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) + where + rh = readerAsk >>= readHexColor + rc = opaque <$> (readerAsk >>= readColourName) -- Addapted from the Clay.Color module of the clay package @@ -303,27 +278,27 @@ -- 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, Monad m) => String -> m (AlphaColour Double) +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" + ('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 - hex a b = (/ 255) <$> case readHex [a,b] of - [(h,"")] -> return h - _ -> fail $ "could not parse as a hex value" ++ [a,b] + 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 @@ -332,7 +307,7 @@ parser = pure () -- | Allow 'Parseable' things to be combined. -instance (Parseable a, Parseable b) => Parseable (a,b) where +instance (Parseable a, Parseable b) => Parseable (a, b) where parser = (,) <$> parser <*> parser -- | Triples of Parsebales should also be Parseable. @@ -348,8 +323,8 @@ -- 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 ResultOf d :: * + type Args d :: Type + type ResultOf d :: Type toResult :: d -> Args d -> ResultOf d @@ -370,8 +345,8 @@ -- | 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)] + 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 @@ -402,8 +377,7 @@ type Args (a -> d) = (a, Args d) type ResultOf (a -> d) = ResultOf d - toResult f (a,args) = toResult (f a) args - + 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 @@ -423,16 +397,13 @@ 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 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. - -- - -- Note the @d@ argument should only be needed to fix the type @d@. Its - -- value should not be relied on as a parameter. - mainArgs :: Parseable (MainOpts d) => d -> IO (MainOpts d) + mainArgs :: Parseable (MainOpts d) => proxy d -> IO (MainOpts d) mainArgs _ = defaultOpts parser -- | Backend specific work of rendering with the given options and mainable @@ -457,17 +428,20 @@ -- implementation should be used to handle more complex interactions with the user. mainWith :: Parseable (MainOpts d) => d -> IO () mainWith d = do - opts <- mainArgs d + 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 +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) + 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` ? @@ -495,14 +469,14 @@ -- 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 +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 + 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 () @@ -526,9 +500,8 @@ -- be output for each second (unit time) of animation. -- -- This function requires a lens into the structure that the particular backend --- uses for it's diagram base case. If @MainOpts (QDiagram b v n Any) ~ DiagramOpts@ --- then this lens will simply be 'output'. For a backend supporting looping --- it will most likely be @_1 . output@. This lens is required because the +-- 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 -- @@ -540,107 +513,24 @@ -- -- 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 + (opts -> QDiagram b v n Any -> IO ()) -> + -- | A lens into the output path. + Lens' opts FilePath -> + (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 + 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) - -putStrF :: String -> IO () -putStrF s = putStr s >> hFlush stdout - -defaultLoopRender :: DiagramLoopOpts -> IO () -defaultLoopRender opts = when (opts ^. loop) $ do - putStrLn "Looping turned on" - prog <- getProgName - args <- getArgs - - srcPath <- case opts ^. src of - Just path -> return path - Nothing -> fromMaybe (error nosrc) <$> findHsFile prog - where - nosrc = "Unable to find Haskell source file.\n" - ++ "Specify source file with '-s' or '--src'" - srcPath' <- canonicalizePath srcPath - - sandbox <- findSandbox [] - sandboxArgs <- case sandbox of - Nothing -> return [] - Just sb -> do - putStrLn ("Using sandbox " ++ takeDirectory sb) - return ["-package-db", sb] - - let args' = delete "-l" . delete "--loop" $ args - newProg = newProgName (takeFileName srcPath) prog - timeOfDay = take 8 . drop 11 . show . eventTime - - -- Polling is only used on Windows - withManagerConf defaultConfig { confPollInterval = opts ^. interval } $ - \mgr -> do - lock <- newIORef False - - _ <- watchDir mgr (takeDirectory srcPath') (existsEvents (== srcPath')) - $ \ev -> do - running <- atomicModifyIORef lock ((,) True) - unless running $ do - putStrF ("Modified " ++ timeOfDay ev ++ " ... ") - exitCode <- recompile srcPath' newProg sandboxArgs - -- Call the new program without the looping option - run newProg args' exitCode - atomicWriteIORef lock False - - putStrLn $ "Watching source file " ++ srcPath - putStrLn $ "Compiling target: " ++ newProg - putStrLn $ "Program args: " ++ unwords args' - forever . threadDelay $ case os of - -- https://ghc.haskell.org/trac/ghc/ticket/7325 - "darwin" -> 5000000000000 - _ -> maxBound - -recompile :: FilePath -> FilePath -> [String] -> IO ExitCode -recompile srcFile outFile args = do - let ghcArgs = ["--make", srcFile, "-o", outFile] ++ args - putStrF "compiling ... " - (exit, _, stderr) <- readProcessWithExitCode "ghc" ghcArgs "" - when (exit /= ExitSuccess) $ putStrLn ('\n':stderr) - return exit - --- | On Windows, the next compilation must have a different output --- than the currently running program. -newProgName :: FilePath -> String -> String -newProgName srcFile oldName = case os of - "mingw32" -> - if oldName == replaceExtension srcFile "exe" - then replaceExtension srcFile ".1.exe" - else replaceExtension srcFile "exe" - _ -> dropExtension srcFile - --- | Run the given program with specified arguments, if and only if --- the previous command returned ExitSuccess. -run :: String -> [String] -> ExitCode -> IO () -run prog args ExitSuccess = do - let path = "." prog - putStrF "running ... " - (exit, stdOut, stdErr) <- readProcessWithExitCode path args "" - case exit of - ExitSuccess -> putStrLn "done." - ExitFailure r -> do - putStrLn $ prog ++ " failed with exit code " ++ show r - unless (null stdOut) $ putStrLn "stdout:" >> putStrLn stdOut - unless (null stdErr) $ putStrLn "stderr:" >> putStrLn stdErr -run _ _ _ = return () + where + fmt = "%0" ++ show nDigits ++ "d" + output' = addExtension (base ++ printf fmt i) ext + (base, ext) = splitExtension (opts ^. out) diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -38,9 +39,11 @@ , boxExtents, boxCenter , mCenterPoint, centerPoint , boxTransform, boxFit - , contains, contains', boundingBoxQuery + , contains, contains' , inside, inside', outside, outside' + , boxGrid + -- * Operations on bounding boxes , union, intersection ) where @@ -55,7 +58,8 @@ import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Path -import Diagrams.ThreeD.Shapes +import Diagrams.Query +import Diagrams.ThreeD.Shapes (cube) import Diagrams.ThreeD.Types import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes @@ -65,7 +69,8 @@ import Data.Traversable as T import Linear.Affine import Linear.Metric -import Linear.Vector +import Linear.Vector hiding (lerp) +import Linear.Vector.Compat (lerp) -- Unexported utility newtype @@ -76,7 +81,7 @@ type instance N (NonEmptyBoundingBox v n) = n fromNonEmpty :: NonEmptyBoundingBox v n -> BoundingBox v n -fromNonEmpty = BoundingBox . Option . Just +fromNonEmpty = BoundingBox . Just fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v n) -> BoundingBox v n fromMaybeEmpty = maybe emptyBox fromNonEmpty @@ -91,7 +96,7 @@ -- | 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 n = BoundingBox (Option (NonEmptyBoundingBox v n)) +newtype BoundingBox v n = BoundingBox (Maybe (NonEmptyBoundingBox v n)) deriving (Eq, Functor) deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) @@ -118,8 +123,12 @@ = fromMaybeEmpty (NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b) +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 + => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners -- Feels like cheating. @@ -130,9 +139,8 @@ . getEnvelope instance TypeableFloat n => Traced (BoundingBox V3 n) where - getTrace = getTrace - . ((`boxFit` cube) . boundingBox :: Envelope V3 n -> D V3 n) - . getEnvelope + 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 @@ -159,7 +167,7 @@ -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't -- require the same type constraints that the @Monoid@ instance does. emptyBox :: BoundingBox v n -emptyBox = BoundingBox $ Option Nothing +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. @@ -189,17 +197,17 @@ -- | Queries whether the BoundingBox is empty. isEmptyBox :: BoundingBox v n -> Bool -isEmptyBox (BoundingBox (Option Nothing)) = True +isEmptyBox (BoundingBox Nothing) = True isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) -getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p +getCorners (BoundingBox p) = nonEmptyCorners <$> p -- | Computes all of the corners of the bounding box. getAllCorners :: (Additive v, Traversable v) => BoundingBox v n -> [Point v n] -getAllCorners (BoundingBox (Option Nothing)) = [] -getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) +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) @@ -256,9 +264,6 @@ check (l, h) = F.and (liftI2 (<) l p) && F.and (liftI2 (<) p h) -boundingBoxQuery :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Query v n Any -boundingBoxQuery bb = Query $ Any . contains bb - -- | Test whether the first bounding box is contained inside -- the second. inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool @@ -311,3 +316,19 @@ union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend +-- | @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 + mkRange lo hi = [lo, (1-f)*lo + f*hi .. hi] + + -- 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,10 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.Combinators -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) @@ -12,49 +17,55 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Higher-level tools for combining diagrams. --- ------------------------------------------------------------------------------ - -module Diagrams.Combinators - ( -- * Unary operations - - withEnvelope, withTrace - , phantom, strut - , pad, frame - , extrudeEnvelope, intrudeEnvelope - - -- * Binary operations - , atop - , beneath - , beside - , atDirection +module Diagrams.Combinators ( + -- * Unary operations + withEnvelope, + withTrace, + phantom, + strut, + pad, + frame, + extrudeEnvelope, + intrudeEnvelope, - -- * n-ary operations - , appends - , position, atPoints - , cat, cat' - , CatOpts(_catMethod, _sep), catMethod, sep - , CatMethod(..) + -- * Binary operations + atop, + beneath, + beside, + atDirection, - ) where + -- * n-ary operations + appends, + position, + atPoints, + cat, + cat', + CatOpts (_catMethod, _sep), + catMethod, + sep, + CatMethod (..), + composeAligned, +) where -import Control.Lens hiding (beside, ( # )) -import Data.Default.Class -import Data.Monoid.Deletable (toDeletable) -import Data.Monoid.MList (inj) -import Data.Proxy -import Data.Semigroup -import qualified Data.Tree.DUAL as D +import Control.Lens hiding (beside, (#)) +import Data.Default +import Data.Maybe (fromJust, listToMaybe) +import Data.Monoid.Deletable (toDeletable) +import Data.Monoid.MList (inj) +import Data.Proxy +import Data.Semigroup +import qualified Data.Tree.DUAL as D -import Diagrams.Core -import Diagrams.Core.Types (QDiagram (QD)) -import Diagrams.Direction -import Diagrams.Segment (straight) -import Diagrams.Util +import Diagrams.Core +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 +import Linear.Affine +import Linear.Metric +import Linear.Vector ------------------------------------------------------------ -- Working with envelopes @@ -73,14 +84,16 @@ -- > ) -- > 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 :: + (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 :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) - => a -> QDiagram b v n m -> QDiagram b v n 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 @@ -94,42 +107,47 @@ -- 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 :: (Metric v, OrderedField n, Monoid' m) - => n -> QDiagram b v n m -> QDiagram b v n 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 :: + (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. -- -- <> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 -strut :: (Metric v, OrderedField n) - => v n -> QDiagram b v n m +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 - -- in 2D; see Diagrams.TwoD.Segment). This is a good reason to have - -- a special 'strut' combinator (before the introduction of traces - -- it was mostly just for convenience). - -- - -- also note that we can't remove the call to getEnvelope, since - -- translating a segment has no effect. + 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 +-- in 2D; see Diagrams.TwoD.Segment). This is a good reason to have +-- a special 'strut' combinator (before the introduction of traces +-- it was mostly just for convenience). +-- +-- also note that we can't remove the call to getEnvelope, since +-- translating a segment has no effect. + -- | @extrudeEnvelope v d@ asymmetrically \"extrudes\" the envelope of -- a diagram in the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset outwards @@ -138,10 +156,10 @@ -- This works by offsetting the envelope distance proportionally to -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. -extrudeEnvelope - :: (Metric v, OrderedField n, Monoid' m) - => v n -> QDiagram b v n m -> QDiagram b v n m -extrudeEnvelope = deformEnvelope 0.5 +extrudeEnvelope :: + (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 @@ -150,23 +168,23 @@ -- -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. -intrudeEnvelope - :: (Metric v, OrderedField n, Monoid' m) - => v n -> QDiagram b v n m -> QDiagram b v n m -intrudeEnvelope = deformEnvelope (-0.5) +intrudeEnvelope :: + (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 - :: (Metric v, OrderedField n, Monoid' m) - => n -> v n -> QDiagram b v n m -> QDiagram b v n m +deformEnvelope :: + (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 - deformE = Option . fmap deformE' . getOption - deformE' env v' - | dp > 0 = Max $ getMax (env v') + (dp * s) / norm v' - | otherwise = env v' - where - dp = v' `dot` v + where + deformE = fmap deformE' + deformE' env v' + | dp > 0 = Max $ getMax (env v') + (dp * s) / quadrance v' + | otherwise = env v' + where + dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects @@ -175,8 +193,9 @@ -- | @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 :: (Metric v, OrderedField n, Monoid' m) - => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n 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` @@ -224,8 +243,9 @@ -- 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 :: + (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a) => + Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------ @@ -242,8 +262,8 @@ -- > 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) +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 @@ -264,26 +284,30 @@ atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. -data CatMethod = Cat -- ^ Normal catenation: simply put diagrams - -- next to one another (possibly with a - -- certain distance in between each). The - -- distance between successive diagram - -- /envelopes/ will be consistent; the - -- distance between /origins/ may vary if - -- the diagrams are of different sizes. - | Distrib -- ^ Distribution: place the local origins of - -- diagrams at regular intervals. With - -- this method, the distance between - -- successive /origins/ will be consistent - -- but the distance between envelopes may - -- not be. Indeed, depending on the amount - -- of separation, diagrams may overlap. +data CatMethod + = -- | Normal catenation: simply put diagrams + -- next to one another (possibly with a + -- certain distance in between each). The + -- distance between successive diagram + -- /envelopes/ will be consistent; the + -- distance between /origins/ may vary if + -- the diagrams are of different sizes. + Cat + | -- | Distribution: place the local origins of + -- diagrams at regular intervals. With + -- this method, the distance between + -- successive /origins/ will be consistent + -- but the distance between envelopes may + -- not be. Indeed, depending on the amount + -- of separation, diagrams may overlap. + Distrib -- | Options for 'cat''. -data CatOpts n = CatOpts { _catMethod :: CatMethod - , _sep :: n - , catOptsvProxy :: Proxy n - } +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 @@ -309,10 +333,12 @@ sep :: Lens' (CatOpts n) n instance Num n => Default (CatOpts n) where - def = CatOpts { _catMethod = Cat - , _sep = 0 - , catOptsvProxy = Proxy - } + def = + CatOpts + { _catMethod = Cat + , _sep = 0 + , catOptsvProxy = Proxy + } -- | @cat v@ positions a list of objects so that their local origins -- lie along a line in the direction of @v@. Successive objects @@ -322,8 +348,9 @@ -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. -cat :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) - => v n -> [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 @@ -343,11 +370,58 @@ -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). -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 *^ signorm (negated v) - -cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = +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 *^ signorm (negated v) +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) => + -- | Alignment function + (QDiagram b v n m -> QDiagram b v n m) -> + -- | Composition function + ([QDiagram b v n m] -> QDiagram b v n m) -> + ([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 = maybe origin location . listToMaybe . 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 @@ -19,8 +19,8 @@ ) where +import Data.Kind (Type) import Diagrams.Points - import Linear (V2 (..), V3 (..), V4 (..)) -- | Types which are instances of the @Coordinates@ class can be @@ -36,13 +36,13 @@ 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 diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -1,39 +1,51 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ------------------------------------------------------------------------------ + -- | -- Module : Diagrams.CubicSpline -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- 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. -- ------------------------------------------------------------------------------ -module Diagrams.CubicSpline - ( - -- * Constructing paths from cubic splines - cubicSpline - ) where +-- 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 Control.Lens (view) +import Data.List.NonEmpty (NonEmpty (..)) +import Diagrams.CubicSpline.NonSingleton (NonSingleton (..)) -import Diagrams.Core -import Diagrams.CubicSpline.Internal -import Diagrams.Located (Located, at, mapLoc) -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike (TrailLike (..)) +import Diagrams.Core +import Diagrams.CubicSpline.Boehm +import Diagrams.CubicSpline.Internal +import Diagrams.Located (Located, at, mapLoc) +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike (TrailLike (..)) -import Linear.Affine -import Linear.Metric +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 @@ -50,15 +62,16 @@ -- -- For more information, see . 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 [] = 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 closed $ lineFromSegments (map bez bs) `at` P b - bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) +cubicSpline closed (p1 : p2 : ps) = flattenBeziers . map f . solveCubicSplineCoefficients closed . fmap (view lensP) $ (p1 :|| (p2 :| 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 closed $ lineFromSegments (map bez bs) `at` P b + bez [a, b, c, d] = bezier3 (b - a) (c - a) (d - a) -closeIf :: (Metric v, OrderedField n) - => Bool -> Located (Trail' Line v n) -> Located (Trail v n) +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,156 @@ +{-# 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.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +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 = NonEmpty (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)) + +takeMaybe :: Int -> [a] -> Maybe [a] +takeMaybe 0 _ = Just [] +takeMaybe _ [] = Nothing +takeMaybe k (a : as) = (a :) <$> takeMaybe (k - 1) as + +-- | @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] -> [NonEmpty a] +windows 0 _ = [] +windows _ [] = [] +windows k (a : as) = case takeMaybe (k - 1) as of + Just as' -> (a :| as') : windows k as + Nothing -> [] + +-- | @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 _ [] = [] +extend k (x : xs) = replicate k x ++ (x : xs) ++ replicate k (NE.last (x :| 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 :: NonEmpty n} + +mkPolarPt :: Ord n => Point v n -> NonEmpty n -> PolarPt v n +mkPolarPt pt kts = PP pt (NE.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 (NE.head kts1) (NE.last kts2) newKt pt1 pt2) + (newKt :| NE.drop 1 kts1) + where + newKt = NE.toList 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 = NE.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 (NE.toList 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,6 +1,7 @@ ------------------------------------------------------------------------------ +{-# LANGUAGE GADTs #-} + -- | --- Module : Diagrams.CubicSpline +-- Module : Diagrams.CubicSpline.Internal -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com @@ -9,53 +10,60 @@ -- passing through a given sequence of points. This module implements -- a straightforward spline generation algorithm based on solving -- tridiagonal systems of linear equations. --- ------------------------------------------------------------------------------ -module Diagrams.CubicSpline.Internal - ( - -- * Solving for spline coefficents - solveCubicSplineDerivatives - , solveCubicSplineDerivativesClosed - , solveCubicSplineCoefficients - ) where - -import Diagrams.Solve.Tridiagonal +module Diagrams.CubicSpline.Internal ( + -- * Solving for spline coefficents + solveCubicSplineDerivatives, + solveCubicSplineDerivativesClosed, + solveCubicSplineCoefficients, +) where -import Data.List +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty.Compat as NE +import Diagrams.CubicSpline.NonSingleton (NonSingleton (..)) +import qualified Diagrams.CubicSpline.NonSingleton as NS +import Diagrams.Solve.Tridiagonal -- | 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 - as = replicate (l - 1) 1 - bs = 2 : replicate (l - 2) 4 ++ [2] - l = length ds - ds = zipWith f (xs ++ [last xs]) (x:x:xs) - f a b = 3*(a - b) - -solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives must be nonempty" +-- +-- See e.g. https://observablehq.com/@jrus/cubic-spline +solveCubicSplineDerivatives :: Fractional a => NonSingleton a -> NonEmpty a +solveCubicSplineDerivatives xs = solveTriDiagonal as bs as (NS.toNonEmpty ds) + where + as = NE.map (const 1) (NS.tail ds) + bs = 2 :| map (const 4) (NE.tail (NS.tail ds)) ++ [2] + -- zipWith f [x1, x2, x3, ..., xn, xn] [x0, x0, x1, ... x{n-2}, x{n-1}] + ds = NS.zipWith f (NS.dupLast (NS.tail xs)) (NS.dupFirst xs) + f a b = 3 * (a - b) -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. -solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] +solveCubicSplineDerivativesClosed :: Fractional a => NonSingleton a -> NonEmpty a solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 - where - as = replicate (l - 1) 1 - bs = replicate l 4 - l = length xs - xs' = cycle xs - ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') - f a b = 3*(a - b) + where + as = fmap (const 1) (NS.tail xs) + bs = fmap (const 4) (NS.toNonEmpty xs) + -- zipWith f [x1, x2, x3, ..., xn, x0] [xn, x0, x1, ..., x{n-1}] + -- ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') where l = length xs + xsNE = NS.toNonEmpty xs + ds = NE.zipWith f (NE.tail xsNE |: NE.head xsNE) (NE.cons (NE.last xsNE) xsNE) + f a b = 3 * (a - b) + + (|:) :: [a] -> a -> NonEmpty a + (|:) ys y = foldr NE.cons (NE.singleton y) ys + -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. -solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] +solveCubicSplineCoefficients :: Fractional a => Bool -> NonSingleton a -> [[a]] 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 - ds | closed = solveCubicSplineDerivativesClosed xs - | otherwise = solveCubicSplineDerivatives xs - close as | closed = as ++ [head as] - | otherwise = as - xs' = close xs - ds' = close ds + [ [x, d, 3 * (x1 - x) - 2 * d - d1, 2 * (x - x1) + d + d1] + | (x, x1, d, d1) <- zip4 (NE.toList xs') (NE.tail xs') (NE.toList ds') (NE.tail ds') + ] + where + ds + | closed = solveCubicSplineDerivativesClosed xs + | otherwise = solveCubicSplineDerivatives xs + close as + | closed = as <> NE.singleton (NE.head as) + | otherwise = as + xs' = close (NS.toNonEmpty xs) + ds' = close ds diff --git a/src/Diagrams/CubicSpline/NonSingleton.hs b/src/Diagrams/CubicSpline/NonSingleton.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline/NonSingleton.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTSyntax #-} + +-- | +-- Module : Diagrams.CubicSpline.NonSingleton +-- Copyright : (c) 2026 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A simple type representing lists with at least 2 elements, needed +-- as input for the cubic spline solver. +module Diagrams.CubicSpline.NonSingleton ( + -- * Non-singleton lists + NonSingleton (..), + toNonEmpty, + tail, + zipWith, + dupFirst, + dupLast, +) where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Prelude hiding (tail, zipWith) + +-- | Lists with at least 2 elements. +data NonSingleton a where + (:||) :: a -> NonEmpty a -> NonSingleton a + deriving (Functor) + +infixr 5 :|| + +toNonEmpty :: NonSingleton a -> NonEmpty a +toNonEmpty (x :|| xs) = NE.cons x xs + +dupFirst :: NonSingleton a -> NonSingleton a +dupFirst (x :|| xs) = x :|| NE.cons x xs + +dupLast :: NonEmpty a -> NonSingleton a +dupLast (x :| []) = x :|| (x :| []) +dupLast (x :| (y : ys)) = x :|| (y :| (ys ++ [NE.last (y :| ys)])) + +zipWith :: (a -> b -> c) -> NonSingleton a -> NonSingleton b -> NonSingleton c +zipWith f (x :|| xs) (y :|| ys) = f x y :|| NE.zipWith f xs ys + +tail :: NonSingleton a -> NonEmpty a +tail (_ :|| xs) = xs diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Diagrams.Deform diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -27,8 +28,8 @@ import Diagrams.Core import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector -------------------------------------------------------------------------------- -- Direction @@ -76,11 +77,10 @@ fromDir (Dir v) = signorm v -- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: (Metric v, Floating n) +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 directions from @p@ to @q@ +-- | @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 $ p .-. q - +dirBetween p q = dir $ q .-. p diff --git a/src/Diagrams/LinearMap.hs b/src/Diagrams/LinearMap.hs --- a/src/Diagrams/LinearMap.hs +++ b/src/Diagrams/LinearMap.hs @@ -6,7 +6,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.LinearMap diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -26,18 +28,19 @@ where import Control.Lens (Lens, Lens') -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor ((<$>)) -#endif import Text.Read import Linear.Affine import Linear.Vector +import Diagrams.Align import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Parametric +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 @@ -62,8 +65,10 @@ -- 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. @@ -144,6 +149,9 @@ 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) @@ -163,6 +171,8 @@ => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p + + 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 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 diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -22,12 +22,13 @@ ) where +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 @@ -55,7 +56,7 @@ -- with numeric scalars). domainUpper :: p -> N p - default domainUpper :: Num n => p -> n + default domainUpper :: Num (N p) => p -> N p domainUpper = const 1 -- | Type class for querying the values of a parametric object at the diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs --- a/src/Diagrams/Parametric/Adjust.hs +++ b/src/Diagrams/Parametric/Adjust.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -25,7 +26,7 @@ (.~), (^.)) import Data.Proxy -import Data.Default.Class +import Data.Default import Diagrams.Core.V import Diagrams.Parametric diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- for Data.Semigroup + -- | -- Module : Diagrams.Path -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) @@ -23,63 +25,56 @@ -- similar notion of \"path\". Note that paths with multiple trails -- are necessary for being able to draw /e.g./ filled objects with -- holes in them. --- ------------------------------------------------------------------------------ - -module Diagrams.Path - ( - - -- * Paths - - Path(..), pathTrails - - -- * Constructing paths - -- $construct - - , ToPath (..) - , pathFromTrail - , pathFromTrailAt - , pathFromLocTrail - - -- * Eliminating paths - - , pathPoints - , pathVertices' - , pathVertices - , pathOffsets - , pathCentroid - , pathLocSegments, fixPath +module Diagrams.Path ( + -- * Paths + Path (..), + pathTrails, - -- * Modifying paths + -- * Constructing paths + -- $construct + ToPath (..), + pathFromTrail, + pathFromTrailAt, + pathFromLocTrail, - , scalePath - , reversePath + -- * Eliminating paths + pathPoints, + pathVertices', + pathVertices, + pathOffsets, + pathCentroid, + pathLocSegments, + fixPath, - -- * Miscellaneous + -- * Modifying paths + scalePath, + reversePath, - , explodePath - , partitionPath + -- * Miscellaneous + explodePath, + partitionPath, +) where - ) where +import Control.Arrow ((***)) +import Control.Lens hiding (at, transform, (#)) +import qualified Data.Foldable as F +import Data.List (partition) +import Data.Semigroup -import Control.Arrow ((***)) -import Control.Lens hiding ((#), transform, at) -import qualified Data.Foldable as F -import Data.List (partition) -import Data.Semigroup -import Data.Typeable +import Diagrams.Align +import Diagrams.Core +import Diagrams.Located +import Diagrams.Points +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform -import Diagrams.Align -import Diagrams.Core -import Diagrams.Located -import Diagrams.Points -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.Transform +import Linear.Metric +import Linear.Vector -import Linear.Metric -import Linear.Vector +import Data.Serialize (Serialize) +import GHC.Generics (Generic) ------------------------------------------------------------ -- Paths ------------------------------------------------- @@ -90,23 +85,12 @@ -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. newtype Path v n = Path [Located (Trail v n)] - deriving (Semigroup, Monoid -#if __GLASGOW_HASKELL__ >= 707 - , Typeable -#endif - ) + deriving (Semigroup, Monoid, Generic) -#if __GLASGOW_HASKELL__ < 707 --- This should really be Typeable2 Path but since Path has kind --- (* -> *) -> * -> * --- not --- * -> * -> * --- we can only do Typeable1 (Path v). This is why the instance cannot be --- derived. -instance forall v. Typeable1 v => Typeable1 (Path v) where - typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path") [] `mkAppTy` - typeOf1 (undefined :: v n) -#endif +-- 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) instance Wrapped (Path v n) where type Unwrapped (Path v n) = [Located (Trail v n)] @@ -133,8 +117,8 @@ pathTrails = op Path 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) +deriving instance Eq (v n) => Eq (Path v n) +deriving instance Ord (v n) => Ord (Path v n) type instance V (Path v n) = v type instance N (Path v n) = n @@ -145,18 +129,21 @@ -- | 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 . (:[]) + trailLike = Path . (: []) -- See Note [Transforming paths] -instance (HasLinearMap v, Metric v, OrderedField n) - => Transformable (Path v n) where +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 n) -> Envelope v n - trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) + where + -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 + trailEnvelope :: Located (Trail v n) -> Envelope v n + trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) instance (Metric v, OrderedField n) => Juxtaposable (Path v n) where juxtapose = juxtaposeDefault @@ -164,8 +151,10 @@ instance (Metric v, OrderedField n) => Alignable (Path v n) where defaultBoundary = envelopeBoundary -instance (HasLinearMap v, Metric v, OrderedField n) - => Renderable (Path v n) NullBackend where +instance + (HasLinearMap v, Metric v, OrderedField n) => + Renderable (Path v n) NullBackend + where render _ _ = mempty ------------------------------------------------------------ @@ -177,7 +166,6 @@ -- 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'. @@ -189,6 +177,9 @@ 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 @@ -196,12 +187,12 @@ toPath = pathFromLocTrail . mapLoc Trail instance ToPath (Located (Segment Closed v n)) where - toPath (viewLoc -> (p,seg)) - = Path [trailFromSegments [seg] `at` p] + 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] + toPath (viewLoc -> (p, segs)) = + Path [trailFromSegments segs `at` p] instance ToPath (FixedSegment v n) where toPath = toPath . fromFixedSeg diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -29,8 +29,11 @@ import Linear.Vector -- | The centroid of a set of /n/ points is their sum divided by /n/. +-- Returns the origin for an empty list of points. centroid :: (Additive v, Fractional n) => [Point v n] -> Point v n -centroid = meanV +centroid [] = origin +centroid ps = meanV ps +{-# INLINE centroid #-} 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) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + -- | -- Module : Diagrams.Prelude -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) @@ -9,76 +9,73 @@ -- -- A module to re-export most of the functionality of the diagrams -- core and standard library. --- ------------------------------------------------------------------------------ - -module Diagrams.Prelude - ( - -- * Diagrams library - -- | Exports from this library for working with diagrams. - module Diagrams - - -- * Convenience re-exports from other packages - - -- | For working with default values. Diagrams also exports 'with', - -- an alias for 'def'. - , module Data.Default.Class - - -- | For representing and operating on colors. - , module Data.Colour - - -- | A large list of color names. - , module Data.Colour.Names - - -- | Specify your own colours. - , module Data.Colour.SRGB - - -- | 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 Linear.Vector - - -- | For computing with points and vectors. - , module Linear.Affine +module Diagrams.Prelude ( + -- * Diagrams library - -- | For computing with dot products and norm. - , module Linear.Metric + -- | Exports from this library for working with diagrams. + module Diagrams, - -- | For working with 'Active' (i.e. animated) things. - , module Data.Active + -- * Convenience re-exports from other packages - -- | 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 default values. Diagrams also exports 'with', + -- an alias for 'def'. + module Data.Default, + -- | For representing and operating on colors. + module Data.Colour, + -- | A large list of color names. + module Data.Colour.Names, + -- | Specify your own colours. + module Data.Colour.SRGB, + -- | 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 Linear.Vector, + -- | For computing with points and vectors. + module Linear.Affine, + -- | For computing with dot products and norm. + module Linear.Metric, + -- | For working with 'Active' (i.e. animated) things. + module Data.Active, + -- | 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, + Applicative (..), + (*>), + (<*), + (<$>), + (<$), + liftA, + liftA2, + liftA3, +) where - , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 - ) where +import Diagrams -import Diagrams +import Prelude.Compat +import Prelude () -import Control.Applicative +import Control.Applicative #if MIN_VERSION_lens(4,13,0) import Control.Lens hiding (argument, at, backwards, beside, @@ -93,13 +90,13 @@ (<.>)) #endif -import Data.Active -import Data.Colour hiding (AffineSpace (..), atop, over) -import Data.Colour.Names hiding (tan) -import Data.Colour.SRGB -import Data.Default.Class -import Data.Semigroup +import Data.Active +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) +import Data.Colour.SRGB +import Data.Default +import Data.Semigroup -import Linear.Affine -import Linear.Metric -import Linear.Vector +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,9 +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,18 +1,18 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.Segment -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) @@ -31,57 +31,63 @@ -- "Diagrams.Trail", "Diagrams.TrailLike", and "Diagrams.Path" should -- usually suffice. However, directly manipulating segments can -- occasionally be useful. --- ------------------------------------------------------------------------------ - -module Diagrams.Segment - ( -- * Open/closed tags - - Open, Closed - - -- * Segment offsets - - , Offset(..) , segOffset - - -- * Constructing and modifying segments - - , 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 - , TotalOffset(..) - , OffsetEnvelope(..), oeOffset, oeEnvelope - , SegMeasure +module Diagrams.Segment ( + -- * Open/closed tags + Open, + Closed, - ) where + -- * Segment offsets + Offset (..), + segOffset, -import Control.Lens hiding (at, transform) -import Data.FingerTree -import Data.Monoid.MList -import Data.Semigroup -import Numeric.Interval.Kaucher (Interval (..)) -import qualified Numeric.Interval.Kaucher as I + -- * Constructing and modifying segments + Segment (..), + straight, + bezier3, + bézier3, + reverseSegment, + mapSegmentVectors, + openLinear, + openCubic, -import Linear.Affine -import Linear.Metric -import Linear.Vector + -- * Fixed (absolutely located) segments + FixedSegment (..), + mkFixedSeg, + fromFixedSeg, + fixedSegIso, -import Control.Applicative -import Diagrams.Core hiding (Measured) -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Solve.Polynomial + -- * Segment measures + -- $segmeas + SegCount (..), + ArcLength (..), + getArcLengthCached, + getArcLengthFun, + getArcLengthBounded, + TotalOffset (..), + OffsetEnvelope (..), + oeOffset, + oeEnvelope, + SegMeasure, +) where +import Control.Lens hiding (at, transform) +import Data.FingerTree +import Data.Monoid.MList +import Data.Semigroup +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize +import Diagrams.Core hiding (Measured) +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Solve.Polynomial +import Linear.Affine +import Linear.Metric +import Linear.Vector hiding (lerp) +import Linear.Vector.Compat (lerp) +import Numeric.Interval.Kaucher (Interval (..)) +import qualified Numeric.Interval.Kaucher as I +import Prelude.Compat +import Prelude () ------------------------------------------------------------ -- Open/closed type tags --------------------------------- @@ -106,32 +112,32 @@ -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. data Offset c v n where - OffsetOpen :: Offset Open v n + OffsetOpen :: Offset Open v n OffsetClosed :: v n -> Offset Closed v n 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) +deriving instance Eq (v n) => Eq (Offset c v n) +deriving instance Ord (v n) => Ord (Offset c v n) instance Functor v => Functor (Offset c v) where - fmap _ OffsetOpen = OffsetOpen + fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f 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 + each _ OffsetOpen = pure OffsetOpen {-# INLINE each #-} -- | 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 + 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 _ OffsetOpen = OffsetOpen transform t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------ @@ -146,35 +152,41 @@ -- however, affected by other transformations such as rotations and -- scales. data Segment c v n - = Linear !(Offset c v n) - -- ^ A linear segment with given offset. - - | 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. - + = -- | A linear segment with given offset. + Linear !(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. + Cubic !(v n) !(v n) !(Offset c v n) 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 - + 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 + 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. @@ -226,24 +238,29 @@ -- 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 (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 + 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 n => DomainBounds (Segment Closed v n) instance (Additive v, Num n) => EndValues (Segment Closed v n) where - atStart = const zero - atEnd (Linear (OffsetClosed v)) = v + 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 n -> v n -segOffset (Linear (OffsetClosed v)) = v +segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v -- | An open linear segment. This means the trail makes a straight line @@ -284,18 +301,19 @@ -- | The envelope for a segment is based at the segment's start. instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where - getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> - maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v - + 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) `dot` v) / quadrance v) $ - [0,1] ++ - filter (liftA2 (&&) (>0) (<1)) - (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) - (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) - ((3 *^ c1) `dot` v)) + maximum + . map (\t -> ((s `atParam` t) `dot` v) / quadrance v) + $ [0, 1] + ++ filter + (liftA2 (&&) (> 0) (< 1)) + ( quadForm + (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) + (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) + ((3 *^ c1) `dot` v) + ) ------------------------------------------------------------ -- Manipulating segments @@ -303,54 +321,66 @@ 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 t x1 zero + where + left = straight p + right = straight (x1 ^-^ p) + 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 t c2 c1 - a = lerp t c1 zero - b = lerp t p a - d = lerp t x2 c2 - c = lerp t d p - e = lerp t c b + where + left = bezier3 a b e + right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) + 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 :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n -reverseSegment (Linear (OffsetClosed v)) = straight (negated v) +reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) -instance (Metric v, OrderedField n) - => HasArcLength (Segment Closed v n) 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 #-} +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 norm [c1, c2 ^-^ c1, x2 ^-^ c2]) - lb = norm x2 + | otherwise = arcLengthBounded (m / 2) l + arcLengthBounded (m / 2) r + where + (l, r) = s `splitAtParam` 0.5 + 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 < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) - | len `I.elem` 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) - $ arcLengthToParam (9*m/10) r (len - I.midpoint llen) - where (l,r) = s `splitAtParam` 0.5 - llen = arcLengthBounded (m/10) l - slen = arcLengthBounded m s + arcLengthToParam m s@(Cubic {}) len + | len `member` I (-m / 2) (m / 2) = 0 + | len < 0 = -arcLengthToParam m (fst (splitAtParam s (-1))) (-len) + | 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) + $ arcLengthToParam (9 * m / 10) r (len - I.midpoint llen) + where + (l, r) = s `splitAtParam` 0.5 + llen = arcLengthBounded (m / 10) l + slen = arcLengthBounded m s - -- Note, the above seems to be quite slow since it duplicates a lot of - -- work. We could trade off some time for space by building a tree of - -- parameter values (up to a certain depth...) +-- Note, the above seems to be quite slow since it duplicates a lot of +-- work. We could trade off some time for space by building a tree of +-- parameter values (up to a certain depth...) ------------------------------------------------------------ -- Fixed segments @@ -361,21 +391,22 @@ -- (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 n = FLinear (Point v n) (Point v n) - | FCubic (Point v n) (Point v n) (Point v n) (Point v n) - 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 n) = v type instance N (FixedSegment v n) = n 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 + 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 #-} -- | Reverses the control points. instance Reversing (FixedSegment v n) where - reversing (FLinear p0 p1) = FLinear p1 p0 + reversing (FLinear p0 p1) = FLinear p1 p0 reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 instance (Additive v, Num n) => Transformable (FixedSegment v n) where @@ -386,15 +417,18 @@ instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) - where (p, s) = viewLoc $ fromFixedSeg f + where + (p, s) = viewLoc $ fromFixedSeg f - -- Eventually we might decide it's cleaner/more efficient (?) to - -- have all the computation in the FixedSegment instance of - -- Envelope, and implement the Segment instance in terms of it, - -- instead of the other way around +-- Eventually we might decide it's cleaner/more efficient (?) to +-- have all the computation in the FixedSegment instance of +-- 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 +instance + (Metric v, OrderedField n) => + HasArcLength (FixedSegment v n) + where arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) @@ -402,12 +436,12 @@ 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) + (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 :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n) -fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 +fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -- | Use a 'FixedSegment' to make an 'Iso' between an @@ -418,42 +452,45 @@ 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 p2 p1 + atParam (FLinear p1 p2) t = lerp t p1 p2 atParam (FCubic x1 c1 c2 x2) t = p3 - where p11 = lerp t c1 x1 - p12 = lerp t c2 c1 - p13 = lerp t x2 c2 + where + p11 = lerp t x1 c1 + p12 = lerp t c1 c2 + p13 = lerp t c2 x2 - p21 = lerp t p12 p11 - p22 = lerp t p13 p12 + p21 = lerp t p11 p12 + p22 = lerp t p12 p13 - p3 = lerp t p22 p21 + 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 + 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 p1 p0 + 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 c1 p0 - p = lerp t c2 c1 - d = lerp t p1 c2 - -- second round - b = lerp t p a - c = lerp t d p - -- final round - cut = lerp t c b + 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 @@ -481,7 +518,6 @@ -- 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 n = ArcLength (Sum (Interval n), n -> Sum (Interval n)) @@ -504,15 +540,17 @@ -- | 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 n, Ord n) - => n -> ArcLength n -> Interval n +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 + | otherwise = getArcLengthFun al eps + where + cached = getArcLengthCached al + deriving instance (Num n, Ord n) => Semigroup (ArcLength n) -deriving instance (Num n, Ord n) => Monoid (ArcLength n) +deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments. @@ -528,7 +566,7 @@ TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) instance (Num n, Additive v) => Monoid (TotalOffset v n) where - mempty = TotalOffset zero + mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of @@ -536,47 +574,99 @@ -- combining the envelopes of two consecutive chains needs to take -- the offset of the first into account. data OffsetEnvelope v n = OffsetEnvelope - { _oeOffset :: !(TotalOffset v n) + { _oeOffset :: !(TotalOffset v n) , _oeEnvelope :: Envelope v n } makeLenses ''OffsetEnvelope instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where - (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) - = let !negOff = negated . op TotalOffset $ o1 - e2Off = moveOriginBy negOff e2 - !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off - in OffsetEnvelope + (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 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 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). +type SegMeasure v n = + SegCount + ::: ArcLength n + ::: OffsetEnvelope v n + ::: () -instance (Metric v, OrderedField n) - => Measured (SegMeasure v n) (SegMeasure v n) where +-- unfortunately we can't cache Trace, since there is not a generic +-- instance Traced (Segment Closed v), only Traced (Segment Closed R2). + +instance + (Metric v, OrderedField n) => + Measured (SegMeasure v n) (SegMeasure v n) + where measure = id -instance (OrderedField n, Metric v) - => Measured (SegMeasure v n) (Segment Closed v n) 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 + ) + *: OffsetEnvelope + (TotalOffset . segOffset $ s) + (getEnvelope s) + *: () - -- 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 ) +------------------------------------------------------------ +-- Serialize instances +------------------------------------------------------------ - *: OffsetEnvelope (TotalOffset . segOffset $ s) - (getEnvelope s) +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 --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.Size -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) @@ -21,45 +21,42 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Utilities for working with sizes of objects. --- ------------------------------------------------------------------------------ -module Diagrams.Size - ( -- * Size spec - SizeSpec +module Diagrams.Size ( + -- * Size spec + SizeSpec, - -- ** Making size spec - , mkSizeSpec - , dims - , absolute + -- ** Making size spec + mkSizeSpec, + dims, + absolute, - -- ** Extracting size specs - , getSpec - , specToSize + -- ** Extracting size specs + getSpec, + specToSize, - -- ** Functions on size specs - , requiredScale - , requiredScaling - , sized - , sizedAs - , sizeAdjustment - ) where + -- ** 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.Semigroup -import Data.Maybe -import Data.Typeable -import GHC.Generics (Generic) -import Prelude +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 GHC.Generics (Generic) +import Prelude -import Diagrams.Core -import Diagrams.BoundingBox +import Diagrams.BoundingBox +import Diagrams.Core -import Linear.Affine -import Linear.Vector +import Linear.Affine +import Linear.Vector ------------------------------------------------------------ -- Computing diagram sizes @@ -68,20 +65,13 @@ -- | A 'SizeSpec' is a way of specifying a size without needed lengths for all -- the dimensions. newtype SizeSpec v n = SizeSpec (v n) - deriving ( -#if __GLASGOW_HASKELL__ >= 707 - Typeable, -#endif - Functor, - Generic, - Hashable, - Show) - -#if __GLASGOW_HASKELL__ < 707 -instance forall v. Typeable1 v => Typeable1 (SizeSpec v) where - typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Size" "Size") [] `mkAppTy` - typeOf1 (undefined :: v n) -#endif + deriving + ( Eq + , Functor + , Generic + , Hashable + , Show + ) type instance V (SizeSpec v n) = v type instance N (SizeSpec v n) = n @@ -89,7 +79,7 @@ -- | 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 +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 @@ -111,56 +101,67 @@ -- 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 + 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 :: + (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 + | 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 :: + (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 :: + (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 :: + ( 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 :: + (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)) + 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 + sz = boxExtents bb + sz' = + if allOf folded isJust (getSpec spec) + then specToSize 0 spec + else s *^ sz - s = requiredScale spec sz + s = requiredScale spec sz - t = translation v <> scaling s + t = translation v <> scaling s diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs --- a/src/Diagrams/Tangent.hs +++ b/src/Diagrams/Tangent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} -- for ghc < 7.8, TypeFamilies covers GADT patten mathcing in > 7.8 {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD --- 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 -- @@ -40,17 +40,16 @@ -- 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 + ( 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 @@ -61,4 +60,3 @@ 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 --- a/src/Diagrams/ThreeD/Align.hs +++ b/src/Diagrams/ThreeD/Align.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs --- a/src/Diagrams/ThreeD/Attributes.hs +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes @@ -29,7 +29,6 @@ import Control.Lens import Data.Semigroup -import Data.Typeable import Data.Colour @@ -38,7 +37,7 @@ -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. newtype SurfaceColor = SurfaceColor (Last (Colour Double)) - deriving (Typeable, Semigroup) + deriving (Semigroup, Show) instance AttributeClass SurfaceColor @@ -59,7 +58,7 @@ -- 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) + deriving (Semigroup, Show) instance AttributeClass Diffuse @@ -82,7 +81,7 @@ -- indirect lighting incident on that object and the diffuse -- reflectance. newtype Ambient = Ambient (Last Double) - deriving (Typeable, Semigroup) + deriving (Semigroup, Show) instance AttributeClass Ambient @@ -107,12 +106,12 @@ data Specular = Specular { _specularIntensity :: Double , _specularSize :: Double - } + } deriving Show makeLenses ''Specular newtype Highlight = Highlight (Last Specular) - deriving (Typeable, Semigroup) + deriving (Semigroup, Show) instance AttributeClass Highlight @@ -136,4 +135,3 @@ -- '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 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -50,23 +49,11 @@ , up :: V3 n , lens :: l n } -#if __GLASGOW_HASKELL__ >= 707 - deriving Typeable -#else -instance forall l. Typeable1 l => Typeable1 (Camera l) where - typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera") [] `mkAppTy` - typeOf1 (undefined :: l n) -#endif - type instance V (Camera l n) = V3 type instance N (Camera l n) = n -#if __GLASGOW_HASKELL__ > 707 class Typeable l => CameraLens l where -#else -class Typeable1 l => CameraLens l where -#endif -- | The natural aspect ratio of the projection. aspect :: Floating n => l n -> n @@ -75,7 +62,6 @@ { _horizontalFieldOfView :: Angle n -- ^ Horizontal field of view. , _verticalFieldOfView :: Angle n -- ^ Vertical field of view. } - deriving Typeable makeLenses ''PerspectiveLens @@ -90,7 +76,6 @@ { _orthoWidth :: n -- ^ Width , _orthoHeight :: n -- ^ Height } - deriving Typeable makeLenses ''OrthoLens diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs --- a/src/Diagrams/ThreeD/Deform.hs +++ b/src/Diagrams/ThreeD/Deform.hs @@ -19,7 +19,7 @@ -- | 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 ^. _x) +perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _z) facingZ :: (R3 v, Functor v, Fractional n) => Deformation v v n facingZ = Deformation $ diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -28,7 +29,6 @@ -- | 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 @@ -36,7 +36,6 @@ -- | 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 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,9 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -17,22 +18,37 @@ ----------------------------------------------------------------------------- module Diagrams.ThreeD.Shapes - ( - Ellipsoid(..), sphere - , Box(..), cube - , Frustum(..) , frustum, cone, cylinder - ) where + ( + -- * Skinned class + Skinned(..) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif + -- * Basic 3D shapes + , Ellipsoid(..) + , sphere + + , Box(..) + , cube + + , Frustum(..) + , frustum + , cone + , cylinder + + -- * Constructive solid geometry + , CSG(..) + , union + , intersection + , difference + ) where + import Control.Lens (review, (^.), _1) -import Data.Typeable 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 @@ -42,7 +58,6 @@ import Linear.Vector data Ellipsoid n = Ellipsoid (Transformation V3 n) - deriving Typeable type instance V (Ellipsoid n) = V3 type instance N (Ellipsoid n) = n @@ -53,61 +68,59 @@ instance Fractional n => Renderable (Ellipsoid n) NullBackend where render _ _ = mempty +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 :: (Typeable n, OrderedField n, Renderable (Ellipsoid n) b) => QDiagram b V3 n Any -sphere = mkQD (Prim $ Ellipsoid mempty) - (mkEnvelope sphereEnv) - (mkTrace sphereTrace) - mempty - (Query sphereQuery) - where - sphereEnv v = 1 / norm v - sphereTrace (P p) v = mkSortedList $ quadForm a b c - where - a = v `dot` v - b = 2 * (p `dot` v) - c = p `dot` (p - 1) - sphereQuery v = Any $ quadrance (v .-. origin) <= 1 +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) + transform t1 (Box t2) = Box (t1 <> t2) instance Fractional n => Renderable (Box n) NullBackend where render _ _ = mempty --- | A cube with side length 1, in the positive octant, with one --- vertex at the origin. -cube :: (Typeable n, OrderedField n, Renderable (Box n) b) => QDiagram b V3 n Any -cube = mkQD (Prim $ Box mempty) - (mkEnvelope boxEnv) - (mkTrace boxTrace) - mempty - (Query boxQuery) - where - corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] - boxEnv v = maximum (map (v `dot`) corners) / quadrance v - -- ts gives all intersections with the planes forming the box - -- filter keeps only those actually on the box surface - boxTrace p v = mkSortedList . filter (range . atT) $ ts where - (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) +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 - boxQuery = Any . range + 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 @@ -118,55 +131,189 @@ 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 :: (TypeableFloat n, Renderable (Frustum n) b) => n -> n -> QDiagram b V3 n Any -frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) - (mkEnvelope frEnv) - (mkTrace frTrace) - mempty - (Query frQuery) - where - projectXY u = u ^-^ project unitZ u - frQuery p = Any $ x >= 0 && x <= 1 && a <= r where - (x, _, z) = unp3 p - r = r0 + (r1 - r0)*z - v = p .-. origin - a = norm $ projectXY v - -- 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 - frEnv v = maximum . map (norm . project v . review r3CylindricalIso) $ corners - where - θ = v ^. _theta - corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] - -- 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 - frTrace p v = mkSortedList $ filter zbounds (quadForm a b c) ++ ends - where - (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 +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 :: (TypeableFloat n, Renderable (Frustum n) b) => QDiagram b V3 n Any +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 :: (TypeableFloat n, Renderable (Frustum n) b) => QDiagram b V3 n Any +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) + +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 --- a/src/Diagrams/ThreeD/Size.hs +++ b/src/Diagrams/ThreeD/Size.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -5,6 +6,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Transform @@ -50,9 +55,9 @@ import Diagrams.Angle import Diagrams.Direction +import Diagrams.Points import Diagrams.ThreeD.Types import Diagrams.Transform -import Diagrams.Points import Control.Lens (view, (&), (*~), (.~), (//~)) import Data.Semigroup @@ -138,18 +143,18 @@ -- 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 +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 => V3 n -> V3 n -> V3 n -> Transformation V3 n +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 => V3 n -> V3 n -> V3 n -> Transformation V3 n +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 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 diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -1,1313 +1,1539 @@ -{-# 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 - , 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 - - -- * Modifying trails - - , reverseTrail, reverseLocTrail - , reverseLine, reverseLocLine - , reverseLoop, reverseLocLoop - - -- * Internals - -- $internals - - -- ** Type tags - - , Line, Loop - - -- ** Segment trees - - , SegTree(..), trailMeasure, numSegs, offset - - -- ** Extracting segments - - , GetSegment(..), getSegment - - ) where - -import Control.Arrow ((***)) -import Control.Lens hiding (at, transform, (<|), (|>)) -import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), - (<|), (|>)) -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 - --- $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)) - -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) - -type SplitResult v n = ((SegTree v n, n -> n), (SegTree v n, n -> n)) - -splitAtParam' :: (Metric v, OrderedField n, Real n) => SegTree v n -> n -> SplitResult v n -splitAtParam' tree@(SegTree t) p - | p < 0 = - case FT.viewl t of - EmptyL -> emptySplit - seg FT.:< t' -> - case seg `splitAtParam` (p * tSegs) of - (seg1, seg2) -> - ( (SegTree $ FT.singleton seg1, (*p)) - , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1)) - ) - | p >= 1 = - case FT.viewr t of - EmptyR -> emptySplit - t' FT.:> seg -> - case seg `splitAtParam` (1 - (1 - p)*tSegs) of - (seg1, seg2) -> - ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1)) - , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) - ) - | otherwise = - case FT.viewl after of - EmptyL -> emptySplit - seg FT.:< after' -> - let (n, p') = propFrac $ p * tSegs - f p n u | u * tSegs < n = u * tSegs / (n + 1) - | otherwise = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1) - in case seg `splitAtParam` p' of - (seg1, seg2) -> - ( ( SegTree $ before |> seg1 , f p n ) - , ( SegTree $ seg2 <| after' - , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v) - ) - ) - where - (before, after) = FT.split ((p * tSegs <) . numSegs) t - tSegs = numSegs t - emptySplit = let t' = (tree, id) in (t',t') - - propFrac x = let m = signum x * mod1 x in (x - m, m) - -instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where - splitAtParam tree p = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b) - - reverseDomain (SegTree t) = SegTree $ FT.reverse t' - where t' = FT.fmap' reverseSegment t - - section x t1 t2 = let ((a,fa),_) = splitAtParam' x t2 - in snd $ splitAtParam a (fa t1) - - -- XXX seems like it should be possible to collapse some of the - -- above cases into one? - -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 = 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 :: (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 - - 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 #-} - --------------------------------------------------- --- 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 @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 - - 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 - -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. -fixTrail :: (Metric v, OrderedField n) - => Located (Trail v n) -> [FixedSegment v n] -fixTrail t = map mkFixedSeg (trailLocSegments t) - --- | 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 - +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- 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 qualified Data.List.NonEmpty as NE +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), Semigroup) + +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, seg, after) = case FT.split ((pSegs <) . numSegs) t of + (before, rest) -> case viewl rest of + EmptyL -> (before, Linear (OffsetClosed zero), rest) + seg FT.:< after -> (before, seg, after) + (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 (.-.) (drop 1 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)) = case NE.nonEmpty . lineSegments . cutLoop $ t of + Nothing -> [] + Just segs + | NE.length segs > 1 -> if far > toler then init ps else init . drop 1 $ ps + | otherwise -> ps + where + far = + quadrance + ( (signorm . tangentAtStart . NE.head $ segs) + ^-^ (signorm . tangentAtEnd . NE.last $ segs) + ) + ps = segmentVertices' toler p (NE.toList 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 #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform @@ -120,4 +125,4 @@ -- @ translated :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) => v n -> Iso a b a b -translated = transformed . translation +translated v = transformed $ translation v diff --git a/src/Diagrams/Transform/Matrix.hs b/src/Diagrams/Transform/Matrix.hs --- a/src/Diagrams/Transform/Matrix.hs +++ b/src/Diagrams/Transform/Matrix.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -28,7 +30,7 @@ -- | 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 . el +mkMat t = distribute . tabulate $ apply t . unit . (\x -> el x) -- | Build a 3D transformation matrix in homogeneous coordinates from -- a 'Transformation V3'. @@ -39,13 +41,13 @@ -- 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 = flip (fromMatWithInv m) v $ inv22 m +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 = flip (fromMatWithInv m) v $ inv33 m +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) @@ -54,8 +56,8 @@ -> v n -- ^ translation -> Transformation v n fromMatWithInv m m_ v = - Transformation ((*! m) <-> (*! m_)) - ((*! distribute m) <-> (*! distribute m_)) + Transformation ((m !*) <-> (m_ !*)) + ((distribute m !*) <-> (distribute m_ !*)) v -- | Prism onto a 2D transformation from a 2x2 transform matrix and @@ -64,7 +66,8 @@ mat22 :: Floating n => Iso' (M22 n, V2 n) (T2 n) mat22 = iso (uncurry fromMat22) (mkMat &&& transl) --- | Prism onto a 2D transformation from a 2x2 transform matrix and --- translation vector (in which case the 'T3' will be invalid). +-- | 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 --- a/src/Diagrams/Transform/ScaleInv.hs +++ b/src/Diagrams/Transform/ScaleInv.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,6 +7,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -27,9 +27,6 @@ where import Control.Lens (makeLenses, view, (^.)) -#if __GLASGOW_HASKELL__ < 710 -import Data.Semigroup -#endif import Data.Typeable import Diagrams.Angle @@ -77,7 +74,6 @@ , _scaleInvDir :: Vn t , _scaleInvLoc :: Point (V t) (N t) } - deriving Typeable deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -181,7 +181,9 @@ -- * Text , text, topLeftText, alignedText, baselineText - , font, italic, oblique, bold, fontSize + , font, italic, oblique, fontSize + , bold, bolder, lighter, thinWeight + , ultraLight, light, mediumWeight, heavy, semiBold, ultraBold , _font, _fontSizeR, _fontSize , fontSizeO, fontSizeL, fontSizeN, fontSizeG @@ -210,9 +212,12 @@ , translationX, translateX , translationY, translateY , translation, translate + -- ** Conformal affine maps + , scalingRotationTo, scaleRotateTo -- ** Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- ** Shears , shearingX, shearX @@ -235,7 +240,7 @@ , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , rectEnvelope + , rectEnvelope, crop -- ** Background @@ -247,7 +252,7 @@ , centerX, centerY, centerXY -- * Snugging - , snugL, snugR, snugT, snugB, snugTL, snugTR, snugBL, snugBR + , snugL, snugR, snugT, snugB , snugX, snugY , snugCenterX, snugCenterY, snugCenterXY 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,7 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Adjust @@ -21,15 +25,15 @@ ) where 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.Size -import Diagrams.BoundingBox -import Control.Lens (Lens', (^.), set) -import Data.Default.Class +import Control.Lens (Lens', set, (^.)) +import Data.Default import Data.Semigroup 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -29,7 +30,6 @@ -- ** Align by trace , snugL, snugR, snugT, snugB - , snugTL, snugTR, snugBL, snugBR -- * Relative alignment , alignX, snugX, alignY, snugY @@ -83,14 +83,6 @@ alignBL = alignB . alignL alignBR = alignB . alignR -snugTL, snugTR, snugBL, snugBR - :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) - => a -> a -snugTL = snugT . snugL -snugTR = snugT . snugR -snugBL = snugB . snugL -snugBR = snugB . snugR - -- | @alignX@ and @snugX@ move the local origin horizontally as follows: -- -- * @alignX (-1)@ moves the local origin to the left edge of the boundary; @@ -140,5 +132,3 @@ 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,6 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc @@ -36,11 +42,11 @@ import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY, unit_Y, e) +import Diagrams.TwoD.Vector (e, unitX, unitY, unit_Y) import Diagrams.Util (( # )) import Control.Lens ((&), (<>~), (^.)) -import Data.Semigroup ((<>)) +import Data.Semigroup import Linear.Affine import Linear.Metric diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# 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) @@ -18,165 +18,166 @@ -- -- 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' +-- . +module Diagrams.TwoD.Arrow ( + -- * Examples - , arrow - , arrow' + -- ** Example 1 - , arrowFromLocatedTrail - , arrowFromLocatedTrail' + -- | <> + -- + -- > -- 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 - -- * Options - , ArrowOpts(..) + -- ** Example 2 - , arrowHead - , arrowTail - , arrowShaft - , headGap - , tailGap - , gaps, gap - , headTexture - , headStyle - , headLength - , tailTexture - , tailStyle - , tailLength - , lengths - , shaftTexture - , shaftStyle - , straightShaft + -- | <> + -- + -- > -- 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 - -- | See "Diagrams.TwoD.Arrowheads" for a list of standard - -- arrowheads and help creating your own. - , module Diagrams.TwoD.Arrowheads - ) where + -- * Creating arrows + arrowV, + arrowV', + arrowAt, + arrowAt', + arrowBetween, + arrowBetween', + connect, + connect', + connectPerim, + connectPerim', + connectOutside, + connectOutside', + arrow, + arrow', + arrowFromLocatedTrail, + arrowFromLocatedTrail', -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Lens (Lens', Traversal', - generateSignatures, lensRules, - makeLensesWith, view, (%~), (&), - (.~), (^.)) -import Data.Default.Class -import Data.Maybe (fromMaybe) -import Data.Monoid.Coproduct (untangle) -import Data.Semigroup -import Data.Typeable + -- * 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 Data.Colour hiding (atop) -import Diagrams.Core -import Diagrams.Core.Style (unmeasureAttrs) -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') +import Control.Lens ( + Lens', + Traversal', + both, + generateSignatures, + lensRules, + makeLensesWith, + over, + view, + (%~), + (&), + (.~), + (^.), + ) +import Data.Default +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup +import Data.Typeable -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, rotate, translateX) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unit_X) -import Diagrams.Util (( # )) +import Data.Colour hiding (atop, over) +import Diagrams.Core +import Diagrams.Core.Style (unmeasureAttrs) +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') -import Linear.Affine -import Linear.Metric -import Linear.Vector +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 - } + { _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 - } + 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 @@ -197,9 +198,10 @@ -- | 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) +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) @@ -254,23 +256,23 @@ -- 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 +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) +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) +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) + 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. @@ -278,12 +280,11 @@ 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 + 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 @@ -295,48 +296,61 @@ -- | 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 :: + (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 :: + (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)) +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)) --- | Make a trail with the same angles and offset as an arrow with tail width --- tw, head width hw and shaft of tr, such that the magnituted of the shaft --- offset is size. Used for calculating the offset of an arrow. +-- | @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 + 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 --- | Calculate the amount required to scale a shaft trail so that an arrow with --- head width hw and tail width tw has offset t. +-- | @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 - +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. @@ -348,30 +362,30 @@ -- 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 + 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 + where + -- we will usually get both a positive and a negative solution; + -- return the maximum (i.e. positive) solution + 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 + 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 @@ -384,92 +398,97 @@ -- @(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) = option 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 +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 - p = origin # transform tr - q = origin # translateX ln # transform tr + -- 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 + -- 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 + -- 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) + -- 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 + 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 + -- 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 + -- 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') + -- 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 + -- 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) + -- 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. @@ -480,9 +499,9 @@ -- @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' :: + (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 @@ -490,14 +509,16 @@ 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 +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 @@ -507,82 +528,90 @@ -- | @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' :: + (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 :: + (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' :: + (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 + 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 :: + (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' :: + (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) + withName n2 $ \sub2 -> + let (s, e) = over both 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 :: + (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' :: + (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) + withName n2 $ \sub2 -> + let (os, oe) = over both 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 :: + (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' :: + (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') + 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 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Arrowheads -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) @@ -13,77 +18,75 @@ -- 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 -module Diagrams.TwoD.Arrowheads - ( - -- * Arrowheads - -- ** Standard arrowheads - tri - , dart - , halfDart - , spike - , thorn - , lineHead - , noHead + -- ** 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 + -- ** Configurable arrowheads - -- * Arrow tails - -- ** Standard arrow tails - , tri' - , dart' - , halfDart' - , spike' - , thorn' - , lineTail - , noTail - , quill - , block + -- | 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, - -- ** Configurable arrow tails + -- * Arrow tails - , arrowtailQuill - , arrowtailBlock + -- ** Standard arrow tails + tri', + dart', + halfDart', + spike', + thorn', + lineTail, + noTail, + quill, + block, - -- * Internals - , ArrowHT - ) where + -- ** Configurable arrow tails + arrowtailQuill, + arrowtailBlock, -import Control.Lens ((&), (.~), (<>~), (^.)) -import Data.Default.Class -import Data.Monoid (mempty, (<>)) + -- * Internals + ArrowHT, +) where -import Diagrams.Angle -import Diagrams.Core +import Control.Lens (both, over, (&), (.~), (<>~), (^.)) +import Data.Default +import Data.Monoid (mempty, (<>)) -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 Diagrams.Angle +import Diagrams.Core -import Linear.Affine -import Linear.Metric -import Linear.Vector +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) @@ -107,106 +110,121 @@ -- > <> 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 - + 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) + 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) = over both (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) + -- 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 + 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) + -- 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 +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. + -- 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 + -- 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)) + -- 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) + 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) + -- 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 + 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) @@ -218,31 +236,31 @@ -- > triEx = drawHead tri tri :: RealFloat n => ArrowHT n -tri = arrowheadTriangle (1/3 @@ turn) +tri = arrowheadTriangle (1 / 3 @@ turn) -- | <> -- > spikeEx = drawHead spike spike :: RealFloat n => ArrowHT n -spike = arrowheadSpike (3/8 @@ turn) +spike = arrowheadSpike (3 / 8 @@ turn) -- | <> -- > thornEx = drawHead thorn thorn :: RealFloat n => ArrowHT n -thorn = arrowheadThorn (3/8 @@ turn) +thorn = arrowheadThorn (3 / 8 @@ turn) -- | <> -- > dartEx = drawHead dart dart :: RealFloat n => ArrowHT n -dart = arrowheadDart (2/5 @@ turn) +dart = arrowheadDart (2 / 5 @@ turn) -- | <> -- > halfDartEx = drawHead halfDart halfDart :: RealFloat n => ArrowHT n -halfDart = arrowheadHalfDart (2/5 @@ turn) +halfDart = arrowheadHalfDart (2 / 5 @@ turn) -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none @@ -254,47 +272,50 @@ -- 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' + 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 :: 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 + 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] + 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) @@ -336,10 +357,10 @@ -- > quillEx = drawTail quill quill :: (Floating n, Ord n) => ArrowHT n -quill = arrowtailQuill (2/5 @@ turn) +quill = arrowtailQuill (2 / 5 @@ turn) -- | <> -- > blockEx = drawTail block block :: RealFloat n => ArrowHT n -block = arrowtailBlock (7/16 @@ turn) +block = arrowtailBlock (7 / 16 @@ turn) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# 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) @@ -26,60 +27,93 @@ -- '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 + Texture (..), + solid, + _SC, + _AC, + _LG, + _RG, + defaultLG, + defaultRG, + GradientStop (..), + stopColor, + stopFraction, + mkStops, + SpreadMethod (..), + lineLGradient, + lineRGradient, -- ** Linear Gradients - , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd - , lGradSpreadMethod, mkLinearGradient + LGradient (..), + lGradStops, + lGradTrans, + lGradStart, + lGradEnd, + lGradSpreadMethod, + mkLinearGradient, -- ** Radial Gradients - , RGradient(..), rGradStops, rGradTrans - , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 - , rGradSpreadMethod, mkRadialGradient + RGradient (..), + rGradStops, + rGradTrans, + rGradCenter0, + rGradRadius0, + rGradCenter1, + rGradRadius1, + rGradSpreadMethod, + mkRadialGradient, -- ** Line texture - , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA - , mkLineTexture, _lineTexture + LineTexture (..), + _LineTexture, + getLineTexture, + lineTexture, + lineTextureA, + mkLineTexture, + _lineTexture, -- ** Line color - , lineColor, lc, lcA + lineColor, + lc, + lcA, -- ** Fill texture - , FillTexture(..), _FillTexture, getFillTexture, fillTexture - , mkFillTexture, _fillTexture, _fillTextureR + FillTexture (..), + _FillTexture, + getFillTexture, + fillTexture, + mkFillTexture, + _fillTexture, + _fillTextureR, -- ** Fill color - , fillColor, fc, fcA, recommendFillColor + 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.Class -import Data.Monoid.Recommend -import Data.Semigroup + splitTextureFills, +) where -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 +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 -------------------------------------------------- @@ -87,7 +121,7 @@ -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop - { _stopColor :: SomeColor + { _stopColor :: SomeColor , _stopFraction :: d } @@ -108,11 +142,12 @@ -- | Linear Gradient data LGradient n = LGradient - { _lGradStops :: [GradientStop n] - , _lGradStart :: Point V2 n - , _lGradEnd :: Point V2 n - , _lGradTrans :: Transformation V2 n - , _lGradSpreadMethod :: SpreadMethod } + { _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 @@ -143,13 +178,14 @@ -- | 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 } + { _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 @@ -169,7 +205,7 @@ rGradRadius0 :: Lens' (RGradient n) n -- | The center of the outer circle. -rGradCenter1 :: Lens' (RGradient n) (Point V2 n) +rGradCenter1 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the outer circle in 'local' coordinates. rGradRadius1 :: Lens' (RGradient n) n @@ -190,7 +226,6 @@ -- 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 @@ -204,7 +239,7 @@ 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 + transform _ sc = sc -- | Convert a solid colour into a texture. solid :: Color a => a -> Texture n @@ -215,28 +250,32 @@ -- 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 - } +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 - } +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). @@ -247,16 +286,23 @@ -- 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) +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) +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 -------------------------------------------------------- @@ -265,14 +311,19 @@ -- 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) + deriving (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 + (LineTexture n) + (LineTexture n') + (Texture n) + (Texture n') _LineTexture = iso getLineTexture (LineTexture . Last) -- Only gradients get transformed. The transform is applied to the gradients @@ -297,8 +348,8 @@ _lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) _lineTexture = atTAttr . anon def isDef . _LineTexture - where - isDef = anyOf (_LineTexture . _AC) (== opaque black) + 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 @@ -333,20 +384,21 @@ -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) - deriving (Typeable, Semigroup) + deriving (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 + 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 @@ -370,8 +422,8 @@ -- | 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) + 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'). @@ -415,10 +467,11 @@ -- | 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, +-- 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 :: + 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 #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators @@ -31,7 +36,7 @@ , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop - , rectEnvelope + , rectEnvelope, crop , boundingRect, bg, bgFrame @@ -39,7 +44,7 @@ import Control.Lens ((&), (.~)) import Data.Colour -import Data.Default.Class +import Data.Default import Data.Semigroup import Diagrams.Core @@ -48,6 +53,7 @@ import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Path +import Diagrams.Query (value) import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align @@ -244,6 +250,11 @@ => 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 :: ( InSpace V2 n a, SameSpace a t @@ -254,12 +265,15 @@ -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. -bg :: (TypeableFloat n, Renderable (Path V2 n) b) => Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any -bg c d = d <> boundingRect d # lwO 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. -bgFrame :: (TypeableFloat n, Renderable (Path V2 n) b) - => n -> Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any -bgFrame f c d = d <> boundingRect (frame f d) # lwO 0 # fc c +-- 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/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 #-} ----------------------------------------------------------------------------- -- | 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,12 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Image -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) @@ -18,60 +22,73 @@ -- 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 ( + DImage (..), + ImageData (..), + Embedded, + External, + Native, + image, + embeddedImage, + loadImageEmb, + loadImageEmbBS, + loadImageExt, + uncheckedImageRef, + raster, + rasterDia, +) where -module Diagrams.TwoD.Image - ( - DImage(..), ImageData(..) - , Embedded, External, Native - , image - , loadImageEmb - , loadImageExt - , uncheckedImageRef - , raster - , rasterDia - ) where +import Codec.Picture -import Codec.Picture -import Codec.Picture.Types (dynamicMap) +import Data.Colour (AlphaColour) +import Data.Kind (Type) +import Data.Semigroup +import Data.Typeable (Typeable) -import Data.Colour (AlphaColour) -import Data.Semigroup -import Data.Typeable (Typeable) +import Diagrams.Core -import Diagrams.Core +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 -import Diagrams.Attributes (colorToSRGBA) -import Diagrams.TwoD.Path (isInsideEvenOdd) -import Diagrams.TwoD.Shapes (rect) -import Diagrams.TwoD.Types +import Data.ByteString -import Linear.Affine +import Linear.Affine -data Embedded deriving Typeable -data External deriving Typeable -data Native (t :: *) deriving Typeable +data Embedded +data External +data Native (t :: Type) -- | '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 :: * -> * where +data ImageData :: Type -> Type where ImageRaster :: DynamicImage -> ImageData Embedded - ImageRef :: FilePath -> ImageData External + ImageRef :: FilePath -> ImageData External ImageNative :: t -> ImageData (Native t) ------------------------------------------------------------------------------- + -- | 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 :: * -> * -> * where +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) @@ -79,30 +96,41 @@ moveOriginTo p = translate (origin .-. p) -- | 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 p r)) - where - r = rect (fromIntegral w) (fromIntegral h) - DImage _ w h _ = img +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 --- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. +rectPath :: RealFloat n => n -> n -> Path V2 n +rectPath = rect + +-- | 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 + +-- | 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 = do - dImg <- readImage path - return $ case dImg of - Left msg -> Left msg - Right img -> Right (DImage (ImageRaster img) w h mempty) - where - w = dynamicMap imageWidth img - h = dynamicMap imageHeight img +loadImageEmb path = fmap embeddedImage `fmap` readImage path +-- | 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 @@ -110,11 +138,11 @@ loadImageExt path = do dImg <- readImage path return $ case dImg of - Left msg -> Left msg + Left msg -> Left msg Right img -> Right $ DImage (ImageRef path) w h mempty - where - w = dynamicMap imageWidth img - h = dynamicMap imageHeight img + 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 @@ -123,24 +151,24 @@ 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 :: + (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 + 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) + 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -37,7 +38,7 @@ import Control.Lens (makeLenses, (^.)) import Data.Colour (Colour) import Data.Colour.Names -import Data.Default.Class +import Data.Default import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (catMaybes) 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,12 +1,16 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ------------------------------------------------------------------------------ +-- for Data.Semigroup + -- | -- Module : Diagrams.TwoD.Offset -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) @@ -15,69 +19,71 @@ -- -- Compute offsets to segments in two dimensions. More details can be -- found in the manual at --- . --- ------------------------------------------------------------------------------ -module Diagrams.TwoD.Offset - ( - -- * Offsets - - offsetSegment - - , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon - , offsetTrail - , offsetTrail' - , offsetPath - , offsetPath' - - -- * Expansions - - , ExpandOpts(..), expandJoin, expandMiterLimit, expandCap, expandEpsilon - , expandTrail - , expandTrail' - , expandPath - , expandPath' +-- . +module Diagrams.TwoD.Offset ( + -- * Offsets + offsetSegment, + OffsetOpts (..), + offsetJoin, + offsetMiterLimit, + offsetEpsilon, + offsetTrail, + offsetTrail', + offsetPath, + offsetPath', - ) where + -- * Expansions + ExpandOpts (..), + expandJoin, + expandMiterLimit, + expandCap, + expandEpsilon, + expandTrail, + expandTrail', + expandPath, + expandPath', +) where -import Control.Applicative -import Control.Lens hiding (at) -import Prelude +import Control.Applicative +import Control.Lens hiding (at) +import Prelude -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Monoid.Inf +import Data.Maybe (catMaybes) +import Data.Monoid +import Data.Monoid.Inf -import Data.Default.Class +import Data.Default -import Diagrams.Core +import Diagrams.Core -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) +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) -import Linear.Affine -import Linear.Metric -import Linear.Vector +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 cubic t +perpAtParam cubic t = negated $ unitPerp a + where + a = case snd $ splitAtParam cubic t of + Cubic x _ _ -> x + _ -> error "Impossible: splitAtParam on a cubic segment returned a non-cubic segment" -- | Compute the offset of a segment. Given a segment compute the offset -- curve that is a fixed distance from the original curve. For linear @@ -104,15 +110,14 @@ -- 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. --- -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. data OffsetOpts d = OffsetOpts - { _offsetJoin :: LineJoin - , _offsetMiterLimit :: d - , _offsetEpsilon :: d - } + { _offsetJoin :: LineJoin + , _offsetMiterLimit :: d + , _offsetEpsilon :: d + } deriving instance Eq d => Eq (OffsetOpts d) deriving instance Show d => Show (OffsetOpts d) @@ -131,15 +136,16 @@ -- | 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 + 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) + { _expandJoin :: LineJoin + , _expandMiterLimit :: d + , _expandCap :: LineCap + , _expandEpsilon :: d + } + deriving (Eq, Show) makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts @@ -155,66 +161,70 @@ -- | 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 factor from the radius of curvature of - -- the offset. - -> n -- ^ Offset from the original segment, positive is - -- on the right of the curve, negative is on the - -- left. - -> 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 +instance Fractional d => Default (ExpandOpts d) where + def = ExpandOpts def 10 def 0.01 +offsetSegment :: + RealFloat 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 factor from the radius of curvature of + -- the offset. + n -> + -- | Offset from the original segment, positive is + -- on the right of the curve, negative is on the + -- left. + n -> + -- | Original segment + Segment Closed V2 n -> + -- | Resulting located (at the offset) trail. + Located (Trail V2 n) +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)) = t `at` origin .+^ va - where - t = trailFromSegments (go (radiusOfCurvature s 0.5)) - -- Perpendiculars to handles. - va = (-r) *^ unitPerp a - vc = (-r) *^ unitPerp (c ^-^ b) - -- Split segments. - 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) + where + t = trailFromSegments (go (radiusOfCurvature s 0.5)) + -- Perpendiculars to handles. + va = (-r) *^ unitPerp a + vc = (-r) *^ unitPerp (c ^-^ b) + -- Split segments. + ss = (\(x, y) -> [x, y]) $ splitAtParam s 0.5 + subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss - -- We observe a corner. Subdivide right away. - go (Finite 0) = subdivided - -- We have some curvature - go roc - | close = [o] - | otherwise = subdivided - where - -- We want the multiplicative factor that takes us from the original - -- segment's radius of curvature roc, to roc + r. - -- - -- r + sr = x * sr - -- - o = offset $ case roc of - Infinity -> 1 -- Do the right thing. - Finite sr -> 1 + r / sr + -- Offset with handles scaled based on curvature. + offset factor = bezier3 (a ^* factor) ((b ^-^ c) ^* factor ^+^ c ^+^ vc ^-^ va) (c ^+^ vc ^-^ va) - 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') - ] + -- We observe a corner. Subdivide right away. + go (Finite 0) = subdivided + -- We have some curvature + go roc + | close = [o] + | otherwise = subdivided + where + -- We want the multiplicative factor that takes us from the original + -- segment's radius of curvature roc, to roc + r. + -- + -- r + sr = x * sr + -- + o = offset $ case roc of + Infinity -> 1 -- Do the right thing. + Finite sr -> 1 + r / sr + 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 -- > @@ -242,13 +252,14 @@ -- 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 + 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 :: + 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 @@ -268,23 +279,25 @@ -- 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) +offsetTrail' :: + RealFloat n => + OffsetOpts 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. + n -> + 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 = rotateL . trailPoints $ t + | otherwise = drop 1 . trailPoints $ t + j = fromLineJoin (opts ^. offsetJoin) - isLoop = withTrail (const False) (const True) (unLoc t) + 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) @@ -292,9 +305,10 @@ -- | 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 +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 @@ -304,7 +318,7 @@ -- "right" make sense. -- -- > import Diagrams.TwoD.Offset --- > import Data.Default.Class +-- > import Data.Default -- > -- > corner :: (OrderedField n) => Located (Trail V2 n) -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin @@ -339,8 +353,8 @@ 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 + 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 @@ -354,40 +368,45 @@ -- 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' :: + (OrderedField n, RealFloat n, RealFrac n) => + ExpandOpts 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. + n -> + 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. + | 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) + 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 = drop 1 . 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 + 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 = rotateL . 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 @@ -395,16 +414,17 @@ -- | 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 +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.Class +-- > import Data.Default -- > -- > expandTrailExample :: Diagram SVG -- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) @@ -429,7 +449,6 @@ -- > 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. @@ -439,21 +458,31 @@ -- 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 +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 + 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 @@ -461,17 +490,18 @@ -- | 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) +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 a c) (dirBetween b c) - | otherwise = scale r $ arcCCW (dirBetween a c) (dirBetween b c) + 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 @@ -481,34 +511,36 @@ -- 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 :: + 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 +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 <*> drop 1) $ 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 :: + 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 + 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 @@ -524,38 +556,44 @@ -- | 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 :: + 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 :: + 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 :: + 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) + 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) + +rotateL :: [a] -> [a] +rotateL [] = [] +rotateL (a : as) = as ++ [a] 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,19 +1,20 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# 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,66 +22,81 @@ -- create a 2D diagram, and (eventually) perform operations such as -- intersection and union. They also have a trace, whereas paths in -- higher dimensions do not. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Path - ( -- * Constructing path-based diagrams - - stroke, stroke' - , strokePath, strokeP, strokePath', strokeP' - , strokeTrail, strokeT, strokeTrail', strokeT' - , strokeLine, strokeLoop - , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop - - -- ** Stroke options - - , FillRule(..) - , getFillRule, fillRule, _fillRule - , StrokeOpts(..), vertexNames, queryFillRule - - -- ** Inside/outside testing - - , isInsideWinding, isInsideEvenOdd - - -- * Clipping - - , Clip(..), _Clip, _clip - , clipBy, clipTo, clipped - - -- * Intersections +module Diagrams.TwoD.Path ( + -- * Constructing path-based diagrams + stroke, + stroke', + strokePath, + strokeP, + strokePath', + strokeP', + strokeTrail, + strokeT, + strokeTrail', + strokeT', + strokeLine, + strokeLoop, + strokeLocTrail, + strokeLocT, + strokeLocLine, + strokeLocLoop, - , intersectPoints, intersectPoints' - , intersectPointsP, intersectPointsP' - , intersectPointsT, intersectPointsT' - ) where + -- ** Stroke options + FillRule (..), + getFillRule, + fillRule, + _fillRule, + StrokeOpts (..), + vertexNames, + queryFillRule, -import Control.Applicative (liftA2) -import Control.Lens hiding (at, transform) -import qualified Data.Foldable as F -import Data.Semigroup -import Data.Typeable + -- ** Inside/outside testing + Crossings (..), + isInsideWinding, + isInsideEvenOdd, -import Data.Default.Class + -- * Clipping + Clip (..), + _Clip, + _clip, + clipBy, + clipTo, + clipped, -import Diagrams.Angle -import Diagrams.Combinators (withEnvelope, withTrace) -import Diagrams.Core -import Diagrams.Core.Trace -import Diagrams.Located (Located, mapLoc, unLoc) -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Solve.Polynomial -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Segment -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util (tau) + -- * Intersections + intersectPoints, + intersectPoints', + intersectPointsP, + intersectPointsP', + intersectPointsT, + intersectPointsT', +) where -import Linear.Affine -import Linear.Vector +import Control.Lens hiding (at, transform) +import Data.Default +import qualified Data.Foldable as F +import Data.Semigroup +import Data.Typeable +import Diagrams.Angle +import Diagrams.Combinators (withEnvelope, withTrace) +import Diagrams.Core +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.Polynomial +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Segment +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util (tau) +import Linear.Affine +import Linear.Vector +import Prelude.Compat +import Prelude () ------------------------------------------------------------ -- Trail and path traces --------------------------------- @@ -91,11 +107,12 @@ -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. instance RealFloat n => Traced (Trail V2 n) where - getTrace = withLine $ - foldr + getTrace = + withLine + $ foldr (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty - . lineSegments + . lineSegments instance RealFloat n => Traced (Path V2 n) where getTrace = F.foldMap getTrace . op Path @@ -107,15 +124,17 @@ -- | 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) +data FillRule + = -- | Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + Winding + | -- | Interior points are those where a ray + -- extended infinitely in a particular direction crosses + -- the path an odd number of times. See + -- . + EvenOdd + deriving (Show, Eq, Ord) instance AttributeClass FillRule instance Semigroup FillRule where @@ -129,11 +148,9 @@ -- records can be created using @'with' { ... }@ notation. data StrokeOpts a = StrokeOpts - { _vertexNames :: [[a]] - - , _queryFillRule :: FillRule - - } + { _vertexNames :: [[a]] + , _queryFillRule :: FillRule + } makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts @@ -146,29 +163,36 @@ -- so on. -- -- The default value is the empty list. - -vertexNames :: forall a a'. Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] +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 :: forall a. Lens' (StrokeOpts a) FillRule - +queryFillRule :: Lens' (StrokeOpts a) FillRule instance Default (StrokeOpts a) where - def = StrokeOpts - { _vertexNames = [] - , _queryFillRule = def - } + 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 behaviour to be customized. -stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) - => t -> QDiagram b V2 n Any +-- +-- @ +-- '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 @@ -178,108 +202,127 @@ -- -- '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' :: + (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 :: + (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 :: + (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 +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' :: + (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 - (pLines,pLoops) = partitionPath (isLine . unLoc) path - mkP p - = mkQD (Prim p) - (getEnvelope p) - (getTrace p) - (fromNames . concat $ - zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) - ) - (Query $ Any . flip (runFillRule (opts^.queryFillRule)) p) + | otherwise = mkP pLines <> mkP pLoops + where + (pLines, pLoops) = partitionPath (isLine . unLoc) path + mkP p = + mkQD + (Prim p) + (getEnvelope p) + (getTrace p) + ( fromNames + . concat + $ zipWith zip (opts ^. vertexNames) ((map . map) subPoint (pathVertices p)) + ) + (Query $ Any . (runFillRule (opts ^. queryFillRule)) p) -- | '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' :: + (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => + StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any strokePath' = strokeP' -- | 'stroke' specialised to 'Trail'. -strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail V2 n -> QDiagram b V2 n Any +strokeTrail :: + (TypeableFloat n, Renderable (Path V2 n) b) => + Trail V2 n -> QDiagram b V2 n Any strokeTrail = stroke . pathFromTrail -- | 'stroke' specialised to 'Trail'. -strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail V2 n -> QDiagram b V2 n Any +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. -strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) - => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any +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' :: + (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 :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail' Line V2 n -> QDiagram b V2 n Any +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 :: (TypeableFloat n, Renderable (Path V2 n) b) - => Trail' Loop V2 n -> QDiagram b V2 n Any +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; @strokeLocTrail = stroke . trailLike@. -strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail V2 n) -> QDiagram b V2 n Any +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 :: + (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 :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail' Line V2 n) -> QDiagram b V2 n Any +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 :: (TypeableFloat n, Renderable (Path V2 n) b) - => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any +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 ------------------------------------------------------------ -runFillRule :: RealFloat n => FillRule -> Point V2 n -> Path V2 n -> Bool +runFillRule :: RealFloat n => FillRule -> Path V2 n -> Point V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd @@ -296,14 +339,57 @@ _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) +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 paths consisting of lines -- (as opposed to loops), regardless of the winding number. -isInsideWinding :: RealFloat n => Point V2 n -> Path V2 n -> Bool -isInsideWinding p = (/= 0) . crossings p +-- +-- @ +-- '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 path, -- by testing whether a ray extending from the point in the positive @@ -311,52 +397,61 @@ -- number of times. Note that @False@ is /always/ returned for -- paths consisting of lines (as opposed to loops), regardless of -- the number of crossings. -isInsideEvenOdd :: RealFloat n => Point V2 n -> Path V2 n -> 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 :: RealFloat n => Point V2 n -> Path V2 n -> Int -crossings p = F.sum . map (trailCrossings p) . op Path +-- +-- @ +-- '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 :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Int - - -- non-loop trails have no inside or outside, so don't contribute crossings +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 - 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 (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)) - $ cubForm (- x1y + 3*c1y - 3*c2y + x2y) - ( 3*x1y - 6*c1y + 3*c2y) - (-3*x1y + 3*c1y) - (x1y - y) - testT t = let (unp2 -> (px,_)) = c `atParam` t - in if px > x then signFromDerivAt t else 0 - signFromDerivAt t = - 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 +trailCrossings p@(unp2 -> (x, y)) 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 + (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)) + $ cubForm + (-x1y + 3 * c1y - 3 * c2y + x2y) + (3 * x1y - 6 * c1y + 3 * c2y) + (-3 * x1y + 3 * c1y) + (x1y - y) + testT t = + let (unp2 -> (px, _)) = c `atParam` t + in if px > x then signFromDerivAt t else 0 + signFromDerivAt t = + 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 = cross2 (b .-. a) (p .-. a) + isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ---------------------------------------------- @@ -368,7 +463,7 @@ -- The clipping region is the intersection of all the applied -- clipping paths. newtype Clip n = Clip [Path V2 n] - deriving (Typeable, Semigroup) + deriving (Semigroup) makeWrapped ''Clip @@ -380,9 +475,15 @@ type instance V (Clip n) = V2 type instance N (Clip n) = n -instance (OrderedField n) => Transformable (Clip n) where +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 @@ -397,36 +498,40 @@ -- -- * The envelope of the diagram is unaffected. clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a -clipBy = applyTAttr . Clip . (:[]) +clipBy = applyTAttr . Clip . (: []) -- | 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 :: + 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 (newPt dDist) p - dInside pDist = getAny . sample d $ newPt pDist + 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 :: + TypeableFloat n => + Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipped p = withTrace p . withEnvelope p . clipBy p ------------------------------------------------------------ @@ -434,19 +539,21 @@ ------------------------------------------------------------ -- | 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-10 +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' :: + (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-10 +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] @@ -457,7 +564,7 @@ -- | Compute the intersect points between two located trails. intersectPointsT :: OrderedField n => Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] -intersectPointsT = intersectPointsT' 1e-10 +intersectPointsT = intersectPointsT' 1e-8 -- | Compute the intersect points between two located trails within the given -- tolerance. diff --git a/src/Diagrams/TwoD/Points.hs b/src/Diagrams/TwoD/Points.hs --- a/src/Diagrams/TwoD/Points.hs +++ b/src/Diagrams/TwoD/Points.hs @@ -1,4 +1,6 @@ ------------------------------------------------------------------------------ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Diagrams.TwoD.Points -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) @@ -6,54 +8,49 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Special functions for points in R2. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE TypeFamilies #-} - module Diagrams.TwoD.Points where -import Data.List - +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Diagrams.Core -import Diagrams.TwoD.Vector import Diagrams.TwoD.Types (P2) +import Diagrams.TwoD.Vector 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) +convexHull2D [] = [] +convexHull2D (p : ps) = NE.init upper ++ reverse (NE.tail lower) + where + (upper, lower) = sortedConvexHull (NE.sort (p :| 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 +-- | 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 :: OrderedField n => NonEmpty (P2 n) -> (NonEmpty (P2 n), NonEmpty (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) + 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 - 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 + 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,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- | -- Module : Diagrams.TwoD.Polygons -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) @@ -15,137 +14,147 @@ -- -- This module defines a general API for creating various types of -- polygons. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Polygons( - -- * Polygons - PolyType(..) - , PolyOrientation(..) - , PolygonOpts(..), polyType, polyOrient, polyCenter - - , polygon - , polyTrail - - -- ** Generating polygon vertices - - , polyPolarTrail - , polySidesTrail - , polyRegularTrail - - , orient +module Diagrams.TwoD.Polygons ( + -- * Polygons + PolyType (..), + PolyOrientation (..), + PolygonOpts (..), + polyType, + polyOrient, + polyCenter, + polygon, + polyTrail, - -- * Star polygons - , StarOpts(..) - , star + -- ** Generating polygon vertices + polyPolarTrail, + polySidesTrail, + polyRegularTrail, + orient, - -- ** Function graphs - -- $graphs - , GraphPart(..) - , orbits, mkGraph + -- * Star polygons + StarOpts (..), + star, - ) where + -- ** Function graphs + -- $graphs + GraphPart (..), + orbits, + mkGraph, +) where -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.Class -import Data.List (maximumBy, minimumBy) -import Data.Maybe (catMaybes) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mconcat, mempty) -#endif -import Data.Ord (comparing) +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.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +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.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.Angle +import Diagrams.Core +import Diagrams.Located +import Diagrams.Path +import Diagrams.Points (centroid) +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, (#)) -import Linear.Affine -import Linear.Metric -import Linear.Vector +import Linear.Affine +import Linear.Metric +import Linear.Vector -- | Method used to determine the vertices of a polygon. -data PolyType n = PolyPolar [Angle n] [n] - -- ^ A \"polar\" polygon. - -- - -- * The first argument is a list of /central/ - -- /angles/ from each vertex to the next. - -- - -- * The second argument is a list of /radii/ from - -- the origin to each successive vertex. - -- - -- To construct an /n/-gon, use a list of /n-1/ - -- angles and /n/ radii. Extra angles or radii - -- are ignored. - -- - -- Cyclic polygons (with all vertices lying on a - -- circle) can be constructed using a second - -- argument of @(repeat r)@. - - | PolySides [Angle n] [n] - -- ^ A polygon determined by the distance between - -- 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 - -- 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 external angle at each vertex - -- from the previous vertex to the next. The - -- 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. - -- - -- * The second argument is a list of distances - -- between successive vertices. - -- - -- To construct an /n/-gon, use a list of /n-2/ - -- angles and /n-1/ edge lengths. Extra angles or - -- lengths are ignored. - - | PolyRegular Int n - -- ^ A regular polygon with the given number of - -- sides (first argument) and the given radius - -- (second argument). +data PolyType n + = -- | A \"polar\" polygon. + -- + -- * The first argument is a list of /central/ + -- /angles/ from each vertex to the next. + -- + -- * The second argument is a list of /radii/ from + -- the origin to each successive vertex. + -- + -- To construct an /n/-gon, use a list of /n-1/ + -- angles and /n/ radii. Extra angles or radii + -- are ignored. + -- + -- Cyclic polygons (with all vertices lying on a + -- circle) can be constructed using a second + -- argument of @(repeat r)@. + PolyPolar [Angle n] [n] + | -- | A polygon determined by the distance between + -- 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 + -- 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 external angle at each vertex + -- from the previous vertex to the next. The + -- 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. + -- + -- * The second argument is a list of distances + -- between successive vertices. + -- + -- To construct an /n/-gon, use a list of /n-2/ + -- angles and /n-1/ edge lengths. Extra angles or + -- lengths are ignored. + PolySides [Angle n] [n] + | -- | A regular polygon with the given number of + -- sides (first argument) and the given radius + -- (second argument). + PolyRegular Int n -- | Determine how a polygon should be oriented. -data PolyOrientation n = 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 (V2 n) -- ^ 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 + = -- | No special orientation; the first + -- vertex will be at (1,0). + NoOrient + | -- | Orient /horizontally/, so the + -- bottommost edge is parallel to + -- the x-axis. + -- This is the default. + OrientH + | -- | Orient /vertically/, so the + -- leftmost edge is parallel to the + -- y-axis. + OrientV + | -- | Orient so some edge is + -- /facing/ /in/ /the/ /direction/ + -- /of/, that is, perpendicular + -- to, the given vector. + OrientTo (V2 n) + deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. data PolygonOpts n = PolygonOpts - { _polyType :: PolyType n - , _polyOrient :: PolyOrientation n - , _polyCenter :: Point V2 n - } + { _polyType :: PolyType n + , _polyOrient :: PolyOrientation n + , _polyCenter :: Point V2 n + } makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts @@ -163,21 +172,21 @@ -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. instance Num n => Default (PolygonOpts n) where - def = PolygonOpts (PolyRegular 5 1) OrientH origin + def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. polyTrail :: OrderedField n => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr - where - 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 po^.polyOrient of - OrientH -> orient unit_Y tr - OrientV -> orient unitX tr - OrientTo v -> orient v tr - NoOrient -> mempty + where + 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 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 :: (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t @@ -185,34 +194,36 @@ -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) +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 - where - p1 = p2 (1,0) # scale r - tr = closeTrail . trailFromVertices $ - zipWith - (\a l -> rotate a . scale l $ p2 (1,0)) - (scanl (^+^) zero ans) - (r:rs) +polyPolarTrail ans (r : rs) = tr `at` p1 + where + p1 = p2 (1, 0) # scale r + tr = + closeTrail . trailFromVertices $ + zipWith + (\a l -> rotate a . scale l $ p2 (1, 0)) + (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 :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) +polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) - where - ans' = scanl (^+^) zero ans - offsets = zipWith rotate ans' (map (unitY ^*) ls) - ps = scanl (.+^) origin offsets - tr = closeTrail . trailFromOffsets $ offsets + where + 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 :: OrderedField n => Int -> n -> Located (Trail V2 n) -polyRegularTrail n r = polyPolarTrail - (replicate (n - 1) $ fullTurn ^/ fromIntegral n) - (repeat r) +polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n) +polyRegularTrail n r = + polyPolarTrail + (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 @@ -222,27 +233,33 @@ orient v = orientPoints v . trailVertices orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n -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 `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 = negated phi - where - o' = signorm o - theta = acos (v' `dot` o') - -- phi :: Angle (Scalar v) - phi - | theta <= tau/4 = tau/4 - theta @@ rad - | otherwise = theta - tau/4 @@ rad +orientPoints _ [] = mempty +orientPoints _ [_] = mempty +orientPoints v xs@(y : ys) = rotation a + where + (n1, x, n2) = + maximumBy + (comparing (distAlong v . sndOf3)) + (zip3 (ys ++ [y]) xs (NE.last (y :| ys) : NE.init (y :| ys))) + 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 = negated phi + where + o' = signorm o + theta = acos (v' `dot` o') + -- phi :: Angle (Scalar v) + phi + | theta <= tau / 4 = tau / 4 - theta @@ rad + | otherwise = theta - tau / 4 @@ rad ------------------------------------------------------------ -- Function graphs @@ -253,49 +270,54 @@ -- the offchance that someone else finds them useful. -- | Pieces of a function graph can either be cycles or \"hairs\". -data GraphPart a = Cycle [a] - | Hair [a] +data GraphPart a + = Cycle [a] + | Hair [a] deriving (Show, Functor) -- | @orbits f n@ computes the graph of @f@ on the integers mod @n@. orbits :: (Int -> Int) -> Int -> [GraphPart Int] orbits f n = runST genOrbits - where - f_n i = f i `mod` n + where + f_n i = f i `mod` n - genOrbits :: ST s [GraphPart Int] - genOrbits = newArray (0,n-1) False >>= genOrbits' + genOrbits :: ST s [GraphPart Int] + genOrbits = newArray (0, n - 1) False >>= genOrbits' - genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int] - genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n-1] (genPart marks)) + genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int] + genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n - 1] (genPart marks)) - genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int]) - genPart marks i = do - tr <- markRho i marks - case tr of - [] -> return Nothing - _ -> return . Just . splitParts $ tr + genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int]) + genPart marks i = do + tr <- markRho i marks + case tr of + [] -> return Nothing + _ -> return . Just . splitParts $ tr - markRho :: Int -> STUArray s Int Bool -> ST s [Int] - markRho i marks = do - isMarked <- readArray marks i - if isMarked - then return [] - else writeArray marks i True >> - liftM (i:) (markRho (f_n i) marks) + markRho :: Int -> STUArray s Int Bool -> ST s [Int] + markRho i marks = do + isMarked <- readArray marks i + if isMarked + then return [] + else + writeArray marks i True + >> liftM (i :) (markRho (f_n i) marks) - splitParts :: [Int] -> [GraphPart Int] - splitParts tr = hair ++ cyc - where hair | not (null tl) = [Hair $ tl ++ [f_n (last tl)]] - | otherwise = [] - cyc | not (null body) = [Cycle body] - | otherwise = [] - l = last tr - (tl, body) = span (/= f_n l) tr + splitParts :: [Int] -> [GraphPart Int] + splitParts tr = hair ++ cyc + where + hair + | not (null tl) = [Hair $ tl ++ [f_n (last tl)]] + | otherwise = [] + cyc + | not (null body) = [Cycle body] + | otherwise = [] + l = last tr + (tl, body) = span (/= f_n l) tr -- | Generate a function graph from the given function and labels. mkGraph :: (Int -> Int) -> [a] -> [GraphPart a] -mkGraph f xs = (map . fmap) (xs!!) $ orbits f (length xs) +mkGraph f xs = (map . fmap) (xs !!) $ orbits f (length xs) ------------------------------------------------------------ -- Star polygons @@ -303,20 +325,20 @@ -- | Options for creating \"star\" polygons, where the edges connect -- possibly non-adjacent vertices. -data StarOpts = StarFun (Int -> Int) - -- ^ Specify the order in which the vertices should be - -- connected by a function that maps each vertex - -- index to the index of the vertex that should come - -- next. Indexing of vertices begins at 0. - - | StarSkip Int - -- ^ Specify a star polygon by a \"skip\". A skip of - -- 1 indicates a normal polygon, where edges go - -- between successive vertices. A skip of 2 means - -- that edges will connect every second vertex, - -- skipping one in between. Generally, a skip of - -- /n/ means that edges will connect every /n/th - -- vertex. +data StarOpts + = -- | Specify the order in which the vertices should be + -- connected by a function that maps each vertex + -- index to the index of the vertex that should come + -- next. Indexing of vertices begins at 0. + StarFun (Int -> Int) + | -- | Specify a star polygon by a \"skip\". A skip of + -- 1 indicates a normal polygon, where edges go + -- between successive vertices. A skip of 2 means + -- that edges will connect every second vertex, + -- skipping one in between. Generally, a skip of + -- /n/ means that edges will connect every /n/th + -- vertex. + StarSkip Int -- | Create a generalized /star/ /polygon/. The 'StarOpts' are used -- to determine in which order the given vertices should be @@ -329,14 +351,15 @@ -- to be connected in several disjoint cycles. 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 - StarSkip k -> (+k) - graphToPath = mconcat . map partToPath - - partToPath (Cycle ps) = pathFromLocTrail - . mapLoc closeTrail - . fromVertices - $ ps + where + f = case sOpts of + StarFun g -> g + StarSkip k -> (+ k) + graphToPath = mconcat . map partToPath - partToPath (Hair ps) = fromVertices ps + partToPath (Cycle ps) = + pathFromLocTrail + . mapLoc closeTrail + . fromVertices + $ ps + partToPath (Hair ps) = fromVertices ps 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,15 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE ViewPatterns #-} {-# 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 -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) @@ -18,47 +20,44 @@ -- -- Segments in two dimensions are special since we may meaningfully -- compute their point of intersection with a ray. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Segment - ( -- * Segment intersections - - intersectPointsS - , intersectPointsS' - - -- * Closest point on a segment +module Diagrams.TwoD.Segment ( + -- * Segment intersections + intersectPointsS, + intersectPointsS', - , closestPoint - , closestPoint' - , closestDistance - , closestDistance' - , closestParam - , closestParam' + -- * Closest point on a segment + closestPoint, + closestPoint', + closestDistance, + closestDistance', + closestParam, + closestParam', - -- ** Low level functions - , segmentSegment - , lineSegment - ) - where + -- ** Low level functions + segmentSegment, + lineSegment, +) +where -import Control.Lens hiding (at, contains, transform, ( # )) -import Data.Maybe +import Control.Lens hiding (at, contains, transform, (#)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe -import Diagrams.Core +import Diagrams.Core -import Diagrams.Direction -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Segment -import Diagrams.TwoD.Points -import Diagrams.TwoD.Segment.Bernstein -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types hiding (p2) -import Diagrams.TwoD.Vector +import Diagrams.Direction +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.TwoD.Points +import Diagrams.TwoD.Segment.Bernstein +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types hiding (p2) +import Diagrams.TwoD.Vector -import Linear.Affine -import Linear.Metric +import Linear.Affine +import Linear.Metric {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. @@ -108,21 +107,22 @@ -- tolerance. closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] closestParam' _ (FLinear p0 p1) p - | t < 0 = [0] - | t > 1 = [1] + | t < 0 = [0] + | t > 1 = [1] | otherwise = [t] - where - vp = p .-. p0 - v = p1 .-. p0 - dp = vp `dot` v - t = dp / quadrance v + 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' + 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' ------------------------------------------------------------------------ -- Low level @@ -132,65 +132,70 @@ -- 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) + 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) -- | 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 +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 = [] - - -- 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) - - | 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 ) ] - - -- 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 +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 = case chopCubics p q of + Nothing -> [] + -- This check happens before the subdivision + -- test to avoid non-termination as values + -- transition to within epsilon. + Just (tminChop, tmaxChop) + | 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 + p' = section p tminChop tmaxChop clip' = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) @@ -198,29 +203,45 @@ -- | 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 - | isNothing chopInterval = [] - | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 - tmid = tmin' + (tmax' - tmin') / 2 - in bezierFindRoot eps p1 tmin' tmid ++ - bezierFindRoot eps p2 tmid tmax' - | tmax' - tmin' < eps = [avg tmin' 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) - - +bezierFindRoot :: + OrderedField n => + -- | The accuracy + n -> + -- | the Bernstein coefficients of the polynomial + BernsteinPoly n -> + -- | The lower bound of the interval + n -> + -- | The upper bound of the interval + n -> + -- | The roots found + [n] +bezierFindRoot eps p initMin initMax + -- 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 /= initMax && abs (evaluateBernstein p initMax) <= eps = + roots ++ [initMax] + | 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 initMin initMax + go pInit tmin tmax = case chopYs (bernsteinCoeffs pInit) of + Nothing -> [] + Just (tminChop, tmaxChop) + | 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 + newP = section pInit tminChop tmaxChop + clip = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) ------------------------------------------------------------------------ -- Internal @@ -228,67 +249,79 @@ -- | 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) +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 :: OrderedField n => NonEmpty 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 + where + points = NE.zipWith mkP2 (NE.zipWith (\i _ -> fromIntegral @Integer i / fromIntegral n) (0 :| [1 ..]) ds) ds + n = NE.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 :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n, n) +chopCubics p q@(FCubic q0 _ _ q3) = + chopHull dmin dmax dps + where + dps = NE.zipWith mkP2 (0 :| [1 / 3, 2 / 3, 1]) ds + ds = NE.map d $ case p of + FLinear p0 p1 -> p0 :| [p1] + FCubic p0 p1 p2 p3 -> p0 :| [p1, p2, p3] + 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 :: OrderedField n => n -> n -> NonEmpty (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) + tL <- testBelow upper $ testBetween (NE.head upper) $ testAbove lower + tR <- testBelow (NE.reverse upper) $ testBetween (NE.last upper) $ testAbove (NE.reverse lower) Just (tL, tR) - where - (upper, lower) = sortedConvexHull dps + 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 + 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 + 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) - | otherwise = Just $ intersectPt dmax p1 p2 - testAbove _ = Nothing + 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 + (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) + where + coeffs = toListOf each seg ------------------------------------------------------------------------ -- Lines @@ -296,44 +329,46 @@ -- Could split this into a separate module. --- | Returns @(a, b, c)@ such that @ax + by + c = 0@ is the line going through --- @p1@ and @p2@ with @a^2 + b^2 = 1@. -lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n) -lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c) - where - a = a' / d - b = b' / d - c = -(x1*a' + y1*b') / d - a' = y1 - y2 - b' = x2 - x1 - d = sqrt $ a'*a' + b'*b' +-- | 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 :: Floating n => P2 n -> P2 n -> P2 n -> n -lineDistance p1 p2 (P (V2 x y)) = a*x + b*y + c - where (a, b, c) = lineEquation p1 p2 - --- find the x value where the line through the two points --- intersect the line y=d -intersectPt :: OrderedField n => n -> P2 n -> P2 n -> n -intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = - x1 + (d - y1) * (x2 - x1) / (y2 - y1) +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 +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 +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 @@ -342,9 +377,11 @@ 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 (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) - +inRange x = x < (1 + defEps) && x > (-defEps) diff --git a/src/Diagrams/TwoD/Segment/Bernstein.hs b/src/Diagrams/TwoD/Segment/Bernstein.hs --- a/src/Diagrams/TwoD/Segment/Bernstein.hs +++ b/src/Diagrams/TwoD/Segment/Bernstein.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Diagrams.TwoD.Segment.Bernstein -- Copyright : (c) 2014-2015 diagrams-lib team (see LICENSE) @@ -10,129 +10,133 @@ -- 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 +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 +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty.Compat as NE +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] +binomials :: Num n => Int -> NonEmpty n +binomials n = NE.map fromIntegral $ NE.scanl (\x m -> x * (n - m + 1) `quot` m) 1 [1 .. n] data BernsteinPoly n = BernsteinPoly { bernsteinDegree :: Int - , bernsteinCoeffs :: [n] - } deriving (Show, Functor) + , bernsteinCoeffs :: NonEmpty n + } + deriving (Show, Functor) -type instance V (BernsteinPoly n) = V1 -type instance N (BernsteinPoly n) = n +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 +listToBernstein l = case NE.nonEmpty l of + Nothing -> 0 + Just ne -> BernsteinPoly (length l - 1) ne -- | Degree elevate a bernstein polynomial a number of times. degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n -degreeElevate b 0 = b +degreeElevate b 0 = b degreeElevate (BernsteinPoly lp p) times = - degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1) - where - n = fromIntegral lp + degreeElevate (BernsteinPoly (lp + 1) (NE.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) + 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 +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" + 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 + | 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 +bernsteinDeriv (BernsteinPoly _ (_ :| [])) = 0 +bernsteinDeriv (BernsteinPoly lp p@(_ :| (a1 : as))) = + -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (drop 1 p) p + BernsteinPoly (lp - 1) $ NE.zipWith (\a b -> (a - b) * fromIntegral lp) (a1 :| as) 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) +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 (NE.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 + ( BernsteinPoly lp $ NE.map NE.head controls + , BernsteinPoly lp $ NE.reverse $ NE.map NE.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 + -- terp :: NonEmpty n -> [NonEmpty n] + terp l@(_ :| as) = case NE.nonEmpty as of + Nothing -> [] + Just as' -> + let ctrs = NE.zipWith interp l as' + 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 + | la < lb = BernsteinPoly lb $ NE.zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b + | la > lb = BernsteinPoly la $ NE.zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb) + | otherwise = BernsteinPoly la $ NE.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 + | la < lb = BernsteinPoly lb $ NE.zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b + | la > lb = BernsteinPoly la $ NE.zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) + | otherwise = BernsteinPoly la $ NE.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) + BernsteinPoly (la + lb) $ + NE.zipWith (flip (/)) (binomials (la + lb)) $ + NE.map sum $ + NE.appendList + (NE.map (NE.zipWith (*) a') (down b')) + (map (NE.zipWith (*) (NE.reverse b')) (NE.tail $ NE.tails1 a')) + where + down (x :| xs) = NE.scanl (flip NE.cons) (x :| []) xs -- [[1], [2, 1], [3, 2, 1], ... + a' = NE.zipWith (*) a (binomials la) + b' = NE.zipWith (*) b (binomials lb) - fromInteger a = BernsteinPoly 0 [fromInteger a] + fromInteger a = BernsteinPoly 0 (fromInteger a :| []) - signum (BernsteinPoly _ []) = 0 - signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a] + 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,8 +1,15 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +-- for Data.Semigroup + ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Shapes -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) @@ -10,60 +17,58 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Various two-dimensional shapes. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Shapes - ( - -- * Miscellaneous - hrule, vrule - - -- * Regular polygons - - , regPoly - , triangle - , eqTriangle - , square - , pentagon - , hexagon - , heptagon - , septagon - , octagon - , nonagon - , decagon - , hendecagon - , dodecagon - - -- * Other special polygons - , unitSquare - , rect +module Diagrams.TwoD.Shapes ( + -- * Miscellaneous + hrule, + vrule, - -- * Other shapes + -- * Regular polygons + regPoly, + triangle, + eqTriangle, + square, + pentagon, + hexagon, + heptagon, + septagon, + octagon, + nonagon, + decagon, + hendecagon, + dodecagon, - , roundedRect - , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR - , roundedRect' - ) where + -- * Other special polygons + unitSquare, + rect, -import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) -import Data.Default.Class -import Data.Semigroup + -- * Other shapes + roundedRect, + RoundedRectOpts (..), + radiusTL, + radiusTR, + radiusBL, + radiusBR, + roundedRect', +) where -import Diagrams.Core +import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) +import Data.Default +import Data.Semigroup -import Diagrams.Angle -import Diagrams.Located (at) -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail -import Diagrams.TrailLike -import Diagrams.TwoD.Arc -import Diagrams.TwoD.Polygons -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Util +import Diagrams.Core +import Diagrams.Angle +import Diagrams.Located (at) +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.TwoD.Arc +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util -- | Create a centered horizontal (L-R) line of the given length. -- @@ -72,7 +77,7 @@ -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 hrule :: (InSpace V2 n t, TrailLike t) => n -> t -hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) +hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d / 2, 0) -- | Create a centered vertical (T-B) line of the given length. -- @@ -81,15 +86,19 @@ -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 vrule :: (InSpace V2 n t, TrailLike t) => n -> t -vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2) +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 :: (InSpace V2 n t, TrailLike t) => t -unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) - & polyOrient .~ OrientH) +unitSquare = + polygon + ( def + & polyType .~ PolyRegular 4 (sqrt 2 / 2) + & polyOrient .~ OrientH + ) -- > unitSquareEx = unitSquare # pad 1.1 # showOrigin @@ -108,26 +117,29 @@ -- -- <> rect :: (InSpace V2 n t, TrailLike t) => n -> n -> t -rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h +rect w h = case op Path $ unitSquare # scaleX w # scaleY h of + (t : _) -> trailLike t + -- This case can't happen---the unitSquare path is definitely non-empty. + [] -> error "Impossible - unitSquare returned an empty path!" -- > rectEx = rect 1 0.7 # pad 1.1 - -- The above may seem a bit roundabout. In fact, we used to have - -- - -- rect w h = unitSquare # scaleX w # scaleY h - -- - -- since unitSquare can produce any TrailLike. The current code - -- instead uses (unitSquare # scaleX w # scaleY h) to specifically - -- produce a Path, which is then deconstructed and passed back into - -- 'trailLike' to create any TrailLike. - -- - -- The difference is that while scaling by zero works fine for - -- Path it does not work very well for, say, Diagrams (leading to - -- NaNs or worse). This way, we force the scaling to happen on a - -- Path, where we know it will behave properly, and then use the - -- resulting geometry to construct an arbitrary TrailLike. - -- - -- See https://github.com/diagrams/diagrams-lib/issues/43 . +-- The above may seem a bit roundabout. In fact, we used to have +-- +-- rect w h = unitSquare # scaleX w # scaleY h +-- +-- since unitSquare can produce any TrailLike. The current code +-- instead uses (unitSquare # scaleX w # scaleY h) to specifically +-- produce a Path, which is then deconstructed and passed back into +-- 'trailLike' to create any TrailLike. +-- +-- The difference is that while scaling by zero works fine for +-- Path it does not work very well for, say, Diagrams (leading to +-- NaNs or worse). This way, we force the scaling to happen on a +-- Path, where we know it will behave properly, and then use the +-- resulting geometry to construct an arbitrary TrailLike. +-- +-- See https://github.com/diagrams/diagrams-lib/issues/43 . ------------------------------------------------------------ -- Regular polygons @@ -140,12 +152,15 @@ -- -- The polygon will be oriented with one edge parallel to the x-axis. regPoly :: (InSpace V2 n t, TrailLike t) => Int -> n -> t -regPoly n l = polygon (def & polyType .~ - PolySides - (repeat (1/fromIntegral n @@ turn)) - (replicate (n-1) l) - & polyOrient .~ OrientH - ) +regPoly n l = + polygon + ( def + & polyType + .~ PolySides + (repeat (1 / fromIntegral n @@ turn)) + (replicate (n - 1) l) + & polyOrient .~ OrientH + ) -- > shapeEx sh = sh 1 # pad 1.1 -- > triangleEx = shapeEx triangle @@ -234,15 +249,16 @@ ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ -data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d - , _radiusTR :: d - , _radiusBL :: d - , _radiusBR :: d - } +data RoundedRectOpts d = RoundedRectOpts + { _radiusTL :: d + , _radiusTR :: d + , _radiusBL :: d + , _radiusBR :: d + } makeLenses ''RoundedRectOpts -instance (Num d) => Default (RoundedRectOpts d) where +instance Num d => Default (RoundedRectOpts d) where def = RoundedRectOpts 0 0 0 0 -- | @roundedRect w h r@ generates a closed trail, or closed path @@ -265,54 +281,64 @@ -- > & radiusTR .~ -0.2 -- > & radiusBR .~ 0.1) -- > ] - 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 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' :: (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)) - . wrapTrail - . glueLine - $ seg (0, h - abs rTR - abs rBR) - <> mkCorner 0 rTR - <> seg (abs rTR + abs rTL - w, 0) - <> mkCorner 1 rTL - <> seg (0, abs rTL + abs rBL - h) - <> mkCorner 2 rBL - <> seg (w - abs rBL - abs rBR, 0) - <> mkCorner 3 rBR - where seg = lineFromOffsets . (:[]) . r2 - diag = sqrt (w * w + h * h) - -- to clamp corner radius, need to compare with other corners that share an - -- edge. If the corners overlap then reduce the largest corner first, as far - -- as 50% of the edge in question. - rTL = clampCnr radiusTR radiusBL radiusBR radiusTL - 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') = (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 - then sign r * max (len/2) (min (len - abs adj) (abs r)) - else r - -- prevent inward curves of diagonally opposite corners from intersecting - clampDiag opp r = if r < 0 && opp < 0 && abs r > diag / 2 - then sign r * max (diag / 2) (min (abs r) (diag + opp)) - else r - sign n = if n < 0 then -1 else 1 - mkCorner k r | r == 0 = mempty - | r < 0 = doArc 3 (-1) - | otherwise = doArc 0 1 - where - doArc d s = - arc' r (xDir & _theta <>~ ((k+d)/4 @@ turn)) (s/4 @@ turn) +roundedRect' w h opts = + trailLike + . (`at` p2 (w / 2, abs rBR - h / 2)) + . wrapTrail + . glueLine + $ seg (0, h - abs rTR - abs rBR) + <> mkCorner 0 rTR + <> seg (abs rTR + abs rTL - w, 0) + <> mkCorner 1 rTL + <> seg (0, abs rTL + abs rBL - h) + <> mkCorner 2 rBL + <> seg (w - abs rBL - abs rBR, 0) + <> mkCorner 3 rBR + where + seg = lineFromOffsets . (: []) . r2 + diag = sqrt (w * w + h * h) + -- to clamp corner radius, need to compare with other corners that share an + -- edge. If the corners overlap then reduce the largest corner first, as far + -- as 50% of the edge in question. + rTL = clampCnr radiusTR radiusBL radiusBR radiusTL + 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') = (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 + then sign r * max (len / 2) (min (len - abs adj) (abs r)) + else r + -- prevent inward curves of diagonally opposite corners from intersecting + clampDiag opp r = + if r < 0 && opp < 0 && abs r > diag / 2 + then sign r * max (diag / 2) (min (abs r) (diag + opp)) + else r + sign n = if n < 0 then -1 else 1 + mkCorner k r + | r == 0 = mempty + | r < 0 = doArc 3 (-1) + | otherwise = doArc 0 1 + 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} 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,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + -- | -- Module : Diagrams.TwoD.Text -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) @@ -15,48 +18,80 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Very basic text primitives along with associated attributes. --- ------------------------------------------------------------------------------ - module Diagrams.TwoD.Text ( -- * Creating text diagrams - Text(..), TextAlignment(..) - , text, topLeftText, alignedText, baselineText, mkText + Text (..), + TextAlignment (..), + text, + topLeftText, + alignedText, + baselineText, + mkText, + mkText', -- * Text attributes + -- ** Font family - , Font(..), _Font - , getFont, font, _font + Font (..), + _Font, + getFont, + font, + _font, + -- ** Font size - , FontSize(..), _FontSize - , getFontSize, fontSizeM, fontSize - , fontSizeN, fontSizeO, fontSizeL, fontSizeG - , _fontSizeR, _fontSize, _fontSizeU + FontSize (..), + _FontSize, + fontSize, + recommendFontSize, + fontSizeN, + fontSizeO, + fontSizeL, + fontSizeG, + getFontSize, + fontSizeM, + _fontSizeR, + _fontSize, + _fontSizeU, + -- ** Font slant - , FontSlant(..) - , getFontSlant, fontSlant, italic, oblique, _fontSlant + FontSlant (..), + getFontSlant, + fontSlant, + italic, + oblique, + _fontSlant, + -- ** Font weight - , FontWeight(..) - , getFontWeight, fontWeight, bold, _fontWeight - ) where + FontWeight (..), + getFontWeight, + fontWeight, + bold, + bolder, + lighter, + _fontWeight, + thinWeight, + ultraLight, + light, + mediumWeight, + heavy, + semiBold, + ultraBold, +) where -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 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.Class -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -#endif -import Data.Monoid.Recommend -import Data.Semigroup -import Data.Typeable +import Data.Colour hiding (over) +import Data.Default +import Data.Monoid.Recommend +import Data.Semigroup +import Data.Typeable -import Linear.Affine +import Linear.Affine ------------------------------------------------------------ -- Text diagrams @@ -70,14 +105,14 @@ -- This constructor should not be used directly. Use 'text', -- 'alignedText' or 'baselineText'. data Text n = Text (T2 n) (TextAlignment n) String - deriving Typeable type instance V (Text n) = V2 type instance N (Text n) = n 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) + where + t' = scaling (1 / avgScale t) instance Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p) @@ -88,19 +123,31 @@ -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment n = BaselineText | BoxAlignedText n n --- | Make a text from a 'TextAlignment'. -mkText :: (TypeableFloat n, Renderable (Text n) b) - => TextAlignment n -> String -> QDiagram b V2 n Any -mkText a t = recommendFillColor black - -- See Note [recommendFillColor] - . recommendFontSize (local 1) - -- See Note [recommendFontSize] +-- | 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 - $ mkQD (Prim $ Text mempty a t) - (pointEnvelope origin) - mempty - mempty - mempty +-- | 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] @@ -116,17 +163,20 @@ -- must therefore explicitly set the fill to transparent -- but this -- meant that it was also drawing text with a transparent fill. The -- solution is that we now explicitly inform all backends that the --- *default* ("recommended") fill color for text should be black; an + +-- * default* ("recommended") fill color for text should be black; an + -- absence of fill specification now consistently means to use a -- "transparent" fill no matter what the primitive. The reason we -- need the special recommend/commit distinction is because if the -- user explicitly sets a fill color later it should override this -- recommendation; normally, the innermost occurrence of an attribute -- would override all outer occurrences. --- --- The reason we "recommend" a fill color of black instead of setting --- it directly (or instead of simply not specifying a fill color at +-- ~~~~ 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@. -- @@ -153,8 +203,9 @@ -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. -alignedText :: (TypeableFloat n, Renderable (Text n) b) - => n -> n -> String -> QDiagram b V2 n Any +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 @@ -163,8 +214,9 @@ -- graphics library. -- -- Note that it /takes up no space/. -baselineText :: (TypeableFloat n, Renderable (Text n) b) - => String -> QDiagram b V2 n Any +baselineText :: + (TypeableFloat n, Renderable (Text n) b) => + String -> QDiagram b V2 n Any baselineText = mkText BaselineText ------------------------------------------------------------ @@ -177,7 +229,7 @@ -- | The @Font@ attribute specifies the name of a font family. Inner -- @Font@ attributes override outer ones. newtype Font = Font (Last String) - deriving (Typeable, Semigroup, Eq) + deriving (Semigroup, Eq) _Font :: Iso' Font String _Font = iso getFont (Font . Last) @@ -202,22 +254,24 @@ -- | The @FontSize@ attribute specifies the size of a font's -- em-square. Inner @FontSize@ attributes override outer ones. newtype FontSize n = FontSize (Recommend (Last n)) - deriving (Typeable, Semigroup) + deriving (Semigroup) -- 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))) + 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 + 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 @@ -231,14 +285,21 @@ -- | Extract the size from a @FontSize@ attribute. getFontSize :: FontSize n -> n getFontSize (FontSize (Recommend (Last s))) = s -getFontSize (FontSize (Commit (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@. +-- 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 @@ -259,9 +320,6 @@ fontSizeM :: (N a ~ n, Typeable n, HasStyle a) => FontSizeM n -> a -> a fontSizeM = applyMAttr -recommendFontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a -recommendFontSize = applyMAttr . fmap (FontSize . Recommend . Last) - _fontSizeR :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) _fontSizeR = atMAttr . anon def (const False) . _FontSizeM @@ -270,7 +328,7 @@ _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 :: Typeable n => Lens' (Style v n) (Maybe n) _fontSizeU = atAttr . mapping (_FontSize . committed) -------------------------------------------------- @@ -279,12 +337,13 @@ -- | 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, Show, Typeable, Ord) +data FontSlant + = FontSlantNormal + | FontSlantItalic + | FontSlantOblique + deriving (Eq, Show, Ord) -instance AttributeClass FontSlant where +instance AttributeClass FontSlant instance Semigroup FontSlant where _ <> b = b @@ -319,9 +378,19 @@ -- | 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. -data FontWeight = FontWeightNormal - | FontWeightBold - deriving (Eq, Ord, Show, Typeable) +data FontWeight + = FontWeightNormal + | FontWeightBold + | FontWeightBolder + | FontWeightLighter + | FontWeightThin + | FontWeightUltraLight + | FontWeightLight + | FontWeightMedium + | FontWeightSemiBold + | FontWeightUltraBold + | FontWeightHeavy + deriving (Eq, Ord, Show) instance AttributeClass FontWeight @@ -336,7 +405,7 @@ getFontWeight :: FontWeight -> FontWeight getFontWeight = id --- | Specify the weight (normal or bold) that should be +-- | 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 @@ -345,6 +414,42 @@ -- | 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 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -5,6 +6,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform @@ -23,7 +28,6 @@ T2 -- * Rotation , rotation, rotate, rotateBy, rotated - , rotationAround, rotateAround , rotationTo, rotateTo @@ -40,9 +44,13 @@ , translationY, translateY , translation, translate + -- * Conformal affine maps + , scalingRotationTo, scaleRotateTo + -- * Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- * Shears @@ -56,41 +64,21 @@ import Diagrams.Core.Transform import Diagrams.Direction import Diagrams.Transform +import Diagrams.Transform.Matrix import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -import Control.Lens hiding (at, transform) +import Control.Lens hiding (at, transform) import Data.Semigroup 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 :: 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 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 +-- For the definitions of 'rotation' and 'rotate', see Diagrams.Angle. -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than @@ -110,7 +98,7 @@ -- @ rotated :: (InSpace V2 n a, Floating n, SameSpace a b, Transformable a, Transformable b) => Angle n -> Iso a b a b -rotated = transformed . rotation +rotated a = transformed $ rotation a -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). @@ -205,6 +193,29 @@ => 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 @@ -227,13 +238,25 @@ reflectY :: (InSpace v n t, R2 v, Transformable t) => t -> t reflectY = transform reflectionY +-- | 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 d <> translation (origin .-. p)) + conjugate (rotationTo (reflectY d) <> translation (origin .-. p)) reflectionY + + + -- | @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) @@ -280,4 +303,3 @@ -- @(1,0)@ to @(1,d)@. shearY :: (InSpace V2 n t, Transformable t) => n -> t -> t shearY = transform . shearingY - 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 @@ -79,8 +79,14 @@ 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,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Util @@ -39,9 +41,8 @@ import Control.Monad.Catch import Control.Monad.Trans import Control.Monad.Trans.Maybe -import Data.Default.Class +import Data.Default import Data.List -import Data.List.Lens import Data.Maybe import Data.Monoid import System.Directory @@ -202,7 +203,7 @@ findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig where -- first path in environment - lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv + lookEnv = MaybeT . fmap ((listToMaybe . 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 @@ -237,9 +238,13 @@ 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). 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/Diagrams/TwoD/OffsetTest.hs b/test/Diagrams/TwoD/OffsetTest.hs deleted file mode 100644 --- a/test/Diagrams/TwoD/OffsetTest.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Diagrams.TwoD.OffsetTest - ( - 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/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 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,10 +1,26 @@ -import Test.Tasty (defaultMain, testGroup, TestTree) +import Test.Tasty (TestTree, defaultMain, testGroup) -import qualified Diagrams.TwoD.OffsetTest as TwoD.OffsetTest +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.OffsetTest.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