diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,291 @@ +## [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.5.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created @@ -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.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git @@ -40,6 +40,7 @@ Diagrams.Combinators, Diagrams.Coordinates, Diagrams.CubicSpline, + Diagrams.CubicSpline.Boehm, Diagrams.CubicSpline.Internal, Diagrams.Deform Diagrams.Direction, @@ -99,38 +100,40 @@ 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.22, + containers >= 0.3 && < 0.8, array >= 0.3 && < 0.6, - semigroups >= 0.3.4 && < 0.19, - monoid-extras >= 0.3 && < 0.5, + semigroups >= 0.3.4 && < 0.21, + monoid-extras >= 0.6 && < 0.8, dual-tree >= 0.2 && < 0.3, - diagrams-core >= 1.3 && < 1.4, + diagrams-core >= 1.4 && < 1.6, diagrams-solve >= 0.1 && < 0.2, active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, - data-default-class < 0.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, + tagged >= 0.7 && < 0.9, + optparse-applicative >= 0.11 && < 0.20, + filepath >= 1.4 && < 1.6, + JuicyPixels >= 3.3.4 && < 3.4, + hashable >= 1.1 && < 1.6, + linear >= 1.20.1 && < 1.24, adjunctions >= 4.0 && < 5.0, distributive >=0.2.2 && < 1.0, - process >= 1.1 && < 1.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 + text >= 0.7.1 && < 2.2, + mtl >= 2.0 && < 2.3 || >= 2.3.1 && < 2.4, + transformers >= 0.3.0 && < 0.7.0, + profunctors >= 5.0 && < 6.0, + exceptions >= 0.6 && < 1.0, + cereal >=0.4.1.1 && <0.6, + bytestring >=0.9 && <0.13, + fail >= 4.9.0.0 && <4.10 Hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 @@ -144,10 +147,36 @@ 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, + deepseq >= 1.3 && < 1.6, + diagrams-lib, + lens, + distributive, + numeric-extras, + diagrams-solve default-language: Haskell2010 + +benchmark benchmarks + type: exitcode-stdio-1.0 + main-is:Speed.hs + hs-source-dirs:test + default-language: Haskell2010 + build-depends: + base < 5, + criterion, + diagrams-core, + diagrams-lib diff --git a/diagrams/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 @@ -344,6 +348,58 @@ -- | Lens onto the opacity in a style. _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 (Typeable, 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 (Typeable, Semigroup) +instance AttributeClass StrokeOpacity + +_StrokeOpacity :: Iso' StrokeOpacity Double +_StrokeOpacity = iso getStrokeOpacity (StrokeOpacity . Product) + +getStrokeOpacity :: StrokeOpacity -> Double +getStrokeOpacity (StrokeOpacity (Product d)) = d + +-- | Multiply the stroke opacity (see 'StrokeOpacity') by the given value. For +-- example, @strokeOpacity 0.8@ means \"decrease this diagram's +-- stroke opacity to 80% of its previous value\". +strokeOpacity :: HasStyle a => Double -> a -> a +strokeOpacity = applyAttr . StrokeOpacity . Product + +-- | Lens onto the stroke opacity in a style. +_strokeOpacity :: Lens' (Style v n) Double +_strokeOpacity = atAttr . mapping _StrokeOpacity . non 1 ------------------------------------------------------------------------ -- Line stuff 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,4 +1,5 @@ -{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -22,7 +23,7 @@ -- executables. -- -- For a tutorial on command-line diagram creation see --- . +-- . -- ----------------------------------------------------------------------------- @@ -49,13 +50,6 @@ , diagramAnimOpts , fpu - -- ** Loop options - , DiagramLoopOpts(..) - , diagramLoopOpts - , loop - , src - , interval - -- * Parsing , Parseable(..) , readHexColor @@ -70,46 +64,36 @@ -- ** helper functions for implementing @mainRender@ , defaultAnimMainRender , defaultMultiMainRender - , defaultLoopRender ) where import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) import Diagrams.Animation import Diagrams.Attributes -import Diagrams.Core hiding (output, value) -import Diagrams.Util +import Diagrams.Core hiding (output) import Options.Applicative import Options.Applicative.Types (readerAsk) -import Control.Monad (forM_, forever, unless, when) +import Control.Monad (forM_) +-- MonadFail comes from Prelude in base-4.13 and up +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif + import Data.Active hiding (interval) import Data.Char (isDigit) import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data -import Data.IORef -import Data.List (delete) -import Data.Maybe (fromMaybe) +import Data.Functor.Identity +import Data.Kind (Type) import Data.Monoid import Numeric -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) +import System.Environment (getProgName) +import System.FilePath (addExtension, splitExtension) import Text.Printf @@ -142,15 +126,6 @@ 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). @@ -193,31 +168,21 @@ <> 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.") - -- | 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 +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 @@ -271,11 +236,6 @@ 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 @@ -303,7 +263,7 @@ -- 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 @@ -348,8 +308,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 @@ -423,16 +383,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,7 +414,7 @@ -- 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 @@ -526,9 +483,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 -- @@ -560,87 +516,3 @@ 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 () 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} @@ -35,11 +36,13 @@ , cat, cat' , CatOpts(_catMethod, _sep), catMethod, sep , CatMethod(..) + , composeAligned ) where import Control.Lens hiding (beside, ( # )) -import Data.Default.Class +import Data.Default +import Data.Maybe (fromJust) import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) import Data.Proxy @@ -49,6 +52,7 @@ import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Direction +import Diagrams.Names (named) import Diagrams.Segment (straight) import Diagrams.Util @@ -110,7 +114,7 @@ -- 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. -- @@ -141,7 +145,7 @@ extrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m -extrudeEnvelope = deformEnvelope 0.5 +extrudeEnvelope = deformEnvelope 1 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of -- a diagram away from the given direction. All parts of the envelope @@ -153,7 +157,7 @@ intrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m -intrudeEnvelope = deformEnvelope (-0.5) +intrudeEnvelope = deformEnvelope (-1) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope @@ -161,9 +165,9 @@ => 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 = fmap deformE' deformE' env v' - | dp > 0 = Max $ getMax (env v') + (dp * s) / norm v' + | dp > 0 = Max $ getMax (env v') + (dp * s) / quadrance v' | otherwise = env v' where dp = v' `dot` v @@ -351,3 +355,45 @@ cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = position . zip (iterate (.+^ (s *^ signorm v)) origin) + +-- | Compose a list of diagrams using the given composition function, +-- first aligning them all according to the given alignment, /but/ +-- retain the local origin of the first diagram, as it would be if +-- the composition function were applied directly. That is, +-- @composeAligned algn comp@ is equivalent to @translate v . comp +-- . map algn@ for some appropriate translation vector @v@. +-- +-- Unfortunately, this only works for diagrams (and not, say, paths) +-- because there is no most general type for alignment functions, +-- and no generic way to find out what an alignment function does to +-- the origin of things. (However, it should be possible to make a +-- version of this function that works /specifically/ on paths, if +-- such a thing were deemed useful.) +-- +-- <> +-- +-- > alignedEx1 = (hsep 2 # composeAligned alignT) (map circle [1,3,5,2]) +-- > # showOrigin +-- > # frame 0.5 +-- +-- <> +-- +-- > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1] +-- > # showOrigin +-- > # frame 0.1 +composeAligned + :: (Monoid' m, Floating n, Ord n, Metric v) + => (QDiagram b v n m -> QDiagram b v n m) -- ^ Alignment function + -> ([QDiagram b v n m] -> QDiagram b v n m) -- ^ Composition function + -> ([QDiagram b v n m] -> QDiagram b v n m) +composeAligned _ combine [] = combine [] +composeAligned algn comb (d:ds) = (comb $ map algn (d:ds)) # moveOriginTo l + where + mss = ( (() .>> d) -- qualify first to avoid stomping on an existing () name + # named () -- Mark the origin + # algn -- Apply the alignment function + ) + -- then find out what happened to the origin + ^. subMap . _Wrapped . Control.Lens.at (toName ()) + l = location . head . fromJust $ mss + -- the fromJust is Justified since we put the () name in diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -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,6 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline @@ -8,24 +12,35 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- A /cubic spline/ is a smooth, connected sequence of cubic curves --- passing through a given sequence of points. This module provides --- the 'cubicSpline' method, which can be used to create closed or --- open cubic splines from a list of points. For access to the --- internals of the spline generation algorithm (including in --- particular a solver for cyclic tridiagonal systems of linear --- equations), see "Diagrams.CubicSpline.Internal". +-- A /cubic spline/ is a smooth, connected sequence of cubic curves. +-- This module provides two methods for constructing splines. -- +-- The 'cubicSpline' method can be used to create closed or open cubic +-- splines from a list of points. The resulting splines /pass through/ +-- all the control points, but depend on the control points in a +-- "global" way (that is, changing one control point may alter the +-- entire curve). For access to the internals of the spline +-- generation algorithm, see "Diagrams.CubicSpline.Internal". +-- +-- 'bspline' creates a cubic B-spline, which starts and ends at the +-- first and last control points, but does not necessarily pass +-- through any of the other control points. It depends on the control +-- points in a "local" way, that is, changing one control point will +-- only affect a local portion of the curve near that control point. +-- ----------------------------------------------------------------------------- module Diagrams.CubicSpline ( -- * Constructing paths from cubic splines cubicSpline + , BSpline + , bspline ) where import Control.Lens (view) import Diagrams.Core +import Diagrams.CubicSpline.Boehm import Diagrams.CubicSpline.Internal import Diagrams.Located (Located, at, mapLoc) import Diagrams.Segment diff --git a/src/Diagrams/CubicSpline/Boehm.hs b/src/Diagrams/CubicSpline/Boehm.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/CubicSpline/Boehm.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.CubicSpline.Boehm +-- Copyright : (c) 2015 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Boehm's algorithm for converting a cubic B-spline into a sequence +-- of cubic Bezier curves. +-- +-- See +-- +-- * Thomas W. Sederberg, /An Introduction to B-Spline Curves/, +-- +-- +-- * Lyle Ramshaw, /Blossoming: A Connect-the-Dots Approach to Splines/, +-- +-- +----------------------------------------------------------------------------- +module Diagrams.CubicSpline.Boehm + ( BSpline + , bsplineToBeziers + , bspline + ) where + +import Data.List (sort, tails) +import Diagrams.Core (N, Point, V, origin) +import Diagrams.Located (at, loc, unLoc) +import Diagrams.Segment (FixedSegment (..), fromFixedSeg) +import Diagrams.TrailLike (TrailLike, fromLocSegments) +import Diagrams.Util (iterateN) +import Linear.Vector (Additive) +import Linear.Vector.Compat (lerp) + +type BSpline v n = [Point v n] + +-- | @affineCombo a b t x y@ computes an affine combination of x and y +-- which lies at parameter t, if x has parameter a and y has parameter b. +-- The usual @lerp@ arises by giving x parameter 0 and y parameter 1. +affineCombo :: (Additive f, Fractional a) => a -> a -> a -> f a -> f a -> f a +affineCombo a b t = lerp ((t-a)/(b-a)) + +-- | @windows k xs@ yields all the length-@k@ windows from @xs@, e.g. +-- @windows 3 [a,b,c,d,e] == [[a,b,c], [b,c,d], [c,d,e]]@. +windows :: Int -> [a] -> [[a]] +windows k = takeWhile ((==k) . length) . map (take k) . tails + +-- | @extend k xs@ extends @xs@ on both ends by prepending @k@ copies +-- of its head and appending @k@ copies of its last element. For example, +-- @extend 2 [1..5] == [1,1,1,2,3,4,5,5,5]@. +extend :: Int -> [a] -> [a] +extend k xs = replicate k (head xs) ++ xs ++ replicate k (last xs) + +-- | A "polar point" is a point along with three knot values. +-- We consider the "blossom" of a cubic spline, a 3-ary symmetric +-- polynomial; a polar point consists of 3 values paired with the +-- output of the blossom at those input values. Blossoms have nice +-- affine properties so this makes it easy to keep track of how +-- points may be combined to yield other points of interest. +-- +-- Invariant: knot values are in nondecreasing order. +data PolarPt v n = PP { unPP :: Point v n, _knots :: [n] } + +mkPolarPt :: Ord n => Point v n -> [n] -> PolarPt v n +mkPolarPt pt kts = PP pt (sort kts) + +-- | Precondition: the knots of the two polar points overlap, like abc +-- and bcd. The @Int@ should be 0 or 1, indicating which knot to +-- replicate (0 means to replicate b, yielding bbc, 1 means to +-- replicate c, yielding bcc). +combine + :: (Additive v, Fractional n, Ord n) + => Int -> PolarPt v n -> PolarPt v n -> PolarPt v n +combine k (PP pt1 kts1) (PP pt2 kts2) + = mkPolarPt + (affineCombo (head kts1) (last kts2) newKt pt1 pt2) + (newKt : drop 1 kts1) + where + newKt = kts2 !! k + +-- | Convert a uniform cubic B-spline to a sequence of cubic beziers. +-- (/Uniform/ refers to the fact that the knots are assumed to be +-- evenly spaced, with no duplicates.) The knots at the end are +-- replicated so the cubic spline begins and ends at the first and +-- last control points, tangent to the line from the end control +-- point to the next. +bsplineToBeziers + :: (Additive v, Fractional n, Num n, Ord n) + => BSpline v n + -> [FixedSegment v n] +bsplineToBeziers controls = beziers + where + n = length controls + numKnots = n + 2 + knots = iterateN numKnots (+1/(fromIntegral numKnots - 1)) 0 + + -- The control points are P(a,b,c), P(b,c,d), P(c,d,e), and so on. + controls' = zipWith mkPolarPt (extend 2 controls) (windows 3 $ extend 2 knots) + + -- The bezier internal control points are affine combinations of + -- the spline control points. + bezierControls = map combineC (windows 2 controls') + combineC [pabc, pbcd] = (combine 0 pabc pbcd, combine 1 pabc pbcd) + combineC _ = error "combineC must be called on a list of length 2" + + -- The bezier end points are affine combinations of the bezier + -- control points. + bezierEnds = map combineE (windows 2 bezierControls) + combineE [(_,pabb),(pbbc,_)] = combine 0 pabb pbbc + combineE _ = error "combineE must be called on a list of length 2" + + -- Finally, we actually put together the generated bezier segments. + beziers = zipWith mkBezier (drop 1 bezierControls) (windows 2 bezierEnds) + where + mkBezier (paab,pabb) [paaa,pbbb] + = FCubic (unPP paaa) (unPP paab) (unPP pabb) (unPP pbbb) + mkBezier _ _ = error "mkBezier must be called on a list of length 2" + + -- Note that the above algorithm works in any dimension but is + -- very specific to *cubic* splines. This can of course be + -- generalized to higher degree splines but keeping track of + -- everything gets a bit more complicated; to be honest I am not + -- quite sure how to do it. + +-- | Generate a uniform cubic B-spline from the given control points. +-- The spline starts and ends at the first and last control points, +-- and is tangent to the line to the second(-to-last) control point. +-- It does not necessarily pass through any of the other control +-- points. +-- +-- <> +-- +-- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] +-- > spot = circle 0.2 # fc blue # lw none +-- > bsplineEx = mconcat +-- > [ position (zip pts (repeat spot)) +-- > , bspline pts +-- > ] +-- > # frame 0.5 + +bspline :: (TrailLike t, V t ~ v, N t ~ n) => BSpline v n -> t +bspline = fromLocSegments . fixup . map fromFixedSeg . bsplineToBeziers + where + fixup [] = [] `at` origin + fixup (b1:rest) = (unLoc b1 : map unLoc rest) `at` loc b1 diff --git a/src/Diagrams/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,7 +1,6 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -#endif +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -9,8 +8,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Path @@ -62,10 +66,10 @@ ) where -import Control.Arrow ((***)) -import Control.Lens hiding ((#), transform, at) -import qualified Data.Foldable as F -import Data.List (partition) +import Control.Arrow ((***)) +import Control.Lens hiding (at, transform, ( # )) +import qualified Data.Foldable as F +import Data.List (partition) import Data.Semigroup import Data.Typeable @@ -81,6 +85,9 @@ import Linear.Metric import Linear.Vector +import Data.Serialize (Serialize) +import GHC.Generics (Generic) + ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ @@ -90,23 +97,13 @@ -- 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 + deriving (Semigroup, Monoid, Generic , Typeable -#endif ) -#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)] @@ -188,6 +185,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 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 @@ -22,7 +22,7 @@ -- | For working with default values. Diagrams also exports 'with', -- an alias for 'def'. - , module Data.Default.Class + , module Data.Default -- | For representing and operating on colors. , module Data.Colour @@ -97,7 +97,7 @@ import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Colour.SRGB -import Data.Default.Class +import Data.Default import Data.Semigroup import Linear.Affine 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} @@ -74,7 +75,8 @@ import Linear.Affine import Linear.Metric -import Linear.Vector +import Linear.Vector hiding (lerp) +import Linear.Vector.Compat (lerp) import Control.Applicative import Diagrams.Core hiding (Measured) @@ -82,6 +84,8 @@ import Diagrams.Parametric import Diagrams.Solve.Polynomial +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize ------------------------------------------------------------ -- Open/closed type tags --------------------------------- @@ -305,16 +309,16 @@ splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) - p = lerp t x1 zero + 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 + 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 @@ -323,6 +327,11 @@ reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) +-- 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 @@ -337,9 +346,9 @@ arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s arcLengthToParam m s@(Cubic {}) len - | len `I.elem` I (-m/2) (m/2) = 0 + | len `member` I (-m/2) (m/2) = 0 | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) - | len `I.elem` slen = 1 + | len `member` slen = 1 | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len | len < I.sup llen = (*0.5) $ arcLengthToParam m l len | otherwise = (+0.5) . (*0.5) @@ -363,7 +372,7 @@ -- 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 + deriving (Eq, Ord, Show) type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n @@ -418,16 +427,16 @@ 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) @@ -441,19 +450,19 @@ splitAtParam (FLinear p0 p1) t = (left, right) where left = FLinear p0 p right = FLinear p p1 - p = lerp t p1 p0 + 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 + a = lerp t p0 c1 + p = lerp t c1 c2 + d = lerp t c2 p1 -- second round - b = lerp t p a - c = lerp t d p + b = lerp t a p + c = lerp t p d -- final round - cut = lerp t c b + cut = lerp t b c reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 @@ -580,3 +589,48 @@ *: () +------------------------------------------------------------ +-- Serialize instances +------------------------------------------------------------ + +instance (Serialize (v n)) => Serialize (Segment Open v n) where + {-# INLINE put #-} + put segment = case segment of + Linear OffsetOpen -> Serialize.put True + Cubic v w OffsetOpen -> do + Serialize.put False + Serialize.put v + Serialize.put w + + {-# INLINE get #-} + get = do + isLinear <- Serialize.get + case isLinear of + True -> return (Linear OffsetOpen) + False -> do + v <- Serialize.get + w <- Serialize.get + return (Cubic v w OffsetOpen) + +instance (Serialize (v n)) => Serialize (Segment Closed v n) where + {-# INLINE put #-} + put segment = case segment of + Linear (OffsetClosed z) -> do + Serialize.put z + Serialize.put True + Cubic v w (OffsetClosed z) -> do + Serialize.put z + Serialize.put False + Serialize.put v + Serialize.put w + + {-# INLINE get #-} + get = do + z <- Serialize.get + isLinear <- Serialize.get + case isLinear of + True -> return (Linear (OffsetClosed z)) + False -> do + v <- Serialize.get + w <- Serialize.get + return (Cubic v w (OffsetClosed z)) diff --git a/src/Diagrams/Size.hs b/src/Diagrams/Size.hs --- a/src/Diagrams/Size.hs +++ b/src/Diagrams/Size.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -#endif {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -45,18 +43,18 @@ ) where import Control.Applicative -import Control.Lens hiding (transform) +import Control.Lens hiding (transform) import Control.Monad -import Data.Foldable as F +import Data.Foldable as F import Data.Hashable -import Data.Semigroup import Data.Maybe +import Data.Semigroup import Data.Typeable -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Prelude -import Diagrams.Core import Diagrams.BoundingBox +import Diagrams.Core import Linear.Affine import Linear.Vector @@ -69,19 +67,12 @@ -- the dimensions. newtype SizeSpec v n = SizeSpec (v n) deriving ( -#if __GLASGOW_HASKELL__ >= 707 + Eq, 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 type instance V (SizeSpec v n) = v type instance N (SizeSpec v n) = n 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 @@ -38,7 +38,7 @@ -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. newtype SurfaceColor = SurfaceColor (Last (Colour Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Show) instance AttributeClass SurfaceColor @@ -59,7 +59,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 (Typeable, Semigroup, Show) instance AttributeClass Diffuse @@ -82,7 +82,7 @@ -- indirect lighting incident on that object and the diffuse -- reflectance. newtype Ambient = Ambient (Last Double) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Show) instance AttributeClass Ambient @@ -107,12 +107,12 @@ data Specular = Specular { _specularIntensity :: Double , _specularSize :: Double - } + } deriving Show makeLenses ''Specular newtype Highlight = Highlight (Last Specular) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Show) instance AttributeClass Highlight @@ -136,4 +136,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,12 @@ , 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 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 #-} 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,38 @@ ----------------------------------------------------------------------------- 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 @@ -53,21 +70,20 @@ 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 @@ -76,36 +92,37 @@ 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 @@ -118,55 +135,190 @@ 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) + deriving Typeable + +type instance V (CSG n) = V3 +type instance N (CSG n) = n + +instance Fractional n => Transformable (CSG n) where + transform t (CsgEllipsoid p) = CsgEllipsoid $ transform t p + transform t (CsgBox p) = CsgBox $ transform t p + transform t (CsgFrustum p) = CsgFrustum $ transform t p + transform t (CsgUnion ps) = CsgUnion $ map (transform t) ps + transform t (CsgIntersection ps) = CsgIntersection $ map (transform t) ps + transform t (CsgDifference p1 p2) = CsgDifference (transform t p1) (transform t p2) + +-- | The Envelope for an Intersection or Difference is simply the +-- Envelope of the Union. This is wrong but easy to implement. +instance RealFloat n => Enveloped (CSG n) where + getEnvelope (CsgEllipsoid p) = getEnvelope p + getEnvelope (CsgBox p) = getEnvelope p + getEnvelope (CsgFrustum p) = getEnvelope p + getEnvelope (CsgUnion ps) = foldMap getEnvelope ps + getEnvelope (CsgIntersection ps) = foldMap getEnvelope ps + getEnvelope (CsgDifference p1 p2) = getEnvelope p1 <> getEnvelope p2 +-- TODO after implementing some approximation scheme, calculate +-- correct (approximate) envelopes for intersections and difference. + +instance (Floating n, Ord n) => HasQuery (CSG n) Any where + getQuery (CsgEllipsoid prim) = getQuery prim + getQuery (CsgBox prim) = getQuery prim + getQuery (CsgFrustum prim) = getQuery prim + getQuery (CsgUnion ps) = foldMap getQuery ps + getQuery (CsgIntersection ps) = + Any . getAll <$> foldMap (fmap (All . getAny) . getQuery) ps + getQuery (CsgDifference p1 p2) = inOut <$> getQuery p1 <*> getQuery p2 where + inOut (Any a) (Any b) = Any $ a && not b + +instance (RealFloat n, Ord n) => Traced (CSG n) where + getTrace (CsgEllipsoid p) = getTrace p + getTrace (CsgBox p) = getTrace p + getTrace (CsgFrustum p) = getTrace p + -- on surface of some p, and not inside any of the others + getTrace (CsgUnion []) = mempty + getTrace (CsgUnion (s:ss)) = mkTrace t where + t pt v = onSortedList (filter $ without s) (appTrace (getTrace (CsgUnion ss)) pt v) + <> onSortedList (filter $ without (CsgUnion ss)) (appTrace (getTrace s) pt v) where + newPt dist = pt .+^ v ^* dist + without prim = not . inquire prim . newPt + -- on surface of some p, and inside all the others + getTrace (CsgIntersection []) = mempty + getTrace (CsgIntersection (s:ss)) = mkTrace t where + t pt v = onSortedList (filter $ within s) (appTrace (getTrace (CsgIntersection ss)) pt v) + <> onSortedList (filter $ within (CsgIntersection ss)) (appTrace (getTrace s) pt v) where + newPt dist = pt .+^ v ^* dist + within prim = inquire prim . newPt + -- on surface of p1, outside p2, or on surface of p2, inside p1 + getTrace (CsgDifference s1 s2) = mkTrace t where + t pt v = onSortedList (filter $ not . within s2) (appTrace (getTrace s1) pt v) + <> onSortedList (filter $ within s1) (appTrace (getTrace s2) pt v) where + newPt dist = pt .+^ v ^* dist + within prim = inquire prim . newPt + +instance (RealFloat n, Ord n) => Skinned (CSG n) where + skin s = mkQD (Prim s) (getEnvelope s) (getTrace s) mempty (getQuery s) + +-- | Types which can be included in CSG trees. +class CsgPrim a where + toCsg :: a n -> CSG n + +instance CsgPrim Ellipsoid where + toCsg = CsgEllipsoid + +instance CsgPrim Box where + toCsg = CsgBox + +instance CsgPrim Frustum where + toCsg = CsgFrustum + +instance CsgPrim CSG where + toCsg = id + +union :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +union a b = CsgUnion [toCsg a, toCsg b] + +intersection :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +intersection a b = CsgIntersection [toCsg a, toCsg b] + +difference :: (CsgPrim a, CsgPrim b) => a n -> b n -> CSG n +difference a b = CsgDifference (toCsg a) (toCsg b) diff --git a/src/Diagrams/ThreeD/Size.hs b/src/Diagrams/ThreeD/Size.hs --- 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,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -56,6 +58,7 @@ , Trail(..) , _Line, _Loop + , _LocLine, _LocLoop , wrapTrail, wrapLine, wrapLoop , onTrail, onLine @@ -81,7 +84,7 @@ , trailPoints, linePoints, loopPoints , trailVertices', lineVertices', loopVertices' , trailVertices, lineVertices, loopVertices - , trailLocSegments, fixTrail + , trailLocSegments, fixTrail, unfixTrail -- * Modifying trails @@ -102,14 +105,14 @@ -- ** Extracting segments - , GetSegment(..), getSegment + , 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 @@ -127,6 +130,9 @@ 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 @@ -172,6 +178,18 @@ newtype SegTree v n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n)) deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n)) +-- Only derive the Semigroup instance for versions of base that +-- include Semigroup. This is because the fingertree package has +-- similar CPP to only export a Semigroup instance for those versions +-- of base, so for GHC 7.10 and earlier we get a 'no instance found' +-- error when trying to derive the Semigroup instance for SegTree. It +-- would also be possible to depend on the 'semigroups' package in +-- order to get the Semigroup class regardless of base version, but +-- presumably fingertree didn't want to add a dependency. +#if MIN_VERSION_base(4,9,0) +deriving instance (Ord n, Floating n, Metric v) => Semigroup (SegTree v n) +#endif + instance Wrapped (SegTree v n) where type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n) _Wrapped' = iso (\(SegTree x) -> x) SegTree @@ -203,60 +221,46 @@ 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) +splitAtParam' :: (Metric v, OrderedField n, Real n) + => SegTree v n -> n -> ((SegTree v n, SegTree v n), n -> n) +splitAtParam' (SegTree t) p + | tSegs == 0 = ((mempty , mempty ), id) + | otherwise = ((SegTree treeL, SegTree treeR), rescale) + where + tSegs = numSegs t + splitParam q | q < 0 = (0 , q * tSegs) + | q >= 1 = (tSegs - 1, 1 + (q - 1) * tSegs) + | otherwise = propFrac $ q * tSegs + where propFrac x = let m = mod1 x in (x - m, m) + (pSegs, pParam) = splitParam p + (before, viewl -> seg FT.:< after) = FT.split ((pSegs <) . numSegs) t + (segL, segR) = seg `splitAtParam` pParam + (treeL, treeR) | pParam == 0 = (before , seg <| after) + | pParam == 1 = (before |> seg , after) + | otherwise = (before |> segL, segR <| after) + -- section uses rescale to find the new value of p1 after the split at p2 + rescale u | pSegs' == uSegs = (uSegs + uParam / pParam' {-'1-}) / (pSegs' + 1) {-'2-} + | otherwise = u * tSegs / (pSegs' + 1) {-'3-} + where + -- param 0 on a segment is param 1 on the previous segment + (pSegs', pParam') | pParam == 0 = (pSegs-1, 1) + | otherwise = (pSegs , pParam) + (uSegs , uParam ) = splitParam u + -- '1 (pParam ≠ 0 → pParam' = pParam) ∧ (pParam = 0 → pParam' = 1) → pParam' ≠ 0 + -- '2 uSegs ≥ 0 ∧ pSegs' = uSegs → pSegs' ≥ 0 → pSegs' + 1 > 0 + -- '3 pSegs' + 1 = 0 → pSegs' = -1 → pSegs = 0 ∧ pParam = 0 → p = 0 + -- → rescale is not called instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where - splitAtParam tree p = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b) + splitAtParam tree p = fst $ splitAtParam' tree p 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? + 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 @@ -307,7 +311,7 @@ -- (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 +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@, @@ -502,6 +506,8 @@ 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) @@ -533,6 +539,17 @@ _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 @@ -554,9 +571,10 @@ -- 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: +-- 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, @@ -749,6 +767,8 @@ 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) @@ -766,6 +786,14 @@ _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) @@ -1237,10 +1265,30 @@ 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)] @@ -1311,3 +1359,38 @@ 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 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -18,7 +19,7 @@ -- -- Drawing arrows in two dimensions. For a tutorial on drawing arrows -- using this module, see the diagrams website: --- . +-- . -- ----------------------------------------------------------------------------- @@ -104,14 +105,11 @@ , module Diagrams.TwoD.Arrowheads ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif import Control.Lens (Lens', Traversal', generateSignatures, lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) -import Data.Default.Class +import Data.Default import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct (untangle) import Data.Semigroup @@ -134,7 +132,7 @@ import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Path (stroke, strokeT) -import Diagrams.TwoD.Transform (reflectY, rotate, translateX) +import Diagrams.TwoD.Transform (reflectY, translateX) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) @@ -321,9 +319,10 @@ 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 @@ -332,8 +331,9 @@ 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 @@ -402,7 +402,7 @@ -- 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 + let (trans, globalSty) = maybe mempty untangle . fst $ da in dArrow globalSty trans len g n -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). @@ -423,7 +423,7 @@ opts' = opts & headStyle %~ maybe id fillTexture globalLC & tailStyle %~ maybe id fillTexture globalLC - & shaftStyle %~ applyStyle sty + & 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. 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -60,7 +61,7 @@ ) where import Control.Lens ((&), (.~), (<>~), (^.)) -import Data.Default.Class +import Data.Default import Data.Monoid (mempty, (<>)) import Diagrams.Angle 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -10,7 +10,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -66,7 +65,7 @@ import Control.Lens hiding (transform) import Data.Colour hiding (AffineSpace, over) import Data.Data -import Data.Default.Class +import Data.Default import Data.Monoid.Recommend import Data.Semigroup 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -25,7 +26,9 @@ DImage(..), ImageData(..) , Embedded, External, Native , image + , embeddedImage , loadImageEmb + , loadImageEmbBS , loadImageExt , uncheckedImageRef , raster @@ -33,29 +36,33 @@ ) where import Codec.Picture -import Codec.Picture.Types (dynamicMap) import Data.Colour (AlphaColour) +import Data.Kind (Type) import Data.Semigroup import Data.Typeable (Typeable) 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 Data.ByteString + import Linear.Affine data Embedded deriving Typeable data External deriving Typeable -data Native (t :: *) deriving Typeable +data Native (t :: Type) deriving Typeable -- | '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 ImageNative :: t -> ImageData (Native t) @@ -65,13 +72,19 @@ -- 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) @@ -86,22 +99,31 @@ (getEnvelope r) (getTrace r) mempty - (Query $ \p -> Any (isInsideEvenOdd p r)) + (Query $ \p -> Any (isInsideEvenOdd r p)) where - r = rect (fromIntegral w) (fromIntegral h) + 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 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,11 +1,16 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset @@ -15,7 +20,7 @@ -- -- Compute offsets to segments in two dimensions. More details can be -- found in the manual at --- . +-- . -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Offset @@ -48,7 +53,7 @@ import Data.Monoid import Data.Monoid.Inf -import Data.Default.Class +import Data.Default import Diagrams.Core @@ -304,7 +309,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 @@ -404,7 +409,7 @@ 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) @@ -470,8 +475,8 @@ 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) + 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 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,13 +8,16 @@ {-# 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 -- @@ -25,35 +29,37 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD.Path - ( -- * Constructing path-based diagrams + ( -- * Constructing path-based diagrams - stroke, stroke' - , strokePath, strokeP, strokePath', strokeP' - , strokeTrail, strokeT, strokeTrail', strokeT' - , strokeLine, strokeLoop - , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop + stroke, stroke' + , strokePath, strokeP, strokePath', strokeP' + , strokeTrail, strokeT, strokeTrail', strokeT' + , strokeLine, strokeLoop + , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop - -- ** Stroke options + -- ** Stroke options - , FillRule(..) - , getFillRule, fillRule, _fillRule - , StrokeOpts(..), vertexNames, queryFillRule + , FillRule(..) + , getFillRule, fillRule, _fillRule + , StrokeOpts(..), vertexNames, queryFillRule - -- ** Inside/outside testing + -- ** Inside/outside testing - , isInsideWinding, isInsideEvenOdd + , Crossings (..) + , isInsideWinding + , isInsideEvenOdd - -- * Clipping + -- * Clipping - , Clip(..), _Clip, _clip - , clipBy, clipTo, clipped + , Clip(..), _Clip, _clip + , clipBy, clipTo, clipped - -- * Intersections + -- * Intersections - , intersectPoints, intersectPoints' - , intersectPointsP, intersectPointsP' - , intersectPointsT, intersectPointsT' - ) where + , intersectPoints, intersectPoints' + , intersectPointsP, intersectPointsP' + , intersectPointsT, intersectPointsT' + ) where import Control.Applicative (liftA2) import Control.Lens hiding (at, transform) @@ -61,7 +67,7 @@ import Data.Semigroup import Data.Typeable -import Data.Default.Class +import Data.Default import Diagrams.Angle import Diagrams.Combinators (withEnvelope, withTrace) @@ -70,6 +76,7 @@ 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 @@ -107,14 +114,14 @@ -- | 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 - -- . +data FillRule + = Winding -- ^ Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + | EvenOdd -- ^ Interior points are those where a ray + -- extended infinitely in a particular direction crosses + -- the path an odd number of times. See + -- . deriving (Show, Typeable, Eq, Ord) instance AttributeClass FillRule @@ -147,14 +154,13 @@ -- -- 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 @@ -167,6 +173,13 @@ -- -- See also 'stroke'', which takes an extra options record allowing -- its behaviour to be customized. +-- +-- @ +-- '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 @@ -212,7 +225,7 @@ (fromNames . concat $ zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) ) - (Query $ Any . flip (runFillRule (opts^.queryFillRule)) p) + (Query $ Any . (runFillRule (opts^.queryFillRule)) p) -- | 'stroke'' specialised to 'Path'. strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) @@ -279,7 +292,7 @@ -- 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 +309,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,23 +367,24 @@ -- 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 +trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Crossings -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 trailCrossings p@(unp2 -> (x,y)) tr - = sum . map test $ fixTrail tr + = F.foldMap test $ fixTrail tr where test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 @@ -383,6 +440,12 @@ 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 @@ -420,7 +483,7 @@ -- 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 + 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 @@ -436,7 +499,7 @@ -- | 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 = intersectPoints' 1e-8 -- | Find the intersect points of two objects that can be converted to a path -- within the given tolerance. @@ -446,7 +509,7 @@ -- | 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 +520,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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Points 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,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,31 +46,27 @@ ) 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.Maybe (catMaybes) +import Data.Ord (comparing) import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path -import Diagrams.Points (centroid) +import Diagrams.Points (centroid) import Diagrams.Trail import Diagrams.TrailLike -import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) -import Diagrams.Util (tau, ( # )) +import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) +import Diagrams.Util (tau, ( # )) import Linear.Affine import Linear.Metric @@ -127,10 +123,10 @@ -- | 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. + -- This is the default. | OrientV -- ^ Orient /vertically/, so the -- leftmost edge is parallel to the -- y-axis. @@ -174,10 +170,10 @@ 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 + 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 @@ -222,6 +218,8 @@ orient v = orientPoints v . trailVertices orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n +orientPoints _ [] = mempty +orientPoints _ [_] = mempty orientPoints v xs = rotation a where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) 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,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -168,6 +169,14 @@ go p q tmin tmax umin umax clip revCurves | isNothing chopInterval = [] + -- This check happens before the subdivision + -- test to avoid non-termination as values + -- transition to within epsilon. + | max (umax - umin) (tmax' - tmin') < eps = + if revCurves -- return parameters in correct order + then [ (avg umin umax, avg tmin' tmax') ] + else [ (avg tmin' tmax', avg umin umax ) ] + -- split the curve if there isn't enough reduction | clip > 0.8 && clip' > 0.8 = if tmax' - tmin' > umax - umin -- split the longest segment @@ -180,11 +189,6 @@ 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 @@ -205,22 +209,32 @@ -> 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) - - + -- If we generated the max number of roots and tmax is also a root + -- (which is not among the generated ones), there must in fact be an + -- infinite number of roots, so just include tmax. + | length roots == bernsteinDegree p && last roots /= tmax && abs (evaluateBernstein p tmax) <= eps + = roots ++ [tmax] + | otherwise = roots + where + -- Lazily take a number of roots at most the degree of the bernstein + -- polynomial, to avoid generating a ton of roots in the case of a + -- straight Bezier segment along the x-axis. See https://github.com/diagrams/diagrams-contrib/issues/91 . + roots = take (bernsteinDegree p) $ go p tmin tmax + go p tmin tmax + | isNothing chopInterval = [] + | tmax' - tmin' < eps = [avg tmin' tmax'] + | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 + tmid = tmin' + (tmax' - tmin') / 2 + in go p1 tmin' tmid ++ + go p2 tmid tmax' + | otherwise = bezierFindRoot eps newP tmin' tmax' + where + chopInterval = chopYs (bernsteinCoeffs p) + Just (tminChop, tmaxChop) = chopInterval + newP = section p tminChop tmaxChop + clip = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) ------------------------------------------------------------------------ -- Internal @@ -280,11 +294,21 @@ | 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 + | 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) @@ -296,28 +320,30 @@ -- 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) +-- | 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 - a = a' / d - b = b' / d - c = -(x1*a' + y1*b') / d - a' = y1 - y2 - b' = x2 - x1 - d = sqrt $ a'*a' + b'*b' + 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 @@ -345,6 +371,9 @@ segLine (FLinear p0 p1) = mkLine p0 p1 segLine (FCubic p0 _ _ p3) = mkLine p0 p3 +-- This function uses `defEps`, but is used in functions +-- above that take an epsilon parameter. It would be nice +-- to clearify the meaning of each of these epsilons. inRange :: (Fractional n, Ord n) => n -> Bool inRange x = x < (1+defEps) && x > (-defEps) diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Shapes @@ -46,7 +50,7 @@ ) where import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) -import Data.Default.Class +import Data.Default import Data.Semigroup import Diagrams.Core 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,10 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -21,23 +22,31 @@ module Diagrams.TwoD.Text ( -- * Creating text diagrams Text(..), TextAlignment(..) - , text, topLeftText, alignedText, baselineText, mkText + , text, topLeftText, alignedText, baselineText + , mkText, mkText' -- * Text attributes + -- ** Font family , Font(..), _Font , getFont, font, _font + -- ** Font size , FontSize(..), _FontSize - , getFontSize, fontSizeM, fontSize + , fontSize, recommendFontSize , fontSizeN, fontSizeO, fontSizeL, fontSizeG + , getFontSize, fontSizeM , _fontSizeR, _fontSize, _fontSizeU + -- ** Font slant , FontSlant(..) , getFontSlant, fontSlant, italic, oblique, _fontSlant + -- ** Font weight , FontWeight(..) - , getFontWeight, fontWeight, bold, _fontWeight + , getFontWeight, fontWeight, bold, bolder, lighter, _fontWeight + , thinWeight, ultraLight, light, mediumWeight, heavy, semiBold, ultraBold + ) where import Control.Lens hiding (transform) @@ -48,10 +57,7 @@ import Diagrams.TwoD.Types import Data.Colour hiding (over) -import Data.Default.Class -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -#endif +import Data.Default import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable @@ -88,20 +94,28 @@ -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment n = BaselineText | BoxAlignedText n n --- | Make a text from a 'TextAlignment'. +-- | 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 t = recommendFillColor black - -- See Note [recommendFillColor] - . recommendFontSize (local 1) - -- See Note [recommendFontSize] +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] -- The reason we "recommend" a fill color of black instead of setting @@ -123,10 +137,11 @@ -- 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@. -- @@ -234,11 +249,18 @@ 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 +281,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 @@ -321,7 +340,17 @@ -- @FontWeightA@ attributes override outer ones. data FontWeight = FontWeightNormal | FontWeightBold - deriving (Eq, Ord, Show, Typeable) + | FontWeightBolder + | FontWeightLighter + | FontWeightThin + | FontWeightUltraLight + | FontWeightLight + | FontWeightMedium + | FontWeightSemiBold + | FontWeightUltraBold + | FontWeightHeavy + deriving (Eq, + Ord, Show, Typeable) instance AttributeClass FontWeight @@ -336,7 +365,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 +374,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 @@ -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