diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,88 @@ +## [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/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.4 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 @@ -21,7 +21,7 @@ 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 +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.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,20 +100,20 @@ Diagrams.TwoD.Types, Diagrams.TwoD.Vector, Diagrams.Util - Build-depends: base >= 4.2 && < 4.10, + Build-depends: base >= 4.6 && < 4.10, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.19, monoid-extras >= 0.3 && < 0.5, dual-tree >= 0.2 && < 0.3, - diagrams-core >= 1.3 && < 1.4, + diagrams-core >= 1.4 && < 1.5, diagrams-solve >= 0.1 && < 0.2, active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, data-default-class < 0.2, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.8, - lens >= 4.6 && < 4.15, + lens >= 4.6 && < 4.16, tagged >= 0.7, optparse-applicative >= 0.11 && < 0.14, filepath, @@ -128,7 +129,9 @@ text >= 0.7.1 && < 1.3, mtl >= 2.0 && < 2.3, transformers >= 0.3.0 && < 0.6.0, - exceptions >= 0.6 && < 1.0 + profunctors >= 5.0 && < 6.0, + exceptions >= 0.6 && < 1.0, + cereal >=0.4.1.1 && <0.6 if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src @@ -144,10 +147,31 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs - other-modules: Diagrams.TwoD.OffsetTest + other-modules: Diagrams.Test.Direction + , Diagrams.Test.Transform + , Diagrams.Test.TwoD.Offset + , 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 + tasty >= 0.10 && < 0.12, + tasty-hunit >= 0.9.2 && < 0.10, + tasty-quickcheck >= 0.8 && < 0.9, + deepseq >= 1.3 && < 1.5, + diagrams-lib, + lens, + 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/Angle.hs b/src/Diagrams/Angle.hs --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -33,19 +36,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 +207,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/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -55,6 +55,12 @@ , Opacity, _Opacity , getOpacity, opacity, _opacity + , FillOpacity, _FillOpacity + , getFillOpacity, fillOpacity, _fillOpacity + + , StrokeOpacity, _StrokeOpacity + , getStrokeOpacity, strokeOpacity, _strokeOpacity + -- ** Converting colors , colorToSRGBA, colorToRGBA @@ -344,6 +350,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/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -76,7 +76,7 @@ import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) import Diagrams.Animation import Diagrams.Attributes -import Diagrams.Core hiding (output, value) +import Diagrams.Core hiding (output) import Diagrams.Util import Options.Applicative diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -38,7 +38,7 @@ , boxExtents, boxCenter , mCenterPoint, centerPoint , boxTransform, boxFit - , contains, contains', boundingBoxQuery + , contains, contains' , inside, inside', outside, outside' -- * Operations on bounding boxes @@ -55,7 +55,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 @@ -118,8 +119,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 +135,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 @@ -256,9 +260,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 @@ -310,4 +311,3 @@ -- function is just an alias for @mappend@. union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend - diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -35,11 +35,13 @@ , cat, cat' , CatOpts(_catMethod, _sep), catMethod, sep , CatMethod(..) + , composeAligned ) where import Control.Lens hiding (beside, ( # )) import Data.Default.Class +import Data.Maybe (fromJust) import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) import Data.Proxy @@ -49,6 +51,7 @@ import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Direction +import Diagrams.Names (named) import Diagrams.Segment (straight) import Diagrams.Util @@ -351,3 +354,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/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -8,24 +8,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,147 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- 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, 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 x y = lerp ((t-a)/(b-a)) y x + +-- | @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/Direction.hs b/src/Diagrams/Direction.hs --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -27,8 +27,8 @@ import Diagrams.Core import Linear.Affine -import Linear.Vector import Linear.Metric +import Linear.Vector -------------------------------------------------------------------------------- -- Direction @@ -76,11 +76,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 :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n dirBetween p q = dir $ p .-. q - diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -4,6 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located @@ -34,10 +35,14 @@ import Linear.Affine import Linear.Vector +import Diagrams.Align import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Parametric +import GHC.Generics (Generic) +import Data.Serialize (Serialize) + -- | \"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 +67,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. @@ -143,6 +150,9 @@ -- translated to the location. 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) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Path @@ -81,6 +82,9 @@ import Linear.Metric import Linear.Vector +import GHC.Generics (Generic) +import Data.Serialize (Serialize) + ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ @@ -90,12 +94,16 @@ -- 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 + deriving (Semigroup, Monoid, Generic #if __GLASGOW_HASKELL__ >= 707 , Typeable #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) + #if __GLASGOW_HASKELL__ < 707 -- This should really be Typeable2 Path but since Path has kind -- (* -> *) -> * -> * @@ -188,6 +196,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/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 @@ -82,6 +82,8 @@ import Diagrams.Parametric import Diagrams.Solve.Polynomial +import Data.Serialize (Serialize) +import qualified Data.Serialize as Serialize ------------------------------------------------------------ -- Open/closed type tags --------------------------------- @@ -580,3 +582,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/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/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/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -17,14 +17,32 @@ ----------------------------------------------------------------------------- module Diagrams.ThreeD.Shapes - ( - Ellipsoid(..), sphere - , Box(..), cube - , Frustum(..) , frustum, cone, cylinder - ) where + ( + -- * Skinned class + Skinned(..) + -- * Basic 3D shapes + , Ellipsoid(..) + , sphere + + , Box(..) + , cube + + , Frustum(..) + , frustum + , cone + , cylinder + + -- * Constructive solid geometry + , CSG(..) + , union + , intersection + , difference + ) where + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative +import Data.Foldable (foldMap) #endif import Control.Lens (review, (^.), _1) import Data.Typeable @@ -32,7 +50,9 @@ 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 +73,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 +95,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 +138,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/Transform.hs b/src/Diagrams/ThreeD/Transform.hs --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -50,9 +50,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 +138,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/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -56,6 +56,7 @@ , Trail(..) , _Line, _Loop + , _LocLine, _LocLoop , wrapTrail, wrapLine, wrapLoop , onTrail, onLine @@ -81,7 +82,7 @@ , trailPoints, linePoints, loopPoints , trailVertices', lineVertices', loopVertices' , trailVertices, lineVertices, loopVertices - , trailLocSegments, fixTrail + , trailLocSegments, fixTrail, unfixTrail -- * Modifying trails @@ -102,7 +103,7 @@ -- ** Extracting segments - , GetSegment(..), getSegment + , GetSegment(..), getSegment, GetSegmentCodomain(..) ) where @@ -127,6 +128,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 @@ -554,9 +558,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, @@ -766,6 +771,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 +1250,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 +1344,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/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 @@ -213,6 +215,7 @@ -- ** Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- ** Shears , shearingX, shearX @@ -247,7 +250,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/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -29,7 +29,6 @@ -- ** Align by trace , snugL, snugR, snugT, snugB - , snugTL, snugTR, snugBL, snugBR -- * Relative alignment , alignX, snugX, alignY, snugY @@ -83,14 +82,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 +131,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/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -134,7 +134,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 +321,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 +333,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 @@ -423,7 +425,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/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -43,7 +43,9 @@ import Diagrams.Attributes (colorToSRGBA) import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.Path (Path) import Diagrams.TwoD.Shapes (rect) +import Diagrams.Query import Diagrams.TwoD.Types import Linear.Affine @@ -72,6 +74,12 @@ 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,10 +94,14 @@ (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 + +rectPath :: RealFloat n => n -> n -> Path V2 n +rectPath = rect -- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values. 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 @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- 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 +25,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) @@ -70,6 +72,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 +110,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 +150,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 +169,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 +221,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 +288,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 +305,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 +363,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 +436,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 +479,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 +495,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 +505,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 +516,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/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -67,7 +67,6 @@ 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, ( # )) @@ -222,6 +221,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/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -21,23 +21,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) @@ -88,20 +96,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 +139,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 +251,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 +283,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 +342,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 +367,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 +376,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 @@ -23,7 +23,6 @@ T2 -- * Rotation , rotation, rotate, rotateBy, rotated - , rotationAround, rotateAround , rotationTo, rotateTo @@ -43,6 +42,7 @@ -- * Reflection , reflectionX, reflectX , reflectionY, reflectY + , reflectionXY, reflectXY , reflectionAbout, reflectAbout -- * Shears @@ -63,34 +63,12 @@ import Data.Semigroup import Linear.Affine +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 @@ -205,6 +183,8 @@ => n -> t -> t translateY = transform . translationY + + -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to @@ -227,13 +207,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 +272,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/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/Transform.hs b/test/Diagrams/Test/Transform.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/Transform.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} + + +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/TwoD.hs b/test/Diagrams/Test/TwoD.hs new file mode 100644 --- /dev/null +++ b/test/Diagrams/Test/TwoD.hs @@ -0,0 +1,53 @@ +-- | + +module Diagrams.Test.TwoD where + +import Diagrams.Prelude +import Diagrams.Trail (linePoints) +import Instances +import Test.Tasty +import Test.Tasty.QuickCheck + +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]) + ] + ] 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/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,132 @@ +{-# 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 + +------------------------------------------------------------ + -- 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 (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 (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 (v n) => Arbitrary (Point v n) where + arbitrary = P <$> arbitrary + shrink (P v) = P <$> shrink v + +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 = 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 = 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,45 @@ +{-# LANGUAGE FlexibleContexts #-} + +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,22 @@ -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.TwoD as TwoD +import qualified Diagrams.Test.TwoD.Offset as TwoD.Offset +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 + , TwoD.tests + , Angle.tests + , Direction.tests + , Transform.tests + , Trail.tests + ] main :: IO () main = defaultMain tests