diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,10 +1,91 @@ +1.2 (27 May 2014) +----------------- + +* **New features** + + - Several attributes (such as line width, dashing size, arrowhead + size, and font size) that formerly had a value of type `Double` + now have the more general type `Measure R2`. This allows the + attributes to be specified relative to one of four measurement + frames: `Local`, `Global`, `Normalized`, and `Output`. + + - New DSL for specifying measurements. + + - New synonyms for specifying measurements, *e.g.* `thin`, + `thick`, and `medium`, `large`. + + - Support for radial and linear gradients for fills and strokes. + + - New `DImage` type that supports both embedded and external images in + Backends that support them. + + - New `lengths` Traversal for setting `headLength` and `tailLength` + simultaneously. + + - `Frustrum` and `Box` shapes added to `Diagrams.ThreeD.Shapes`. + + - New function `quartForm` to find roots of quartic polynomials. + + - New Lenses for polar coordinates. + + - New trig functions, `sinA`, `atanA`, etc. which take `Angle` as + input or output. + +* **New instances** + + - `Transformable` instances for `LineWidth`, `Dashing`, + `LineTexture`, and `FillTexture`. + +* **API changes** + + - `FillColor` and `LineColor` attributes have been replaced with + the more general `FillTexture` and `LineTexture`. Use the `solid` + function to convert a color to a texture. + + - The size of arrow heads and tails is now specified in terms of + length instead of the radius of their circumcircle. + + - Gaps at the ends of arrows are now specified using `Measure R2`. + + - The `gap` traversal has been replaced by `gaps` for consistency + in naming, though `gap` is still provided for backwards compatibility. + + - `fontSize` now takes a value of type `Measure R2`. + + - Get rid of (bitrotted) `Show` backend. + + - Functions in `TwoD.Adjust` now return the adjustment + transformation itself in addition to the resized `Diagram` and + `Options` record; this can be used, *e.g.* to convert screen + coordinates back into diagram coordinates. + + - Export `pathLocSegments`. + + - The `avgScale` function has been moved to `Diagrams.Core`. + + - The `Angle` definition and related functions (*e.g.* + `angleBetween`) have moved to a separate module, `Diagrams.Angle`. + + - A separate `Diagrams.TwoD.Attributes` module now contains most + of the attributes that require 2D transformation instances. + + - The `splitColorFills` function has been replaced by `splitTextureFills`. + +* **Dependency/version changes** + + - Allow `semigroups-0.15` + + - Allow `opt-parse-applicative-0.9.0 + + - Allow `lens-4.2` + 1.1.0.7 (15 May 2014) ------------------------ - Allow `semigroups-0.14` 1.1.0.6 (10 April 2014) ----------------------- +------------------------ - Allow `semigroups-0.13` 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.1.0.7 +Version: 1.2 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 @@ -28,6 +28,7 @@ Exposed-modules: Diagrams.Prelude, Diagrams.Prelude.ThreeD, Diagrams.Align, + Diagrams.Angle, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, @@ -56,6 +57,7 @@ Diagrams.TwoD.Align, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, + Diagrams.TwoD.Attributes, Diagrams.TwoD.Combinators, Diagrams.TwoD.Deform, Diagrams.TwoD.Transform, @@ -75,6 +77,7 @@ Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, Diagrams.ThreeD.Align, + Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, @@ -86,30 +89,31 @@ Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, - Diagrams.Backend.Show, Diagrams.Backend.CmdLine Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.6, - semigroups >= 0.3.4 && < 0.15, + semigroups >= 0.3.4 && < 0.16, monoid-extras >= 0.3 && < 0.4, - diagrams-core >= 1.1 && < 1.2, + dual-tree >= 0.2 && < 0.3, + diagrams-core >= 1.2 && < 1.3, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, vector-space-points >= 0.1.2 && < 0.3, MemoTrie >= 0.6 && < 0.7, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, - pretty >= 1.0.1.2 && < 1.2, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.8, - lens >= 4.0 && < 4.2, + lens >= 4.0 && < 4.3, tagged >= 0.7, - optparse-applicative >= 0.7 && < 0.9, + optparse-applicative >= 0.7 && < 0.10, filepath, safe >= 0.2 && < 0.4, + JuicyPixels >= 3.1.5 && < 3.2, hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src + ghc-options: -Wall default-language: Haskell2010 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg deleted file mode 100644 --- a/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg deleted file mode 100644 --- a/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ -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,4 +1,4 @@ -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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + 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,4 +1,4 @@ - + diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Angle.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Angle +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing angles, independent of vector-space +-- +----------------------------------------------------------------------------- + +module Diagrams.Angle + ( + Angle + , rad, turn, deg + , fullTurn, fullCircle, angleRatio + , sinA, cosA, tanA, asinA, acosA, atanA + , (@@) + , angleBetween + , HasTheta(..) + ) where + +import Control.Lens (Iso', Lens', iso, review, (^.)) + -- , review , (^.), _1, _2, Lens', lens) + +import Data.VectorSpace + +-- | Angles can be expressed in a variety of units. Internally, +-- they are represented in radians. +newtype Angle = Radians Double + deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) + +instance VectorSpace Angle where + type Scalar Angle = Double + s *^ Radians t = Radians (s*t) + +-- | The radian measure of an @Angle@ @a@ can be accessed as @a +-- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. +rad :: Iso' Angle Double +rad = iso (\(Radians r) -> r) Radians + +-- | The measure of an @Angle@ @a@ in full circles can be accessed as +-- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as +-- @1/2 \@\@ turn@. +turn :: Iso' Angle Double +turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) + +-- | The degree measure of an @Angle@ @a@ can be accessed as @a +-- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ +-- deg@. +deg :: Iso' Angle Double +deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) + +-- | An angle representing one full turn. +fullTurn :: Angle +fullTurn = 1 @@ turn + +-- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. +fullCircle :: Angle +fullCircle = fullTurn + +-- | Calculate ratio between two angles. +angleRatio :: Angle -> Angle -> Double +angleRatio a b = (a^.rad) / (b^.rad) + +-- | The sine of the given @Angle@. +sinA :: Angle -> Double +sinA (Radians r) = sin r + +-- | The cosine of the given @Angle@. +cosA :: Angle -> Double +cosA (Radians r) = cos r + +-- | The tangent function of the given @Angle@. +tanA :: Angle -> Double +tanA (Radians r) = tan r + +-- | The @Angle@ with the given sine. +asinA :: Double -> Angle +asinA = Radians . asin + +-- | The @Angle@ with the given cosine. +acosA :: Double -> Angle +acosA = Radians . acos + +-- | The @Angle@ with the given tangent. +atanA :: Double -> Angle +atanA = Radians . atan + +-- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. +-- +-- More generally, @\@\@@ reverses the @Iso\'@ on its right, and +-- applies the @Iso\'@ to the value on the left. @Angle@s are the +-- motivating example where this order improves readability. +(@@) :: b -> Iso' a b -> a +-- The signature above is slightly specialized, in favor of readability +a @@ i = review i a + +infixl 5 @@ + +-- | compute the positive angle between the two vectors in their common plane +angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle +angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad + +------------------------------------------------------------ +-- Polar Coordinates + +-- | The class of types with at least one angle coordinate, called _theta. +class HasTheta t where + _theta :: Lens' t Angle diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -29,22 +29,13 @@ Color(..), SomeColor(..), someToAlpha - -- ** Line color - , LineColor, getLineColor, mkLineColor, styleLineColor, lineColor, lineColorA, lc, lcA - - -- ** Fill color - , FillColor, getFillColor, mkFillColor, styleFillColor, recommendFillColor, fillColor, fc, fcA - -- ** Opacity , Opacity, getOpacity, opacity -- ** Converting colors , colorToSRGBA, colorToRGBA - -- * Lines - -- ** Width - , LineWidth, getLineWidth, lineWidth, lineWidthA, lw - + -- * Line stuff -- ** Cap style , LineCap(..), LineCapA, getLineCap, lineCap @@ -54,31 +45,17 @@ -- ** Miter limit , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA - -- ** Dashing - , Dashing(..), DashingA, getDashing, dashing - - -- * Compilation utilities - , splitFills - ) where -import Control.Lens (Setter, sets) import Data.Colour import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) import Data.Default.Class -import Data.Maybe (fromMaybe) -import Data.Monoid.Recommend + import Data.Semigroup import Data.Typeable -import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Style (setAttr) -import Diagrams.Core.Types (RTree) -import Diagrams.Located (unLoc) -import Diagrams.Path (Path, pathTrails) -import Diagrams.Trail (isLoop) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -112,110 +89,6 @@ someToAlpha :: SomeColor -> AlphaColour Double someToAlpha (SomeColor c) = toAlphaColour c --- | The color with which lines (strokes) are drawn. Note that child --- colors always override parent colors; that is, @'lineColor' c1 --- . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. --- More precisely, the semigroup structure on line color attributes --- is that of 'Last'. -newtype LineColor = LineColor (Last SomeColor) - deriving (Typeable, Semigroup) -instance AttributeClass LineColor - -instance Default LineColor where - def = LineColor (Last (SomeColor (black :: Colour Double))) - -getLineColor :: LineColor -> SomeColor -getLineColor (LineColor (Last c)) = c - -mkLineColor :: Color c => c -> LineColor -mkLineColor = LineColor . Last . SomeColor - -styleLineColor :: (Color c, Color c') => Setter (Style v) (Style v) c c' -styleLineColor = sets modifyLineColor - where - modifyLineColor f s - = flip setAttr s - . mkLineColor - . f - . fromAlphaColour . someToAlpha - . getLineColor - . fromMaybe def . getAttr - $ s - --- | Set the line (stroke) color. This function is polymorphic in the --- color type (so it can be used with either 'Colour' or --- 'AlphaColour'), but this can sometimes create problems for type --- inference, so the 'lc' and 'lcA' variants are provided with more --- concrete types. -lineColor :: (Color c, HasStyle a) => c -> a -> a -lineColor = applyAttr . mkLineColor - --- | Apply a 'lineColor' attribute. -lineColorA :: HasStyle a => LineColor -> a -> a -lineColorA = applyAttr - --- | A synonym for 'lineColor', specialized to @'Colour' Double@ --- (i.e. opaque colors). -lc :: HasStyle a => Colour Double -> a -> a -lc = lineColor - --- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ --- (i.e. colors with transparency). -lcA :: HasStyle a => AlphaColour Double -> a -> a -lcA = lineColor - --- | The color with which shapes are filled. Note that child --- colors always override parent colors; that is, @'fillColor' c1 --- . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. --- More precisely, the semigroup structure on fill color attributes --- is that of 'Last'. -newtype FillColor = FillColor (Recommend (Last SomeColor)) - deriving (Typeable, Semigroup) -instance AttributeClass FillColor - -instance Default FillColor where - def = FillColor (Recommend (Last (SomeColor (transparent :: AlphaColour Double)))) - -mkFillColor :: Color c => c -> FillColor -mkFillColor = FillColor . Commit . Last . SomeColor - -styleFillColor :: (Color c, Color c') => Setter (Style v) (Style v) c c' -styleFillColor = sets modifyFillColor - where - modifyFillColor f s - = flip setAttr s - . mkFillColor - . f - . fromAlphaColour . someToAlpha - . getFillColor - . fromMaybe def . getAttr - $ s - --- | Set the fill color. This function is polymorphic in the color --- type (so it can be used with either 'Colour' or 'AlphaColour'), --- but this can sometimes create problems for type inference, so the --- 'fc' and 'fcA' variants are provided with more concrete types. -fillColor :: (Color c, HasStyle a) => c -> a -> a -fillColor = applyAttr . mkFillColor - --- | Set a \"recommended\" fill color, to be used only if no explicit --- calls to 'fillColor' (or 'fc', or 'fcA') are used. -recommendFillColor :: (Color c, HasStyle a) => c -> a -> a -recommendFillColor = applyAttr . FillColor . Recommend . Last . SomeColor - -getFillColor :: FillColor -> SomeColor -getFillColor (FillColor c) = getLast . getRecommend $ c - --- | A synonym for 'fillColor', specialized to @'Colour' Double@ --- (i.e. opaque colors). -fc :: HasStyle a => Colour Double -> a -> a -fc = fillColor - --- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ --- (i.e. colors with transparency). -fcA :: HasStyle a => AlphaColour Double -> a -> a -fcA = fillColor - instance (Floating a, Real a) => Color (Colour a) where toAlphaColour = opaque . colourConvert fromAlphaColour = colourConvert . (`over` black) @@ -228,14 +101,6 @@ toAlphaColour (SomeColor c) = toAlphaColour c fromAlphaColour c = SomeColor c -instance Color LineColor where - toAlphaColour (LineColor c) = toAlphaColour . getLast $ c - fromAlphaColour = LineColor . Last . fromAlphaColour - -instance Color FillColor where - toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c - fromAlphaColour = FillColor . Commit . Last . fromAlphaColour - -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) colorToSRGBA col = (r, g, b, a) @@ -277,43 +142,9 @@ opacity = applyAttr . Opacity . Product ------------------------------------------------------------ --- Lines and stuff ------------------------------------- +-- Line stuff ------------------------------------- ------------------------------------------------------------ --- | The width of lines. By default, the line width is measured with --- respect to the /final/ coordinate system of a rendered diagram, --- as opposed to the local coordinate systems in effect at the time --- the line width was set for various subdiagrams. This is so that --- it is easy to combine a variety of shapes (some created by --- scaling) and have them all drawn using a consistent line width. --- However, sometimes it is desirable for scaling to affect line --- width; the 'freeze' operation is provided for this purpose. The --- line width of frozen diagrams is affected by transformations. --- --- Line widths specified on child nodes always override line widths --- specified at parent nodes. -newtype LineWidth = LineWidth (Last Double) - deriving (Typeable, Semigroup) -instance AttributeClass LineWidth - -instance Default LineWidth where - def = LineWidth (Last 0.01) - -getLineWidth :: LineWidth -> Double -getLineWidth (LineWidth (Last w)) = w - --- | Set the line (stroke) width. -lineWidth :: HasStyle a => Double -> a -> a -lineWidth = applyAttr . LineWidth . Last - --- | Apply a 'LineWidth' attribute. -lineWidthA :: HasStyle a => LineWidth -> a -> a -lineWidthA = applyAttr - --- | A convenient synonym for 'lineWidth'. -lw :: HasStyle a => Double -> a -> a -lw = lineWidth - -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. | LineCapRound -- ^ Lines are capped with semicircles @@ -379,43 +210,3 @@ -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr - --- | Create lines that are dashing... er, dashed. -data Dashing = Dashing [Double] Double - deriving (Typeable, Eq) - -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass DashingA - -getDashing :: DashingA -> Dashing -getDashing (DashingA (Last d)) = d - --- | Set the line dashing style. -dashing :: HasStyle a => - [Double] -- ^ A list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Double -- ^ An offset into the dash pattern at which the - -- stroke should start. - -> a -> a -dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) - ------------------------------------------------------------- - -data FillLoops v = FillLoops - -instance Typeable v => SplitAttribute (FillLoops v) where - type AttrType (FillLoops v) = FillColor - type PrimType (FillLoops v) = Path v - - primOK _ = all (isLoop . unLoc) . pathTrails - --- | Push fill attributes down until they are at the root of subtrees --- containing only loops. This makes life much easier for backends, --- which typically have a semantics where fill attributes are --- applied to lines/non-closed paths as well as loops/closed paths, --- whereas in the semantics of diagrams, fill attributes only apply --- to loops. -splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a -splitFills = splitAttr (FillLoops :: FillLoops v) diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs --- a/src/Diagrams/Attributes/Compile.hs +++ b/src/Diagrams/Attributes/Compile.hs @@ -83,7 +83,7 @@ -- * is some sort of prim not under consideration: don't apply the attribute; return True -- * is unsafe: don't apply the attribute; return False -- * is safe : do apply the attribute; return True - splitAttr' mattr (Node rp@(RPrim _ (Prim prm)) _) = + splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) = case cast prm :: Maybe (PrimType code) of Nothing -> (Node rp [], True) Just p -> 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 @@ -423,13 +423,15 @@ -- that users will call from their program @main@. For instance an expected -- user program would take the following form. -- - -- > import Diagrams.Prelude - -- > import Diagrams.Backend.TheBestBackend.CmdLine - -- > - -- > d :: Diagram B R2 - -- > d = ... - -- > - -- > main = mainWith d + -- @ + -- import Diagrams.Prelude + -- import Diagrams.Backend.TheBestBackend.CmdLine + -- + -- d :: Diagram B R2 + -- d = ... + -- + -- main = mainWith d + -- @ -- -- Most backends should be able to use the default implementation. A different -- implementation should be used to handle more complex interactions with the user. @@ -449,7 +451,7 @@ -- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ... -- Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ? --- | With this instance we can perform IO to produce something +-- | With this instance we can perform IO to produce something -- 'Mainable' before rendering. instance Mainable d => Mainable (IO d) where type MainOpts (IO d) = MainOpts d @@ -464,9 +466,11 @@ -- -- Typically a backend can write its @[(String,Diagram B V)]@ instance as -- --- > instance Mainable [(String,Diagram B V)] where --- > type MainOpts [(String,Diagram B V)] = (DiagramOpts, DiagramMultiOpts) --- > mainRender = defaultMultiMainRender +-- @ +-- instance Mainable [(String,Diagram B V)] where +-- type MainOpts [(String,Diagram B V)] = (DiagramOpts, DiagramMultiOpts) +-- mainRender = defaultMultiMainRender +-- @ -- -- We do not provide this instance in general so that backends can choose to -- opt-in to this form or provide a different instance that makes more sense. @@ -508,9 +512,11 @@ -- implementation works by modifying the output field and running the base @mainRender@. -- Typically a backend can write its @Animation B V@ instance as -- --- > instance Mainable (Animation B V) where --- > type MainOpts (Animation B V) = (DiagramOpts, DiagramAnimOpts) --- > mainRender = defaultAnimMainRender output +-- @ +-- instance Mainable (Animation B V) where +-- type MainOpts (Animation B V) = (DiagramOpts, DiagramAnimOpts) +-- mainRender = defaultAnimMainRender output +-- @ -- -- We do not provide this instance in general so that backends can choose to -- opt-in to this form or provide a different instance that makes more sense. diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs deleted file mode 100644 --- a/src/Diagrams/Backend/Show.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Diagrams.Backend.Show --- Copyright : (c) 2011 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- A simple Show-based diagrams backend, for testing purposes. --- ------------------------------------------------------------------------------ -module Diagrams.Backend.Show where - -import Diagrams.Core.Transform (onBasis) -import Diagrams.Prelude - -import Data.Basis - -import Text.PrettyPrint (Doc, empty, hsep, parens, ($+$)) -import qualified Text.PrettyPrint as PP - -import Data.List (transpose) - --- | Token for identifying this backend. -data ShowBackend = ShowBackend - -instance HasLinearMap v => Backend ShowBackend v where - data Render ShowBackend v = SR Doc - type Result ShowBackend v = String - data Options ShowBackend v = SBOpt - - withStyle _ _ _ r = r -- XXX FIXME - - doRender _ _ (SR r) = PP.render r - -instance Monoid (Render ShowBackend v) where - mempty = SR empty - (SR d1) `mappend` (SR d2) = SR (d1 $+$ d2) - -renderTransf :: forall v. (Num (Scalar v), HasLinearMap v, Show (Scalar v)) - => Transformation v -> Doc -renderTransf t = renderMat mat - where vmat :: [v] - (vmat, _) = onBasis t - mat :: [[Scalar v]] - mat = map decompV vmat --- mat' :: [[Scalar v]] --- mat' = map (++[0]) mat ++ [decompV tr ++ [1]] - decompV = map snd . decompose - -renderMat :: Show a => [[a]] -> Doc -renderMat = PP.vcat . map renderRow . transpose - where renderRow = parens . hsep . map (PP.text . show) - -instance (Show v, HasLinearMap v) => Renderable (Segment o v) ShowBackend where - render _ s = SR $ PP.text (show s) - -instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Trail v) ShowBackend where - render _ t = SR $ PP.text (show t) - -instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Path v) ShowBackend where - render _ p = SR $ PP.text (show p) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} @@ -39,21 +40,27 @@ import Data.Typeable -import Control.Lens (Lens', generateSignatures, lensField, - lensRules, makeLensesWith, (%~), (&), (.~), - (^.), _Wrapping) +import Control.Lens (Lens', generateSignatures, lensField, + lensRules, makeLensesWith, (%~), (&), + (.~), (^.), _Wrapping) import Data.AdditiveGroup -import Data.AffineSpace ((.+^)) +import Data.AffineSpace ((.+^)) import Data.Default.Class +import Data.Monoid.Deletable (toDeletable) +import Data.Monoid.MList (inj) +#if __GLASGOW_HASKELL__ < 707 import Data.Proxy +#endif import Data.Semigroup +import qualified Data.Tree.DUAL as D import Data.VectorSpace import Diagrams.Core +import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Located import Diagrams.Path -import Diagrams.Segment (straight) -import Diagrams.Trail (Trail, trailVertices) +import Diagrams.Segment (straight) +import Diagrams.Trail (Trail, trailVertices) import Diagrams.Util ------------------------------------------------------------ @@ -68,7 +75,7 @@ -- > sqNewEnv = -- > circle 1 # fc green -- > ||| --- > ( c # dashing [0.1,0.1] 0 # lc white +-- > ( c # dashingG [0.1,0.1] 0 # lc white -- > <> square 2 # withEnvelope (c :: D R2) # fc blue -- > ) -- > c = circle 0.8 @@ -86,7 +93,7 @@ -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. phantom :: (Backend b (V a), Typeable (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m -phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty +phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of -- @s@ (factors between 0 and 1 can be used to shrink the envelope). @@ -127,7 +134,7 @@ , Monoid' m ) => v -> QDiagram b v m -strut v = mkQD nullPrim env mempty mempty mempty +strut v = QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -16,7 +16,7 @@ ( (:&)(..), Coordinates(..) -- * Lenses for particular axes - , HasX(..), HasY(..), HasZ(..) + , HasX(..), HasY(..), HasZ(..), HasR(..) ) where @@ -121,3 +121,8 @@ -- | The class of types with at least three coordinates, the third called _z. class HasZ t where _z :: Lens' t Double + +-- | The class of types with a single length coordinate _r. _r is +-- magnitude of a vector, or the distance from the origin of a point. +class HasR t where + _r :: Lens' t Double diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -41,9 +41,9 @@ -- <> -- -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] --- > dot = circle 0.2 # fc blue # lw 0 +-- > dot = circle 0.2 # fc blue # lw none -- > mkPath closed = position (zip pts (repeat dot)) --- > <> cubicSpline closed pts # lw 0.05 +-- > <> cubicSpline closed pts -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) -- > # centerXY # pad 1.1 -- diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs --- a/src/Diagrams/Deform.hs +++ b/src/Diagrams/Deform.hs @@ -1,25 +1,26 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where -import Control.Lens (under, _Unwrapped) -import Data.AffineSpace -import Data.Basis -import Data.MemoTrie -import Data.Monoid hiding ((<>)) -import Data.Semigroup -import Data.VectorSpace +import Control.Lens (under, _Unwrapped) +import Data.AffineSpace +import Data.Basis +import Data.MemoTrie +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.VectorSpace -import Diagrams.Core -import Diagrams.Located -import Diagrams.Parametric -import Diagrams.Path -import Diagrams.Segment -import Diagrams.Trail +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail ------------------------------------------------------------ -- Deformations diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -44,7 +44,7 @@ , pathVertices , pathOffsets , pathCentroid - , fixPath + , pathLocSegments, fixPath -- * Modifying paths @@ -130,8 +130,6 @@ of the v's are inside Points and hence ought to be translated. -} -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => IsPrim (Path v) - instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 @@ -188,6 +186,11 @@ -- its vertices). pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v pathCentroid = centroid . concat . pathVertices + +-- | Convert a path into a list of lists of located segments. +pathLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Path v -> [[Located (Segment Closed v)]] +pathLocSegments = map trailLocSegments . op Path -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -84,8 +84,10 @@ -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional @@ -123,6 +125,7 @@ import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs --- a/src/Diagrams/Prelude/ThreeD.hs +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -80,8 +80,11 @@ -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle + -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | things (shapes, transformations, combinators) specific -- to creating three-dimensional diagrams. @@ -118,6 +121,7 @@ import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -493,7 +493,7 @@ (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = let !negOff = negateV . op TotalOffset $ o1 e2Off = moveOriginBy negOff e2 - !() = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) diff --git a/src/Diagrams/Solve.hs b/src/Diagrams/Solve.hs --- a/src/Diagrams/Solve.hs +++ b/src/Diagrams/Solve.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Solve @@ -6,12 +5,15 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Exact solving of low-degree (n <= 3) polynomials. +-- Exact solving of low-degree (n <= 4) polynomials. -- ----------------------------------------------------------------------------- module Diagrams.Solve ( quadForm , cubForm + , quartForm + , cubForm' + , quartForm' ) where import Data.List (maximumBy) @@ -19,6 +21,20 @@ import Diagrams.Util (tau) +import Prelude hiding ((^)) +import qualified Prelude as P ((^)) + +-- | A specialization of (^) to Integer +-- c.f. http://comments.gmane.org/gmane.comp.lang.haskell.libraries/21164 +-- for discussion. "The choice in (^) and (^^) to overload on the +-- power's Integral type... was a genuinely bad idea." - Edward Kmett +(^) :: (Num a) => a -> Integer -> a +(^) = (P.^) + +-- | Utility function used to avoid singularities +aboutZero' :: (Ord a, Num a) => a -> a -> Bool +aboutZero' toler x = abs x < toler + ------------------------------------------------------------ -- Quadratic formula ------------------------------------------------------------ @@ -48,14 +64,12 @@ -- see http://www.mpi-hd.mpg.de/astrophysik/HEA/internal/Numerical_Recipes/f5-6.pdf | otherwise = [q/a, c/q] - where d = b*b - 4*a*c + where d = b^2 - 4*a*c q = -1/2*(b + signum b * sqrt d) -quadForm_prop :: Double -> Double -> Double -> Bool -quadForm_prop a b c = all (aboutZero . eval) (quadForm a b c) - where eval x = a*x*x + b*x + c - aboutZero x = abs x < tolerance - tolerance = 1e-10 +_quadForm_prop :: Double -> Double -> Double -> Bool +_quadForm_prop a b c = all (aboutZero' 1e-10 . eval) (quadForm a b c) + where eval x = a*x^2 + b*x + c ------------------------------------------------------------ -- Cubic formula @@ -64,10 +78,10 @@ -- See http://en.wikipedia.org/wiki/Cubic_formula#General_formula_of_roots -- | Solve the cubic equation ax^3 + bx^2 + cx + d = 0, returning a --- list of all real roots. -cubForm :: (Floating d, Ord d) => d -> d -> d -> d -> [d] -cubForm a b c d - | aboutZero a = quadForm b c d +-- list of all real roots. First argument is tolerance. +cubForm' :: (Floating d, Ord d) => d -> d -> d -> d -> d -> [d] +cubForm' toler a b c d + | aboutZero' toler a = quadForm b c d -- three real roots, use trig method to avoid complex numbers | delta > 0 = map trig [0,1,2] @@ -77,35 +91,35 @@ -- two real roots, one of multiplicity 2 | delta == 0 && disc /= 0 = [ (b*c - 9*a*d)/(2*disc) - , (9*a*a*d - 4*a*b*c + b*b*b)/(a * disc) + , (9*a^2*d - 4*a*b*c + b^3)/(a * disc) ] -- one real root (and two complex) | otherwise = [-b/(3*a) - cc/(3*a) + disc/(3*a*cc)] - where delta = 18*a*b*c*d - 4*b*b*b*d + b*b*c*c - 4*a*c*c*c - 27*a*a*d*d - disc = 3*a*c - b*b - qq = sqrt(-27*a*a*delta) - qq' | aboutZero disc = maximumBy (comparing (abs . (+xx))) [qq, -qq] + where delta = 18*a*b*c*d - 4*b^3*d + b^2*c^2 - 4*a*c^3 - 27*a^2*d^2 + disc = 3*a*c - b^2 + qq = sqrt(-27*(a^2)*delta) + qq' | aboutZero' toler disc = maximumBy (comparing (abs . (+xx))) [qq, -qq] | otherwise = qq cc = cubert (1/2*(qq' + xx)) - xx = 2*b*b*b - 9*a*b*c + 27*a*a*d - p = disc/(3*a*a) - q = xx/(27*a*a*a) - trig k = 2 * sqrt(-p/3) * cos(1/3*acos(3*q/(2*p)*sqrt(-3/p)) - k*tau/3) - - b/(3*a) - + xx = 2*b^3 - 9*a*b*c + 27*a^2*d + p = disc/(3*a^2) + q = xx/(27*a^3) + phi = 1/3*acos(3*q/(2*p)*sqrt(-3/p)) + trig k = 2 * sqrt(-p/3) * cos(phi - k*tau/3) - b/(3*a) cubert x | x < 0 = -((-x)**(1/3)) | otherwise = x**(1/3) - aboutZero x = abs x < toler - toler = 1e-10 +-- | Solve the cubic equation ax^3 + bx^2 + cx + d = 0, returning a +-- list of all real roots within 1e-10 tolerance +-- (although currently it's closer to 1e-5) +cubForm :: (Floating d, Ord d) => d -> d -> d -> d -> [d] +cubForm = cubForm' 1e-10 -cubForm_prop :: Double -> Double -> Double -> Double -> Bool -cubForm_prop a b c d = all (aboutZero . eval) (cubForm a b c d) - where eval x = a*x*x*x + b*x*x + c*x + d - aboutZero x = abs x < tolerance - tolerance = 1e-5 +_cubForm_prop :: Double -> Double -> Double -> Double -> Bool +_cubForm_prop a b c d = all (aboutZero' 1e-5 . eval) (cubForm a b c d) + where eval x = a*x^3 + b*x^2 + c*x + d -- Basically, however large you set the tolerance it seems -- that quickcheck can always come up with examples where -- the returned solutions evaluate to something near zero @@ -116,3 +130,58 @@ -- issue in practice we could, say, use the solutions -- generated here as very good guesses to a numerical -- solver which can give us a more precise answer? + +------------------------------------------------------------ +-- Quartic formula +------------------------------------------------------------ + +-- Based on http://tog.acm.org/resources/GraphicsGems/gems/Roots3b/and4.c +-- as of 5/12/14, with help from http://en.wikipedia.org/wiki/Quartic_function + +-- | Solve the quartic equation c4 x^4 + c3 x^3 + c2 x^2 + c1 x + c0 = 0, returning a +-- list of all real roots. First argument is tolerance. +quartForm' :: (Floating d, Ord d) => d -> d -> d -> d -> d -> d -> [d] +quartForm' toler c4 c3 c2 c1 c0 + -- obvious cubic + | aboutZero' toler c4 = cubForm c3 c2 c1 c0 + -- x(ax^3+bx^2+cx+d) + | aboutZero' toler c0 = 0 : cubForm c4 c3 c2 c1 + -- substitute solutions of y back to x + | otherwise = map (\x->x-(a/4)) roots + where + -- eliminate c4: x^4+ax^3+bx^2+cx+d + [a,b,c,d] = map (/c4) [c3,c2,c1,c0] + -- eliminate cubic term via x = y - a/4 + -- reduced quartic: y^4 + py^2 + qy + r = 0 + p = b - 3/8*a^2 + q = 1/8*a^3-a*b/2+c + r = (-3/256)*a^4+a^2*b/16-a*c/4+d + + -- | roots of the reduced quartic + roots | aboutZero' toler r = + 0 : cubForm 1 0 p q -- no constant term: y(y^3 + py + q) = 0 + | u < 0 || v < 0 = [] -- no real solutions due to square root + | otherwise = s1++s2 -- solutions of the quadratics + + -- solve the resolvent cubic - only one solution is needed + z:_ = cubForm 1 (-p/2) (-r) (p*r/2 - q^2/8) + + -- solve the two quadratic equations + -- y^2 ± v*y-(±u-z) + u = z^2 - r + v = 2*z - p + u' = if aboutZero' toler u then 0 else sqrt u + v' = if aboutZero' toler v then 0 else sqrt v + s1 = quadForm 1 (if q<0 then -v' else v') (z-u') + s2 = quadForm 1 (if q<0 then v' else -v') (z+u') + +-- | Solve the quartic equation c4 x^4 + c3 x^3 + c2 x^2 + c1 x + c0 = 0, returning a +-- list of all real roots within 1e-10 tolerance +-- (although currently it's closer to 1e-5) +quartForm :: (Floating d, Ord d) => d -> d -> d -> d -> d -> [d] +quartForm = quartForm' 1e-10 + +_quartForm_prop :: Double -> Double -> Double -> Double -> Double -> Bool +_quartForm_prop a b c d e = all (aboutZero' 1e-5 . eval) (quartForm a b c d e) + where eval x = a*x^4 + b*x^3 + c*x^2 + d*x + e + -- Same note about tolerance as for cubic diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -31,7 +31,9 @@ -- for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD - ( module Diagrams.ThreeD.Align + ( + module Diagrams.ThreeD.Align + , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Light , module Diagrams.ThreeD.Shapes @@ -41,6 +43,7 @@ ) where import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Attributes +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines some common attributes relevant in +-- 3D; particular backends may also define more backend-specific +-- attributes. +-- +-- Every attribute type must have a /semigroup/ structure, that is, an +-- associative binary operation for combining two attributes into one. +-- Unless otherwise noted, all the attributes defined here use the +-- 'Last' structure, that is, combining two attributes simply keeps +-- the second one and throws away the first. This means that child +-- attributes always override parent attributes. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Attributes where + +import Control.Lens +import Data.Semigroup +import Data.Typeable + +import Data.Colour + +import Diagrams.Core + +-- | @SurfaceColor@ is the inherent pigment of an object, assumed to +-- be opaque. +newtype SurfaceColor = SurfaceColor (Last (Colour Double)) + deriving (Typeable, Semigroup) +instance AttributeClass SurfaceColor + +surfaceColor :: Iso' SurfaceColor (Colour Double) +surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) + +-- | Set the surface color. +sc :: HasStyle d => Colour Double -> d -> d +sc = applyAttr . review surfaceColor + +-- | @Diffuse@ is the fraction of incident light reflected diffusely, +-- that is, in all directions. The actual light reflected is the +-- product of this value, the incident light, and the @SurfaceColor@ +-- Attribute. For physical reasonableness, @Diffuse@ should have a +-- value between 0 and 1; this is not checked. +newtype Diffuse = Diffuse (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Diffuse + +_Diffuse :: Iso' Diffuse Double +_Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) + +-- | Set the diffuse reflectance. +diffuse :: HasStyle d => Double -> d -> d +diffuse = applyAttr . review _Diffuse + +-- | @Ambient@ is an ad-hoc representation of indirect lighting. The +-- product of @Ambient@ and @SurfaceColor@ is added to the light +-- leaving an object due to diffuse and specular terms. @Ambient@ can +-- be set per-object, and can be loosely thought of as the product of +-- indirect lighting incident on that object and the diffuse +-- reflectance. +newtype Ambient = Ambient (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Ambient + +_Ambient :: Iso' Ambient Double +_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) + +-- | Set the emittance due to ambient light. +ambient :: HasStyle d => Double -> d -> d +ambient = applyAttr . review _Ambient + +-- | A specular highlight has two terms, the intensity, between 0 and +-- 1, and the size. The highlight size is assumed to be the exponent +-- in a Phong shading model (though Backends are free to use a +-- different shading model). In this model, reasonable values are +-- between 1 and 50 or so, with higher values for shinier objects. +-- Physically, the intensity and the value of @Diffuse@ must add up to +-- less than 1; this is not enforced. +data Specular = Specular { _specularIntensity :: Double + , _specularSize :: Double + } + +makeLenses ''Specular + +newtype Highlight = Highlight (Last Specular) + deriving (Typeable, Semigroup) +instance AttributeClass Highlight + +_Highlight :: Iso' Highlight Specular +_Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) + +-- | Set the specular highlight. +highlight :: HasStyle d => Specular -> d -> d +highlight = applyAttr . review _Highlight diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -34,6 +34,7 @@ import Data.Monoid import Data.Typeable +import Diagrams.Angle import Diagrams.Core import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector @@ -85,8 +86,6 @@ (transform t u) l -instance IsPrim (Camera l) - instance Renderable (Camera l) NullBackend where render _ _ = mempty @@ -119,13 +118,13 @@ -- aspect ratio of 4:3, for VGA and similar computer resulotions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: Direction d => Camera l -> d +camForward :: Camera l -> Direction camForward = direction . forward -camUp :: Direction d => Camera l -> d +camUp :: Camera l -> Direction camUp = direction . up -camRight :: Direction d => Camera l -> d +camRight :: Camera l -> Direction camRight c = direction right where right = cross3 (forward c) (up c) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -22,7 +22,6 @@ import Diagrams.Core import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector data PointLight = PointLight P3 (Colour Double) deriving Typeable @@ -39,9 +38,6 @@ instance Transformable ParallelLight where transform t (ParallelLight v c) = ParallelLight (transform t v) c -instance IsPrim PointLight -instance IsPrim ParallelLight - -- | Construct a Diagram with a single PointLight at the origin, which -- takes up no space. pointLight :: (Backend b R3, Renderable PointLight b) @@ -51,8 +47,8 @@ (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Direction d, Backend b R3, Renderable ParallelLight b) - => d -- ^ The direction in which the light travels. +parallelLight :: (Backend b R3, Renderable ParallelLight b) + => Direction -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b R3 parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) 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 @@ -15,18 +15,24 @@ module Diagrams.ThreeD.Shapes ( - Ellipsoid(..) - , sphere + Ellipsoid(..), sphere + , Box(..), cube + , Frustum(..) , frustum, cone, cylinder ) where +import Control.Applicative +import Control.Lens (review, (^.), _1) import Data.Typeable import Data.AffineSpace import Data.Semigroup import Data.VectorSpace +import Diagrams.Angle +import Diagrams.Coordinates import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector data Ellipsoid = Ellipsoid T3 deriving Typeable @@ -36,11 +42,10 @@ instance Transformable Ellipsoid where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) -instance IsPrim Ellipsoid - instance Renderable Ellipsoid NullBackend where render _ _ = mempty +-- | A sphere of radius 1 with its center at the origin. sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) @@ -54,3 +59,104 @@ c = p' <.> p' - 1 p' = p .-. origin sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 + +data Box = Box T3 + deriving (Typeable) + +type instance V Box = R3 + +instance Transformable Box where + transform t1 (Box t2) = Box (t1 <> t2) + +instance Renderable Box NullBackend where + render _ _ = mempty + +-- | A cube with side length 1, in the positive octant, with one +-- vertex at the origin. +cube :: (Backend b R3, Renderable Box b) => Diagram b R3 +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 <.>) corners) / magnitudeSq 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) + range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where + (x, y, z) = unp3 u + boxQuery = Any . range + +data Frustum = Frustum Double Double T3 + deriving (Typeable) + +type instance V Frustum = R3 + +instance Transformable Frustum where + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) + +instance Renderable Frustum NullBackend where + render _ _ = mempty + +-- | 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 :: (Backend b R3, Renderable Frustum b) => Double -> Double -> Diagram b R3 +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 = magnitude $ 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 (magnitude . project v . review cylindrical) $ 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 = if (ray t)^.cylindrical._1 < r0 + z*dr + then [t] + else [] + where + t = (z - pz) / vz + +-- | 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 :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cone = frustum 1 0 + +-- | A circular cylinder of radius 1 with one end cap centered on the +-- origin, and extending to Z=1. +cylinder :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cylinder = frustum 1 1 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 @@ -46,9 +46,9 @@ import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector import Diagrams.Coordinates import Control.Lens (view, (*~), (//~)) @@ -102,11 +102,10 @@ -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout - :: Direction d - => P3 -- ^ origin of rotation - -> d -- ^ direction of rotation axis - -> Angle -- ^ angle of rotation +rotationAbout :: + P3 -- ^ origin of rotation + -> Direction -- ^ direction of rotation axis + -> Angle -- ^ angle of rotation -> T3 rotationAbout p d a = mconcat [translation (negateV t), @@ -128,7 +127,7 @@ -- 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 :: Direction d => d -> d -> d -> T3 +pointAt :: Direction -> Direction -> Direction -> T3 pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors @@ -137,9 +136,9 @@ pointAt' about initial final = tilt <> pan where inPanPlane = final ^-^ project final initial panAngle = angleBetween initial inPanPlane - pan = rotationAbout origin (direction about :: Spherical) panAngle + pan = rotationAbout origin (direction about) panAngle tiltAngle = angleBetween initial inPanPlane - tiltDir = direction $ cross3 inPanPlane about :: Spherical + tiltDir = direction $ cross3 inPanPlane about tilt = rotationAbout origin tiltDir tiltAngle -- Scaling ------------------------------------------------- @@ -261,4 +260,4 @@ -- useful for implementing backends. onBasis :: T3 -> ((R3, R3, R3), R3) onBasis t = ((x, y, z), v) - where ((x:y:z:[]), v) = T.onBasis t + where (x:y:z:[], v) = T.onBasis t diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Types @@ -21,28 +21,23 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3, r3, unr3, mkR3 + R3(..), r3, unr3, mkR3 , P3, p3, unp3, mkP3 , T3 , r3Iso, p3Iso - -- * Two-dimensional angles - -- | These are defined in "Diagrams.TwoD.Types" but - -- reëxported here for convenience. - , Angle, rad, turn, deg, (@@) - , fullTurn, angleRatio - -- * Directions in 3D - , Direction(..) - , Spherical(..) - , asSpherical + , Direction, direction, fromDirection, angleBetweenDirs + -- * other coördinate systems + , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', iso, over, Wrapped(..), Rewrapped - , _1, _2, _3) +import Control.Lens (Iso', Lens', iso, over + , _1, _2, _3, (^.)) import Diagrams.Core -import Diagrams.TwoD.Types +import Diagrams.Angle +import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates import Data.AffineSpace.Point @@ -54,31 +49,28 @@ -- 3D Euclidean space -- | The three-dimensional Euclidean vector space R^3. -newtype R3 = R3 { unR3 :: (Double, Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Show, Read) +data R3 = R3 !Double !Double !Double + deriving (Eq, Ord, Show, Read) r3Iso :: Iso' R3 (Double, Double, Double) -r3Iso = iso unR3 R3 +r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 -r3 = R3 +r3 (x,y,z) = R3 x y z -- | Curried version of `r3`. mkR3 :: Double -> Double -> Double -> R3 -mkR3 x y z = r3 (x, y, z) +mkR3 = R3 -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) -unr3 = unR3 - --- | Lens wrapped isomorphisms for R3. -instance Wrapped R3 where - type Unwrapped R3 = (Double, Double, Double) - _Wrapped' = iso unr3 r3 - {-# INLINE _Wrapped' #-} +unr3 (R3 x y z) = (x,y,z) -instance Rewrapped R3 R3 +instance AdditiveGroup R3 where + zeroV = R3 0 0 0 + R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) + negateV (R3 x y z) = R3 (-x) (-y) (-z) type instance V R3 = R3 @@ -88,31 +80,31 @@ instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = R3 . basisValue - decompose = decompose . unR3 - decompose' = decompose' . unR3 + basisValue = r3 . basisValue + decompose = decompose . unr3 + decompose' = decompose' . unr3 instance InnerSpace R3 where - (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 + (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 instance Coordinates R3 where type FinalCoord R3 = Double type PrevDim R3 = R2 type Decomposition R3 = Double :& Double :& Double - (coords -> x :& y) ^& z = r3 (x,y,z) - coords (unR3 -> (x,y,z)) = x :& y :& z + (coords -> x :& y) ^& z = R3 x y z + coords (R3 x y z) = x :& y :& z -- | Points in R^3. type P3 = Point R3 -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 -p3 = P . R3 +p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) -unp3 = unR3 . unPoint +unp3 = unr3 . unPoint p3Iso :: Iso' P3 (Double, Double, Double) p3Iso = iso unp3 p3 @@ -133,33 +125,14 @@ -------------------------------------------------------------------------------- -- Direction --- | Direction is a type class representing directions in R3. The interface is --- based on that of the Angle class in 2D. - -class Direction d where - -- | Convert to spherical coördinates - toSpherical :: d -> Spherical - - -- | Convert from spherical coördinates - fromSpherical :: Spherical -> d - --- | A direction expressed as a pair of spherical coordinates. --- `Spherical 0 0` is the direction of `unitX`. The first coordinate --- represents rotation about the Z axis, the second rotation towards the Z axis. -data Spherical = Spherical Angle Angle - deriving (Show, Read, Eq) - -instance Direction Spherical where - toSpherical = id - fromSpherical = id +-- | A @Direction@ represents directions in R3. The constructor is +-- not exported; @Direction@s can be used with 'fromDirection' and the +-- lenses provided by its instances. +data Direction = Direction R3 --- | The identity function with a restricted type, for conveniently --- restricting unwanted polymorphism. For example, @fromDirection --- . asSpherical . camForward@ gives a unit vector pointing in the --- direction of the camera view. Without @asSpherical@, the --- intermediate type would be ambiguous. -asSpherical :: Spherical -> Spherical -asSpherical = id +-- | Not exported +_Dir :: Iso' Direction R3 +_Dir = iso (\(Direction v) -> v) Direction instance HasX R3 where _x = r3Iso . _1 @@ -178,3 +151,73 @@ instance HasZ P3 where _z = p3Iso . _3 + +-- | Types which can be expressed in spherical 3D coordinates, as a +-- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the +-- angle from the Z axis. +class Spherical t where + spherical :: Iso' t (Double, Angle, Angle) + +-- | Types which can be expressed in cylindrical 3D coordinates. +class Cylindrical t where + cylindrical :: Iso' t (Double, Angle, Double) -- r, θ, z + +instance Cylindrical R3 where + cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) + (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) + +instance Spherical R3 where + spherical = iso + (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) + (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) + +-- We'd like to write: instance Spherical t => HasR t +-- But GHC can't work out that the instance won't overlap. Just write them explicitly: + +instance HasR R3 where + _r = spherical . _1 + +instance HasR P3 where + _r = spherical . _1 + +instance HasTheta R3 where + _theta = cylindrical . _2 + +instance HasTheta P3 where + _theta = cylindrical . _2 + +-- | The class of types with at least two angle coordinates, the +-- second called _phi. +class HasPhi t where + _phi :: Lens' t Angle + +instance HasPhi R3 where + _phi = spherical . _3 + +instance HasPhi P3 where + _phi = spherical . _3 + +instance Cylindrical P3 where + cylindrical = _relative origin . cylindrical + +instance Spherical P3 where + spherical = _relative origin . spherical + +instance HasTheta Direction where + _theta = _Dir . _theta + +instance HasPhi Direction where + _phi = _Dir . _phi + +-- | @direction v@ is the direction in which @v@ points. Returns an +-- unspecified value when given the zero vector as input. +direction :: R3 -> Direction +direction = Direction + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: Direction -> R3 +fromDirection (Direction v) = normalized v + +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: Direction -> Direction -> Angle +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -15,17 +15,10 @@ module Diagrams.ThreeD.Vector ( -- * Special 2D vectors unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, - - -- * Converting between vectors and angles - direction, fromDirection, angleBetween, angleBetweenDirs ) where -import Control.Lens ((^.)) -import Data.VectorSpace -import Data.Cross - -import Diagrams.ThreeD.Types import Diagrams.Coordinates +import Diagrams.ThreeD.Types -- | The unit vector in the positive X direction. @@ -51,33 +44,3 @@ -- | The unit vector in the negative Z direction. unit_Z :: R3 unit_Z = 0 ^& 0 ^& (-1) - - --- | @direction v@ is the direction in which @v@ points. Returns an --- unspecified value when given the zero vector as input. -direction :: Direction d => R3 -> d -direction v - | r == 0 = fromSpherical $ Spherical zero zero - | otherwise = fromSpherical $ Spherical θ φ where - r = magnitude v - (x,y,z) = unr3 v - φ = asin (z / r) @@ rad - θ = atan2 y x @@ rad - zero = 0 @@ rad - --- | @fromDirection d@ is the unit vector in the direction @d@. -fromDirection :: Direction d => d -> R3 -fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where - θ = θ'^.rad - φ = φ'^.rad - x = cos θ * cos φ - y = sin θ * cos φ - z = sin φ - --- | compute the positive angle between the two vectors in their common plane -angleBetween :: R3 -> R3 -> Angle -angleBetween v1 v2 = atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) @@ rad - --- | compute the positive angle between the two vectors in their common plane -angleBetweenDirs :: Direction d => d -> d -> Angle -angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -77,7 +77,7 @@ , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailVertices, lineVertices, loopVertices - , fixTrail + , trailLocSegments, fixTrail -- * Modifying trails @@ -163,10 +163,8 @@ => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) where - transform t = SegTree . transform t . op SegTree +deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (SegTree v) type instance Codomain (SegTree v) = v @@ -938,7 +936,7 @@ -- -- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 -- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] --- > # stroke # lc red # lw 0.05 +-- > # stroke # lc red trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v trailOffset = withLine lineOffset @@ -993,8 +991,12 @@ -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] -fixTrail t = zipWith ((mkFixedSeg .) . at) - (trailSegments (unLoc t)) (trailVertices t) +fixTrail t = map mkFixedSeg (trailLocSegments t) + +-- | Convert a concretely located trail into a list of located segments. +trailLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [Located (Segment Closed v)] +trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) ------------------------------------------------------------ -- Modifying trails -------------------------------------- diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -11,6 +11,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE TypeFamilies #-} + module Diagrams.Transform ( -- * Transformations Transformation, inv, transl, apply, papply @@ -52,5 +54,5 @@ -- @ -- -- for all transformations @t1@ and @t2@. -under :: Transformable a => (a -> a) -> Transformation (V a) -> a -> a +under :: (Transformable a, Transformable b, V a ~ V b) => (a -> b) -> Transformation (V a) -> a -> b f `under` t = transform (inv t) . f . transform t diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -65,14 +65,10 @@ , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y - , direction, angleBetween, fromDirection + , direction, fromDirection -- * Angles , tau - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , (@@) -- * Paths -- ** Stroking @@ -148,24 +144,33 @@ , arrowHead , arrowTail , arrowShaft - , headSize - , tailSize , headGap , tailGap - , gap - , headColor + , gaps, gap + , headTexture , headStyle - , tailColor + , tailTexture , tailStyle - , shaftColor + , shaftTexture , shaftStyle + , headLength + , tailLength + , lengths -- * Text , text, topLeftText, alignedText, baselineText - , font, fontSize, italic, oblique, bold + , font, italic, oblique, bold, fontSize + , fontSizeO, fontSizeL, fontSizeN, fontSizeG -- * Images - , Image, image + , DImage(..), ImageData(..) + , Embedded, External + , image + , loadImageEmb + , loadImageExt + , uncheckedImageRef + , raster + , rasterDia -- * Transformations -- ** Rotation @@ -233,6 +238,33 @@ -- ** Adjusting size , sized, sizedAs + -- * Textures + , Texture(..), solid + , SpreadMethod(..), GradientStop(..), mkStops, getFillTexture + , fillTexture, getLineTexture, lineTexture, lineTextureA + , stopFraction, stopColor + + , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd + , lGradSpreadMethod, defaultLG, _LG, mkLinearGradient + + , RGradient(..) + , rGradStops, rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 + , rGradTrans, rGradSpreadMethod, defaultRG, _RG, mkRadialGradient + + -- ** Colors + , fillColor, fc, fcA, recommendFillColor + , lineColor, lc, lcA, _SC + + -- ** Width + , LineWidth, getLineWidth, lineWidth, lineWidthA + , lw, lwN, lwO, lwL, lwG + , ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none + , tiny, verySmall, small, normal, large, veryLarge, huge + + -- ** Dashing + , Dashing(..), DashingA, getDashing + , dashing, dashingO, dashingL, dashingN, dashingG + -- * Visual aids for understanding the internal model , showOrigin , showOrigin' @@ -245,13 +277,14 @@ import Diagrams.TwoD.Arc import Diagrams.TwoD.Arrow import Diagrams.TwoD.Arrowheads +import Diagrams.TwoD.Attributes import Diagrams.TwoD.Combinators +import Diagrams.TwoD.Deform import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image import Diagrams.TwoD.Model import Diagrams.TwoD.Path import Diagrams.TwoD.Polygons -import Diagrams.TwoD.Deform import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size import Diagrams.TwoD.Text diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ViewPatterns - #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -18,27 +17,22 @@ setDefault2DAttributes , adjustDiaSize2D , adjustDia2D - , adjustSize -- for backwards compatibility - , requiredScale -- re-exported for backwards compatibility ) where -import Diagrams.Core - -import Diagrams.Attributes (lineWidthA, lineColorA, lineCap - , lineJoin, lineMiterLimitA - ) -import Diagrams.Util ((#)) - -import Diagrams.TwoD.Types (R2, p2) -import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) - , requiredScaleT, requiredScale - ) -import Diagrams.TwoD.Text (fontSizeA) - -import Data.AffineSpace ((.-.)) -import Data.Semigroup +import Diagrams.Attributes (lineCap, lineJoin, + lineMiterLimitA) +import Diagrams.Core +import Diagrams.TwoD.Attributes (lineWidthA, lineTextureA) +import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, + requiredScale, size2D) +import Diagrams.TwoD.Text (fontSizeA) +import Diagrams.TwoD.Types (R2, T2, p2) +import Diagrams.Util (( # )) -import Data.Default.Class +import Control.Lens (Lens', (&), (.~), (^.)) +import Data.AffineSpace ((.-.)) +import Data.Default.Class +import Data.Semigroup -- | Set default attributes of a 2D diagram (in case they have not -- been set): @@ -55,62 +49,58 @@ -- -- * Miter limit 10 setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m -setDefault2DAttributes d = d # lineWidthA def # lineColorA def # fontSizeA def +setDefault2DAttributes d = d # lineWidthA def # lineTextureA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def + -- | Adjust the size and position of a 2D diagram to fit within the --- requested size. The first two arguments specify a method for --- extracting the requested output size from the rendering options, --- and a way of updating the rendering options with a new (more --- specific) size. +-- requested size. The first argument is a lens into the output +-- size contained in the rendering options. Returns an updated +-- options record, any transformation applied to the diagram (the +-- inverse of which can be used, say, to translate output/device +-- coordinates back into local diagram coordinates), and the +-- modified diagram itself. adjustDiaSize2D :: Monoid' m - => (Options b R2 -> SizeSpec2D) - -> (SizeSpec2D -> Options b R2 -> Options b R2) + => Lens' (Options b R2) SizeSpec2D -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, QDiagram b R2 m) -adjustDiaSize2D getSize setSize _ opts d = + -> (Options b R2, T2, QDiagram b R2 m) +adjustDiaSize2D szL _ opts d = ( case spec of - Dims _ _ -> opts - _ -> setSize (uncurry Dims . scale s $ size) opts - - , d # scale s - # translate tr + Dims _ _ -> opts + _ -> opts & szL .~ (uncurry Dims . scale s $ size) + , adjustT + , d # transform adjustT ) - where spec = getSize opts + where spec = opts ^. szL size = size2D d s = requiredScale spec size finalSz = case spec of Dims w h -> (w,h) _ -> scale s size tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) + adjustT = translation tr <> scaling s -- | @adjustDia2D@ provides a useful default implementation of -- the 'adjustDia' method from the 'Backend' type class. -- --- As its first two arguments it requires a method for extracting --- the requested output size from the rendering options, and a way --- of updating the rendering options with a new (more specific) size. +-- As its first argument it requires a lens into the output size +-- contained in the rendering options. -- -- It then performs the following adjustments: -- -- * Set default attributes (see 'setDefault2DAttributes') -- --- * Freeze the diagram in its final form --- -- * Scale and translate the diagram to fit within the requested -- size (see 'adjustDiaSize2D') -- --- * Also return the actual adjusted size of the diagram. +-- It returns an updated options record, any transformation applied +-- to the diagram (the inverse of which can be used, say, to +-- translate output/device coordinates back into local diagram +-- coordinates), and the modified diagram itself. adjustDia2D :: Monoid' m - => (Options b R2 -> SizeSpec2D) - -> (SizeSpec2D -> Options b R2 -> Options b R2) + => Lens' (Options b R2) SizeSpec2D -> b -> Options b R2 -> QDiagram b R2 m - -> (Options b R2, QDiagram b R2 m) -adjustDia2D getSize setSize b opts d - = adjustDiaSize2D getSize setSize b opts (d # setDefault2DAttributes # freeze) + -> (Options b R2, T2, QDiagram b R2 m) +adjustDia2D szL b opts d + = adjustDiaSize2D szL b opts (d # setDefault2DAttributes) -{-# DEPRECATED adjustSize "Use Diagrams.TwoD.Size.requiredScaleT instead." #-} --- | Re-export 'requiredScaleT' with the name 'adjustSize' for --- backwards compatibility. -adjustSize :: SizeSpec2D -> (Double, Double) -> Transformation R2 -adjustSize = requiredScaleT diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -23,6 +23,7 @@ , annularWedge ) where +import Diagrams.Angle import Diagrams.Core import Diagrams.Located (at) import Diagrams.Segment @@ -130,7 +131,7 @@ -- -- <> -- --- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] +-- > arc'Ex = mconcat [ arc' r (0 @@ turn) (1/4 @@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 arc' :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) @@ -143,9 +144,9 @@ -- <> -- -- > wedgeEx = hcat' (with & sep .~ 0.5) --- > [ wedge 1 (0 \@\@ turn) (1/4) --- > , wedge 1 (7/30 \@\@ turn) (11/30) --- > , wedge 1 (1/8 \@\@ turn) (7/8) +-- > [ wedge 1 (0 @@ turn) (1/4 @@ turn) +-- > , wedge 1 (7/30 @@ turn) (11/30 @@ turn) +-- > , wedge 1 (1/8 @@ turn) (7/8 @@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 @@ -195,9 +196,9 @@ -- <> -- -- > annularWedgeEx = hcat' (with & sep .~ 0.50) --- > [ annularWedge 1 0.5 (0 \@\@ turn) (1/4) --- > , annularWedge 1 0.3 (7/30 \@\@ turn) (11/30) --- > , annularWedge 1 0.7 (1/8 \@\@ turn) (7/8) +-- > [ annularWedge 1 0.5 (0 @@ turn) (1/4 @@ turn) +-- > , annularWedge 1 0.3 (7/30 @@ turn) (11/30 @@ turn) +-- > , annularWedge 1 0.7 (1/8 @@ turn) (7/8 @@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -25,14 +27,14 @@ -- -- > -- Connecting two diagrams at their origins. -- > --- > sq = square 2 # showOrigin # lc darkgray # lw 0.07 +-- > sq = square 2 # showOrigin # lc darkgray # lw ultraThick -- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right") -- > -- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)]) -- > --- > example1 = ds # connect' (with & arrowHead .~ dart & headSize .~ 0.6 --- > & tailSize .~ 0.5 & arrowTail .~ quill --- > & shaftStyle %~ lw 0.02 & arrowShaft .~ shaft) +-- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill +-- > & arrowShaft .~ shaft +-- > & headLength .~ huge & tailLength .~ veryLarge) -- > "left" "right" # pad 1.1 -- ** Example 2 @@ -41,12 +43,13 @@ -- -- > -- Comparing connect, connectPerim, and arrowAt. -- > --- > oct = octagon 1 # lc darkgray # lw 0.10 # showOrigin +-- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin -- > dias = oct # named "first" ||| strut 3 ||| oct # named "second" -- > -- > -- Connect two diagrams and two points on their trails. --- > ex12 = dias # connect "first" "second" --- > # connectPerim "first" "second" (15/16 \@\@ turn) (9/16 \@\@ turn) +-- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second" +-- > # connectPerim' (with & lengths .~ veryLarge) +-- > "first" "second" (15/16 @@ turn) (9/16 @@ turn) -- > -- > -- Place an arrow at (0,0) the size and direction of (0,1). -- > ex3 = arrowAt origin unit_Y @@ -76,16 +79,17 @@ , arrowHead , arrowTail , arrowShaft - , headSize - , tailSize , headGap , tailGap - , gap - , headColor + , gaps, gap + , headTexture , headStyle - , tailColor + , headLength + , tailTexture , tailStyle - , shaftColor + , tailLength + , lengths + , shaftTexture , shaftStyle , straightShaft @@ -94,51 +98,49 @@ , module Diagrams.TwoD.Arrowheads ) where -import Control.Applicative ((<*>)) -import Control.Arrow (first) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, - lensRules, makeLensesWith, - (%~), (&), (.~), (^.)) +import Control.Applicative ((<*>)) +import Control.Lens (Lens', Setter', Traversal', + generateSignatures, lensRules, + makeLensesWith, (%~), (&), (.~), + (^.)) import Data.AffineSpace import Data.Default.Class -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) -import Data.Monoid (mempty, (<>)) -import Data.Monoid.Coproduct (untangle) -import Data.Monoid.Split -import Data.Semigroup (option) +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) +import Data.Semigroup import Data.VectorSpace -import Data.Colour hiding (atop) -import Diagrams.Attributes +import Data.Colour hiding (atop) import Diagrams.Core -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') +import Diagrams.Angle +import Diagrams.Attributes import Diagrams.Parametric import Diagrams.Path -import Diagrams.Solve (quadForm) -import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Solve (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) import Diagrams.Trail import Diagrams.TwoD.Arrowheads -import Diagrams.TwoD.Path (strokeT) -import Diagrams.TwoD.Transform (rotate, translateX) -import Diagrams.TwoD.Transform.ScaleInv (scaleInvPrim) +import Diagrams.TwoD.Attributes +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (rotate, translateX) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction, unitX, unit_X) -import Diagrams.Util (( # )) +import Diagrams.TwoD.Vector (direction, unitX, unit_X) +import Diagrams.Util (( # )) data ArrowOpts = ArrowOpts { _arrowHead :: ArrowHT , _arrowTail :: ArrowHT , _arrowShaft :: Trail R2 - , _headSize :: Double - , _tailSize :: Double - , _headGap :: Double - , _tailGap :: Double + , _headGap :: Measure R2 + , _tailGap :: Measure R2 , _headStyle :: Style R2 + , _headLength :: Measure R2 , _tailStyle :: Style R2 + , _tailLength :: Measure R2 , _shaftStyle :: Style R2 } @@ -150,15 +152,15 @@ def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail - , _arrowShaft = trailFromOffsets [unitX] - , _headSize = 0.3 - , _tailSize = 0.3 - , _headGap = 0 - , _tailGap = 0 + , _arrowShaft = straightShaft + , _headGap = none + , _tailGap = none -- See note [Default arrow style attributes] , _headStyle = mempty + , _headLength = normal , _tailStyle = mempty + , _tailLength = normal , _shaftStyle = mempty } @@ -173,21 +175,22 @@ -- | The trail to use for the arrow shaft. arrowShaft :: Lens' ArrowOpts (Trail R2) --- | Radius of a circumcircle around the head. -headSize :: Lens' ArrowOpts Double - --- | Radius of a circumcircle around the tail. -tailSize :: Lens' ArrowOpts Double - -- | Distance to leave between the head and the target point. -headGap :: Lens' ArrowOpts Double +headGap :: Lens' ArrowOpts (Measure R2) -- | Distance to leave between the starting point and the tail. -tailGap :: Lens' ArrowOpts Double +tailGap :: Lens' ArrowOpts (Measure R2) -gap :: Traversal' ArrowOpts Double -gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) +-- | Set both the @headGap@ and @tailGap@ simultaneously. +gaps :: Traversal' ArrowOpts (Measure R2) +gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) + <$> f (opts ^. headGap) + <*> f (opts ^. tailGap) +-- | Same as gaps, provided for backward compatiiblity. +gap :: Traversal' ArrowOpts (Measure R2) +gap = gaps + -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change -- an opaque black arrowhead to translucent orange: @@ -200,37 +203,36 @@ -- | Style to apply to the shaft. See `headStyle`. shaftStyle :: Lens' ArrowOpts (Style R2) --- | A lens for setting or modifying the color of an arrowhead. For --- example, one may write @... (with & headColor .~ blue)@ to get an --- arrow with a blue head, or @... (with & headColor %~ blend 0.5 --- white)@ to make an arrow's head a lighter color. For more general --- control over the style of arrowheads, see 'headStyle'. --- --- Note that the most general type of @headColor@ would be --- --- @ --- (Color c, Color c') => Setter ArrowOpts ArrowOpts c c' --- @ --- --- but that can cause problems for type inference when setting the --- color. However, using it at that more general type may --- occasionally be useful, for example, if you want to apply some --- opacity to a color, as in @... (with & headColor %~ --- (\`withOpacity\` 0.5))@. If you want the more general type, you --- can use @'headStyle' . 'styleFillColor'@ in place of @headColor@. -headColor :: Color c => Setter' ArrowOpts c -headColor = headStyle . styleFillColor +-- | The length from the start of the joint to the tip of the head. +headLength :: Lens' ArrowOpts (Measure R2) --- | A lens for setting or modifying the color of an arrow --- tail. See 'headColor'. -tailColor :: Color c => Setter' ArrowOpts c -tailColor = tailStyle . styleFillColor +-- | The length of the tail plus its joint. +tailLength :: Lens' ArrowOpts (Measure R2) --- | A lens for setting or modifying the color of an arrow --- shaft. See 'headColor'. -shaftColor :: Color c => Setter' ArrowOpts c -shaftColor = shaftStyle . styleLineColor +-- | Set both the @headLength@ and @tailLength@ simultaneously. +lengths :: Traversal' ArrowOpts (Measure R2) +lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) + <*> f (opts ^. tailLength) +-- | A lens for setting or modifying the texture of an arrowhead. For +-- example, one may write @... (with & headTexture .~ grad)@ to get an +-- arrow with a head filled with a gradient, assuming grad has been +-- defined. Or @... (with & headTexture .~ solid blue@ to set the head +-- color to blue. For more general control over the style of arrowheads, +-- see 'headStyle'. +headTexture :: Setter' ArrowOpts Texture +headTexture = headStyle . styleFillTexture + +-- | A lens for setting or modifying the texture of an arrow +-- tail. +tailTexture :: Setter' ArrowOpts Texture +tailTexture = tailStyle . styleFillTexture + +-- | A lens for setting or modifying the texture of an arrow +-- shaft. +shaftTexture :: Setter' ArrowOpts Texture +shaftTexture = shaftStyle . styleLineTexture + -- Set the default shaft style of an `ArrowOpts` record by applying the -- default style after all other styles have been applied. -- The semigroup stucture of the lw attribute will insure that the default @@ -246,6 +248,10 @@ tailSty :: ArrowOpts -> Style R2 tailSty opts = fc black (opts^.tailStyle) +fromMeasure :: Double -> Double -> Measure R2 -> Double +fromMeasure g n m = u + where Output u = toOutput g n m + -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. xWidth :: (Traced t, V t ~ R2) => t -> Double @@ -255,45 +261,52 @@ b = fromMaybe 0 (magnitude <$> traceV origin unit_X p) -- | Get the line color from the shaft to use as the fill color for the joint. -colorJoint :: Style v -> Style v +-- And set the opacity of the shaft to the current opacity. +colorJoint :: Style R2 -> Style R2 colorJoint sStyle = - let c = fmap getLineColor . getAttr $ sStyle in - case c of - Nothing -> fillColor (black :: Colour Double) -- default color for joints - $ mempty - Just c' -> fillColor c' $ mempty + let c = fmap getLineTexture . getAttr $ sStyle + o = fmap getOpacity . getAttr $ sStyle + in + case (c, o) of + (Nothing, Nothing) -> fillColor (black :: Colour Double) $ mempty + (Just t, Nothing) -> fillTexture t $ mempty + (Nothing, Just o') -> opacity o' . fillColor (black :: Colour Double) $ mempty + (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. -widthOfJoint :: Style v -> Double -widthOfJoint sStyle = - let w = fmap getLineWidth . getAttr $ sStyle in - case w of - Nothing -> 0.01 -- this case should never happen. - Just w' -> w' +widthOfJoint :: Style v -> Double -> Double -> Double +widthOfJoint sStyle gToO nToO = + maybe (fromMeasure gToO nToO (Output 1)) -- Should be same as default line width + (fromMeasure gToO nToO) + (fmap getLineWidth . getAttr $ sStyle) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. -mkHead :: Renderable (Path R2) b => ArrowOpts -> (Diagram b R2, Double) -mkHead opts = ( (j <> h) # moveOriginBy (jWidth *^ unit_X) # lw 0 +mkHead :: Renderable (Path R2) b => + Double -> ArrowOpts -> Double -> Double -> (Diagram b R2, Double) +mkHead size opts gToO nToO = ((j <> h) # moveOriginBy (jWidth *^ unit_X) # lwO 0 , hWidth + jWidth) where - (h', j') = (opts^.arrowHead) (opts^.headSize) (widthOfJoint $ shaftSty opts) + (h', j') = (opts^.arrowHead) size + (widthOfJoint (shaftSty opts) gToO nToO) hWidth = xWidth h' jWidth = xWidth j' - h = scaleInvPrim h' unitX # applyStyle (headSty opts) - j = scaleInvPrim j' unitX # applyStyle (colorJoint (opts^.shaftStyle)) + h = stroke h' # applyStyle (headSty opts) + j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | Just like mkHead only the attachment point is on the right. -mkTail :: Renderable (Path R2) b => ArrowOpts -> (Diagram b R2, Double) -mkTail opts = ( (t <> j) # moveOriginBy (jWidth *^ unitX) # lw 0 +mkTail :: Renderable (Path R2) b => + Double -> ArrowOpts -> Double -> Double -> (Diagram b R2, Double) +mkTail size opts gToO nToO = ((t <> j) # moveOriginBy (jWidth *^ unitX) # lwO 0 , tWidth + jWidth) where - (t', j') = (opts^.arrowTail) (opts^.tailSize) (widthOfJoint $ shaftSty opts) + (t', j') = (opts^.arrowTail) size + (widthOfJoint (shaftSty opts) gToO nToO) tWidth = xWidth t' jWidth = xWidth j' - t = scaleInvPrim t' unitX # applyStyle (tailSty opts) - j = scaleInvPrim j' unitX # applyStyle (colorJoint (opts^.shaftStyle)) + t = stroke t' # applyStyle (tailSty 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 @@ -337,6 +350,16 @@ hv = hw *^ (tangentAtEnd tr # normalized) v = trailOffset tr +-- Calculate the approximate envelope of a horizontal arrow +-- as if the arrow were made only of a shaft. +arrowEnv :: ArrowOpts -> Double -> Envelope R2 +arrowEnv opts len = getEnvelope horizShaft + where + horizShaft = shaft # rotate (negateV direction v) # scale (len / m) + m = magnitude v + v = trailOffset shaft + shaft = opts ^. arrowShaft + -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. @@ -350,15 +373,13 @@ arrow' :: Renderable (Path R2) b => ArrowOpts -> Double -> Diagram b R2 arrow' opts len = mkQD' (DelayedLeaf delayedArrow) - -- We must approximate the envelope and trace by just drawing the - -- arrow from the origin to (len,0) and using its envelope and - -- trace. That may not end up being exactly right (if the arrow - -- gets scaled, the shaft may get a bit longer or shorter, and so - -- on) but it's close enough. - (getEnvelope approx) (getTrace approx) mempty mempty + -- Currently arrows have an empty envelope and trace. + (arrowEnv opts len) mempty mempty mempty + where - -- Once we learn the global transformation context this arrow is + -- Once we learn the global transformation context (da) and the two scale + -- factors, normal to output (n) and global to output (g), this arrow is -- drawn in, we can apply it to the origin and (len,0) to find out -- the actual final points between which this arrow should be -- drawn. We need to know this to draw it correctly, since the @@ -366,22 +387,12 @@ -- between which we need to draw the shaft do not transform -- uniformly as the transformation applied to the entire arrow. -- See https://github.com/diagrams/diagrams-lib/issues/112. - delayedArrow da = - - -- Note we only take the *unfrozen* transformation. The frozen - -- transformation *do* affect scale-invariant objects like - -- arrowheads, and will still be higher up in the tree (so we - -- don't need to apply it here). - let (unfrozenTr, globalSty) = option mempty (first unsplitR . untangle) . fst $ da - in dArrow globalSty unfrozenTr len - - unsplitR (M m) = m - unsplitR (_ :| m) = m - - approx = dArrow mempty mempty len + delayedArrow da g n = + let (trans, globalSty) = option mempty untangle . fst $ da + in dArrow globalSty trans len g n -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). - dArrow sty tr ln = (h' <> t' <> shaft) + dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) # rotate (direction (q .-. p) ^-^ dir) # moveTo p @@ -393,15 +404,22 @@ -- Use the existing line color for head, tail, and shaft by -- default (can be overridden by explicitly setting headStyle, -- tailStyle, or shaftStyle). - globalLC = getLineColor <$> getAttr sty + globalLC = getLineTexture <$> getAttr sty opts' = opts - & headStyle %~ maybe id fillColor globalLC - & tailStyle %~ maybe id fillColor globalLC - & shaftStyle %~ maybe id lineColor globalLC + & headStyle %~ maybe id fillTexture globalLC + & tailStyle %~ maybe id fillTexture globalLC + & shaftStyle %~ maybe id lineTexture globalLC + -- The head size, tail size, head gap, and tail gap are obtained + -- from the style and converted to output units. + hSize = fromMeasure gToO nToO (opts ^. headLength) + tSize = fromMeasure gToO nToO (opts ^. tailLength) + hGap = fromMeasure gToO nToO (opts ^. headGap) + tGap = fromMeasure gToO nToO (opts ^. tailGap) + -- Make the head and tail and save their widths. - (h, hWidth') = mkHead opts' - (t, tWidth') = mkTail opts' + (h, hWidth') = mkHead hSize opts' gToO nToO + (t, tWidth') = mkTail tSize opts' gToO nToO rawShaftTrail = opts^.arrowShaft shaftTrail @@ -414,8 +432,8 @@ # transform tr -- Adjust the head width and tail width to take gaps into account - tWidth = tWidth' + opts^.tailGap - hWidth = hWidth' + opts^.headGap + tWidth = tWidth' + tGap + hWidth = hWidth' + hGap -- Calculate the angles that the head and tail should point. tAngle = direction . tangentAtStart $ shaftTrail @@ -459,7 +477,8 @@ arrowAt' :: Renderable (Path R2) b => ArrowOpts -> P2 -> R2 -> Diagram b R2 -arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s +arrowAt' opts s v = arrow' opts len + # rotate dir # moveTo s where len = magnitude v dir = direction v diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -22,7 +22,7 @@ , dart , spike , thorn - , missile + , lineHead , noHead -- ** Configurable arrowheads @@ -33,7 +33,6 @@ , arrowheadDart , arrowheadSpike , arrowheadThorn - , arrowheadMissile -- * Arrow tails -- ** Standard arrow tails @@ -41,7 +40,7 @@ , dart' , spike' , thorn' - , missile' + , lineTail , noTail , quill , block @@ -55,19 +54,20 @@ , ArrowHT ) where -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core -import Diagrams.CubicSpline (cubicSpline) + +import Diagrams.Coordinates ((^&)) import Diagrams.Path import Diagrams.Segment import Diagrams.Trail +import Diagrams.TrailLike (fromOffsets) import Diagrams.TwoD.Align import Diagrams.TwoD.Arc (arc') import Diagrams.TwoD.Path () @@ -75,139 +75,115 @@ import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unitX, unit_X) +import Diagrams.TwoD.Vector (fromDirection, direction, unit_X) import Diagrams.Util (( # )) ----------------------------------------------------------------------------- type ArrowHT = Double -> Double -> (Path R2, Path R2) -htRadius :: Double -htRadius = 0.5 - -scaleR :: (Transformable t, Scalar (V t) ~ Double) => t -> t -scaleR = scale htRadius - -unit_X2 :: R2 -unit_X2 = scaleR unit_X - closedPath :: (Floating (Scalar v), Ord (Scalar v), InnerSpace v) => Trail v -> Path v closedPath = pathFromTrail . closeTrail -- Heads ------------------------------------------------------------------ --- > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw 0) +-- > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) --- > <> square 0.5 # alignL # lw 0 +-- > <> square 0.5 # alignL # lw none -- | Isoceles triangle style. The above example specifies an angle of `2/5 Turn`. -- | <> --- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 \@\@ turn) & shaftStyle %~ lw 0) +-- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn) & shaftStyle %~ lw none) -- > origin (r2 (0.001, 0)) --- > <> square 0.6 # alignL # lw 0 +-- > <> square 0.6 # alignL # lw none arrowheadTriangle :: Angle -> ArrowHT arrowheadTriangle theta = aHead where - aHead size _ = (p, mempty) + aHead len _ = (p, mempty) where + psi = pi - (theta ^. rad) + r = len / (1 + cos psi) p = polygon (def & polyType .~ PolyPolar [theta, (negateV 2 *^ theta)] - (repeat (htRadius * size)) & polyOrient .~ NoOrient) # alignL + (repeat r) & polyOrient .~ NoOrient) # alignL + -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. arrowheadDart :: Angle -> ArrowHT -arrowheadDart theta = aHead +arrowheadDart theta len shaftWidth = (hd # scale size, jt) where - aHead size shaftWidth = (dartP # moveOriginTo (dartVertices !! 2), joint) - where - r = htRadius * size - dartP = polygon - ( def & polyType .~ PolyPolar [theta, (1/2 @@ turn) ^-^ theta, (1/2 @@ turn) ^-^ theta] - [r, r, 0.1 * size, r] - & polyOrient .~ NoOrient - ) - dartVertices = (concat . pathVertices) $ dartP - m = magnitude (dartVertices !! 1 .-. dartVertices !! 3) - s = 1 - shaftWidth / m - v1 = (dartVertices !! 1 .-. dartVertices !! 2) # scale s - v2 = (dartVertices !! 3 .-. dartVertices !! 2) # scale s - joint = (closedPath $ trailFromVertices [ dartVertices !! 2 - , dartVertices !! 1 .-^ v1 - , dartVertices !! 3 .-^ v2 - , dartVertices !! 2 ]) # alignR + hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] + v = fromDirection theta + (t1, t2) = (unit_X ^+^ v, (-0.5 ^& 0) ^-^ v) + [b1, b2] = map (reflectY . negateV) [t1, t2] + psi = pi - (direction . negateV $ t2) ^. rad + jLength = shaftWidth / (2 * tan psi) + -- If the shaft if too wide, set the size to a default value of 1. + size = max 1 ((len - jLength) / (1.5)) + -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: Angle -> ArrowHT -arrowheadSpike theta = aHead +arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where - aHead size shaftWidth = (barb # moveOriginBy (m *^ unit_X) , joint) - where - a = e theta # scaleR - a' = reflectY a - l1 = trailFromSegments [straight (unit_X2 ^+^ a)] - l2 = trailFromSegments [reverseSegment . straight $ (unit_X2 ^+^ a')] - c = reflectX $ arc' htRadius theta (negateV theta) - barb = (closedPath $ (l1 <> c <> l2)) # scale size - m = xWidth barb --c `atParam` 0.5 - b = asin ((shaftWidth / 2) / (htRadius * size)) @@ rad - c' = arc' htRadius (negateV b) b # scale size - joint = (closedPath $ (c')) # centerY # alignR - xWidth p = pa + pb - where - pa = fromMaybe 0 (magnitude <$> traceV origin unitX p) - pb = fromMaybe 0 (magnitude <$> traceV origin unit_X p) + hd = snugL . closedPath $ l1 <> c <> l2 + jt = alignR . centerY . pathFromTrail + . closeTrail $ arc' 1 (negateV phi) phi + l1 = trailFromSegments [straight $ unit_X ^+^ v] + l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ (reflectY v))] + c = reflectX $ arc' 1 theta (negateV theta) + v = fromDirection theta + -- The length of the head without its joint is, -2r cos theta and + -- the length of the joint is r - sqrt (r^2 - y^2). So the total + -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2). + -- Solving the quadratic gives two roots, we want the larger one. + + -- 1/4 turn < theta < 2/3 turn. + a = 1 - 2 * cos (theta ^. rad) + y = shaftWidth / 2 + + -- If the shaft is too wide for the head, we default the radius r to + -- 2/3 * len by setting d=1 and phi=pi/2. + d = max 1 (len**2 + (1 - a**2) * y**2) + r = (a * len + sqrt d) / (a**2 -1) + phi = asin (min 1 (y/r)) @@ rad + -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: Angle -> Double -> ArrowHT -arrowheadThorn theta r = aHead +arrowheadThorn :: Angle -> ArrowHT +arrowheadThorn theta len shaftWidth = (hd # scale size, jt) where - aHead size shaftWidth = (thornP # moveOriginTo (thornVertices !! 2), joint) - where - a = e theta # scaleR - c1 = curvedSide theta - l1 = straight $ (reflectY a) ^-^ (unit_X2 # scale r) - l2 = straight $ unit_X2 # scale r ^-^ a - c2 = c1 # rotate (negateV theta) - thornP = (closedPath $ trailFromSegments [c1, l1, l2, c2]) # scale size - thornVertices = (concat . pathVertices) $ thornP - m = magnitude (thornVertices !! 1 .-. thornVertices !! 3) - s = 1 - shaftWidth / m - v1 = (thornVertices !! 1 .-. thornVertices !! 2) # scale s - v2 = (thornVertices !! 3 .-. thornVertices !! 2) # scale s - joint = (closedPath $ trailFromVertices [ thornVertices !! 2 - , thornVertices !! 1 .-^ v1 - , thornVertices !! 3 .-^ v2 - , thornVertices !! 2 ]) # alignR + hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop + hTop = closeTrail . trailFromSegments $ [c, l] + jt = pathFromTrail . glueTrail $ j <> reflectY j + j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] + c = curvedSide theta + v = fromDirection theta + l = reverseSegment . straight $ t + t = v ^-^ (-0.5 ^& 0) + psi = pi - (direction . negateV $ t) ^. rad + jLength = shaftWidth / (2 * tan psi) + -- If the shaft if too wide, set the size to a default value of 1. + size = max 1 ((len - jLength) / (1.5)) + -- | Make a side for the thorn head. curvedSide :: Angle -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end where - v0 = scaleR unit_X - v1 = e theta # scaleR - ctrl1 = v0 # scaleR - ctrl2 = v0 ^+^ (v1 # scaleR) + v0 = unit_X + v1 = fromDirection theta + ctrl1 = v0 + ctrl2 = v0 ^+^ v1 end = v0 ^+^ v1 --- | Transform an arrowhead/tail by fitting a cubic spline to it's vertices. --- XXX Rear vertices of the arrowhead will extend outside of the unit circle. --- XXX and the joint is a rectancgle as opposed to the correct shape. -smoothArrowhead :: ArrowHT -> ArrowHT -smoothArrowhead f = aHead - where - aHead size shaftWidth = (h, j) - where - (h', _) = f size shaftWidth - h = smooth $ pathVertices h' - -- XXX replace square joint with actual shape - j = square shaftWidth # scaleX 0.25 alignR - smooth [] = mempty - smooth (x:xs) = cubicSpline True x <> smooth xs - -arrowheadMissile :: Angle -> ArrowHT -arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta - -- Standard heads --------------------------------------------------------- +-- | A line the same width as the shaft. +lineHead :: ArrowHT +lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) + noHead :: ArrowHT noHead _ _ = (mempty, mempty) @@ -227,7 +203,7 @@ -- > thornEx = drawHead thorn thorn :: ArrowHT -thorn = arrowheadThorn (3/8 @@ turn) 1 +thorn = arrowheadThorn (3/8 @@ turn) -- | <> @@ -235,16 +211,10 @@ dart :: ArrowHT dart = arrowheadDart (2/5 @@ turn) --- | <> - --- > missileEx = drawHead missile -missile :: ArrowHT -missile = arrowheadMissile (2/5 @@ turn) - -- Tails ------------------------------------------------------------------ --- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw 0 & arrowHead .~ noHead) +-- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none & arrowHead .~ noHead) -- > origin (r2 (0.001, 0)) --- > <> square 0.5 # alignL # lw 0 +-- > <> square 0.5 # alignL # lw none -- | Utility function to convert any arrowhead to an arrowtail, i.e. -- attached at the start of the trail. @@ -260,29 +230,28 @@ arrowtailBlock :: Angle -> ArrowHT arrowtailBlock theta = aTail where - aTail size _ = (t, mempty) + aTail len _ = (t, mempty) where - t = square 1 # scaleX x # scaleY y # scale size # alignR - a' = e theta # scaleR + t = rect len (len * x) # alignR + a' = fromDirection theta a = a' ^-^ (reflectY a') - y = magnitude a - b = a' ^-^ (reflectX a') - x = magnitude b + x = magnitude a -- | The angle is where the top left corner intersects the circle. arrowtailQuill :: Angle -> ArrowHT -arrowtailQuill theta =aTail +arrowtailQuill theta = aTail where - aTail size shaftWidth = (t, j) + aTail len shaftWidth = (t, j) where t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] ) # scale size # alignR + size = len / 0.6 v0 = p2 (0.5, 0) - v2 = p2 (unr2 $ e theta # scaleR) - v1 = v2 # translateX (5/4 * htRadius) + v2 = p2 (unr2 $ fromDirection theta # scale 0.5) + v1 = v2 # translateX (5/8) v3 = p2 (-0.1, 0) v4 = v2 # reflectY - v5 = v4 # translateX (5/4 * htRadius) + v5 = v4 # translateX (5/8) s = 1 - shaftWidth / magnitude (v1 .-. v5) n1 = v0 # translateY (0.5 * shaftWidth) n2 = v1 .-^ ((v1 .-. v0) # scale s) @@ -292,6 +261,9 @@ [ v0, n1, n2, v0, n3, n4, v0 ]) -- Standard tails --------------------------------------------------------- +-- | A line the same width as the shaft. +lineTail :: ArrowHT +lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) noTail :: ArrowHT noTail _ _ = (mempty, mempty) @@ -320,12 +292,6 @@ dart' :: ArrowHT dart' = headToTail dart --- | <> - --- > missile'Ex = drawTail missile' -missile' :: ArrowHT -missile' = headToTail missile - -- | <> -- > quillEx = drawTail quill @@ -336,4 +302,4 @@ -- > blockEx = drawTail block block :: ArrowHT -block = arrowtailBlock (2/5 @@ turn) +block = arrowtailBlock (7/16 @@ turn) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Attributes.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Attributes +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines /Textures/ (Gradients and Colors) in two +-- dimensions. Like the attriubtes defined in the Diagrams.Attributes module, +-- all attributes defined here use the 'Last' or 'Recommend' /semigroup/ structure. +-- 'FillColor' and 'LineColor' attributes are provided so that backends that +-- don't support gradients need not be concerned with using textures. Backends +-- should only implement color attributes or textures attributes, not both. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Attributes ( + -- ** Width + LineWidth, getLineWidth, lineWidth, lineWidthA + , lw, lwN, lwO, lwL, lwG + , ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none + , tiny, verySmall, small, normal, large, veryLarge, huge + + -- ** Dashing + , Dashing(..), DashingA, getDashing + , dashing, dashingN, dashingO, dashingL, dashingG + + -- * Textures + , Texture(..), solid, _SC, _LG, _RG, defaultLG, defaultRG + , GradientStop(..), stopColor, stopFraction, mkStops + , SpreadMethod(..), lineLGradient, lineRGradient + + -- ** Linear Gradients + , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd + , lGradSpreadMethod, mkLinearGradient + + -- ** Radial Gradients + , RGradient(..), rGradStops, rGradTrans + , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 + , rGradSpreadMethod, mkRadialGradient + + -- ** Line texture + , LineTexture(..), getLineTexture, lineTexture, lineTextureA + , mkLineTexture, styleLineTexture + + -- ** Line color + , lineColor, lc, lcA + + -- ** Fill texture + , FillTexture(..), getFillTexture, fillTexture + , mkFillTexture, styleFillTexture + + -- ** Fill color + , fillColor, fc, fcA, recommendFillColor + + -- * Compilation utilities + , splitTextureFills + + ) where + +import Diagrams.Core +import Diagrams.Core.Style (setAttr) +import Diagrams.Attributes +import Diagrams.Attributes.Compile +import Diagrams.TwoD.Types + +import Diagrams.Core.Types (RTree) +import Diagrams.Located (unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Trail (isLoop) + +import Control.Lens ( makeLensesWith, generateSignatures, lensRules + , makePrisms, Lens', (&), (%~), (.~), Setter', sets) + +import Data.Colour hiding (AffineSpace) +import Data.Data +import Data.Default.Class +import Data.Maybe (fromMaybe) + +import Data.Monoid.Recommend +import Data.Semigroup + +-- | Standard 'Measures'. +none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, + tiny, verySmall, small, normal, large, veryLarge, huge :: Measure R2 +none = Output 0 +ultraThin = Normalized 0.0005 `atLeast` Output 0.5 +veryThin = Normalized 0.001 `atLeast` Output 0.5 +thin = Normalized 0.002 `atLeast` Output 0.5 +medium = Normalized 0.004 `atLeast` Output 0.5 +thick = Normalized 0.0075 `atLeast` Output 0.5 +veryThick = Normalized 0.01 `atLeast` Output 0.5 +ultraThick = Normalized 0.02 `atLeast` Output 0.5 + +tiny = Normalized 0.01 +verySmall = Normalized 0.015 +small = Normalized 0.023 +normal = Normalized 0.035 +large = Normalized 0.05 +veryLarge = Normalized 0.07 +huge = Normalized 0.10 + +----------------------------------------------------------------- +-- Line Width ------------------------------------------------- +----------------------------------------------------------------- + +-- | Line widths specified on child nodes always override line widths +-- specified at parent nodes. +newtype LineWidth = LineWidth (Last (Measure R2)) + deriving (Typeable, Data, Semigroup) +instance AttributeClass LineWidth + +type instance V LineWidth = R2 + +instance Transformable LineWidth where + transform t (LineWidth (Last w)) = + LineWidth (Last (transform t w)) + +instance Default LineWidth where + def = LineWidth (Last medium) + +getLineWidth :: LineWidth -> Measure R2 +getLineWidth (LineWidth (Last w)) = w + +-- | Set the line (stroke) width. +lineWidth :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +lineWidth = applyGTAttr . LineWidth . Last + +-- | Apply a 'LineWidth' attribute. +lineWidthA :: (HasStyle a, V a ~ R2) => LineWidth -> a -> a +lineWidthA = applyGTAttr + +-- | Default for 'lineWidth'. +lw :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +lw = lineWidth + +-- | A convenient synonym for 'lineWidth (Global w)'. +lwG :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwG w = lineWidth (Global w) + +-- | A convenient synonym for 'lineWidth (Normalized w)'. +lwN :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwN w = lineWidth (Normalized w) + +-- | A convenient synonym for 'lineWidth (Output w)'. +lwO :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwO w = lineWidth (Output w) + +-- | A convenient sysnonym for 'lineWidth (Local w)'. +lwL :: (HasStyle a, V a ~ R2) => Double -> a -> a +lwL w = lineWidth (Local w) + +----------------------------------------------------------------- +-- Dashing ---------------------------------------------------- +----------------------------------------------------------------- + +-- | Create lines that are dashing... er, dashed. +data Dashing = Dashing [Measure R2] (Measure R2) + deriving (Typeable, Data, Eq) + +newtype DashingA = DashingA (Last Dashing) + deriving (Typeable, Data, Semigroup, Eq) +instance AttributeClass DashingA + +type instance V DashingA = R2 + +instance Transformable DashingA where + transform t (DashingA (Last (Dashing w v))) = + DashingA (Last (Dashing r s)) + where + r = map (transform t) w + s = transform t v + +getDashing :: DashingA -> Dashing +getDashing (DashingA (Last d)) = d + +-- | Set the line dashing style. +dashing :: (HasStyle a, V a ~ R2) => + [Measure R2] -- ^ A list specifying alternate lengths of on + -- and off portions of the stroke. The empty + -- list indicates no dashing. + -> Measure R2 -- ^ An offset into the dash pattern at which the + -- stroke should start. + -> a -> a +dashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) + +-- | A convenient synonym for 'dashing (Global w)'. +dashingG :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingG w v = dashing (map Global w) (Global v) + +-- | A convenient synonym for 'dashing (Normalized w)'. +dashingN :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingN w v = dashing (map Normalized w) (Normalized v) + +-- | A convenient synonym for 'dashing (Output w)'. +dashingO :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingO w v = dashing (map Output w) (Output v) + +-- | A convenient sysnonym for 'dashing (Local w)'. +dashingL :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingL w v = dashing (map Local w) (Local v) + +-- | A gradient stop contains a color and fraction (usually between 0 and 1) +data GradientStop = GradientStop + { _stopColor :: SomeColor + , _stopFraction :: Double} + +makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop + +-- | A color for the stop. +stopColor :: Lens' GradientStop SomeColor + +-- | The fraction for stop. +stopFraction :: Lens' GradientStop Double + +-- | The 'SpreadMethod' determines what happens before 'lGradStart' and after +-- 'lGradEnd'. 'GradPad' fills the space before the start of the gradient +-- with the color of the first stop and the color after end of the gradient +-- with the color of the last stop. 'GradRepeat' restarts the gradient and +-- 'GradReflect' restarts the gradient with the stops in reverse order. +data SpreadMethod = GradPad | GradReflect | GradRepeat + +-- | Linear Gradient +data LGradient = LGradient + { _lGradStops :: [GradientStop] + , _lGradStart :: P2 + , _lGradEnd :: P2 + , _lGradTrans :: T2 + , _lGradSpreadMethod :: SpreadMethod } + +makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient + +-- | A list of stops (colors and fractions). +lGradStops :: Lens' LGradient [GradientStop] + +-- | A transformation to be applied to the gradient. Usually this field will +-- start as the identity transform and capture the transforms that are applied +-- to the gradient. +lGradTrans :: Lens' LGradient T2 + +-- | The starting point for the first gradient stop. The coordinates are in +-- 'Local' units and the default is (-0.5, 0). +lGradStart :: Lens' LGradient P2 + +-- | The ending point for the last gradient stop.The coordinates are in +-- 'Local' units and the default is (0.5, 0). +lGradEnd :: Lens' LGradient P2 + +-- | For setting the spread method. +lGradSpreadMethod :: Lens' LGradient SpreadMethod + +-- | Radial Gradient +data RGradient = RGradient + { _rGradStops :: [GradientStop] + , _rGradCenter0 :: P2 + , _rGradRadius0 :: Double + , _rGradCenter1 :: P2 + , _rGradRadius1 :: Double + , _rGradTrans :: T2 + , _rGradSpreadMethod :: SpreadMethod } + +makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient + +-- | A list of stops (colors and fractions). +rGradStops :: Lens' RGradient [GradientStop] + +-- | The center point of the inner circle. +rGradCenter0 :: Lens' RGradient P2 + +-- | The radius of the inner cirlce in 'Local' coordinates. +rGradRadius0 :: Lens' RGradient Double + +-- | The center of the outer circle. +rGradCenter1 :: Lens' RGradient P2 + +-- | The radius of the outer circle in 'Local' coordinates. +rGradRadius1 :: Lens' RGradient Double + +-- | A transformation to be applied to the gradient. Usually this field will +-- start as the identity transform and capture the transforms that are applied +-- to the gradient. +rGradTrans :: Lens' RGradient T2 + +-- | For setting the spread method. +rGradSpreadMethod :: Lens' RGradient SpreadMethod + +-- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'. +-- An object can have only one texture which is determined by the 'Last' +-- semigroup structure. +data Texture = SC SomeColor | LG LGradient | RG RGradient + deriving (Typeable) + +makePrisms ''Texture + +-- | Convert a solid colour into a texture. +solid :: Color a => a -> Texture +solid = SC . SomeColor + +-- | A default is provided so that linear gradients can easily be created using +-- lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that +-- no default value is provided for @lGradStops@, this must be set before +-- the gradient value is used, otherwise the object will appear transparent. +defaultLG :: Texture +defaultLG = LG (LGradient + { _lGradStops = [] + , _lGradStart = mkP2 (-0.5) 0 + , _lGradEnd = mkP2 (0.5) 0 + , _lGradTrans = mempty + , _lGradSpreadMethod = GradPad + }) + +-- | A default is provided so that radial gradients can easily be created using +-- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that +-- no default value is provided for @rGradStops@, this must be set before +-- the gradient value is used, otherwise the object will appear transparent. +defaultRG :: Texture +defaultRG = RG (RGradient + { _rGradStops = [] + , _rGradCenter0 = mkP2 0 0 + , _rGradRadius0 = 0.0 + , _rGradCenter1 = mkP2 0 0 + , _rGradRadius1 = 0.5 + , _rGradTrans = mempty + , _rGradSpreadMethod = GradPad + }) + +-- | A convenient function for making gradient stops from a list of triples. +-- (An opaque color, a stop fraction, an opacity). +mkStops :: [(Colour Double, Double, Double)] -> [GradientStop] +mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) + +-- | Make a linear gradient texture from a stop list, start point, end point, +-- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity +-- transfrom, to change it use the 'lGradTrans' lens. +mkLinearGradient :: [GradientStop] -> P2 -> P2 -> SpreadMethod -> Texture +mkLinearGradient stops start end spreadMethod + = LG (LGradient stops start end mempty spreadMethod) + +-- | Make a radial gradient texture from a stop list, radius, start point, +-- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity +-- transfrom, to change it use the 'rGradTrans' lens. +mkRadialGradient :: [GradientStop] -> P2 -> Double + -> P2 -> Double -> SpreadMethod -> Texture +mkRadialGradient stops c0 r0 c1 r1 spreadMethod + = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) + +-- | The texture with which lines are drawn. Note that child +-- textures always override parent textures. +-- More precisely, the semigroup structure on line texture attributes +-- is that of 'Last'. +newtype LineTexture = LineTexture (Last Texture) + deriving (Typeable, Semigroup) +instance AttributeClass LineTexture + +type instance V LineTexture = R2 + +-- Only gradients get transformed. The transform is applied to the gradients +-- transform field. Colors are left unchanged. +instance Transformable LineTexture where + transform t (LineTexture (Last texture)) = LineTexture (Last tx) + where + tx = texture & lgt . rgt + lgt = _LG . lGradTrans %~ f + rgt = _RG . rGradTrans %~ f + f = transform t + +instance Default LineTexture where + def = LineTexture (Last (SC (SomeColor (black :: Colour Double)))) + +getLineTexture :: LineTexture -> Texture +getLineTexture (LineTexture (Last t)) = t + +lineTexture :: (HasStyle a, V a ~ R2) => Texture-> a -> a +lineTexture = applyTAttr . LineTexture . Last + +lineTextureA :: (HasStyle a, V a ~ R2) => LineTexture -> a -> a +lineTextureA = applyTAttr + +mkLineTexture :: Texture -> LineTexture +mkLineTexture = LineTexture . Last + +styleLineTexture :: Setter' (Style v) Texture +styleLineTexture = sets modifyLineTexture + where + modifyLineTexture f s + = flip setAttr s + . mkLineTexture + . f + . getLineTexture + . fromMaybe def . getAttr + $ s + +-- | Set the line (stroke) color. This function is polymorphic in the +-- color type (so it can be used with either 'Colour' or +-- 'AlphaColour'), but this can sometimes create problems for type +-- inference, so the 'lc' and 'lcA' variants are provided with more +-- concrete types. +lineColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +lineColor = lineTexture . SC . SomeColor + +-- | A synonym for 'lineColor', specialized to @'Colour' Double@ +-- (i.e. opaque colors). See comment in 'lineColor' about backends. +lc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a +lc = lineColor + +-- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ +-- (i.e. colors with transparency). See comment in 'lineColor' +-- about backends. +lcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a +lcA = lineColor + +-- | Apply a linear gradient. +lineLGradient :: (HasStyle a, V a ~ R2) => LGradient -> a -> a +lineLGradient g = lineTexture (LG g) + +-- | Apply a radial gradient. +lineRGradient :: (HasStyle a, V a ~ R2) => RGradient -> a -> a +lineRGradient g = lineTexture (RG g) + +-- | The texture with which objects are filled. +-- The semigroup structure on fill texture attributes +-- is that of 'Recommed . Last'. +newtype FillTexture = FillTexture (Recommend (Last Texture)) + deriving (Typeable, Semigroup) + +instance AttributeClass FillTexture + +type instance V FillTexture = R2 + +-- Only gradients get transformed. The transform is applied to the gradients +-- transform field. Colors are left unchanged. +instance Transformable FillTexture where + transform _ tx@(FillTexture (Recommend _)) = tx + transform t (FillTexture (Commit (Last texture))) = FillTexture (Commit (Last tx)) + where + tx = texture & lgt . rgt + lgt = _LG . lGradTrans %~ f + rgt = _RG . rGradTrans %~ f + f = transform t + +instance Default FillTexture where + def = FillTexture (Recommend (Last (SC + (SomeColor (transparent :: AlphaColour Double))))) + +getFillTexture :: FillTexture -> Texture +getFillTexture (FillTexture tx) = getLast . getRecommend $ tx + +fillTexture :: (HasStyle a, V a ~ R2) => Texture -> a -> a +fillTexture = applyTAttr . FillTexture . Commit . Last + +mkFillTexture :: Texture -> FillTexture +mkFillTexture = FillTexture . Commit . Last + +styleFillTexture :: Setter' (Style v) Texture +styleFillTexture = sets modifyFillTexture + where + modifyFillTexture f s + = flip setAttr s + . mkFillTexture + . f + . getFillTexture + . fromMaybe def . getAttr + $ s + +-- | Set the fill color. This function is polymorphic in the color +-- type (so it can be used with either 'Colour' or 'AlphaColour'), +-- but this can sometimes create problems for type inference, so the +-- 'fc' and 'fcA' variants are provided with more concrete types. +fillColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +fillColor = fillTexture . SC . SomeColor + +-- | Set a \"recommended\" fill color, to be used only if no explicit +-- calls to 'fillColor' (or 'fc', or 'fcA') are used. +-- See comment after 'fillColor' about backends. +recommendFillColor :: (Color c, HasStyle a, V a ~ R2) => c -> a -> a +recommendFillColor = + applyTAttr . FillTexture . Recommend . Last . SC . SomeColor + +-- | A synonym for 'fillColor', specialized to @'Colour' Double@ +-- (i.e. opaque colors). See comment after 'fillColor' about backends. +fc :: (HasStyle a, V a ~ R2) => Colour Double -> a -> a +fc = fillColor + +-- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ +-- (i.e. colors with transparency). See comment after 'fillColor' about backends. +fcA :: (HasStyle a, V a ~ R2) => AlphaColour Double -> a -> a +fcA = fillColor +------------------------------------------------------------ + +data FillTextureLoops v = FillTextureLoops + +instance Typeable v => SplitAttribute (FillTextureLoops v) where + type AttrType (FillTextureLoops v) = FillTexture + type PrimType (FillTextureLoops v) = Path v + + primOK _ = all (isLoop . unLoc) . pathTrails + +-- | Push fill attributes down until they are at the root of subtrees +-- containing only loops. This makes life much easier for backends, +-- which typically have a semantics where fill attributes are +-- applied to lines/non-closed paths as well as loops/closed paths, +-- whereas in the semantics of diagrams, fill attributes only apply +-- to loops. +splitTextureFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a +splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops v) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -45,7 +45,7 @@ import Diagrams.Core -import Diagrams.Attributes (fc, lw) +import Diagrams.Angle import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates @@ -53,12 +53,13 @@ import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align -import Diagrams.TwoD.Path () +import Diagrams.TwoD.Attributes (lineWidth, fc) +import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Transform (scaleX, scaleY) +import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) -import Diagrams.Util (( # )) +import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) +import Diagrams.Util (( # )) infixl 6 === @@ -247,4 +248,4 @@ -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. bg :: (Renderable (Path R2) b) => Colour Double -> Diagram b R2 -> Diagram b R2 -bg c d = d <> boundingRect d # lw 0 # fc c +bg c d = d <> boundingRect d # lineWidth (Output 0) # fc c diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -70,7 +70,7 @@ -- > -- > segmentA = Cubic (12 ^& 0) (8 ^& 10) (OffsetClosed (20 ^& 8)) -- > --- > curveA = lw 0.1 . stroke . fromSegments $ [segmentA] +-- > curveA = lw thick . stroke . fromSegments $ [segmentA] -- > -- > diagramA = pad 1.1 . centerXY $ curveA -- > @@ -84,11 +84,11 @@ -- > $ curveA -- > <> showCurvature segmentA t -- > # withEnvelope (curveA :: D R2) --- > # lw 0.05 # lc red +-- > # lc red -- > -- > showCurvature bez@(Cubic b c (OffsetClosed d)) t --- > | v == 0 = mempty --- > | otherwise = go (radiusOfCurvature bez t) +-- > | v == (0,0) = mempty +-- > | otherwise = go (radiusOfCurvature bez t) -- > where -- > v@(x,y) = unr2 $ firstDerivative b c d t -- > vp = (-y) ^& x diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -26,6 +26,7 @@ import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.TrailLike import Diagrams.TwoD.Arc diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -11,78 +12,125 @@ -- Maintainer : diagrams-discuss@googlegroups.com -- -- Importing external images into diagrams. --- +-- Usage: To create a diagram from an embedded image with width 1 and height +-- set according to the aspect ratio: 'image img # scaleUToX 1` +-- where 'img' is a 'DImage Embedded' ----------------------------------------------------------------------------- module Diagrams.TwoD.Image ( - Image(..), imgFile, imgSize, imgTransf + DImage(..), ImageData(..) + , Embedded, External , image + , loadImageEmb + , loadImageExt + , uncheckedImageRef + , raster + , rasterDia ) where -import Control.Lens (makeLenses) -import Data.Typeable +import Codec.Picture +import Codec.Picture.Types (dynamicMap) + +import Data.Typeable (Typeable) +import Data.Colour (AlphaColour) + import Diagrams.Core -import Diagrams.Path -import Diagrams.TwoD.Path -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Size (SizeSpec2D (..)) -import Diagrams.TwoD.Types +import Diagrams.Attributes (colorToSRGBA) +import Diagrams.Path (Path) +import Diagrams.TwoD.Path (isInsideEvenOdd) +import Diagrams.TwoD.Shapes (rect) +import Diagrams.TwoD.Types (R2, T2) import Data.AffineSpace ((.-.)) - import Data.Semigroup --- | An external image primitive, representing an image the backend --- should import from another file when rendering. -data Image = Image { _imgFile :: FilePath - , _imgSize :: SizeSpec2D - , _imgTransf :: T2 - } - deriving Typeable +data Embedded deriving Typeable +data External deriving Typeable -makeLenses ''Image +-- | 'ImageData' is either a JuicyPixels @DynamicImage@ tagged as 'Embedded' or +-- a reference tagged as 'External'. +data ImageData :: * -> * where + ImageRaster :: DynamicImage -> ImageData Embedded + ImageRef :: FilePath -> ImageData External -type instance V Image = R2 +------------------------------------------------------------------------------- +-- | An image primitive, the two ints are width followed by height. +-- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, +-- will handle setting the width and heigh to the actual width and height +-- of the image. +data DImage :: * -> * where + DImage :: ImageData t -> Int -> Int -> T2 -> DImage t + deriving Typeable -instance Transformable Image where - transform t1 (Image file sz t2) = Image file sz (t1 <> t2) +type instance V (DImage a) = R2 -instance IsPrim Image +instance Transformable (DImage a) where + transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) -instance HasOrigin Image where +instance HasOrigin (DImage a) where moveOriginTo p = translate (origin .-. p) -instance Renderable Image NullBackend where - render _ _ = mempty +-- | Make a 'DImage' into a 'Diagram'. +image :: (Typeable a, Renderable (DImage a) b) => DImage a -> Diagram b R2 +image img = mkQD (Prim (img)) (getEnvelope r) (getTrace r) mempty + (Query $ \p -> Any (isInsideEvenOdd p r)) + where + r :: Path R2 + r = rect (fromIntegral w) (fromIntegral h) + DImage _ w h _ = img --- See Note [Image size specification] +-- | 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. +loadImageEmb :: FilePath -> IO (Either String (DImage Embedded)) +loadImageEmb path = do + dImg <- readImage path + return $ case dImg of + Left msg -> Left msg + Right img -> Right (DImage (ImageRaster img) w h mempty) + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img --- | Take an external image from the specified file and turn it into a --- diagram with the specified width and height, centered at the --- origin. Note that the image's aspect ratio will be preserved; if --- the specified width and height have a different ratio than the --- image's aspect ratio, there will be extra space in one dimension. -image :: (Renderable Image b) => FilePath -> Double -> Double -> Diagram b R2 -image file w h = mkQD (Prim (Image file (Dims w h) mempty)) - (getEnvelope r) - (getTrace r) - mempty - (Query $ \p -> Any (isInsideEvenOdd p r)) - where r :: Path R2 - r = rect w h +-- | Check that a file exists, and use JuicyPixels to figure out +-- the right size, but save a reference to the image instead +-- of the raster data +loadImageExt :: FilePath -> IO (Either String (DImage External)) +loadImageExt path = do + dImg <- readImage path + return $ case dImg of + Left msg -> Left msg + Right img -> Right $ DImage (ImageRef path) w h mempty + where + w = dynamicMap imageWidth img + h = dynamicMap imageHeight img -{- ~~~~ Note [Image size specification] +-- | Make an "unchecked" image reference; have to specify a +-- width and height. Unless the aspect ratio of the external +-- image is the w :: h, then the image will be distorted. +uncheckedImageRef :: FilePath -> Int -> Int -> DImage External +uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -It's tempting to make 'image' take a SizeSpec2D instead of two -Doubles. For example, if I know I want the image to be x units wide -but I don't know the original aspect ratio of the image, I'd like to -be able to just say "make it x units wide". The problem is that -diagrams would then not know how tall the image is until rendering -time (at least, not without unsafePerformIO yuckiness). A more -general solution will have to wait until we can specify constraints -and solve them later. +-- | Crate a diagram from raw raster data. +rasterDia :: Renderable (DImage Embedded) b + => (Int -> Int -> AlphaColour Double) -> Int -> Int -> Diagram b R2 +rasterDia f w h = image $ raster f w h --} +-- | Create an image "from scratch" by specifying the pixel data +raster :: (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage Embedded +raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty + where + img = generateImage g w h + g x y = fromAlphaColour $ f x y + +fromAlphaColour :: AlphaColour Double -> PixelRGBA8 +fromAlphaColour c = PixelRGBA8 r g b a + where + (r, g, b, a) = (int r', int g', int b', int a') + (r', g', b', a') = colorToSRGBA c + int x = round (255 * x) + +instance Renderable (DImage a) NullBackend where + render _ _ = mempty diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -23,7 +23,7 @@ import Control.Lens (makeLenses, (^.)) import Diagrams.Core -import Diagrams.Attributes +import Diagrams.TwoD.Attributes import Diagrams.Path import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path @@ -69,7 +69,7 @@ showOrigin' oo d = o <> d where o = stroke (circle sz) # fc (oo^.oColor) - # lw 0 + # lineWidth (Output 0) # fmap (const mempty) (w,h) = size2D d ^* oo^.oScale sz = maximum [w, h, oo^.oMinSize] diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -208,7 +208,7 @@ -- > import Diagrams.TwoD.Offset -- > -- > showExample :: Segment Closed R2 -> Diagram SVG R2 --- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 +-- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw thick <> d' # lw thick -- > where -- > d = stroke . fromSegments $ [s] -- > d' = mconcat . zipWith lc colors . map stroke . explodeTrail @@ -298,7 +298,7 @@ -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin -- > -- > offsetTrailExample :: Diagram SVG R2 --- > offsetTrailExample = pad 1.1 . centerXY . lw 0.2 . hcat' (def & sep .~ 1 ) +-- > offsetTrailExample = pad 1.1 . centerXY . lwO 3 . hcat' (def & sep .~ 1 ) -- > . map (uncurry showStyle) -- > $ [ (LineJoinMiter, "LineJoinMiter") -- > , (LineJoinRound, "LineJoinRound") @@ -310,7 +310,7 @@ -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > -- > offsetTrailLeftExample :: Diagram SVG R2 --- > offsetTrailLeftExample = pad 1.1 . centerXY . lw 0.2 +-- > offsetTrailLeftExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike -- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) (-2) $ c) @@ -318,7 +318,7 @@ -- > c = reflectY corner -- > -- > offsetTrailOuterExample :: Diagram SVG R2 --- > offsetTrailOuterExample = pad 1.1 . centerXY . lw 0.2 +-- > offsetTrailOuterExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike -- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) 2 $ c) @@ -401,17 +401,17 @@ -- > , (LineCapSquare, "LineCapSquare") -- > ] -- > where --- > showStyle c s = centerXY (trailLike corner # lc white # lw 0.2 +-- > showStyle c s = centerXY (trailLike corner # lc white # lw veryThick -- > <> stroke (expandTrail' -- > (def & expandJoin .~ LineJoinRound -- > & expandCap .~ c -- > ) 2 corner) --- > # lw 0 # fc green) +-- > # lw none # fc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > -- > expandLoopExample :: Diagram SVG R2 --- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw 0.2 # lc white) --- > <> (stroke t' # lw 0 # fc green)) +-- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw veryThick # lc white) +-- > <> (stroke t' # lw none # fc green)) -- > where -- > t = mapLoc glueTrail $ fromVertices (map p2 [(0, 0), (5, 0), (10, 5), (10, 10), (0, 0)]) -- > t' = expandTrail' (def & expandJoin .~ LineJoinRound) 1 t 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 @@ -45,9 +45,9 @@ ) where import Control.Applicative (liftA2) -import Control.Lens ( makeWrapped, makeLensesWith, (.~), (^.) - , generateSignatures, lensRules, op - , Lens, Lens', _Wrapped') +import Control.Lens (Lens, Lens', generateSignatures, + lensRules, makeLensesWith, makeWrapped, + op, (.~), (^.), _Wrapped') import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable 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 @@ -60,6 +60,7 @@ import Data.Default.Class import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -47,6 +47,7 @@ import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment @@ -99,7 +100,7 @@ square d = rect d d -- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] --- > # centerXY # pad 1.1 # lw 0.03 +-- > # centerXY # pad 1.1 -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -27,7 +27,7 @@ , requiredScaleT, requiredScale -- ** Changing the size of things - , sized, sizedAs + , sized, sizedAs, sizePair ) where import Diagrams.Core @@ -148,3 +148,10 @@ , Enveloped b, V b ~ R2) => b -> a -> a sizedAs other = sized (sizeSpec2D other) + +-- | Make width and height of `SizeSpec2D` into a tuple. +sizePair :: SizeSpec2D -> (Double, Double) +sizePair (Width w') = (w',w') +sizePair (Height h') = (h',h') +sizePair (Dims w' h') = (w',h') +sizePair Absolute = (100,100) 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 @@ -23,45 +23,47 @@ -- ** Font family , Font(..), getFont, font -- ** Font size - , FontSize(..), getFontSize, fontSize, fontSizeA + , FontSize(..), getFontSize, getFontSizeIsLocal, fontSizeA, fontSize + , fontSizeN, fontSizeO, fontSizeL, fontSizeG -- ** Font slant , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique -- ** Font weight , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold ) where -import Diagrams.Attributes import Diagrams.Core -import Diagrams.Core.Envelope (pointEnvelope) +import Diagrams.Core.Envelope (pointEnvelope) +import Diagrams.TwoD.Attributes (recommendFillColor) import Diagrams.TwoD.Types -import Data.AffineSpace ((.-.)) - -import Data.Semigroup - +import Data.AffineSpace ((.-.)) import Data.Colour - +import Data.Data import Data.Default.Class - -import Data.Typeable +import Data.Semigroup ------------------------------------------------------------ -- Text diagrams ------------------------------------------------------------ -- | A text primitive consists of the string contents and alignment --- specification, along with a transformation mapping from the local --- vector space of the text to the vector space in which it is --- embedded. -data Text = Text T2 TextAlignment String +-- specification, along with two transformations: the first +-- accumulates all transformations which have been applied to the +-- text; the second accumulates normalized, "anti-scaled" versions +-- of the transformations which have had their average scaling +-- component removed. +data Text = Text T2 T2 TextAlignment String deriving Typeable type instance V Text = R2 instance Transformable Text where - transform t (Text tt a s) = Text (t <> tt) a s - -instance IsPrim Text + transform t (Text tt tn a s) = Text (t <> tt) (t <> tn <> t') a s + where + t' = scaling (1 / avgScale t) + -- It's important that the anti-scaling is applied *first*, + -- followed by the old transformation tn and then the new + -- transformation t. That way translation is handled properly. instance HasOrigin Text where moveOriginTo p = translate (origin .-. p) @@ -76,7 +78,7 @@ mkText a t = recommendFillColor (black :: Colour Double) -- See Note [recommendFillColor] - $ mkQD (Prim (Text mempty a t)) + $ mkQD (Prim (Text mempty mempty a t)) (pointEnvelope origin) mempty mempty @@ -166,28 +168,64 @@ -- Font size -- | The @FontSize@ attribute specifies the size of a font's --- em-square, measured with respect to the current local vector space. --- Inner @FontSize@ attributes override outer ones. -newtype FontSize = FontSize (Last Double) - deriving (Typeable, Semigroup, Eq) +-- em-square. Inner @FontSize@ attributes override outer ones. +newtype FontSize = FontSize (Last (Measure R2, Bool)) + deriving (Typeable, Data, Semigroup) instance AttributeClass FontSize +-- Note, the Bool stored in the FontSize indicates whether it started +-- life as Local. Typically, if the Bool is True, backends should use +-- the first T2 value stored in a Text object; otherwise, the second +-- (anti-scaled) T2 value should be used. + +type instance V FontSize = R2 + instance Default FontSize where - def = FontSize (Last 1) + def = FontSize (Last (Local 1, True)) +-- FontSize has to be Transformable + also have an instance of Data, +-- so the Measure inside it will be automatically converted to Output. +-- However, we don't actually want the Transformable instance to do +-- anything. All the scaling of text happens not by manipulating the +-- font size but by accumulating T2 values in Text objects. +instance Transformable FontSize where + transform _ f = f + -- | Extract the size from a @FontSize@ attribute. -getFontSize :: FontSize -> Double -getFontSize (FontSize (Last s)) = s +getFontSize :: FontSize -> Measure R2 +getFontSize (FontSize (Last (s,_))) = s +-- | Determine whether a @FontSize@ attribute began its life measured +-- in 'Local' units. +getFontSizeIsLocal :: FontSize -> Bool +getFontSizeIsLocal (FontSize (Last (_,b))) = b + -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. -fontSize :: HasStyle a => Double -> a -> a -fontSize = applyAttr . FontSize . Last +fontSize :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a +fontSize m@(Local {}) = applyGTAttr . FontSize . Last $ (m,True) +fontSize m = applyGTAttr . FontSize . Last $ (m,False) +-- | A convenient synonym for 'fontSize (Global w)'. +fontSizeG :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeG w = fontSize (Global w) + +-- | A convenient synonym for 'fontSize (Normalized w)'. +fontSizeN :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeN w = fontSize (Normalized w) + +-- | A convenient synonym for 'fontSize (Output w)'. +fontSizeO :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeO w = fontSize (Output w) + +-- | A convenient sysnonym for 'fontSize (Local w)'. +fontSizeL :: (HasStyle a, V a ~ R2) => Double -> a -> a +fontSizeL w = fontSize (Local w) + -- | Apply a 'FontSize' attribute. -fontSizeA :: HasStyle a => FontSize -> a -> a -fontSizeA = applyAttr +fontSizeA :: (HasStyle a, V a ~ R2) => FontSize -> a -> a +fontSizeA = applyGTAttr -------------------------------------------------- -- Font slant 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 @@ -47,12 +47,12 @@ -- * Utilities , onBasis - , avgScale ) where import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types @@ -249,41 +249,3 @@ onBasis :: Transformation R2 -> ((R2, R2), R2) onBasis t = ((x, y), v) where ((x:y:[]), v) = T.onBasis t - --- | Compute the \"average\" amount of scaling performed by a --- transformation. Satisfies the properties --- --- @ --- avgScale (scaling k) == k --- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 --- @ --- --- Backends which do not support stroking in the context of an --- arbitrary transformation may instead call 'avgScale' on --- \"frozen\" transformations and multiply the line width by the --- resulting value. -avgScale :: T2 -> Double -avgScale t = sqrt (abs (x1*y2 - y1*x2)) - where ((unr2 -> (x1,y1), unr2 -> (x2,y2)), _) = onBasis t - -{- - -avgScale is computed as the square root of the positive -determinant. Proofs for the specified properties: - -1. sqrt (|det (scaling k)|) = sqrt (k^2) = k -2. sqrt (|det t1|) * sqrt (|det t2|) - = sqrt (|det t1| * |det t2|) - = sqrt (|det t1 * det t2|) - = sqrt (|det (t1 * t2)|) - -From wikipedia: - - A geometric interpretation can be given to the value of the - determinant of a square matrix with real entries: the absolute - value of the determinant gives the scale factor by which area or - volume (or a higher dimensional analogue) is multiplied under the - associated linear transformation, while its sign indicates whether - the transformation preserves orientation. - --} diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -150,24 +150,6 @@ -} --- This is how we handle freezing properly with ScaleInv wrappers. --- Normal transformations are applied ignoring scaling; "frozen" --- transformations (i.e. transformations applied after a freeze) are --- applied directly to the underlying object, scales and all. We must --- take care to transform the reference point and direction vector --- appropriately. -instance (V t ~ R2, Transformable t) => IsPrim (ScaleInv t) where - transformWithFreeze t1 t2 s = ScaleInv t'' d'' origin'' - where - -- first, apply t2 normally, i.e. ignoring scaling - s'@(ScaleInv t' _ _) = transform t2 s - - -- now apply t1 to get the new direction and origin - (ScaleInv _ d'' origin'') = transform t1 s' - - -- but apply t1 directly to the underlying thing, scales and all. - t'' = transform t1 t' - instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where render b = render b . view scaleInvObj diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -25,25 +25,21 @@ , P2, p2, mkP2, unp2, p2Iso , T2 - -- * Angles - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , (@@) ) where -import Control.Lens (Iso', Wrapped(..), Rewrapped, iso - , review , (^.), _1, _2) +import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, + lens, (^.), _1, _2) +import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core import Data.AffineSpace.Point import Data.Basis -import Data.MemoTrie (HasTrie (..)) +import Data.MemoTrie (HasTrie (..)) import Data.VectorSpace -import Data.Typeable +import Data.Data ------------------------------------------------------------ -- 2D Euclidean space @@ -77,7 +73,7 @@ data R2 = R2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Data) instance AdditiveGroup R2 where zeroV = R2 0 0 @@ -184,6 +180,13 @@ instance HasY R2 where _y = r2Iso . _2 +instance HasTheta R2 where + _theta = lens (\v -> atanA (v^._y / v^._x)) + (\v θ -> let r = magnitude v in R2 (r * cosA θ) (r * sinA θ)) + +instance HasR R2 where + _r = lens magnitude (\v r -> let s = r/magnitude v in s *^ v) + -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '^&' (see @@ -235,55 +238,9 @@ instance HasY P2 where _y = p2Iso . _2 ------------------------------------------------------------- --- Angles --- | Angles can be expressed in a variety of units. Internally, --- they are represented in radians. -newtype Angle = Radians Double - deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) - -instance VectorSpace Angle where - type Scalar Angle = Double - s *^ Radians t = Radians (s*t) - --- | The radian measure of an @Angle@ @a@ can be accessed as @a --- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. -rad :: Iso' Angle Double -rad = iso (\(Radians r) -> r) Radians - --- | The measure of an @Angle@ @a@ in full circles can be accessed as --- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as --- @1/2 \@\@ turn@. -turn :: Iso' Angle Double -turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) - --- | The degree measure of an @Angle@ @a@ can be accessed as @a --- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ --- deg@. -deg :: Iso' Angle Double -deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) - --- | An angle representing one full turn. -fullTurn :: Angle -fullTurn = 1 @@ turn - --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle -fullCircle = fullTurn - --- | Calculate ratio between two angles. -angleRatio :: Angle -> Angle -> Double -angleRatio a b = (a^.rad) / (b^.rad) - - --- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. --- --- More generally, @\@\@@ reverses the @Iso\'@ on its right, and --- applies the @Iso\'@ to the value on the left. @Angle@s are the --- motivating example where this order improves readability. -(@@) :: b -> Iso' a b -> a --- The signature above is slightly specialized, in favor of readability -a @@ i = review i a +instance HasR P2 where + _r = _relative origin . _r -infixl 5 @@ +instance HasTheta P2 where + _theta = _relative origin . _theta diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,8 +23,9 @@ ) where import Control.Lens ((^.)) -import Data.AdditiveGroup import Data.VectorSpace ((<.>)) + +import Diagrams.Angle import Diagrams.TwoD.Types import Diagrams.Coordinates @@ -49,15 +50,6 @@ -- vector is arbitrarily assigned the direction 0. direction :: R2 -> Angle direction (coords -> x :& y) = atan2 y x @@ rad - --- | Compute the counterclockwise angle from the first vector to the second. -angleBetween :: R2 -> R2 -> Angle -angleBetween v1 v2 - | d2 > d1 = d2 ^-^ d1 - | otherwise = fullTurn ^+^ d2 ^-^ d1 - where - d1 = direction v1 - d2 = direction v2 -- | Convert an angle into a unit vector pointing in that direction. fromDirection :: Angle -> R2