diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,106 @@ +1.0 (25 November 2013) +---------------------- + +* **New features** + + - New modules `Diagrams.TwoD.Arrow` and `Diagrams.TwoD.Arrowheads` + for creating arrows. + - New module `Diagrams.Backend.CmdLine`, providing a flexible + framework for creating command-line-driven diagram rendering executables. + - New functions in `Diagrams.Offset`: `offsetTrail` and + `offsetPath` for one-sided offsets of trails and paths; + `expandTrail` and `expandPath` for "stroking" trails and paths, + computing a path whose fill corresponds to the stroke of the + given trail or path. + - New module `Diagrams.Tangent` for computing tangent and normal + vectors of segments, trails, and paths. + - New functions in `Diagrams.Align` to allow diagrams to be aligned by `Trace` + called `snug`, `snugBy` and `snugCenter` + and the ability to define other boundary functions for alignment. Functions + `snugL`, `snugR`, etc. are included in `TwoD.Align`. + - Lenses from `Control.Lens` are now used consistently for record fields + throughout the library. + - New function `angleRatio` for calculating the ratio between two angles. + - Restricted identity functions `asTurn`, `asRad`, and `asDeg` for + resolving type ambiguity + - New miter limit attribute. + - New function `annularWedge` in `TwoD.Arc` + - New `avgScale` utility in `TwoD.Transform`, for backends which + cannot fully implement freezing of line width + - New function `heptagon`, a vast improvement over the linguistic + frankenstein `septagon`. + - New function `lookupName` (re-exported from `diagrams-core`) for + simple lookups of named subdiagrams + - New function `angleBetween` to calculate the angle between two + vectors. + - New function `arcBetween` to draw an arc between two given + points. + - A bunch of new modules containing types, primitives and + utilities for constructing 3D diagrams: `Diagrams.ThreeD.Align`, + `.Camera`, `.Light`, `.Shapes`, `.Transform`, `.Types`, and + `.Vector`. This is still a "feature preview" (in particular, + appropriate 3D backends are still under construction). + +* **New instances** + + - `AdditiveGroup` and `VectorSpace` instances for `Turn`, `Rad`, `Deg` + - `Alignable` instance for `(->) e` + - `Default` instances for `FillRule`, `FillRuleA`, `LineJoin`, + `LineCap`, `FillColor` + - `Show` instances for `FillRule`, `FillRuleA` + +* **API changes** + + - `e` no longer exported from `Diagrams.Prelude`. + - `Diagrams.BoundingBox` is no longer exported from `Diagrams.Prelude`. + - Re-export `Diagrams.Core.pointDiagram` from `Diagrams.Prelude`. + - Added `fromAlphaColour` method to `Color` class. + - `&` renamed to `^&` + - Stop re-exporting `tan`, `over`, and `both` from `Data.Colour`. + - New coordinate lenses `_x`, `_y`, and `_z` for `R2`, `P2`, `R3`, `P3` + - Export `fullTurn` from `Diagrams.Prelude`. + - `Codomain (Located a)` is now `Point (Codomain a)` instead of + `Located (Codomain a)`. + - Export `domainBounds` from `Diagrams.Parametric`. + - Adjusting functionality moved from `Diagrams.Parametric` to its + own module, `Diagrams.Parametric.Adjust`. + - Rename `strokeT` (and primed variant) to `strokeTrail`; rename + `strokeLocT` to `strokeLocTrail`. + - `ScaleInv` is now in its own module, `Diagrams.TwoD.Transform.ScaleInv`. + - Re-export `Image` type (but not constructor) from `Diagrams.TwoD` + - Removed `Floating` and `RealFloat` instances for `Turn` and `Deg` + - `offsetSegment` now returns a `Located` instead of a tuple. + - Removed `Num` and `Fractional` instances for `R2`. + +* **Dependency/version changes** + + - Remove `newtype` dependency + - New dependencies on `lens`, `tagged`, `optparse-applicative`, + `filepath`, `safe`, `vector-space-points`, `MemoTrie` + - Depend on `intervals >= 0.3 && < 0.5`. + +* **Bug fixes** + + - Depend on `intervals 0.3`, which allows diagrams to build on + Windows, by evading a GHCi linker bug which affects the FFI use in + previous versions of intervals ([diagrams-contrib#14](https://github.com/diagrams/diagrams-contrib/issues/14)) + + - Use point envelope at the origin for text objects instead of an + empty envelope + ([#115](https://github.com/diagrams/diagrams-lib/issues/115), + [#116](https://github.com/diagrams/diagrams-lib/issues/116)). + - Adjusting the end of a trail now works correctly ([#95](https://github.com/diagrams/diagrams-lib/issues/95)). + - Only look for miter join on corners in `Diagrams.TwoD.Offset` ([#118](https://github.com/diagrams/diagrams-lib/issues/118)). + - `wedge` from `Diagrams.TwoD.Arc` is now a Loop ([#99](https://github.com/diagrams/diagrams-lib/issues/99)) + +* **Performance improvements** + + - `R2` is now strict and `UNPACK`ed + - Add strictness to `Offset`, `Segment`, `OffsetEnvelope`, and `SizeSpec2D`. + - Make `getEnvelope` calculation for `Segment` more efficient by + floating divisions out of the inner calculation. + - Use a specialized `HasTrie` instance for `R2`. + 0.7.1.1 (27 September 2013) --------------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,12 +1,17 @@ Copyright (c) 2011-2013 diagrams-lib team: + Jan Bracker Daniel Bergey Daniil Frumin Niklas Haas Peter Hall Claude Heiland-Allen Deepak Jois + John Lato + Chris Mears + Jeffrey Rosenbluth Ian Ross + Carlos Scheidegger Michael Sloan Jim Snavely Kanchalai Suveepattananont diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,29 +1,2 @@ -import Data.List (isSuffixOf) -import Distribution.Simple -import Distribution.Simple.Setup (Flag (..), HaddockFlags, - haddockDistPref) -import Distribution.Simple.Utils (copyFiles) -import Distribution.Text (display) -import Distribution.Verbosity (normal) -import System.Directory (getDirectoryContents) -import System.FilePath (()) - --- Ugly hack, logic copied from Distribution.Simple.Haddock -haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath -haddockOutputDir flags pkg = destDir - where - baseDir = case haddockDistPref flags of - NoFlag -> "." - Flag x -> x - destDir = baseDir "doc" "html" display (packageName pkg) - -diagramsDir = "diagrams" - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { postHaddock = \args flags pkg lbi -> do - dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents diagramsDir - copyFiles normal (haddockOutputDir flags pkg) - (map (\d -> ("", diagramsDir d)) dias) - postHaddock simpleUserHooks args flags pkg lbi - } +import Distribution.Simple +main = defaultMain diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 0.7.1.1 +Version: 1.0 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 @@ -15,9 +15,10 @@ Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics -Build-type: Custom +Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg +Extra-doc-files: diagrams/*.svg Tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git @@ -32,6 +33,7 @@ Diagrams.Points, Diagrams.Located, Diagrams.Parametric, + Diagrams.Parametric.Adjust, Diagrams.Segment, Diagrams.Trail, Diagrams.TrailLike, @@ -39,6 +41,7 @@ Diagrams.CubicSpline, Diagrams.CubicSpline.Internal, Diagrams.Solve, + Diagrams.Tangent, Diagrams.Transform, Diagrams.BoundingBox, Diagrams.Names, @@ -48,8 +51,11 @@ Diagrams.TwoD, Diagrams.TwoD.Types, Diagrams.TwoD.Align, + Diagrams.TwoD.Arrow, + Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Combinators, Diagrams.TwoD.Transform, + Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Segment, @@ -66,24 +72,36 @@ Diagrams.TwoD.Adjust, Diagrams.ThreeD.Types, Diagrams.ThreeD.Shapes, + Diagrams.ThreeD.Vector, + Diagrams.ThreeD.Transform, + Diagrams.ThreeD.Camera, + Diagrams.ThreeD.Light, + Diagrams.ThreeD Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, - Diagrams.Backend.Show + Diagrams.Backend.Show, + Diagrams.Backend.CmdLine Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.12, monoid-extras >= 0.3 && < 0.4, - diagrams-core >= 0.7 && < 0.8, + diagrams-core >= 1.0 && < 1.1, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, + vector-space-points >= 0.1.2 && < 0.2, + MemoTrie >= 0.6 && < 0.7, NumInstances >= 1.2 && < 1.4, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, pretty >= 1.0.1.2 && < 1.2, - newtype >= 0.2 && < 0.3, fingertree >= 0.1 && < 0.2, - intervals >= 0.2.2 && < 0.3 + intervals >= 0.3 && < 0.5, + lens >= 3.9 && < 3.11, + tagged >= 0.7, + optparse-applicative >= 0.7 && < 0.8, + filepath, + safe >= 0.2 && < 0.4 Hs-source-dirs: src default-language: Haskell2010 diff --git a/diagrams/besideEx.svg b/diagrams/besideEx.svg deleted file mode 100644 --- a/diagrams/besideEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/closeLineEx.svg b/diagrams/closeLineEx.svg deleted file mode 100644 --- a/diagrams/closeLineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/cubicOffsetExample.svg b/diagrams/cubicOffsetExample.svg deleted file mode 100644 --- a/diagrams/cubicOffsetExample.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/cubicSplineEx.svg b/diagrams/cubicSplineEx.svg deleted file mode 100644 --- a/diagrams/cubicSplineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/decagonEx.svg b/diagrams/decagonEx.svg deleted file mode 100644 --- a/diagrams/decagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramA.svg b/diagrams/diagramA.svg deleted file mode 100644 --- a/diagrams/diagramA.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramNeg.svg b/diagrams/diagramNeg.svg deleted file mode 100644 --- a/diagrams/diagramNeg.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramPos.svg b/diagrams/diagramPos.svg deleted file mode 100644 --- a/diagrams/diagramPos.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/diagramZero.svg b/diagrams/diagramZero.svg deleted file mode 100644 --- a/diagrams/diagramZero.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/dodecagonEx.svg b/diagrams/dodecagonEx.svg deleted file mode 100644 --- a/diagrams/dodecagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/glueLineEx.svg b/diagrams/glueLineEx.svg deleted file mode 100644 --- a/diagrams/glueLineEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hendecagonEx.svg b/diagrams/hendecagonEx.svg deleted file mode 100644 --- a/diagrams/hendecagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hexagonEx.svg b/diagrams/hexagonEx.svg deleted file mode 100644 --- a/diagrams/hexagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/hruleEx.svg b/diagrams/hruleEx.svg deleted file mode 100644 --- a/diagrams/hruleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/lineFromOffsetsEx.svg b/diagrams/lineFromOffsetsEx.svg deleted file mode 100644 --- a/diagrams/lineFromOffsetsEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/lineFromVerticesEx.svg b/diagrams/lineFromVerticesEx.svg deleted file mode 100644 --- a/diagrams/lineFromVerticesEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/nonagonEx.svg b/diagrams/nonagonEx.svg deleted file mode 100644 --- a/diagrams/nonagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/octagonEx.svg b/diagrams/octagonEx.svg deleted file mode 100644 --- a/diagrams/octagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/pentagonEx.svg b/diagrams/pentagonEx.svg deleted file mode 100644 --- a/diagrams/pentagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/rectEx.svg b/diagrams/rectEx.svg deleted file mode 100644 --- a/diagrams/rectEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/roundedRectEx.svg b/diagrams/roundedRectEx.svg deleted file mode 100644 --- a/diagrams/roundedRectEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/septagonEx.svg b/diagrams/septagonEx.svg deleted file mode 100644 --- a/diagrams/septagonEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/squareEx.svg b/diagrams/squareEx.svg deleted file mode 100644 --- a/diagrams/squareEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/src_Diagrams_Combinators_appendsEx.svg b/diagrams/src_Diagrams_Combinators_appendsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_appendsEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Combinators_besideEx.svg b/diagrams/src_Diagrams_Combinators_besideEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_besideEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Combinators_positionEx.svg b/diagrams/src_Diagrams_Combinators_positionEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_positionEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Combinators_strutEx.svg b/diagrams/src_Diagrams_Combinators_strutEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_strutEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg b/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TrailLike_twiddleEx.svg b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TrailLike_twiddleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Trail_closeLineEx.svg b/diagrams/src_Diagrams_Trail_closeLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_closeLineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Trail_glueLineEx.svg b/diagrams/src_Diagrams_Trail_glueLineEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_glueLineEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_Trail_trailOffsetEx.svg b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_Trail_trailOffsetEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example1.svg b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrow_example1.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrow_example2.svg b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrow_example2.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg @@ -0,0 +1,4 @@ + + +LineCapSquareLineCapRoundLineCapButt diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg @@ -0,0 +1,4 @@ + + +LineJoinBevelLineJoinRoundLineJoinMiter diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg new file mode 100644 --- /dev/null +++ b/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg @@ -0,0 +1,4 @@ + + + diff --git a/diagrams/trailOffsetEx.svg b/diagrams/trailOffsetEx.svg deleted file mode 100644 --- a/diagrams/trailOffsetEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/triangleEx.svg b/diagrams/triangleEx.svg deleted file mode 100644 --- a/diagrams/triangleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/unitSquareEx.svg b/diagrams/unitSquareEx.svg deleted file mode 100644 --- a/diagrams/unitSquareEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/diagrams/vruleEx.svg b/diagrams/vruleEx.svg deleted file mode 100644 --- a/diagrams/vruleEx.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -21,69 +21,134 @@ ( -- * Alignable class Alignable(..) - , alignByDefault + , alignBy'Default + , envelopeBoundary + , traceBoundary -- * General alignment functions , align + , snug , center + , snugBy + , snugCenter ) where import Diagrams.Core -import Data.AffineSpace (alerp) +import Data.AffineSpace (alerp, (.-.)) import Data.VectorSpace +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Foldable as F -- | Class of things which can be aligned. class Alignable a where -- | @alignBy v d a@ moves the origin of @a@ along the vector -- @v@. If @d = 1@, the origin is moved to the edge of the - -- envelope in the direction of @v@; if @d = -1@, it moves to the - -- edge of the envelope in the direction of the negation of @v@. + -- boundary in the direction of @v@; if @d = -1@, it moves to the + -- edge of the boundary in the direction of the negation of @v@. -- Other values of @d@ interpolate linearly (so for example, @d = -- 0@ centers the origin along the direction of @v@). - alignBy :: V a -> Scalar (V a) -> a -> a + alignBy' :: ( HasOrigin a, AdditiveGroup (V a), Num (Scalar (V a)) + , Fractional (Scalar (V a))) + => (V a -> a -> Point (V a)) -> V a -> Scalar (V a) -> a -> a + alignBy' = alignBy'Default + defaultBoundary :: V a -> a -> Point (V a) + + alignBy :: (HasOrigin a, Num (Scalar (V a)), Fractional (Scalar (V a))) + => V a -> Scalar (V a) -> a -> a + alignBy = alignBy' defaultBoundary + -- | Default implementation of 'alignBy' for types with 'HasOrigin' --- and 'Enveloped' instances. -alignByDefault :: (HasOrigin a, Enveloped a, Num (Scalar (V a))) - => V a -> Scalar (V a) -> a -> a -alignByDefault v d a = moveOriginTo (alerp (envelopeP (negateV v) a) - (envelopeP v a) - ((d + 1) / 2)) - a +-- and 'AdditiveGroup' instances. +alignBy'Default :: ( HasOrigin a, AdditiveGroup (V a), Num (Scalar (V a)) + , Fractional (Scalar (V a))) + => (V a -> a -> Point (V a)) -> V a -> Scalar (V a) -> a -> a +alignBy'Default boundary v d a = moveOriginTo (alerp (boundary (negateV v) a) + (boundary v a) + ((d + 1) / 2)) a +-- | Some standard functions which can be used as the `boundary` argument to +-- `alignBy'`. +envelopeBoundary :: Enveloped a => V a -> a -> Point (V a) +envelopeBoundary = envelopeP + +traceBoundary :: Traced a => V a -> a -> Point (V a) +traceBoundary v a = fromMaybe origin (maxTraceP origin v a) + +combineBoundaries + :: (F.Foldable f, InnerSpace (V a), Ord (Scalar (V a))) + => (V a -> a -> Point (V a)) -> (V a -> f a -> Point (V a)) +combineBoundaries b v fa + = b v $ F.maximumBy (comparing (magnitudeSq . (.-. origin) . b v)) fa + instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Envelope v) where - alignBy = alignByDefault + defaultBoundary = envelopeBoundary -instance (Enveloped b, HasOrigin b) => Alignable [b] where - alignBy = alignByDefault +instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Trace v) where + defaultBoundary = traceBoundary -instance (Enveloped b, HasOrigin b, Ord b) => Alignable (S.Set b) where - alignBy = alignByDefault +instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) + => Alignable [b] where + defaultBoundary = combineBoundaries defaultBoundary -instance (Enveloped b, HasOrigin b) => Alignable (M.Map k b) where - alignBy = alignByDefault +instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) + => Alignable (S.Set b) where + defaultBoundary = combineBoundaries defaultBoundary +instance (InnerSpace (V b), Ord (Scalar (V b)), Alignable b) + => Alignable (M.Map k b) where + defaultBoundary = combineBoundaries defaultBoundary + instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) , Monoid' m ) => Alignable (QDiagram b v m) where - alignBy = alignByDefault + defaultBoundary = envelopeBoundary +-- | Although the 'alignBy' method for the @(b -> a)@ instance is +-- sensible, there is no good implementation for +-- 'defaultBoundary'. Instead, we provide a total method, but one that +-- is not sensible. This should not present a serious problem as long +-- as your use of 'Alignable' happens through 'alignBy'. +instance (HasOrigin a, Alignable a) => Alignable (b -> a) where + alignBy v d f b = alignBy v d (f b) + defaultBoundary _ _ = origin + -- | @align v@ aligns an enveloped object along the edge in the -- direction of @v@. That is, it moves the local origin in the -- direction of @v@ until it is on the edge of the envelope. (Note -- that if the local origin is outside the envelope to begin with, -- it may have to move \"backwards\".) -align :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a +align :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) + , Fractional (Scalar (V a))) => V a -> a -> a align v = alignBy v 1 +-- | Version of @alignBy@ specialized to use @traceBoundary@ +snugBy :: (Alignable a, Traced a, HasOrigin a, Num (Scalar (V a)), Fractional (Scalar (V a))) + => V a -> Scalar (V a) -> a -> a +snugBy = alignBy' traceBoundary + +-- | Like align but uses trace. +snug :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) + => V a -> a -> a +snug v = snugBy v 1 + -- | @center v@ centers an enveloped object along the direction of -- @v@. -center :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a +center :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) + , Fractional (Scalar (V a))) => V a -> a -> a center v = alignBy v 0 + +-- | Like @center@ using trace. +snugCenter + :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) + => V a -> a -> a +snugCenter v = (alignBy' traceBoundary) v 0 + diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -109,7 +109,8 @@ -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. -animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) +animRect :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2 + , Monoid' m) => QAnimation b R2 m -> t animRect = animRect' 30 @@ -117,7 +118,8 @@ -- parameter is the number of samples per time unit to use. Lower -- rates will be faster but less accurate; higher rates are more -- accurate but slower. -animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) +animRect' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2 + , Monoid' m) => Rational -> QAnimation b R2 m -> t animRect' r anim | null results = rect 1 1 diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -39,9 +39,7 @@ import Control.Applicative (pure, (<$>)) -import Diagrams.Align import Diagrams.Core -import Diagrams.Path import Diagrams.TrailLike import Data.Active @@ -97,5 +95,5 @@ ) a1 -instance Alignable a => Alignable (Active a) where - alignBy v d a = alignBy v d <$> a +--instance Alignable a => Alignable (Active a) where +-- alignBy v d a = alignBy v d <$> a diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable - , ExistentialQuantification - , GeneralizedNewtypeDeriving - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -26,13 +25,13 @@ -- * Color -- $color - Color(..), SomeColor(..) + Color(..), SomeColor(..), someToAlpha -- ** Line color - , LineColor, getLineColor, lineColor, lineColorA, lc, lcA + , LineColor, getLineColor, mkLineColor, styleLineColor, lineColor, lineColorA, lc, lcA -- ** Fill color - , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA + , FillColor, getFillColor, mkFillColor, styleFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity @@ -58,19 +57,19 @@ ) where -import Diagrams.Core - -import Data.Default.Class - +import Control.Lens (Setter, sets) import Data.Colour import Data.Colour.RGBSpace -import Data.Colour.SRGB (sRGBSpace) - -import Data.Typeable - +import Data.Colour.SRGB (sRGBSpace) +import Data.Default.Class +import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup +import Data.Typeable +import Diagrams.Core +import Diagrams.Core.Style (setAttr) + ------------------------------------------------------------ -- Color ------------------------------------------------- ------------------------------------------------------------ @@ -88,13 +87,21 @@ -- both the 'Data.Colour.Colour' and 'Data.Colour.AlphaColour' types -- from the "Data.Colour" library. class Color c where - -- | Convert a color to its standard representation, AlphaColour + -- | Convert a color to its standard representation, AlphaColour. toAlphaColour :: c -> AlphaColour Double + -- | Convert from an AlphaColour Double. Note that this direction + -- may lose some information. For example, the instance for + -- 'Colour' drops the alpha channel. + fromAlphaColour :: AlphaColour Double -> c + -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c deriving Typeable +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@. @@ -105,18 +112,33 @@ instance AttributeClass LineColor instance Default LineColor where - def = LineColor (Last (SomeColor black)) + 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 . LineColor . Last . SomeColor +lineColor = applyAttr . mkLineColor -- | Apply a 'lineColor' attribute. lineColorA :: HasStyle a => LineColor -> a -> a @@ -141,12 +163,30 @@ 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 . FillColor . Commit . Last . SomeColor +fillColor = applyAttr . mkFillColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. @@ -167,19 +207,24 @@ fcA = fillColor instance (Floating a, Real a) => Color (Colour a) where - toAlphaColour = opaque . colourConvert + toAlphaColour = opaque . colourConvert + fromAlphaColour = colourConvert . (`over` black) instance (Floating a, Real a) => Color (AlphaColour a) where - toAlphaColour = alphaColourConvert + toAlphaColour = alphaColourConvert + fromAlphaColour = alphaColourConvert instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c + fromAlphaColour c = SomeColor c instance Color LineColor where - toAlphaColour (LineColor (Last c)) = toAlphaColour c + 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 an RGB space while preserving the alpha channel. toRGBAUsingSpace :: Color c => RGBSpace Double -> c diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Backend/CmdLine.hs @@ -0,0 +1,534 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Backend.CmdLine +-- Copyright : (c) 2013 Diagrams team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Convenient creation of command-line-driven executables for +-- rendering diagrams. This module provides a general framework +-- and default behaviors for parsing command-line arguments, +-- records for diagram creation options in various forms, and +-- classes and instances for a unified entry point to command-line-driven +-- diagram creation executables. +-- +-- For a tutorial on command-line diagram creation see +-- . +-- +----------------------------------------------------------------------------- + +module Diagrams.Backend.CmdLine + ( + + -- * Options + + -- ** Standard options + DiagramOpts(..) + , diagramOpts + , width + , height + , output + + -- ** Multi-diagram options + , DiagramMultiOpts(..) + , diagramMultiOpts + , selection + , list + + -- ** Animation options + , DiagramAnimOpts(..) + , diagramAnimOpts + , fpu + + -- ** Loop options + , DiagramLoopOpts(..) + , diagramLoopOpts + , loop + , src + , interval + + -- * Parsing + , Parseable(..) + , readHexColor + + -- * Command-line programs (@Mainable@) + -- ** Arguments, rendering, and entry point + , Mainable(..) + + -- ** General currying + , ToResult(..) + + -- ** Default @mainRender@ implementations + , defaultAnimMainRender + , defaultMultiMainRender + ) where + +import Control.Lens hiding (argument) +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Core hiding (value) + +import Options.Applicative hiding ((&)) + +import Prelude + +import Control.Monad (forM_) + +import Data.Active hiding (interval) +import Data.Char (isDigit) +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Data +import Data.List (intercalate) +import Data.Monoid + +import Numeric + +import Safe (readMay) + +import System.Environment (getProgName) +import System.FilePath (addExtension, splitExtension) + +import Text.Printf + +-- | Standard options most diagrams are likely to have. +data DiagramOpts = DiagramOpts + { _width :: Maybe Int -- ^ Final output width of diagram. + , _height :: Maybe Int -- ^ Final output height of diagram. + , _output :: FilePath -- ^ Output file path, format is typically chosen by extension. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramOpts + +-- | Extra options for a program that can offer a choice +-- between multiple diagrams. +data DiagramMultiOpts = DiagramMultiOpts + { _selection :: Maybe String -- ^ Selected diagram to render. + , _list :: Bool -- ^ Flag to indicate that a list of available diagrams should + -- be printed to standard out. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramMultiOpts + +-- | Extra options for animations. +data DiagramAnimOpts = DiagramAnimOpts + { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation. + } + deriving (Show, Data, Typeable) + +makeLenses ''DiagramAnimOpts + +-- | Extra options for command-line looping. +data DiagramLoopOpts = DiagramLoopOpts + { _loop :: Bool -- ^ Flag to indicate that the program should loop creation. + , _src :: Maybe FilePath -- ^ File path for the source file to recompile. + , _interval :: Int -- ^ Interval in seconds at which to check for recompilation. + } + +makeLenses ''DiagramLoopOpts + +-- | Command line parser for 'DiagramOpts'. +-- Width is option @--width@ or @-w@. +-- Height is option @--height@ or @-h@ (note we change help to be @-?@ due to this). +-- Output is option @--output@ or @-o@. +diagramOpts :: Parser DiagramOpts +diagramOpts = DiagramOpts + <$> (optional . option) + ( long "width" <> short 'w' + <> metavar "WIDTH" + <> help "Desired WIDTH of the output image") + <*> (optional . option) + ( long "height" <> short 'h' + <> metavar "HEIGHT" + <> help "Desired HEIGHT of the output image") + <*> strOption + ( long "output" <> short 'o' + <> value "" + <> metavar "OUTPUT" + <> help "OUTPUT file") + +-- | Command line parser for 'DiagramMultiOpts'. +-- Selection is option @--selection@ or @-s@. +-- List is @--list@ or @-l@. +diagramMultiOpts :: Parser DiagramMultiOpts +diagramMultiOpts = DiagramMultiOpts + <$> (optional . strOption) + ( long "selection" <> short 's' + <> metavar "NAME" + <> help "NAME of the diagram to render") + <*> switch + ( long "list" <> short 'l' + <> help "List all available diagrams") + +-- | Command line parser for 'DiagramAnimOpts' +-- Frames per unit is @--fpu@ or @-f@. +diagramAnimOpts :: Parser DiagramAnimOpts +diagramAnimOpts = DiagramAnimOpts + <$> option + ( long "fpu" <> short 'f' + <> value 30.0 + <> help "Frames per unit time (for animations)") + +-- | CommandLine parser for 'DiagramLoopOpts' +-- Loop is @--loop@ or @-l@. +-- Source is @--src@ or @-s@. +-- Interval is @-i@ defaulting to one second. +diagramLoopOpts :: Parser DiagramLoopOpts +diagramLoopOpts = DiagramLoopOpts + <$> switch (long "loop" <> short 'l' <> help "Run in a self-recompiling loop") + <*> (optional . strOption) + ( long "src" <> short 's' + <> help "Source file to watch") + <*> option + ( long "interval" <> short 'i' + <> value 1 + <> metavar "INTERVAL" + <> help "When running in a loop, check for changes every INTERVAL seconds.") + +-- | A hidden \"helper\" option which always fails. +-- Taken from Options.Applicative.Extra but without the +-- short option 'h'. We want the 'h' for Height. +helper' :: Parser (a -> a) +helper' = abortOption ShowHelpText $ mconcat + [ long "help" + , short '?' + , help "Show this help text" + ] + +-- | Apply a parser to the command line that includes the standard +-- program description and help behavior. Results in parsed commands +-- or fails with a help message. +defaultOpts :: Parser a -> IO a +defaultOpts optsParser = do + prog <- getProgName + let p = info (helper' <*> optsParser) + ( fullDesc + <> progDesc "Command-line diagram generation." + <> header prog) + execParser p + +-- | Parseable instances give a command line parser for a type. If a custom +-- parser for a common type is wanted a newtype wrapper could be used to make +-- a new 'Parseable' instance. Notice that we do /not/ want as many +-- instances as 'Read' because we want to limit ourselves to things that make +-- sense to parse from the command line. +class Parseable a where + parser :: Parser a + +-- The following instance would overlap with the product instance for +-- Parseable. We can't tell if one wants to parse (a,b) as one argument or a +-- as one argument and b as another. Since this is the command line we almost +-- certainly want the latter. So we need to have less Read instances. +-- +-- instance Read a => Parseable a where +-- parser = argument readMay mempty + +-- | Parse 'Int' according to its 'Read' instance. +instance Parseable Int where + parser = argument readMay mempty + +-- | Parse 'Double' according to its 'Read' instance. +instance Parseable Double where + parser = argument readMay mempty + +-- | Parse a string by just accepting the given string. +instance Parseable String where + parser = argument Just mempty + +-- | Parse 'DiagramOpts' using the 'diagramOpts' parser. +instance Parseable DiagramOpts where + parser = diagramOpts + +-- | Parse 'DiagramMultiOpts' using the 'diagramMultiOpts' parser. +instance Parseable DiagramMultiOpts where + parser = diagramMultiOpts + +-- | Parse 'DiagramAnimOpts' using the 'diagramAnimOpts' parser. +instance Parseable DiagramAnimOpts where + parser = diagramAnimOpts + +-- | Parse 'DiagramLoopOpts' using the 'diagramLoopOpts' parser. +instance Parseable DiagramLoopOpts where + parser = diagramLoopOpts + + +-- | Parse @'Colour' Double@ as either a named color from "Data.Colour.Names" +-- or a hexadecimal color. +instance Parseable (Colour Double) where + parser = argument (liftA2 (<|>) rc rh) mempty + where + rh s = (f . colorToSRGBA) <$> readHexColor s + rc s = readColourName s + f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha + -- value be applied to the r g b values? + +-- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names" +-- or a hexadecimal color. +instance Parseable (AlphaColour Double) where + parser = argument (liftA2 (<|>) rc rh) mempty + where + rh s = readHexColor s + rc s = opaque <$> readColourName s + +-- Addapted from the Clay.Color module of the clay package + +-- | Parses a hexadecimal color. The string can start with @\"0x\"@ or @\"#\"@ +-- or just be a string of hexadecimal values. If four or three digits are +-- given each digit is repeated to form a full 24 or 32 bit color. For +-- example, @\"0xfc4\"@ is the same as @\"0xffcc44\"@. When eight or six +-- digits are given each pair of digits is a color or alpha channel with the +-- order being red, green, blue, alpha. +readHexColor :: String -> Maybe (AlphaColour Double) +readHexColor cs = case cs of + ('0':'x':hs) -> handle hs + ('#':hs) -> handle hs + hs -> handle hs + where + handle hs | length hs <= 8 && all isHexDigit hs + = case hs of + [a,b,c,d,e,f,g,h] -> withOpacity <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) <*> hex g h + [a,b,c,d,e,f ] -> opaque <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) + [a,b,c,d ] -> withOpacity <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) <*> hex d d + [a,b,c ] -> opaque <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) + _ -> Nothing + handle _ = Nothing + + isHexDigit c = isDigit c|| c `elem` "abcdef" + + hex a b = (/ 255) <$> case readHex [a,b] of + [(h,"")] -> Just h + _ -> Nothing + + +-- | This instance is needed to signal the end of a chain of +-- nested tuples, it always just results in the unit value +-- without consuming anything. +instance Parseable () where + parser = pure () + +-- | Allow 'Parseable' things to be combined. +instance (Parseable a, Parseable b) => Parseable (a,b) where + parser = (,) <$> parser <*> parser + + +-- | This class allows us to abstract over functions that take some arguments +-- and produce a final value. When some @d@ is an instance of +-- 'ToResult' we get a type @'Args' d@ that is a type of /all/ the arguments +-- at once, and a type @'ResultOf' d@ that is the type of the final result from +-- some base case instance. +class ToResult d where + type Args d :: * + type ResultOf d :: * + + toResult :: d -> Args d -> ResultOf d + +-- | A diagram can always produce a diagram when given @()@ as an argument. +-- This is our base case. +instance ToResult (Diagram b v) where + type Args (Diagram b v) = () + type ResultOf (Diagram b v) = Diagram b v + + toResult d _ = d + +-- | A list of diagrams can produce pages. +instance ToResult [Diagram b v] where + type Args [Diagram b v] = () + type ResultOf [Diagram b v] = [Diagram b v] + + toResult ds _ = ds + +-- | A list of named diagrams can give the multi-diagram interface. +instance ToResult [(String,Diagram b v)] where + type Args [(String,Diagram b v)] = () + type ResultOf [(String,Diagram b v)] = [(String,Diagram b v)] + + toResult ds _ = ds + +-- | An animation is another suitable base case. +instance ToResult (Animation b v) where + type Args (Animation b v) = () + type ResultOf (Animation b v) = Animation b v + + toResult a _ = a + +-- | Diagrams that require IO to build are a base case. +instance ToResult d => ToResult (IO d) where + type Args (IO d) = Args d + type ResultOf (IO d) = IO (ResultOf d) + + toResult d args = flip toResult args <$> d + +-- | An instance for a function that, given some 'a', can produce a 'd' that is +-- also an instance of 'ToResult'. For this to work we need both the +-- argument 'a' and all the arguments that 'd' will need. Producing the +-- result is simply applying the argument to the producer and passing the +-- remaining arguments to the produced producer. + +-- The previous paragraph stands as a witness to the fact that Haskell code +-- is clearer and easier to understand then paragraphs in English written by +-- me. +instance ToResult d => ToResult (a -> d) where + type Args (a -> d) = (a, Args d) + type ResultOf (a -> d) = ResultOf d + + toResult f (a,args) = toResult (f a) args + + +-- | This class represents the various ways we want to support diagram creation +-- from the command line. It has the right instances to select between creating +-- single static diagrams, multiple static diagrams, static animations, and +-- functions that produce diagrams as long as the arguments are 'Parseable'. +-- +-- Backends are expected to create @Mainable@ instances for the types that are +-- suitable for generating output in the backend's format. For instance, +-- Postscript can handle single diagrams, pages of diagrams, animations as +-- separate files, and association lists. This implies instances for +-- @Diagram Postscript R2@, @[Diagram Postscript R2]@, @Animation Postscript R2@, +-- and @[(String,Diagram Postscript R2)]@. We can consider these as the base +-- cases for the function instance. +-- +-- The associated type 'MainOpts' describes the options which need to be parsed +-- from the command-line and passed to @mainRender@. +class Mainable d where + -- | Associated type that describes the options which need to be parsed + -- from the command-line and passed to @mainRender@. + type MainOpts d :: * + + -- | This method invokes the command-line parser resulting in an options + -- value or ending the program with an error or help message. + -- Typically the default instance will work. If a different help message + -- or parsing behavior is desired a new implementation is appropriate. + -- + -- Note the @d@ argument should only be needed to fix the type @d@. Its + -- value should not be relied on as a parameter. + mainArgs :: Parseable (MainOpts d) => d -> IO (MainOpts d) + mainArgs _ = defaultOpts parser + + -- | Backend specific work of rendering with the given options and mainable + -- value is done here. All backend instances should implement this method. + mainRender :: MainOpts d -> d -> IO () + + -- | Main entry point for command-line diagram creation. This is the method + -- that users will call from their program @main@. For instance an expected + -- user program would take the following form. + -- + -- > import Diagrams.Prelude + -- > import Diagrams.Backend.TheBestBackend.CmdLine + -- > + -- > d :: Diagram B R2 + -- > d = ... + -- > + -- > main = mainWith d + -- + -- Most backends should be able to use the default implementation. A different + -- implementation should be used to handle more complex interactions with the user. + mainWith :: Parseable (MainOpts d) => d -> IO () + mainWith d = do + opts <- mainArgs d + mainRender opts d + +-- | This instance allows functions resulting in something that is 'Mainable' to +-- be 'Mainable'. It takes a parse of collected arguments and applies them to +-- the given function producing the 'Mainable' result. +instance (Parseable (Args (a -> d)), ToResult d, Mainable (ResultOf d)) + => Mainable (a -> d) where + type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d)) + + mainRender (opts, a) f = mainRender opts (toResult f a) +-- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ... +-- Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ? + +-- | With this instance we can perform IO to produce something +-- 'Mainable' before rendering. +instance Mainable d => Mainable (IO d) where + type MainOpts (IO d) = MainOpts d + + mainRender opts dio = dio >>= mainRender opts + +-- | @defaultMultiMainRender@ is an implementation of 'mainRender' where +-- instead of a single diagram it takes a list of diagrams paired with names +-- as input. The generated executable then takes a @--selection@ option +-- specifying the name of the diagram that should be rendered. The list of +-- available diagrams may also be printed by passing the option @--list@. +-- +-- Typically a backend can write its @[(String,Diagram B V)]@ instance as +-- +-- > 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. +defaultMultiMainRender :: Mainable d => (MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO () +defaultMultiMainRender (opts,multi) ds = + if multi^.list + then showDiaList (map fst ds) + else case multi^.selection of + Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds) + Just sel -> case lookup sel ds of + Nothing -> putStrLn $ "Unknown diagram: " ++ sel + Just d -> mainRender opts d + +-- | Display the list of diagrams available for rendering. +showDiaList :: [String] -> IO () +showDiaList ds = do + putStrLn "Available diagrams:" + putStrLn $ " " ++ intercalate " " ds + +-- | @defaultAnimMainRender@ is an implementation of 'mainRender' which renders +-- an animation as numbered frames, named by extending the given output file +-- name by consecutive integers. For example if the given output file name is +-- @foo\/blah.ext@, the frames will be saved in @foo\/blah001.ext@, +-- @foo\/blah002.ext@, and so on (the number of padding digits used depends on +-- the total number of frames). It is up to the user to take these images and +-- stitch them together into an actual animation format (using, /e.g./ +-- @ffmpeg@). +-- +-- Of course, this is a rather crude method of rendering animations; +-- more sophisticated methods will likely be added in the future. +-- +-- The @fpu@ option from 'DiagramAnimOpts' can be used to control how many frames will +-- be output for each second (unit time) of animation. +-- +-- This function requires a lens into the structure that the particular backend +-- uses for it's diagram base case. If @MainOpts (Diagram b v) ~ DiagramOpts@ +-- then this lens will simply be 'output'. For a backend supporting looping +-- it will most likely be @_1 . output@. This lens is required because the +-- implementation works by modifying the output field and running the base @mainRender@. +-- Typically a backend can write its @Animation B V@ instance as +-- +-- > instance Mainable (Animation B V) where +-- > type MainOpts (Animation B V) = (DiagramOpts, DiagramAnimOpts) +-- > mainRender = defaultAnimMainRender output +-- +-- We do not provide this instance in general so that backends can choose to +-- opt-in to this form or provide a different instance that makes more sense. +defaultAnimMainRender :: (Mainable (Diagram b v)) + => (Lens' (MainOpts (Diagram b v)) FilePath) -- ^ A lens into the output path. + -> (MainOpts (Diagram b v),DiagramAnimOpts) + -> Animation b v + -> IO () +defaultAnimMainRender out (opts,animOpts) anim = do + let frames = simulate (toRational $ animOpts^.fpu) anim + nDigits = length . show . length $ frames + forM_ (zip [1..] frames) $ \(i,d) -> mainRender (indexize out nDigits i opts) d + +-- | @indexize d n@ adds the integer index @n@ to the end of the +-- output file name, padding with zeros if necessary so that it uses +-- at least @d@ digits. +indexize :: Lens' s FilePath -> Int -> Integer -> s -> s +indexize out nDigits i opts = opts & out .~ output' + where fmt = "%0" ++ show nDigits ++ "d" + output' = addExtension (base ++ printf fmt (i::Integer)) ext + (base, ext) = splitExtension (opts^.out) diff --git a/src/Diagrams/Backend/Show.hs b/src/Diagrams/Backend/Show.hs --- a/src/Diagrams/Backend/Show.hs +++ b/src/Diagrams/Backend/Show.hs @@ -19,7 +19,6 @@ import Diagrams.Core.Transform (onBasis) import Diagrams.Prelude -import Diagrams.Trail import Data.Basis diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE DeriveDataTypeable - , DeriveFunctor - , FlexibleContexts - , GeneralizedNewtypeDeriving - , NoMonomorphismRestriction - , ScopedTypeVariables - , StandaloneDeriving - , TypeFamilies - , UndecidableInstances - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox @@ -42,28 +41,29 @@ , union, intersection ) where -import Control.Applicative ((<$>)) -import Control.Monad (join, liftM2) -import Data.Map (Map, fromList, toList, fromDistinctAscList, toAscList) -import qualified Data.Foldable as F +import Control.Applicative ((<$>)) +import qualified Data.Foldable as F +import Data.Map (Map, fromDistinctAscList, fromList, + toAscList, toList) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) -import Data.VectorSpace +import Data.VectorSpace -- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) -import Data.Basis (HasBasis, Basis, decompose, recompose, basisValue) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..), Option(..)) +import Data.Basis (Basis, HasBasis, basisValue, + decompose, recompose) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Option (..), Semigroup (..)) -import Data.Data (Data) -import Data.Typeable (Typeable) +import Data.Data (Data) +import Data.Typeable (Typeable) -import Diagrams.Core.Points (Point(..)) -import Diagrams.Core.HasOrigin (HasOrigin(..)) -import Diagrams.Core.Envelope (Enveloped(..), appEnvelope) -import Diagrams.Core.V (V) -import Diagrams.Core.Transform - (Transformation(..), Transformable(..), HasLinearMap, (<->)) +import Diagrams.Core.Envelope (Enveloped (..), appEnvelope) +import Diagrams.Core.HasOrigin (HasOrigin (..)) +import Diagrams.Core.Points (Point (..)) +import Diagrams.Core.Transform (HasLinearMap, Transformable (..), + Transformation (..), (<->)) +import Diagrams.Core.V (V) -- Unexported utility newtype @@ -128,7 +128,7 @@ -} -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't --- require the same type constraints that the @Monoid@ +-- require the same type constraints that the @Monoid@ emptyBox :: BoundingBox v emptyBox = BoundingBox $ Option Nothing @@ -182,7 +182,7 @@ getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) = map (P . recompose) - -- Enumerate all combinations of selections of lower / higher values. + -- Enumerate all combinations of selections of lower / higher values. . mapM (\(b, (l', u')) -> [(b, l'), (b, u')]) -- List of [(basis, (lower, upper))] . toList @@ -194,7 +194,7 @@ boxExtents = maybe zeroV (\(P l, P h) -> h ^-^ l) . getCorners -- | Create a transformation mapping points from one bounding box to the other. -boxTransform :: (AdditiveGroup v, HasLinearMap v, +boxTransform :: (AdditiveGroup v, HasLinearMap v, Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v)) => BoundingBox v -> BoundingBox v -> Maybe (Transformation v) boxTransform u v = do diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -29,22 +31,26 @@ -- * n-ary operations , appends , position, decorateTrail, decorateLocatedTrail, decoratePath - , cat, cat', CatOpts(..), CatMethod(..) + , cat, cat' + , CatOpts(_catMethod, _sep), catMethod, sep + , CatMethod(..) ) where +import Control.Lens ( (&), (%~), (.~), Lens', makeLensesWith + , lensRules, lensField, generateSignatures, unwrapping) import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class +import Data.Proxy import Data.Semigroup import Data.VectorSpace import Diagrams.Core import Diagrams.Located import Diagrams.Path -import Diagrams.Segment (Segment (..), straight) +import Diagrams.Segment (straight) import Diagrams.Trail (Trail, trailVertices) -import Diagrams.TrailLike (fromOffsets) import Diagrams.Util ------------------------------------------------------------ @@ -53,6 +59,17 @@ -- | Use the envelope from some object as the envelope for a -- diagram, in place of the diagram's default envelope. +-- +-- <> +-- +-- > sqNewEnv = +-- > circle 1 # fc green +-- > ||| +-- > ( c # dashing [0.1,0.1] 0 # lc white +-- > <> square 2 # withEnvelope (c :: D R2) # fc blue +-- > ) +-- > c = circle 0.8 +-- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 withEnvelope :: (HasLinearMap (V a), Enveloped a, Monoid' m) => a -> QDiagram b (V a) m -> QDiagram b (V a) m withEnvelope = setEnvelope . getEnvelope @@ -87,6 +104,10 @@ -- with a nonempty trace see 'strutR2', 'strutX', and 'strutY' from -- "Diagrams.TwoD.Combinators".) Useful for manually creating -- separation between two diagrams. +-- +-- <> +-- +-- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 strut :: ( Backend b v, InnerSpace v , OrderedField (Scalar v) , Monoid' m @@ -135,7 +156,7 @@ :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m -deformEnvelope s v d = setEnvelope (inEnvelope deform $ getEnvelope d) d +deformEnvelope s v d = setEnvelope (getEnvelope d & unwrapping Envelope %~ deform) d where deform = Option . fmap deform' . getOption deform' env v' @@ -167,7 +188,7 @@ -- identity element, in which case the second object is returned -- unchanged). -- --- <> +-- <> -- -- > besideEx = beside (r2 (20,30)) -- > (circle 1 # fc orange) @@ -203,12 +224,24 @@ -- @x@ in the corresponding direction. Note that each object in -- @ys@ is positioned beside @x@ /without/ reference to the other -- objects in @ys@, so this is not the same as iterating 'beside'. +-- +-- <> +-- +-- > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c)) +-- > # centerXY # pad 1.1 +-- > where c = circle 1 appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in -- the vector space of the combined object. +-- +-- <> +-- +-- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat dot)) +-- > where dot = circle 0.2 # fc black +-- > mkPoint x = p2 (x,x^2) position :: (HasOrigin a, Monoid' a) => [(Point (V a), a)] -> a position = mconcat . map (uncurry moveTo) @@ -257,36 +290,48 @@ -- of separation, diagrams may overlap. -- | Options for 'cat''. -data CatOpts v = CatOpts { catMethod :: CatMethod - -- ^ Which 'CatMethod' should be used: - -- normal catenation (default), or - -- distribution? - , sep :: Scalar v - -- ^ How much separation should be used - -- between successive diagrams - -- (default: 0)? When @catMethod = - -- Cat@, this is the distance between - -- /envelopes/; when @catMethod = - -- Distrib@, this is the distance - -- between /origins/. - , catOptsvProxy__ :: Proxy v - -- ^ This field exists solely to aid type inference; - -- please ignore it. +data CatOpts v = CatOpts { _catMethod :: CatMethod + , _sep :: Scalar v + , _catOptsvProxy__ :: Proxy v } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a --- CatOpts record. This causes problems when writing an expression --- like @with { sep = 10 }@, because knowing the type of the whole +-- CatOpts record. This causes problems when using record update, as +-- in @with { _sep = 10 }@, because knowing the type of the whole -- expression does not tell us anything about the type of @with@, and -- therefore the @Num (Scalar v)@ constraint cannot be satisfied. --- Adding the Proxy field constrains the type of @with@ in @with {sep --- = 10}@ to be the same as the type of the whole expression. +-- Adding the Proxy field constrains the type of @with@ in @with {_sep +-- = 10}@ to be the same as the type of the whole expression. Note +-- this is not a problem when using the 'sep' lens, as its type is +-- more restricted. +makeLensesWith + ( lensRules + -- don't make a lens for the proxy field + & lensField .~ (\label -> + case label of + "_catOptsvProxy__" -> Nothing + _ -> Just (drop 1 label) + ) + & generateSignatures .~ False + ) + ''CatOpts + +-- | Which 'CatMethod' should be used: +-- normal catenation (default), or distribution? +catMethod :: forall v. Lens' (CatOpts v) CatMethod + +-- | How much separation should be used between successive diagrams +-- (default: 0)? When @catMethod = Cat@, this is the distance between +-- /envelopes/; when @catMethod = Distrib@, this is the distance +-- between /origins/. +sep :: forall v. Lens' (CatOpts v) (Scalar v) + instance Num (Scalar v) => Default (CatOpts v) where - def = CatOpts { catMethod = Cat - , sep = 0 - , catOptsvProxy__ = Proxy + def = CatOpts { _catMethod = Cat + , _sep = 0 + , _catOptsvProxy__ = Proxy } -- | @cat v@ positions a list of objects so that their local origins @@ -324,9 +369,9 @@ , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> CatOpts (V a) -> [a] -> a -cat' v (CatOpts { catMethod = Cat, sep = s }) = foldB comb mempty +cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) vs = s *^ normalized (negateV v) -cat' v (CatOpts { catMethod = Distrib, sep = s }) = +cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = position . zip (iterate (.+^ (s *^ normalized v)) origin) diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -10,17 +10,20 @@ -- Nice syntax for constructing and pattern-matching on literal -- points and vectors. -- --- NOTE: to avoid clashing with the '(&)' operator from the @lens@ --- package, this module is not re-exported by "Diagrams.Prelude". To --- make use of the contents of this module, you must explicitly import --- it. --- ----------------------------------------------------------------------------- module Diagrams.Coordinates - ( (:&)(..), Coordinates(..) ) + ( (:&)(..), Coordinates(..) + + -- * Lenses for particular axes + , HasX(..), HasY(..), HasZ(..) + ) where +import Control.Lens (Lens') + +import Diagrams.Core.Points + -- | A pair of values, with a convenient infix (left-associative) -- data constructor. data a :& b = a :& b @@ -30,8 +33,8 @@ -- | Types which are instances of the @Coordinates@ class can be --- constructed using '&' (for example, a three-dimensional vector --- could be constructed by @1 & 6 & 3@), and deconstructed using +-- constructed using '^&' (for example, a three-dimensional vector +-- could be constructed by @1 ^& 6 ^& 3@), and deconstructed using -- 'coords'. A common pattern is to use 'coords' in conjunction -- with the @ViewPatterns@ extension, like so: -- @@ -53,21 +56,25 @@ -- | Construct a value of type @c@ by providing something of one -- less dimension (which is perhaps itself recursively constructed - -- using @(&)@) and a final coordinate. For example, + -- using @(^&)@) and a final coordinate. For example, -- -- @ - -- 2 & 3 :: P2 - -- 3 & 5 & 6 :: R3 + -- 2 ^& 3 :: P2 + -- 3 ^& 5 ^& 6 :: R3 -- @ -- - -- Note that @&@ is left-associative. - (&) :: PrevDim c -> FinalCoord c -> c + -- Note that @^&@ is left-associative. + (^&) :: PrevDim c -> FinalCoord c -> c + -- | Prefix synonym for @^&@. pr stands for pair of @PrevDim@, @FinalCoord@ + pr :: PrevDim c -> FinalCoord c -> c + pr = (^&) + -- | Decompose a value of type @c@ into its constituent coordinates, -- stored in a nested @(:&)@ structure. coords :: c -> Decomposition c -infixl 7 & +infixl 7 ^& -- Some standard instances for plain old tuples @@ -76,7 +83,7 @@ type PrevDim (a,b) = a type Decomposition (a,b) = a :& b - x & y = (x,y) + x ^& y = (x,y) coords (x,y) = x :& y instance Coordinates (a,b,c) where @@ -84,7 +91,7 @@ type PrevDim (a,b,c) = (a,b) type Decomposition (a,b,c) = Decomposition (a,b) :& c - (x,y) & z = (x,y,z) + (x,y) ^& z = (x,y,z) coords (x,y,z) = coords (x,y) :& z instance Coordinates (a,b,c,d) where @@ -92,5 +99,25 @@ type PrevDim (a,b,c,d) = (a,b,c) type Decomposition (a,b,c,d) = Decomposition (a,b,c) :& d - (w,x,y) & z = (w,x,y,z) + (w,x,y) ^& z = (w,x,y,z) coords (w,x,y,z) = coords (w,x,y) :& z + +instance Coordinates v => Coordinates (Point v) where + type FinalCoord (Point v) = FinalCoord v + type PrevDim (Point v) = PrevDim v + type Decomposition (Point v) = Decomposition v + + x ^& y = P (x ^& y) + coords (P v) = coords v + +-- | The class of types with at least one coordinate, called _x. +class HasX t where + _x :: Lens' t Double + +-- | The class of types with at least two coordinates, the second called _y. +class HasY t where + _y :: Lens' t Double + +-- | The class of types with at least three coordinates, the third called _z. +class HasZ t where + _z :: 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 @@ -26,9 +26,7 @@ import Diagrams.Core import Diagrams.Core.Points import Diagrams.CubicSpline.Internal -import Diagrams.Located (at) -import Diagrams.Located -import Diagrams.Path +import Diagrams.Located (Located, at, mapLoc) import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) @@ -36,15 +34,14 @@ -- for e.g. the Fractional (Double, Double) instance import Data.NumInstances.Tuple () -import Control.Newtype -import Data.Semigroup +import Data.AffineSpace.Point import Data.VectorSpace -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first -- argument specifies whether the path should be closed. -- --- <> +-- <> -- -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] -- > dot = circle 0.2 # fc blue # lw 0 @@ -55,12 +52,12 @@ -- -- For more information, see . cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t -cubicSpline c [] = trailLike . closeIf c $ emptyLine `at` origin -cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . map unpack $ ps +cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin +cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map unPoint $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) - = trailLike . closeIf c $ lineFromSegments (map bez bs) `at` P b + = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) closeIf :: (InnerSpace v, OrderedField (Scalar v)) diff --git a/src/Diagrams/Located.hs b/src/Diagrams/Located.hs --- a/src/Diagrams/Located.hs +++ b/src/Diagrams/Located.hs @@ -2,7 +2,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located @@ -20,15 +19,17 @@ module Diagrams.Located ( Located - , at, viewLoc, unLoc, loc, mapLoc + , at, viewLoc, unLoc, loc, mapLoc, located ) where +import Control.Lens (Lens) import Data.AffineSpace +import Data.Functor ((<$>)) import Data.VectorSpace import Diagrams.Core -import Diagrams.Core.Points +import Diagrams.Core.Points () import Diagrams.Core.Transform import Diagrams.Parametric -- for GHC 7.4 type family bug @@ -84,6 +85,10 @@ mapLoc :: (V a ~ V b) => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) +-- | A lens giving access to the object within a 'Located' wrapper. +located :: (V a ~ V a') => Lens (Located a) (Located a') a a' +located f (Loc p a) = Loc p <$> f a + deriving instance (Eq (V a), Eq a ) => Eq (Located a) deriving instance (Ord (V a), Ord a ) => Ord (Located a) deriving instance (Show (V a), Show a) => Show (Located a) @@ -120,16 +125,18 @@ instance Qualifiable a => Qualifiable (Located a) where n |> (Loc p a) = Loc p (n |> a) -type instance Codomain (Located a) = Located (Codomain a) +type instance Codomain (Located a) = Point (Codomain a) -instance (V a ~ V (Codomain a), Parametric a) => Parametric (Located a) where - (Loc x a) `atParam` p = Loc x (a `atParam` p) +instance (Codomain a ~ V a, AdditiveGroup (V a), Parametric a) + => Parametric (Located a) where + (Loc x a) `atParam` p = x .+^ (a `atParam` p) instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a -instance (V a ~ V (Codomain a), EndValues a) => EndValues (Located a) +instance (Codomain a ~ V a, AdditiveGroup (V a), EndValues a) + => EndValues (Located a) instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) , Sectionable a, Parametric a @@ -138,7 +145,12 @@ splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p -instance (HasArcLength a, Fractional (Scalar (V a)), V a ~ V (Codomain a)) + reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) + where y = a `atParam` (domainUpper a) + +instance ( Codomain a ~ V a, AdditiveGroup (V a), Fractional (Scalar (V a)) + , HasArcLength a + ) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l diff --git a/src/Diagrams/Names.hs b/src/Diagrams/Names.hs --- a/src/Diagrams/Names.hs +++ b/src/Diagrams/Names.hs @@ -33,6 +33,7 @@ -- * Querying by name , names + , lookupName , withName, withNameAll, withNames ) where diff --git a/src/Diagrams/Parametric.hs b/src/Diagrams/Parametric.hs --- a/src/Diagrams/Parametric.hs +++ b/src/Diagrams/Parametric.hs @@ -15,22 +15,15 @@ ----------------------------------------------------------------------------- module Diagrams.Parametric ( - -- * Parametric functions stdTolerance , Codomain, Parametric(..) - , DomainBounds(..), EndValues(..), Sectionable(..), HasArcLength(..) - - -- * Adjusting - , adjust - , AdjustOpts(..), AdjustMethod(..), AdjustSide(..) + , DomainBounds(..), domainBounds, EndValues(..), Sectionable(..), HasArcLength(..) ) where import Diagrams.Core -import Diagrams.Util -import Data.Default.Class import Data.VectorSpace import qualified Numeric.Interval as I @@ -96,7 +89,8 @@ -- | Type class for parametric objects which can be split into -- subobjects. -- --- Minimal definition: Either 'splitAtParam' or 'section'. +-- Minimal definition: Either 'splitAtParam' or 'section', +-- plus 'reverseDomain'. class DomainBounds p => Sectionable p where -- | 'splitAtParam' splits an object @p@ into two new objects -- @(l,r)@ at the parameter @t@, where @l@ corresponds to the @@ -139,12 +133,8 @@ default section :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) -> p section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) - -- | Flip the parameterization on the domain. This has the - -- following default definition: - -- - -- > reverse x = section x (domainUpper x) (domainLower x) + -- | Flip the parameterization on the domain. reverseDomain :: p -> p - reverseDomain x = section x (domainUpper x) (domainLower x) -- | The standard tolerance used by @std...@ functions (like -- 'stdArcLength' and 'stdArcLengthToParam', currently set at @@ -187,57 +177,3 @@ default stdArcLengthToParam :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) stdArcLengthToParam = arcLengthToParam stdTolerance - --------------------------------------------------- --- Adjusting length --------------------------------------------------- - --- | What method should be used for adjusting a segment, trail, or --- path? -data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value - -- (use a negative parameter to shrink) - | ByAbsolute (Scalar v) -- ^ Extend by the given arc length - -- (use a negative length to shrink) - | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given - -- arc length - --- | Which side of a segment, trail, or path should be adjusted? -data AdjustSide = Start -- ^ Adjust only the beginning - | End -- ^ Adjust only the end - | Both -- ^ Adjust both sides equally - deriving (Show, Read, Eq, Ord, Bounded, Enum) - --- | How should a segment, trail, or path be adjusted? -data AdjustOpts v = AO { adjMethod :: AdjustMethod v - , adjSide :: AdjustSide - , adjEps :: Scalar v - , adjOptsvProxy__ :: Proxy v - } - -instance Fractional (Scalar v) => Default (AdjustMethod v) where - def = ByParam 0.2 - -instance Default AdjustSide where - def = Both - -instance Fractional (Scalar v) => Default (AdjustOpts v) where - def = AO def def stdTolerance Proxy - --- | Adjust the length of a parametric object such as a segment or --- trail. The second parameter is an option record which controls how --- the adjustment should be performed; see 'AdjustOpts'. -adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) - => a -> AdjustOpts (V a) -> a -adjust s opts = section s - (if adjSide opts == End then domainLower s else getParam s) - (if adjSide opts == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) - where - getParam seg = case adjMethod opts of - ByParam p -> -p * bothCoef - ByAbsolute len -> param (-len * bothCoef) - ToAbsolute len -> param (absDelta len * bothCoef) - where - param = arcLengthToParam eps seg - absDelta len = arcLength eps s - len - bothCoef = if adjSide opts == Both then 0.5 else 1 - eps = adjEps opts diff --git a/src/Diagrams/Parametric/Adjust.hs b/src/Diagrams/Parametric/Adjust.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Parametric/Adjust.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Parametric.Adjust +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Tools for adjusting the length of parametric objects such as +-- segments and trails. +-- +----------------------------------------------------------------------------- +module Diagrams.Parametric.Adjust + ( adjust + , AdjustOpts(_adjMethod, _adjSide, _adjEps) + , adjMethod, adjSide, adjEps + , AdjustMethod(..), AdjustSide(..) + + ) where + +import Control.Lens (makeLensesWith, lensRules, lensField, generateSignatures, (^.), (&), (.~), Lens') +import Data.Proxy + +import Data.Default.Class +import Data.VectorSpace + +import Diagrams.Core.V +import Diagrams.Parametric + +-- | What method should be used for adjusting a segment, trail, or +-- path? +data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value + -- (use a negative parameter to shrink) + | ByAbsolute (Scalar v) -- ^ Extend by the given arc length + -- (use a negative length to shrink) + | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given + -- arc length + +-- | Which side of a segment, trail, or path should be adjusted? +data AdjustSide = Start -- ^ Adjust only the beginning + | End -- ^ Adjust only the end + | Both -- ^ Adjust both sides equally + deriving (Show, Read, Eq, Ord, Bounded, Enum) + +-- | How should a segment, trail, or path be adjusted? +data AdjustOpts v = AO { _adjMethod :: AdjustMethod v + , _adjSide :: AdjustSide + , _adjEps :: Scalar v + , _adjOptsvProxy__ :: Proxy v + } + +makeLensesWith + ( lensRules + -- don't make a lens for the proxy field + & lensField .~ (\label -> + case label of + "_adjOptsvProxy__" -> Nothing + _ -> Just (drop 1 label) + ) + & generateSignatures .~ False + ) + ''AdjustOpts + +-- | Which method should be used for adjusting? +adjMethod :: Lens' (AdjustOpts v) (AdjustMethod v) + +-- | Which end(s) of the object should be adjusted? +adjSide :: Lens' (AdjustOpts v) AdjustSide + +-- | Tolerance to use when doing adjustment. +adjEps :: Lens' (AdjustOpts v) (Scalar v) + +instance Fractional (Scalar v) => Default (AdjustMethod v) where + def = ByParam 0.2 + +instance Default AdjustSide where + def = Both + +instance Fractional (Scalar v) => Default (AdjustOpts v) where + def = AO def def stdTolerance Proxy + +-- | Adjust the length of a parametric object such as a segment or +-- trail. The second parameter is an option record which controls how +-- the adjustment should be performed; see 'AdjustOpts'. +adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) + => a -> AdjustOpts (V a) -> a +adjust s opts = section s + (if opts^.adjSide == End then domainLower s else getParam s) + (if opts^.adjSide == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) + where + getParam seg = case opts^.adjMethod of + ByParam p -> -p * bothCoef + ByAbsolute len -> param (-len * bothCoef) + ToAbsolute len -> param (absDelta len * bothCoef) + where + param = arcLengthToParam eps seg + absDelta len = arcLength eps s - len + bothCoef = if opts^.adjSide == Both then 0.5 else 1 + eps = opts^.adjEps diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -28,7 +29,7 @@ -- * Paths - Path(..) + Path(..), pathTrails -- * Constructing paths -- $construct @@ -58,7 +59,7 @@ import Diagrams.Align import Diagrams.Core -import Diagrams.Core.Points +import Diagrams.Core.Points () import Diagrams.Located import Diagrams.Points import Diagrams.Segment @@ -66,11 +67,12 @@ import Diagrams.TrailLike import Diagrams.Transform -import Control.Arrow (first, second, (***)) -import Control.Newtype hiding (under) +import Control.Arrow ((***)) +import Control.Lens ( Wrapped(..), mapped, over, view, iso + , unwrapped, wrapped, (%~), op) import Data.AffineSpace import qualified Data.Foldable as F -import Data.List (mapAccumL, partition) +import Data.List (partition) import Data.Semigroup import Data.VectorSpace @@ -82,21 +84,25 @@ -- Hence, unlike trails, paths are not translationally invariant, -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. -newtype Path v = Path { pathTrails :: [Located (Trail v)] } +newtype Path v = Path [Located (Trail v)] deriving (Semigroup, Monoid) +instance Wrapped [Located (Trail v)] [Located (Trail v')] (Path v) (Path v') + where wrapped = iso Path $ \(Path x) -> x + +-- | Extract the located trails making up a 'Path'. +pathTrails :: Path v -> [Located (Trail v)] +pathTrails = op Path + deriving instance Show v => Show (Path v) deriving instance Eq v => Eq (Path v) deriving instance Ord v => Ord (Path v) type instance V (Path v) = v -instance Newtype (Path v) [Located (Trail v)] where - pack = Path - unpack = pathTrails - instance VectorSpace v => HasOrigin (Path v) where - moveOriginTo = over Path . map . moveOriginTo + moveOriginTo = over unwrapped . map . moveOriginTo + --moveOriginTo = over pathTrails . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. @@ -106,7 +112,7 @@ -- See Note [Transforming paths] instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Path v) where - transform = over Path . map . transform + transform = over unwrapped . map . transform {- ~~~~ Note [Transforming paths] @@ -121,7 +127,7 @@ 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 . pathTrails + getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 where trailEnvelope :: Located (Trail v) -> Envelope v trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) @@ -130,7 +136,7 @@ juxtapose = juxtaposeDefault instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where - alignBy = alignByDefault + defaultBoundary = envelopeBoundary instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Renderable (Path v) NullBackend where @@ -166,11 +172,11 @@ -- | Extract the vertices of a path, resulting in a separate list of -- vertices for each component trail (see 'trailVertices'). pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] -pathVertices = map trailVertices . pathTrails +pathVertices = map trailVertices . op Path -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] -pathOffsets = map (trailOffset . unLoc) . pathTrails +pathOffsets = map (trailOffset . unLoc) . op Path -- | Compute the /centroid/ of a path (/i.e./ the average location of -- its vertices). @@ -179,18 +185,18 @@ -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] -fixPath = map fixTrail . unpack +fixPath = map fixTrail . op Path -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] -explodePath = map explodeTrail . pathTrails +explodePath = map explodeTrail . op Path -- | Partition a path into two paths based on a predicate on trails: -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) -partitionPath p = (pack *** pack) . partition p . unpack +partitionPath p = (view wrapped *** view wrapped) . partition p . op Path ------------------------------------------------------------ -- Modifying paths --------------------------------------- @@ -204,4 +210,4 @@ -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v -reversePath = (over Path . map) reverseLocTrail +reversePath = unwrapped . mapped %~ reverseLocTrail diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -19,26 +19,18 @@ -- * Point-related utilities , centroid + , pointDiagram ) where -import Diagrams.Coordinates +import Diagrams.Core (pointDiagram) import Diagrams.Core.Points -import Control.Newtype - -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&)) +import Data.AffineSpace.Point import Data.VectorSpace -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v -centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack - -instance Coordinates v => Coordinates (Point v) where - type FinalCoord (Point v) = FinalCoord v - type PrevDim (Point v) = PrevDim v - type Decomposition (Point v) = Decomposition v - - x & y = P (x & y) - coords (P v) = coords v +centroid = P . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unPoint diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -41,6 +41,13 @@ -- | Parametrization of segments and trails. , module Diagrams.Parametric + -- | Adjusting the length of parameterized objects. + , module Diagrams.Parametric.Adjust + + -- | Computing tangent and normal vectors of segments and + -- trails. + , module Diagrams.Tangent + -- | Trail-like things. , module Diagrams.TrailLike @@ -54,10 +61,6 @@ -- conjugation of transformations. , module Diagrams.Transform - -- | Convenient definitions and utilities for working with - -- good old-fashioned, axis-aligned bounding boxes. - , module Diagrams.BoundingBox - -- | Giving names to subdiagrams and later retrieving -- subdiagrams by name. , module Diagrams.Names @@ -77,6 +80,9 @@ -- | Utilities for working with points. , module Diagrams.Points + -- | Convenience infix operators for working with coordinates. + , module Diagrams.Coordinates + -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional -- diagrams. @@ -104,6 +110,9 @@ -- | For working with 'Active' (i.e. animated) things. , module Data.Active + -- | Essential Lens Combinators + , (&), (.~), (%~) + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where @@ -112,7 +121,6 @@ import Diagrams.Align import Diagrams.Animation import Diagrams.Attributes -import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline @@ -120,10 +128,12 @@ import Diagrams.Located import Diagrams.Names import Diagrams.Parametric +import Diagrams.Parametric.Adjust import Diagrams.Path import Diagrams.Points import Diagrams.Query import Diagrams.Segment +import Diagrams.Tangent import Diagrams.Trace import Diagrams.Trail import Diagrams.TrailLike @@ -134,7 +144,8 @@ import Control.Applicative import Data.Active import Data.AffineSpace -import Data.Colour hiding (AffineSpace (..), atop) -import Data.Colour.Names +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) import Data.Semigroup -import Data.VectorSpace hiding (Sum (..)) +import Data.VectorSpace hiding (Sum (..)) +import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,6 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -54,16 +56,17 @@ -- $segmeas , SegCount(..) - , ArcLength(..), getArcLengthCached, getArcLengthFun, getArcLengthBounded + , ArcLength(..) + , getArcLengthCached, getArcLengthFun, getArcLengthBounded , TotalOffset(..) - , OffsetEnvelope(..) + , OffsetEnvelope(..), oeOffset, oeEnvelope , SegMeasure ) where +import Control.Lens (makeLenses, Wrapped(..), iso, op) import Control.Applicative (liftA2) import Data.AffineSpace -import Data.Default.Class import Data.FingerTree import Data.Monoid.MList import Data.Semigroup @@ -75,7 +78,6 @@ import Diagrams.Located import Diagrams.Parametric import Diagrams.Solve -import Diagrams.Util ------------------------------------------------------------ @@ -102,7 +104,7 @@ -- a fixed offset from its start. data Offset c v where OffsetOpen :: Offset Open v - OffsetClosed :: v -> Offset Closed v + OffsetClosed :: !v -> Offset Closed v deriving instance Show v => Show (Offset c v) deriving instance Eq v => Eq (Offset c v) @@ -129,10 +131,10 @@ -- however, affected by other transformations such as rotations and -- scales. data Segment c v - = Linear (Offset c v) + = Linear !(Offset c v) -- ^ A linear segment with given offset. - | Cubic v v (Offset c v) + | Cubic !v !v !(Offset c v) -- ^ A cubic Bézier segment specified by -- three offsets from the starting -- point to the first control point, @@ -231,7 +233,7 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> - maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] + maximum (map (\t -> ((s `atParam` t) <.> v)) [0,1]) / magnitudeSq v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . @@ -349,10 +351,10 @@ -- | Create a 'FixedSegment' from a located 'Segment'. mkFixedSeg :: AdditiveGroup v => Located (Segment Closed v) -> FixedSegment v -mkFixedSeg (viewLoc -> (p, Linear (OffsetClosed v))) - = FLinear p (p .+^ v) -mkFixedSeg (viewLoc -> (p, Cubic c1 c2 (OffsetClosed x2))) - = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) +mkFixedSeg ls = + case viewLoc ls of + (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) + (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. fromFixedSeg :: AdditiveGroup v => FixedSegment v -> Located (Segment Closed v) @@ -382,26 +384,37 @@ -- automatically track various monoidal \"measures\" on segments. -- | A type to track the count of segments in a 'Trail'. -newtype SegCount = SegCount { getSegCount :: Sum Int } +newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) +instance Wrapped (Sum Int) (Sum Int) SegCount SegCount + where wrapped = iso SegCount $ \(SegCount x) -> x + -- | A type to represent the total arc length of a chain of -- segments. The first component is a \"standard\" arc length, -- computed to within a tolerance of @10e-6@. The second component is -- a generic arc length function taking the tolerance as an -- argument. -newtype ArcLength v = ArcLength - { getArcLength :: (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) } +newtype ArcLength v + = ArcLength (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) + +instance (Scalar v ~ u, Scalar v' ~ u', u ~ u') => Wrapped + (Sum (Interval u), u -> Sum (Interval u )) + (Sum (Interval u'), u' -> Sum (Interval u')) + (ArcLength v) + (ArcLength v') + where wrapped = iso ArcLength $ \(ArcLength x) -> x + -- | Project out the cached arc length, stored together with error -- bounds. getArcLengthCached :: ArcLength v -> Interval (Scalar v) -getArcLengthCached = getSum . fst . getArcLength +getArcLengthCached = getSum . fst . op ArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. getArcLengthFun :: ArcLength v -> Scalar v -> Interval (Scalar v) -getArcLengthFun = fmap getSum . snd . getArcLength +getArcLengthFun = fmap getSum . snd . op ArcLength -- | Given a specified tolerance, project out the cached arc length if -- it is accurate enough; otherwise call the generic arc length @@ -418,8 +431,11 @@ -- | A type to represent the total cumulative offset of a chain of -- segments. -newtype TotalOffset v = TotalOffset { getTotalOffset :: v } +newtype TotalOffset v = TotalOffset v +instance Wrapped v v (TotalOffset v) (TotalOffset v) + where wrapped = iso TotalOffset $ \(TotalOffset x) -> x + instance AdditiveGroup v => Semigroup (TotalOffset v) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) @@ -432,15 +448,20 @@ -- combining the envelopes of two consecutive chains needs to take -- the offset of the the offset of the first into account. data OffsetEnvelope v = OffsetEnvelope - { oeOffset :: TotalOffset v - , oeEnvelope :: Envelope v + { _oeOffset :: !(TotalOffset v) + , _oeEnvelope :: Envelope v } +makeLenses ''OffsetEnvelope + instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) - = OffsetEnvelope - (o1 <> o2) - (e1 <> moveOriginBy (negateV . getTotalOffset $ o1) e2) + = let !negOff = negateV . op TotalOffset $ o1 + e2Off = moveOriginBy negOff e2 + !() = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + in OffsetEnvelope + (o1 <> o2) + (e1 <> e2Off) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. diff --git a/src/Diagrams/Tangent.hs b/src/Diagrams/Tangent.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Tangent.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Tangent +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Computing tangent and normal vectors for segments and trails. +-- +----------------------------------------------------------------------------- +module Diagrams.Tangent + ( tangentAtParam + , tangentAtStart + , tangentAtEnd + , normalAtParam + , normalAtStart + , normalAtEnd + , Tangent(..) + ) + where + +import Control.Lens (cloneIso, (^.)) + +import Data.VectorSpace +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TwoD.Types (R2) +import Diagrams.TwoD.Vector (perp) + +------------------------------------------------------------ +-- Tangent +------------------------------------------------------------ + +-- | A newtype wrapper used to give different instances of +-- 'Parametric' and 'EndValues' that compute tangent vectors. +newtype Tangent t = Tangent t + +type instance V (Tangent t) = V t + +instance DomainBounds t => DomainBounds (Tangent t) where + domainLower (Tangent t) = domainLower t + domainUpper (Tangent t) = domainUpper t + +type instance Codomain (Tangent (Located t)) = Codomain (Tangent t) + +instance Parametric (Tangent t) => Parametric (Tangent (Located t)) where + Tangent l `atParam` p = Tangent (unLoc l) `atParam` p + +instance (DomainBounds t, EndValues (Tangent t)) + => EndValues (Tangent (Located t)) where + atStart (Tangent l) = atStart (Tangent (unLoc l)) + atEnd (Tangent l) = atEnd (Tangent (unLoc l)) + +-- | Compute the tangent vector to a segment or trail at a particular +-- parameter. +-- +-- Examples of more specific types this function can have include +-- +-- * @Segment Closed R2 -> Double -> R2@ +-- +-- * @Trail' Line R2 -> Double -> R2@ +-- +-- * @Located (Trail R2) -> Double -> R2@ +-- +-- See the instances listed for the 'Tangent' newtype for more. +tangentAtParam :: Parametric (Tangent t) => t -> Scalar (V t) -> Codomain (Tangent t) +tangentAtParam t p = Tangent t `atParam` p + +-- | Compute the tangent vector at the start of a segment or trail. +tangentAtStart :: EndValues (Tangent t) => t -> Codomain (Tangent t) +tangentAtStart = atStart . Tangent + +-- | Compute the tangent vector at the end of a segment or trail. +tangentAtEnd :: EndValues (Tangent t) => t -> Codomain (Tangent t) +tangentAtEnd = atEnd . Tangent + +-------------------------------------------------- +-- Segment + +type instance Codomain (Tangent (Segment Closed v)) = Codomain (Segment Closed v) + +instance (VectorSpace v, Num (Scalar v)) + => Parametric (Tangent (Segment Closed v)) where + Tangent (Linear (OffsetClosed v)) `atParam` _ = v + Tangent (Cubic c1 c2 (OffsetClosed x2)) `atParam` p + = (3*(3*p*p-4*p+1))*^c1 ^+^ (3*(2-3*p)*p)*^c2 ^+^ (3*p*p)*^x2 + +instance (VectorSpace v, Num (Scalar v)) + => EndValues (Tangent (Segment Closed v)) where + atStart (Tangent (Linear (OffsetClosed v))) = v + atStart (Tangent (Cubic c1 _ _)) = c1 + atEnd (Tangent (Linear (OffsetClosed v))) = v + atEnd (Tangent (Cubic _ c2 (OffsetClosed x2))) = x2 ^-^ c2 + +-------------------------------------------------- +-- Trail' and Trail + +type instance Codomain (Tangent (Trail' c v)) = Codomain (Trail' c v) + +instance ( Parametric (GetSegment (Trail' c v)) + , VectorSpace v + , Num (Scalar v) + ) + => Parametric (Tangent (Trail' c v)) where + Tangent tr `atParam` p = + case GetSegment tr `atParam` p of + Nothing -> zeroV + Just (_, seg, reparam) -> Tangent seg `atParam` (p ^. cloneIso reparam) + +instance ( Parametric (GetSegment (Trail' c v)) + , EndValues (GetSegment (Trail' c v)) + , VectorSpace v + , Num (Scalar v) + ) + => EndValues (Tangent (Trail' c v)) where + atStart (Tangent tr) = + case atStart (GetSegment tr) of + Nothing -> zeroV + Just (_, seg, _) -> atStart (Tangent seg) + atEnd (Tangent tr) = + case atEnd (GetSegment tr) of + Nothing -> zeroV + Just (_, seg, _) -> atEnd (Tangent seg) + +type instance Codomain (Tangent (Trail v)) = Codomain (Trail v) + +instance ( InnerSpace v + , OrderedField (Scalar v) + , RealFrac (Scalar v) + ) + => Parametric (Tangent (Trail v)) where + Tangent tr `atParam` p + = withTrail + ((`atParam` p) . Tangent) + ((`atParam` p) . Tangent) + tr + +instance ( InnerSpace v + , OrderedField (Scalar v) + , RealFrac (Scalar v) + ) + => EndValues (Tangent (Trail v)) where + atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr + atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr + +------------------------------------------------------------ +-- Normal +------------------------------------------------------------ + +-- | Compute the (unit) normal vector to a segment or trail at a +-- particular parameter. +-- +-- Examples of more specific types this function can have include +-- +-- * @Segment Closed R2 -> Double -> R2@ +-- +-- * @Trail' Line R2 -> Double -> R2@ +-- +-- * @Located (Trail R2) -> Double -> P2@ +-- +-- See the instances listed for the 'Tangent' newtype for more. +normalAtParam + :: (Codomain (Tangent t) ~ R2, Parametric (Tangent t)) + => t -> Scalar (V t) -> R2 +normalAtParam t p = normize (t `tangentAtParam` p) + +-- | Compute the normal vector at the start of a segment or trail. +normalAtStart + :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t)) + => t -> R2 +normalAtStart = normize . tangentAtStart + +-- | Compute the normal vector at the end of a segment or trail. +normalAtEnd + :: (Codomain (Tangent t) ~ R2, EndValues (Tangent t)) + => t -> R2 +normalAtEnd = normize . tangentAtEnd + +-- | Construct a normal vector from a tangent. +normize :: R2 -> R2 +normize = negateV . perp . normalized diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module defines the three-dimensional vector space R^3, +-- three-dimensional transformations, and various predefined +-- three-dimensional shapes. This module re-exports useful +-- functionality from a group of more specific modules: +-- +-- * "Diagrams.ThreeD.Types" defines basic types for two-dimensional +-- diagrams, including types representing the 3D Euclidean vector +-- space and various systems of representing directions. +-- +-- * "Diagrams.ThreeD.Transform" defines R^3-specific transformations +-- such as rotation by an angle, and scaling, translation, and +-- reflection in the X, Y, and Z directions. +-- +-- * "Diagrams.ThreeD.Shapes" defines three-dimensional solids, +-- e.g. spheres and cubes. +-- +-- * "Diagrams.ThreeD.Vector" defines some special 3D vectors and +-- functions for converting between vectors and directions. +-- +-- * "Diagrams.ThreeD.Light" and "Diagrams.ThreeD.Camera" define types needed +-- for rendering 3D geometry to (2D) images. +----------------------------------------------------------------------------- +module Diagrams.ThreeD + ( module Diagrams.ThreeD.Types + , module Diagrams.ThreeD.Transform + , module Diagrams.ThreeD.Vector + , module Diagrams.ThreeD.Shapes + , module Diagrams.ThreeD.Light + , module Diagrams.ThreeD.Camera + ) where + + +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Vector +import Diagrams.ThreeD.Light +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Shapes diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Camera.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Camera +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Types to specify viewpoint for 3D rendering. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Camera + ( Camera -- do not export constructor + -- These are safe to construct manually + , PerspectiveLens(..), OrthoLens(..) + , horizontalFieldOfView, verticalFieldOfView + , orthoWidth, orthoHeight + , camLoc, camForward, camUp, camRight, camLens + , facing_ZCamera, mm50Camera + , mm50, mm50Wide, mm50Narrow + , aspect, camAspect + ) + where + +import Control.Lens (makeLenses) +import Data.Monoid +import Data.Cross + +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + +-- Parameterize Camera on the lens type, so that Backends can express which +-- lenses they handle. +data Camera l = Camera + { camLoc :: P3 + , forward :: R3 + , up :: R3 + , lens :: l + } + +class CameraLens l where + -- | The natural aspect ratio of the projection. + aspect :: l -> Double + +-- | A perspective projection +data PerspectiveLens = PerspectiveLens + { _horizontalFieldOfView :: Deg -- ^ Horizontal field of view. + , _verticalFieldOfView :: Deg -- ^ Vertical field of view. + } + +makeLenses ''PerspectiveLens + +instance CameraLens PerspectiveLens where + aspect (PerspectiveLens h v) = angleRatio h v + +-- | An orthographic projection +data OrthoLens = OrthoLens + { _orthoWidth :: Double -- ^ Width + , _orthoHeight :: Double -- ^ Height + } + +makeLenses ''OrthoLens + +instance CameraLens OrthoLens where + aspect (OrthoLens h v) = h / v + +type instance V (Camera l) = R3 + +instance Transformable (Camera l) where + transform t (Camera p f u l) = + Camera (transform t p) + (transform t f) + (transform t u) + l + +instance IsPrim (Camera l) + +instance Renderable (Camera l) NullBackend where + render _ _ = mempty + +-- | A camera at the origin facing along the negative Z axis, with its +-- up-axis coincident with the positive Y axis. The field of view is +-- chosen to match a 50mm camera on 35mm film. Note that Cameras take +-- up no space in the Diagram. +mm50Camera :: (Backend b R3, Renderable (Camera PerspectiveLens) b) => Diagram b R3 +mm50Camera = facing_ZCamera mm50 + +-- | 'facing_ZCamera l' is a camera at the origin facing along the +-- negative Z axis, with its up-axis coincident with the positive Y +-- axis, with the projection defined by l. +facing_ZCamera :: (CameraLens l, Backend b R3, Renderable (Camera l) b) => + l -> Diagram b R3 +facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) + mempty mempty mempty (Query . const . Any $ False) + +mm50, mm50Wide, mm50Narrow :: PerspectiveLens + +-- | mm50 has the field of view of a 50mm lens on standard 35mm film, +-- hence an aspect ratio of 3:2. +mm50 = PerspectiveLens 40.5 27 + +-- | mm50Wide has the same vertical field of view as mm50, but an +-- aspect ratio of 1.6, suitable for wide screen computer monitors. +mm50Wide = PerspectiveLens 43.2 27 + +-- | mm50Narrow has the same vertical field of view as mm50, but an +-- aspect ratio of 4:3, for VGA and similar computer resulotions. +mm50Narrow = PerspectiveLens 36 27 + +camForward :: Direction d => Camera l -> d +camForward = direction . forward + +camUp :: Direction d => Camera l -> d +camUp = direction . up + +camRight :: Direction d => Camera l -> d +camRight c = direction right where + right = cross3 (forward c) (up c) + +camLens :: Camera l -> l +camLens = lens + +camAspect :: CameraLens l => Camera l -> Double +camAspect = aspect . camLens diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Light.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Render +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Types to specify lighting for 3D rendering. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Light where + +import Data.Colour +import Data.Monoid + +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + +data PointLight = PointLight P3 (Colour Double) + +data ParallelLight = ParallelLight R3 (Colour Double) + +type instance V PointLight = R3 +type instance V ParallelLight = R3 + +instance Transformable PointLight where + transform t (PointLight p c) = PointLight (transform t p) c + +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) + => Colour Double -- ^ The color of the light + -> Diagram b R3 +pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty + (Query . const . Any $ False) + +-- | Construct a Diagram with a single ParallelLight, which takes up no space. +parallelLight :: (Direction d, Backend b R3, Renderable ParallelLight b) + => d -- ^ 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) + mempty mempty mempty (Query . const . Any $ False) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Transform.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Transform +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Transformations specific to three dimensions, with a few generic +-- transformations (uniform scaling, translation) also re-exported for +-- convenience. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Transform where + +import Diagrams.Core +import qualified Diagrams.Core.Transform as T + +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector +import Diagrams.Coordinates + +import Control.Lens ((*~), (//~)) +import Data.Semigroup + +import Data.AffineSpace +import Data.Cross +import Data.VectorSpace + +-- | Create a transformation which rotates by the given angle about +-- a line parallel the Z axis passing through the local origin. +-- A positive angle brings positive x-values towards the positive-y axis. +-- +-- The angle can be expressed using any type which is an +-- instance of 'Angle'. For example, @aboutZ (1\/4 :: +-- 'Turn')@, @aboutZ (tau\/4 :: 'Rad')@, and @aboutZ (90 :: +-- 'Deg')@ all represent the same transformation, namely, a +-- counterclockwise rotation by a right angle. For more general rotations, +-- see 'rotationAbout'. +-- +-- Note that writing @aboutZ (1\/4)@, with no type annotation, will +-- yield an error since GHC cannot figure out which sort of angle +-- you want to use. +aboutZ :: Angle a => a -> T3 +aboutZ ang = fromLinear r (linv r) where + r = rot theta <-> rot (-theta) + Rad theta = convertAngle ang + rot th (coords -> x :& y :& z) = (cos th * x - sin th * y) ^& + (sin th * x + cos th * y) ^& + z + +-- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values +-- towards the positive z-axis. +aboutX :: Angle a => a -> T3 +aboutX ang = fromLinear r (linv r) where + r = rot theta <-> rot (-theta) + Rad theta = convertAngle ang + rot th (coords -> x :& y :& z) = (x) ^& + (cos th * y - sin th * z) ^& + (sin th * y + cos th * z) + +-- | Like 'aboutZ', but rotates about the Y axis, bringing postive +-- x-values towards the negative z-axis. +aboutY :: Angle a => a -> T3 +aboutY ang = fromLinear r (linv r) where + r = rot theta <-> rot (-theta) + Rad theta = convertAngle ang + rot th (coords -> x :& y :& z) = (cos th * x + sin th * z) ^& + y ^& + (-sin th * x + cos th * z) + +-- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ +-- passing through @p@. +rotationAbout + :: (Angle a, Direction d) + => P3 -- ^ origin of rotation + -> d -- ^ direction of rotation axis + -> a -- ^ angle of rotation + -> T3 +rotationAbout p d a + = mconcat [translation (negateV t), + fromLinear r (linv r), + translation t] where + r = rot theta <-> rot (-theta) + Rad theta = convertAngle a + w = fromDirection d + rot :: Double -> R3 -> R3 + rot th v = v ^* cos th ^+^ + cross3 w v ^* sin th ^+^ + w ^* ((w <.> v) * (1 - cos th)) + t = p .-. origin + +-- | @pointAt about initial final@ produces a rotation which brings +-- the direction @initial@ to point in the direction @final@ by first +-- panning around @about@, then tilting about the axis perpendicular +-- to initial and final. In particular, if this can be accomplished +-- without tilting, it will be, otherwise if only tilting is +-- necessary, no panning will occur. The tilt will always be between +-- ± 1/4 turn. +pointAt :: Direction d => d -> d -> d -> T3 +pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) + +-- | pointAt' has the same behavior as 'pointAt', but takes vectors +-- instead of directions. +pointAt' :: R3 -> R3 -> R3 -> T3 +pointAt' about initial final = tilt <> pan where + inPanPlane = final ^-^ project final initial + panAngle = angleBetween initial inPanPlane :: Turn + pan = rotationAbout origin (direction about :: Spherical Turn) panAngle + tiltAngle = angleBetween initial inPanPlane :: Turn + tiltDir = direction $ cross3 inPanPlane about :: Spherical Turn + tilt = rotationAbout origin tiltDir tiltAngle + +-- Scaling ------------------------------------------------- + +-- | Construct a transformation which scales by the given factor in +-- the x direction. +scalingX :: Double -> T3 +scalingX c = fromLinear s s + where s = (_x *~ c) <-> (_x //~ c) + +-- | Scale a diagram by the given factor in the x (horizontal) +-- direction. To scale uniformly, use 'scale'. +scaleX :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleX = transform . scalingX + +-- | Construct a transformation which scales by the given factor in +-- the y direction. +scalingY :: Double -> T3 +scalingY c = fromLinear s s + where s = (_y *~ c) <-> (_y //~ c) + +-- | Scale a diagram by the given factor in the y (vertical) +-- direction. To scale uniformly, use 'scale'. +scaleY :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleY = transform . scalingY + +-- | Construct a transformation which scales by the given factor in +-- the z direction. +scalingZ :: Double -> T3 +scalingZ c = fromLinear s s + where s = (_z *~ c) <-> (_z //~ c) + +-- | Scale a diagram by the given factor in the z direction. To scale +-- uniformly, use 'scale'. +scaleZ :: (Transformable t, V t ~ R3) => Double -> t -> t +scaleZ = transform . scalingZ + +-- | Get the matrix equivalent of an affine transform, as a triple of +-- columns paired with the translation vector. This is mostly +-- useful for implementing backends. +onBasis :: T3 -> ((R3, R3, R3), R3) +onBasis t = ((x, y, z), v) + 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,10 +1,10 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -21,20 +21,39 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3, r3, unr3 - , P3, p3, unp3 + 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(..) + , Turn(Turn), asTurn + , CircleFrac + , Rad(Rad), asRad + , Deg(Deg), asDeg + + , fullTurn, convertAngle, angleRatio + + -- * Directions in 3D + , Direction(..) + , Spherical(..) + , asSpherical ) where -import Diagrams.Coordinates -import Diagrams.TwoD.Types -import Diagrams.Core +import Control.Applicative +import Control.Lens (Iso', iso, over, Wrapped, wrapped, _1, _2, _3) -import Control.Newtype +import Diagrams.Core +import Diagrams.TwoD.Types +import Diagrams.Coordinates -import Data.Basis -import Data.VectorSpace +import Data.AffineSpace.Point +import Data.Basis +import Data.Cross +import Data.VectorSpace ------------------------------------------------------------ -- 3D Euclidean space @@ -43,23 +62,31 @@ newtype R3 = R3 { unR3 :: (Double, Double, Double) } deriving (AdditiveGroup, Eq, Ord, Show, Read) -instance Newtype R3 (Double, Double, Double) where - pack = R3 - unpack = unR3 +r3Iso :: Iso' R3 (Double, Double, Double) +r3Iso = iso unR3 R3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 -r3 = pack +r3 = R3 +-- | Curried version of `r3`. +mkR3 :: Double -> Double -> Double -> R3 +mkR3 x y z = r3 (x, y, z) + -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) -unr3 = unpack +unr3 = unR3 +-- | Lens wrapped isomorphisms for R3. +instance Wrapped (Double, Double, Double) (Double, Double, Double) R3 R3 where + wrapped = iso r3 unr3 + {-# INLINE wrapped #-} + type instance V R3 = R3 instance VectorSpace R3 where type Scalar R3 = Double - (*^) = over R3 . (*^) + (*^) = over r3Iso . (*^) instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) @@ -75,7 +102,7 @@ type PrevDim R3 = R2 type Decomposition R3 = Double :& Double :& Double - (coords -> x :& y) & z = r3 (x,y,z) + (coords -> x :& y) ^& z = r3 (x,y,z) coords (unR3 -> (x,y,z)) = x :& y :& z -- | Points in R^3. @@ -83,15 +110,80 @@ -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 -p3 = pack . pack +p3 = P . R3 --- | Convert a 2D point back into a triple of coordinates. +-- | Convert a 3D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) -unp3 = unpack . unpack +unp3 = unR3 . unPoint +p3Iso :: Iso' P3 (Double, Double, Double) +p3Iso = iso unp3 p3 + +-- | Curried version of `r3`. +mkP3 :: Double -> Double -> Double -> P3 +mkP3 x y z = p3 (x, y, z) + -- | Transformations in R^3. type T3 = Transformation R3 instance Transformable R3 where transform = apply +instance HasCross3 R3 where + cross3 u v = r3 $ cross3 (unr3 u) (unr3 v) + +-------------------------------------------------------------------------------- +-- 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 polar angles + toSpherical :: Angle a => d -> Spherical a + + -- | Convert from polar angles + fromSpherical :: Angle a => Spherical a -> 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 a = Spherical a a + deriving (Show, Read, Eq) + +instance Applicative Spherical where + pure a = Spherical a a + Spherical a b <*> Spherical c d = Spherical (a c) (b d) + +instance Functor Spherical where + fmap f s = pure f <*> s + +instance (Angle a) => Direction (Spherical a) where + toSpherical = fmap convertAngle + fromSpherical = fmap convertAngle + +-- | 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 Turn -> Spherical Turn +asSpherical = id + +instance HasX R3 where + _x = r3Iso . _1 + +instance HasX P3 where + _x = p3Iso . _1 + +instance HasY R3 where + _y = r3Iso . _2 + +instance HasY P3 where + _y = p3Iso . _2 + +instance HasZ R3 where + _z = r3Iso . _3 + +instance HasZ P3 where + _z = p3Iso . _3 diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Vector.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts + , TypeFamilies + , ViewPatterns + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Vector +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Three-dimensional vectors. +-- +----------------------------------------------------------------------------- +module Diagrams.ThreeD.Vector + ( -- * Special 2D vectors + unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, + + -- * Converting between vectors and angles + direction, fromDirection, angleBetween, angleBetweenDirs + ) where + +import Control.Lens (op) +import Data.VectorSpace +import Data.Cross + +import Diagrams.ThreeD.Types +import Diagrams.Coordinates + + +-- | The unit vector in the positive X direction. +unitX :: R3 +unitX = 1 ^& 0 ^& 0 + +-- | The unit vector in the positive Y direction. +unitY :: R3 +unitY = 0 ^& 1 ^& 0 + +-- | The unit vector in the positive Z direction. +unitZ :: R3 +unitZ = 0 ^& 0 ^& 1 + +-- | The unit vector in the negative X direction. +unit_X :: R3 +unit_X = (-1) ^& 0 ^& 0 + +-- | The unit vector in the negative Y direction. +unit_Y :: R3 +unit_Y = 0 ^& (-1) ^& 0 + +-- | 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 + φ = Rad . asin $ z / r + θ = Rad . atan2 y $ x + zero = Rad $ 0 + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: Direction d => d -> R3 +fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where + θ = op Rad $ θ' + φ = op Rad $ φ' + x = cos θ * cos φ + y = sin θ * cos φ + z = sin φ + +-- | compute the positive angle between the two vectors in their common plane +angleBetween :: (Angle a, Num a, Ord a) => R3 -> R3 -> a +angleBetween v1 v2 = convertAngle . Rad $ + atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) + +-- | compute the positive angle between the two vectors in their common plane +angleBetweenDirs :: (Direction d, Angle a, Num a, Ord a) => d -> d -> a +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Trace.hs b/src/Diagrams/Trace.hs --- a/src/Diagrams/Trace.hs +++ b/src/Diagrams/Trace.hs @@ -27,24 +27,28 @@ ) where -import Diagrams.Core (HasLinearMap, Point, Subdiagram, - location, origin, setTrace, trace) +import Diagrams.Core (HasLinearMap, Point, Subdiagram + , location, origin, setTrace, trace + , OrderedField) import Diagrams.Core.Trace import Data.Maybe -import Data.VectorSpace (Scalar, negateV) +import Data.Semigroup +import Data.VectorSpace (Scalar, negateV, InnerSpace) import Diagrams.Combinators (withTrace) -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector. If there is no such -- point, the origin is returned; see also 'boundaryFromMay'. -boundaryFrom :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Point v +boundaryFrom :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Semigroup m) + => Subdiagram b v m -> v -> Point v boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector, or @Nothing@ if -- there is no such point. -boundaryFromMay :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Maybe (Point v) +boundaryFromMay :: (HasLinearMap v, OrderedField (Scalar v), Semigroup m, InnerSpace v) + => Subdiagram b v m -> v -> Maybe (Point v) boundaryFromMay s v = traceP (location s) (negateV v) s diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -7,10 +7,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- We have an orphan Transformable FingerTree instance here. + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trail @@ -91,9 +96,14 @@ , SegTree(..), trailMeasure, numSegs, offset + -- ** Extracting segments + + , GetSegment(..), getSegment + ) where import Control.Arrow ((***)) +import Control.Lens (AnIso', iso, view, op, Wrapped(..)) import Data.AffineSpace import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) @@ -137,19 +147,27 @@ -- also easily slice and dice them according to the measures -- (/e.g./, split off the smallest number of segments from the -- beginning which have a combined arc length of at least 5). -newtype SegTree v = SegTree - { getSegTree :: FingerTree (SegMeasure v) (Segment Closed v) } + +newtype SegTree v = SegTree (FingerTree (SegMeasure v) (Segment Closed v)) deriving (Eq, Ord, Show) +instance Wrapped (FingerTree (SegMeasure v) (Segment Closed v)) + (FingerTree (SegMeasure v) (Segment Closed v)) + (SegTree v) + (SegTree v) + where wrapped = iso SegTree $ \(SegTree x) -> x + type instance V (SegTree v) = v deriving instance (OrderedField (Scalar v), InnerSpace v) => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) -deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (SegTree v) where + transform t = SegTree . transform t . op SegTree + type instance Codomain (SegTree v) = v instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) @@ -181,7 +199,7 @@ | otherwise = case FT.viewl after of EmptyL -> emptySplit seg :< after' -> - case seg `splitAtParam` (snd . properFraction $ p * tSegs) of + case seg `splitAtParam` (snd . propFrac $ p * tSegs) of (seg1, seg2) -> ( SegTree $ before |> seg1 , SegTree $ seg2 <| after' ) @@ -190,6 +208,9 @@ tSegs = numSegs t emptySplit = (SegTree t, SegTree t) + reverseDomain (SegTree t) = SegTree $ FT.reverse t' + where t' = FT.fmap' reverseSegment t + -- XXX seems like it should be possible to collapse some of the -- above cases into one? @@ -220,7 +241,7 @@ in (p - 1)/tSegs + 1 | otherwise = case FT.viewl after of EmptyL -> 0 - seg :< after' -> + seg :< _ -> let p = arcLengthToParam (eps/2) seg (l - arcLength (eps/2) (SegTree before)) in (numSegs before + p) / tSegs @@ -248,14 +269,14 @@ FT.Measured (SegMeasure v) a ) => a -> c -numSegs = fromIntegral . trailMeasure 0 (getSum . getSegCount) +numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, FT.Measured (SegMeasure v) t ) => t -> v -offset = trailMeasure zeroV (getTotalOffset . oeOffset) +offset = trailMeasure zeroV (op TotalOffset . view oeOffset) ------------------------------------------------------------ -- Trails ------------------------------------------------ @@ -330,8 +351,8 @@ -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r -withTrail' line loop t@(Line{}) = line t -withTrail' line loop t@(Loop{}) = loop t +withTrail' line _ t@(Line{}) = line t +withTrail' _ loop t@(Loop{}) = loop t deriving instance Show v => Show (Trail' l v) deriving instance Eq v => Eq (Trail' l v) @@ -361,7 +382,7 @@ getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where ftEnv :: Trail' Line v -> Envelope v - ftEnv (Line t) = trailMeasure mempty oeEnvelope $ t + ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) $ t instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Renderable (Trail' o v) NullBackend where @@ -371,13 +392,22 @@ => Parametric (Trail' l v) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) - (\l -> cutLoop l `atParam` p') + (\l -> cutLoop l `atParam` mod1 p) t - where - pf = snd . properFraction $ p - p' | p >= 0 = pf - | otherwise = 1 + pf +-- | Compute the remainder mod 1. Convenient for constructing loop +-- parameterizations that wrap around. +mod1 :: RealFrac a => a -> a +mod1 p = p' + where + pf = snd . propFrac $ p + p' | p >= 0 = pf + | otherwise = 1 + pf + +-- Get rid of defaulting warnings +propFrac :: RealFrac a => a -> (Int, a) +propFrac = properFraction + instance Num (Scalar v) => DomainBounds (Trail' l v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) @@ -389,6 +419,8 @@ where (t1, t2) = splitAtParam t p + reverseDomain = reverseLine + instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail' l v) where arcLengthBounded eps = @@ -403,6 +435,137 @@ tr -------------------------------------------------- +-- Extracting segments + +-- | A newtype wrapper around trails which exists solely for its +-- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea +-- is that if @tr@ is a trail, you can write, /e.g./ +-- +-- @ +-- getSegment tr `atParam` 0.6 +-- @ +-- +-- or +-- +-- @ +-- atStart (getSegment tr) +-- @ +-- +-- to get the segment at parameter 0.6 or the first segment in the +-- trail, respectively. +-- +-- The codomain for 'GetSegment', /i.e./ the result you get from +-- calling 'atParam', 'atStart', or 'atEnd', is @Maybe (v, Segment +-- Closed v, AnIso' (Scalar v) (Scalar v))@. @Nothing@ results if +-- the trail is empty; otherwise, you get: +-- +-- * the offset from the start of the trail to the beginning of the +-- segment, +-- +-- * the segment itself, and +-- +-- * a reparameterization isomorphism: in the forward direction, it +-- translates from parameters on the whole trail to a parameters +-- on the segment. Note that for technical reasons you have to +-- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism +-- you can use. +newtype GetSegment t = GetSegment t + +-- | Create a 'GetSegment' wrapper around a trail, after which you can +-- call 'atParam', 'atStart', or 'atEnd' to extract a segment. +getSegment :: t -> GetSegment t +getSegment = GetSegment + +type instance V (GetSegment t) = V t +type instance Codomain (GetSegment t) + = Maybe + ( V t -- offset from trail start to segment start + , Segment Closed (V t) -- the segment + , AnIso' (Scalar (V t)) (Scalar (V t)) -- reparameterization, trail <-> segment + ) + +-- | Parameters less than 0 yield the first segment; parameters +-- greater than 1 yield the last. A parameter exactly at the +-- junction of two segments yields the second segment (/i.e./ the +-- one with higher parameter values). +instance (InnerSpace v, OrderedField (Scalar v)) + => Parametric (GetSegment (Trail' Line v)) where + atParam (GetSegment (Line (SegTree ft))) p + | p <= 0 + = case FT.viewl ft of + EmptyL -> Nothing + seg :< _ -> Just (zeroV, seg, reparam 0) + + | p >= 1 + = case FT.viewr ft of + EmptyR -> Nothing + ft' :> seg -> Just (offset ft', seg, reparam (n-1)) + + | otherwise + = let (before, after) = FT.split ((p*n <) . numSegs) $ ft + in case FT.viewl after of + EmptyL -> Nothing + seg :< _ -> Just (offset before, seg, reparam (numSegs before)) + where + n = numSegs ft + reparam k = iso (subtract k . (*n)) + ((/n) . (+ k)) + +-- | The parameterization for loops wraps around, /i.e./ parameters +-- are first reduced \"mod 1\". +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => Parametric (GetSegment (Trail' Loop v)) where + atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => Parametric (GetSegment (Trail v)) where + atParam (GetSegment t) p + = withTrail + ((`atParam` p) . GetSegment) + ((`atParam` p) . GetSegment) + t + +instance DomainBounds t => DomainBounds (GetSegment t) where + domainLower (GetSegment t) = domainLower t + domainUpper (GetSegment t) = domainUpper t + +instance (InnerSpace v, OrderedField (Scalar v)) + => EndValues (GetSegment (Trail' Line v)) where + atStart (GetSegment (Line (SegTree ft))) + = case FT.viewl ft of + EmptyL -> Nothing + seg :< _ -> + let n = numSegs ft + in Just (zeroV, seg, iso (*n) (/n)) + + atEnd (GetSegment (Line (SegTree ft))) + = case FT.viewr ft of + EmptyR -> Nothing + ft' :> seg -> + let n = numSegs ft + in Just (offset ft', seg, iso (subtract (n-1) . (*n)) + ((/n) . (+ (n-1))) + ) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => EndValues (GetSegment (Trail' Loop v)) where + atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) + atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) + +instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) + => EndValues (GetSegment (Trail v)) where + atStart (GetSegment t) + = withTrail + (\l -> atStart (GetSegment l)) + (\l -> atStart (GetSegment l)) + t + atEnd (GetSegment t) + = withTrail + (\l -> atEnd (GetSegment l)) + (\l -> atEnd (GetSegment l)) + t + +-------------------------------------------------- -- The Trail type -- | @Trail@ is a wrapper around @Trail'@, hiding whether the @@ -484,6 +647,8 @@ => Sectionable (Trail v) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t + reverseDomain = reverseTrail + instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail v) where arcLengthBounded = withLine . arcLengthBounded @@ -575,10 +740,10 @@ -- vectors, where each vector represents the offset from one vertex -- to the next. See also 'fromOffsets'. -- --- <> +-- <> -- -- > import Diagrams.Coordinates --- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 & 1, 2 & (-1), 2 & 0.5 ] +-- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] lineFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) => [v] -> Trail' Line v lineFromOffsets = lineFromSegments . map straight @@ -603,11 +768,11 @@ -- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' -- ('Trail' v)@. -- --- <> +-- <> -- -- > import Diagrams.Coordinates -- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine --- > $ lineFromVertices [origin, 0 & 1, 1 & 2, 5 & 1] +-- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1] lineFromVertices :: (InnerSpace v, OrderedField (Scalar v)) => [Point v] -> Trail' Line v lineFromVertices [] = emptyLine @@ -632,14 +797,13 @@ -- know happens to end where it starts, and then call 'glueLine' to -- turn it into a loop. -- --- <> +-- <> -- --- > import Diagrams.Coordinates --- > glueLineEx = pad 1.1 . hcat' with {sep = 1} +-- > glueLineEx = pad 1.1 . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] -- > -- > almostClosed :: Trail' Line R2 --- > almostClosed = fromOffsets [2 & (-1), (-3) & (-0.5), (-2) & 1, 1 & 0.5] +-- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)] -- -- @glueLine@ is left inverse to 'cutLoop', that is, -- @@ -677,9 +841,9 @@ -- closeLine . lineFromVertices $ ps -- @ -- --- <> +-- <> -- --- > closeLineEx = pad 1.1 . centerXY . hcat' with {sep = 1} +-- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] closeLine :: Trail' Line v -> Trail' Loop v closeLine (Line t) = Loop t (Linear OffsetOpen) @@ -707,7 +871,7 @@ (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where offV :: v - offV = negateV . trailMeasure zeroV (getTotalOffset . oeOffset) $ t + offV = negateV . trailMeasure zeroV (op TotalOffset .view oeOffset) $ t off = OffsetClosed offV -- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is @@ -770,7 +934,7 @@ -- -- but is more efficient. -- --- <> +-- <> -- -- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 -- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] @@ -790,7 +954,7 @@ -- there is no corresponding @loopOffset@ function because by -- definition it would be constantly zero.) lineOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v -lineOffset (Line t) = trailMeasure zeroV (getTotalOffset . oeOffset) t +lineOffset (Line t) = trailMeasure zeroV (op TotalOffset . view oeOffset) t -- | Extract the vertices of a concretely located trail. Note that -- for loops, the starting vertex will /not/ be repeated at the end. @@ -802,7 +966,7 @@ -- Note that it does not make sense to ask for the vertices of a -- 'Trail' by itself; if you want the vertices of a trail -- with the first vertex at, say, the origin, you can use --- @trailVertices . (`at` origin)@. +-- @trailVertices . (\`at\` origin)@. trailVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [Point v] trailVertices (viewLoc -> (p,t)) diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -30,6 +30,7 @@ import Data.AffineSpace ((.-.)) import Data.VectorSpace +import Control.Lens (view, wrapped) import Diagrams.Core import Diagrams.Located @@ -95,7 +96,7 @@ -- | Translationally invariant things are trail-like as long as the -- underlying type is. instance TrailLike t => TrailLike (TransInv t) where - trailLike = TransInv . trailLike + trailLike = view wrapped . trailLike -- | 'Located' things are trail-like as long as the underlying type -- is. The location is taken to be the location of the input @@ -110,7 +111,14 @@ -- | Construct a trail-like thing from a list of segments, with the -- origin as the location. -- --- XXX example/picture +-- <> +-- +-- > fromSegmentsEx = fromSegments +-- > [ straight (r2 (1,1)) +-- > , bézier3 (r2 (1,1)) unitX unit_Y +-- > , straight unit_X +-- > ] +-- > # centerXY # pad 1.1 fromSegments :: TrailLike t => [Segment Closed (V t)] -> t fromSegments = fromLocSegments . (`at` origin) @@ -121,7 +129,15 @@ -- | Construct a trail-like thing of linear segments from a list -- of offsets, with the origin as the location. -- --- XXX example/picture +-- <> +-- +-- > fromOffsetsEx = fromOffsets +-- > [ unitX +-- > , unitX # rotateBy (1/6) +-- > , unitX # rotateBy (-1/6) +-- > , unitX +-- > ] +-- > # centerXY # pad 1.1 fromOffsets :: TrailLike t => [V t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets @@ -135,7 +151,21 @@ -- vertices are given, the empty trail is used with the origin as -- the location. -- --- XXX example/picture +-- <> +-- +-- > import Data.List (transpose) +-- > +-- > fromVerticesEx = +-- > ( [ pentagon 1 +-- > , pentagon 1.3 # rotateBy (1/15) +-- > , pentagon 1.5 # rotateBy (2/15) +-- > ] +-- > # transpose +-- > # concat +-- > ) +-- > # fromVertices +-- > # closeTrail # strokeTrail +-- > # centerXY # pad 1.1 fromVertices :: TrailLike t => [Point (V t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) @@ -145,12 +175,26 @@ segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- | Create a linear trail between two given points. +-- +-- <> +-- +-- > twiddleEx +-- > = mconcat ((~~) <$> hexagon 1 <*> hexagon 1) +-- > # centerXY # pad 1.1 (~~) :: TrailLike t => Point (V t) -> Point (V t) -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each -- segment into its own separate trail. Useful for (say) applying a -- different style to each segment. +-- +-- <> +-- +-- > explodeTrailEx +-- > = pentagon 1 +-- > # explodeTrail -- generate a list of diagrams +-- > # zipWith lc [orange, green, yellow, red, blue] +-- > # mconcat # centerXY # pad 1.1 explodeTrail :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -42,6 +42,9 @@ -- * "Diagrams.TwoD.Shapes" defines other two-dimensional shapes, -- e.g. various polygons. -- +-- * "Diagrams.TwoD.Arrow" contains tools for drawing arrows between +-- things. +-- -- * "Diagrams.TwoD.Text" defines primitive text diagrams. -- -- * "Diagrams.TwoD.Image" allows importing external images into diagrams. @@ -58,24 +61,27 @@ ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 - R2, r2, unr2 - , P2, p2, unp2 + R2, r2, unr2, mkR2 + , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y - , direction, fromDirection, e + , direction, angleBetween, fromDirection -- * Angles , tau , Angle(..) - , Turn(..), CircleFrac, Rad(..), Deg(..) - , fullCircle, convertAngle + , Turn(..), asTurn, CircleFrac + , Rad(..), asRad + , Deg(..), asDeg + , fullTurn, fullCircle, convertAngle -- * Paths -- ** Stroking - , stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop - , strokeLocT, strokeLocLine, strokeLocLoop + , stroke, stroke', strokeTrail, strokeT, strokeTrail', strokeT' + , strokeLine, strokeLoop + , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule - , StrokeOpts(..) + , StrokeOpts(..), vertexNames, queryFillRule -- ** Clipping , clipBy @@ -93,10 +99,13 @@ , arc' , arcCW , wedge + , arcBetween + , annularWedge -- ** General polygons , polygon, polyTrail - , PolygonOpts(..), PolyType(..), PolyOrientation(..) + , PolygonOpts(..), polyType, polyOrient, polyCenter + , PolyType(..), PolyOrientation(..) -- ** Star polygons , StarOpts(..), star @@ -108,6 +117,7 @@ , square , pentagon , hexagon + , heptagon , septagon , octagon , nonagon @@ -121,14 +131,40 @@ -- ** Other shapes , roundedRect, roundedRect' - , RoundedRectOpts(..) + , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR + -- ** Arrows + , arrow, arrow' + , arrowAt, arrowAt' + , arrowBetween, arrowBetween' + , connect, connect' + , connectPerim, connectPerim' + , connectOutside, connectOutside' + , straightShaft + , module Diagrams.TwoD.Arrowheads + + , ArrowOpts(..) + + , arrowHead + , arrowTail + , arrowShaft + , headSize + , tailSize + , headGap + , tailGap + , headColor + , headStyle + , tailColor + , tailStyle + , shaftColor + , shaftStyle + -- * Text , text, topLeftText, alignedText, baselineText , font, fontSize, italic, oblique, bold -- * Images - , image + , Image, image -- * Transformations -- ** Rotation @@ -175,6 +211,11 @@ , alignX, alignY , centerX, centerY, centerXY + -- * Snugging + , snugL, snugR, snugT, snugB, snugTL, snugTR, snugBL, snugBR + , snugX, snugY + , snugCenterX, snugCenterY, snugCenterXY + -- * Size -- ** Computing size , width, height, size2D, sizeSpec2D @@ -190,13 +231,15 @@ -- * Visual aids for understanding the internal model , showOrigin , showOrigin' - , OriginOpts(..) + , OriginOpts(..), oColor, oScale, oMinSize , showLabels ) where import Diagrams.TwoD.Align import Diagrams.TwoD.Arc +import Diagrams.TwoD.Arrow +import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Combinators import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image 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 @@ -40,8 +40,6 @@ import Data.Default.Class -import Data.Colour.Names (black) - -- | Set default attributes of a 2D diagram (in case they have not -- been set): -- diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE FlexibleContexts - , TypeFamilies - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Align @@ -12,86 +11,141 @@ -- "Diagrams.Align" for more general alignment combinators. -- -- The basic idea is that alignment is achieved by moving diagrams' --- local origins relative to their envelopes. For example, to align --- several diagrams along their tops, we first move their local --- origins to the upper edge of their envelopes (using e.g. @map --- 'alignTop'@), and then put them together with their local origins --- along a horizontal line (using e.g. 'hcat' from --- "Diagrams.TwoD.Combinators"). +-- local origins relative to their envelopes or traces (or some other +-- sort of boundary). For example, to align several diagrams along +-- their tops, we first move their local origins to the upper edge of +-- their boundary (using e.g. @map 'alignTop'@), and then put them +-- together with their local origins along a horizontal line (using +-- e.g. 'hcat' from "Diagrams.TwoD.Combinators"). -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Align ( -- * Absolute alignment + -- ** Align by envelope alignL, alignR, alignT, alignB , alignTL, alignTR, alignBL, alignBR + -- ** Align by trace + , snugL, snugR, snugT, snugB + , snugTL, snugTR, snugBL, snugBR + -- * Relative alignment - , alignX, alignY + , alignX, snugX, alignY, snugY -- * Centering , centerX, centerY, centerXY + , snugCenterX, snugCenterY, snugCenterXY ) where -import Diagrams.Core +import Diagrams.Core -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -import Diagrams.Align +import Diagrams.Align +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector -import Data.VectorSpace +import Data.VectorSpace -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. -alignL :: (Alignable a, V a ~ R2) => a -> a +alignL :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a alignL = align (negateV unitX) +snugL :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugL = snug (negateV unitX) + -- | Align along the right edge. -alignR :: (Alignable a, V a ~ R2) => a -> a +alignR :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a alignR = align unitX +snugR :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugR = snug unitX + + -- | Align along the top edge. -alignT :: (Alignable a, V a ~ R2) => a -> a +alignT :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a alignT = align unitY +snugT:: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugT = snug unitY + -- | Align along the bottom edge. -alignB :: (Alignable a, V a ~ R2) => a -> a +alignB :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a alignB = align (negateV unitY) -alignTL, alignTR, alignBL, alignBR :: (Alignable a, V a ~ R2) => a -> a +snugB :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugB = snug (negateV unitY) + +alignTL, alignTR, alignBL, alignBR :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR --- | @alignX@ moves the local origin horizontally as follows: +snugTL, snugTR, snugBL, snugBR + :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ R2) + => a -> a +snugTL = snugT . snugL +snugTR = snugT . snugR +snugBL = snugB . snugL +snugBR = snugB . snugR + +-- | @alignX@ and @snugX@ move the local origin horizontally as follows: -- --- * @alignX (-1)@ moves the local origin to the left edge of the envelope; +-- * @alignX (-1)@ moves the local origin to the left edge of the boundary; -- -- * @align 1@ moves the local origin to the right edge; -- -- * any other argument interpolates linearly between these. For -- example, @alignX 0@ centers, @alignX 2@ moves the origin one -- \"radius\" to the right of the right edge, and so on. -alignX :: (Alignable a, V a ~ R2) => Double -> a -> a +-- +-- * @snugX@ works the same way. + +alignX :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> a alignX = alignBy unitX +-- | See the documentation for 'alignX'. +snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => Double -> a -> a +snugX = snugBy unitX + -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. -alignY :: (Alignable a, V a ~ R2) => Double -> a -> a +alignY :: (Alignable a, HasOrigin a, V a ~ R2) => Double -> a -> a alignY = alignBy unitY +snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => Double -> a -> a +snugY = snugBy unitY + -- | Center the local origin along the X-axis. -centerX :: (Alignable a, V a ~ R2) => a -> a +centerX :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a centerX = alignBy unitX 0 +snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugCenterX = snugBy unitX 0 + -- | Center the local origin along the Y-axis. -centerY :: (Alignable a, V a ~ R2) => a -> a +centerY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a centerY = alignBy unitY 0 +snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugCenterY = snugBy unitY 0 + -- | Center along both the X- and Y-axes. -centerXY :: (Alignable a, V a ~ R2) => a -> a +centerXY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a centerXY = centerX . centerY + +snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R2) => a -> a +snugCenterXY = snugCenterX . snugCenterY diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -19,22 +19,24 @@ , bezierFromSweep , wedge + , arcBetween + , annularWedge ) where -import Diagrams.Coordinates import Diagrams.Core import Diagrams.Located (at) -import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unitX) +import Diagrams.TwoD.Vector (direction, e, unitX) import Diagrams.Util (tau, ( # )) +import Data.AffineSpace ((.-.)) import Data.Semigroup ((<>)) -import Data.VectorSpace (negateV, (*^), (^-^)) +import Data.VectorSpace (magnitude, negateV, (*^), (^-^)) +import Diagrams.Coordinates -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf @@ -46,7 +48,7 @@ bezierFromSweepQ1 :: Rad -> Segment Closed R2 bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s/2) v - c1 = ((4-x)/3) & ((1-x)*(3-x)/(3*y)) + c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 v = unitX @@ -89,18 +91,18 @@ -- 'Trail' of a radius one arc counterclockwise between the two angles. arcT :: Angle a => a -> a -> Trail R2 arcT start end - | e < s = arcT s (e + fromIntegral d) - | otherwise = (if sweep >= tau then glueTrail else id) - $ trailFromSegments bs + | end' < start' = arcT start' (end' + fromIntegral d) + | otherwise = (if sweep >= tau then glueTrail else id) + $ trailFromSegments bs where sweep = convertAngle $ end - start bs = map (rotate start) . bezierFromSweep $ sweep -- We want to compare the start and the end and in case -- there isn't some law about 'Angle' ordering, we use a -- known 'Angle' for that. - s = convertAngle start :: Turn - e = convertAngle end - d = ceiling (s - e) :: Integer + start' = convertAngle start :: Turn + end' = convertAngle end + d = ceiling (start' - end') :: Integer -- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the -- path of a radius one arc counterclockwise between the two angles. @@ -124,6 +126,11 @@ -- the two angles. If a negative radius is given, the arc will -- be clockwise, otherwise it will be counterclockwise. The origin -- of the arc is its center. +-- +-- <> +-- +-- > arc'Ex = mconcat [ arc' r 0 (1/4 :: Turn) | r <- [0.5,-1,1.5] ] +-- > # centerXY # pad 1.1 arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) where ts | r < 0 = reverseTrail $ arcT end start @@ -131,8 +138,72 @@ -- | Create a circular wedge of the given radius, beginning at the -- first angle and extending counterclockwise to the second. +-- +-- <> +-- +-- > 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) +-- > ] +-- > # fc blue +-- > # centerXY # pad 1.1 wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p -wedge r a1 a2 = trailLike . (`at` origin) . wrapLine +wedge r a1 a2 = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ e a1] <> arc a1 a2 # scale r <> fromOffsets [r *^ negateV (e a2)] + +-- | @arcBetween p q height@ creates an arc beginning at @p@ and +-- ending at @q@, with its midpoint at a distance of @abs height@ +-- away from the straight line from @p@ to @q@. A positive value of +-- @height@ results in an arc to the left of the line from @p@ to +-- @q@; a negative value yields one to the right. +-- +-- <> +-- +-- > arcBetweenEx = mconcat +-- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] +-- > # centerXY # pad 1.1 +arcBetween :: (TrailLike t, V t ~ R2) => P2 -> P2 -> Double -> t +arcBetween p q ht = trailLike (a # rotateBy (direction v) # moveTo p) + where + h = abs ht + isStraight = h < 0.00001 + v = q .-. p + d = magnitude (q .-. p) + th = acos ((d*d - 4*h*h)/(d*d + 4*h*h)) + r = d/(2*sin th) + mid | ht >= 0 = tau/4 + | otherwise = 3*tau/4 + st = mid - Rad th + end = mid + Rad th + a | isStraight + = fromOffsets [d *^ unitX] + | otherwise + = arc st end + # scale r + # translateY ((if ht > 0 then negate else id) (r-h)) + # translateX (d/2) + # (if ht > 0 then reverseLocTrail else id) + +-- | Create an annular wedge of the given radii, beginning at the +-- first angle and extending counterclockwise to the second. +-- The radius of the outer circle is given first. +-- +-- <> +-- +-- > 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) +-- > ] +-- > # fc blue +-- > # centerXY # pad 1.1 +annularWedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> Double -> a -> a -> p +annularWedge r1' r2' a1 a2 = trailLike . (`at` o) . glueTrail . wrapLine + $ fromOffsets [(r1'-r2') *^ e a1] + <> arc a1 a2 # scale r1' + <> fromOffsets [(r1'-r2') *^ negateV (e a2)] + <> arcCW a2 a1 # scale r2' + where o = origin # translate (r2' *^ e a1) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Arrow.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Arrow +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Drawing arrows in two dimensions. For a tutorial on drawing arrows +-- using this module, see the diagrams website: +-- . +-- +----------------------------------------------------------------------------- + + +module Diagrams.TwoD.Arrow + ( -- * Examples + -- ** Example 1 +-- | <> +-- +-- > -- Connecting two diagrams at their origins. +-- > +-- > sq = square 2 # showOrigin # lc darkgray # lw 0.07 +-- > 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) +-- > "left" "right" # pad 1.1 + + -- ** Example 2 + +-- | <> +-- +-- > -- Comparing connect, connectPerim, and arrowAt. +-- > +-- > oct = octagon 1 # lc darkgray # lw 0.10 # 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) +-- > +-- > -- Place an arrow at (0,0) the size and direction of (0,1). +-- > ex3 = arrowAt origin unit_Y +-- > +-- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 + + -- * Creating arrows + arrow + , arrow' + , arrowAt + , arrowAt' + , arrowBetween + , arrowBetween' + , connect + , connect' + , connectPerim + , connectPerim' + , connectOutside + , connectOutside' + , straightShaft + + -- * Options + , ArrowOpts(..) + + , arrowHead + , arrowTail + , arrowShaft + , headSize + , tailSize + , headGap + , tailGap + , headColor + , headStyle + , tailColor + , tailStyle + , shaftColor + , shaftStyle + + -- | See "Diagrams.TwoD.Arrowheads" for a list of standard + -- arrowheads and help creating your own. + , module Diagrams.TwoD.Arrowheads + ) where + +import Control.Arrow (first) +import Control.Lens (Lens', Setter', + generateSignatures, + lensRules, makeLensesWith, + (%~), (&), (.~), (^.)) +import Data.AffineSpace +import Data.Default.Class +import Data.Functor ((<$>)) +import Data.Maybe (fromJust, fromMaybe) +import Data.Monoid (mempty, (<>)) +import Data.Monoid.Coproduct (untangle) +import Data.Monoid.Split +import Data.Semigroup (option) +import Data.VectorSpace + +import Data.Colour hiding (atop) +import Diagrams.Attributes +import Diagrams.Core +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') + +import Diagrams.Parametric +import Diagrams.Path +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, rotateBy, translateX) +import Diagrams.TwoD.Transform.ScaleInv (scaleInvPrim) +import Diagrams.TwoD.Types +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 + , _headStyle :: Style R2 + , _tailStyle :: Style R2 + , _shaftStyle :: Style R2 + } + +-- | Straight line arrow shaft. +straightShaft :: Trail R2 +straightShaft = trailFromOffsets [unitX] + +instance Default ArrowOpts where + def = ArrowOpts + { _arrowHead = dart + , _arrowTail = noTail + , _arrowShaft = trailFromOffsets [unitX] + , _headSize = 0.3 + , _tailSize = 0.3 + , _headGap = 0 + , _tailGap = 0 + + -- See note [Default arrow style attributes] + , _headStyle = mempty + , _tailStyle = mempty + , _shaftStyle = mempty + } + +makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts + +-- | A shape to place at the head of the arrow. +arrowHead :: Lens' ArrowOpts ArrowHT + +-- | A shape to place at the tail of the arrow. +arrowTail :: Lens' ArrowOpts ArrowHT + +-- | 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 +-- | Distance to leave between the starting point and the tail. +tailGap :: Lens' ArrowOpts Double + +-- | Style to apply to the head. @headStyle@ is modified by using the lens +-- combinator @%~@ to change the current style. For example, to change +-- an opaque black arrowhead to translucent orange: +-- @(with & headStyle %~ fc orange . opacity 0.75)@. +headStyle :: Lens' ArrowOpts (Style R2) + +-- | Style to apply to the tail. See `headStyle`. +tailStyle :: Lens' ArrowOpts (Style R2) + +-- | 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 + +-- | A lens for setting or modifying the color of an arrow +-- tail. See 'headColor'. +tailColor :: Color c => Setter' ArrowOpts c +tailColor = tailStyle . styleFillColor + +-- | A lens for setting or modifying the color of an arrow +-- shaft. See 'headColor'. +shaftColor :: Color c => Setter' ArrowOpts c +shaftColor = shaftStyle . styleLineColor + +-- Set the default shaft style of an `ArrowOpts` record by applying the +-- default style after all other styles have been applied. +-- The semigroup stucture of the lw attribute will insure that the default +-- is only used if it has not been set in @opts@. +shaftSty :: ArrowOpts -> Style R2 +shaftSty opts = opts^.shaftStyle + +-- Set the default head style. See `shaftSty`. +headSty :: ArrowOpts -> Style R2 +headSty opts = fc black (opts^.headStyle) + +-- Set the default tail style. See `shaftSty`. +tailSty :: ArrowOpts -> Style R2 +tailSty opts = fc black (opts^.tailStyle) + +-- | Calculate the length of the portion of the horizontal line that passes +-- through the origin and is inside of p. +xWidth :: (Traced t, V t ~ R2) => t -> Double +xWidth p = a + b + where + a = fromMaybe 0 (magnitude <$> traceV origin unitX p) + 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 +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 + +-- | 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' + +-- | 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 + , hWidth + jWidth) + where + (h', j') = (opts^.arrowHead) (opts^.headSize) (widthOfJoint $ shaftSty opts) + hWidth = xWidth h' + jWidth = xWidth j' + h = scaleInvPrim h' unitX # applyStyle (headSty opts) + j = scaleInvPrim j' unitX # 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 + , tWidth + jWidth) + where + (t', j') = (opts^.arrowTail) (opts^.tailSize) (widthOfJoint $ shaftSty opts) + tWidth = xWidth t' + jWidth = xWidth j' + t = scaleInvPrim t' unitX # applyStyle (tailSty opts) + j = scaleInvPrim j' unitX # applyStyle (colorJoint (opts^.shaftStyle)) + +-- | Make a trail with the same angles and offset as an arrow with tail width +-- tw, head width hw and shaft of tr, such that the magnituted of the shaft +-- offset is size. Used for calculating the offset of an arrow. +spine :: Trail R2 -> Double -> Double -> Double -> Trail R2 +spine tr tw hw size = tS <> tr # scale size <> hS + where + tSpine = trailFromOffsets [(normalized . tangentAtStart) $ tr] # scale tw + hSpine = trailFromOffsets [(normalized . tangentAtEnd) $ tr] # scale hw + hS = if hw > 0 then hSpine else mempty + tS = if tw > 0 then tSpine else mempty + +-- | Calculate the amount required to scale a shaft trail so that an arrow with +-- head width hw and tail width tw has offset t. +scaleFactor :: Trail R2 -> Double -> Double -> Double -> Double +scaleFactor tr tw hw t + + -- Let tv be a vector representing the tail width, i.e. a vector + -- of length tw tangent to the trail's start; similarly for hv. + -- Let v be the vector offset of the trail. + -- + -- Then we want to find k such that + -- + -- || tv + k*v + hv || = t. + -- + -- We can solve by squaring both sides and expanding the LHS as a + -- dot product, resulting in a quadratic in k. + + = case quadForm + (magnitudeSq v) + (2* (v <.> (tv ^+^ hv))) + (magnitudeSq (tv ^+^ hv) - t*t) + of + [] -> 1 -- no scale works, just return 1 + [s] -> s -- single solution + ss -> maximum ss + -- we will usually get both a positive and a negative solution; + -- return the maximum (i.e. positive) solution + where + tv = tw *^ (tangentAtStart tr # normalized) + hv = hw *^ (tangentAtEnd tr # normalized) + v = trailOffset tr + +-- | @arrow len@ creates an arrow of length @len@ with default +-- parameters, starting at the origin and ending at the point +-- @(len,0)@. +arrow :: Renderable (Path R2) b => Double -> Diagram b R2 +arrow len = arrow' def len + +-- | @arrow' opts len@ creates an arrow of length @len@ using the +-- given options, starting at the origin and ending at the point +-- @(len,0)@. In particular, it scales the given 'arrowShaft' so +-- that the entire arrow has length @len@. +arrow' :: 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 + where + + -- Once we learn the global transformation context this arrow is + -- drawn in, we can apply it to the origin and (len,0) to find out + -- the actual final points between which this arrow should be + -- drawn. We need to know this to draw it correctly, since the + -- head and tail are scale invariant, and hence the precise points + -- between which we need to draw the shaft do not transform + -- uniformly as the transformation applied to the entire arrow. + -- See https://github.com/diagrams/diagrams-lib/issues/112. + delayedArrow da = + + -- 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 + + -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). + dArrow sty tr ln = (h' <> t' <> shaft) + # moveOriginBy (tWidth *^ (unit_X # rotateBy tAngle)) + # rotateBy (direction (q .-. p) - dir) + # moveTo p + where + + p = origin # transform tr + q = origin # translateX ln # transform tr + + -- Use the existing line color for head, tail, and shaft by + -- default (can be overridden by explicitly setting headStyle, + -- tailStyle, or shaftStyle). + globalLC = getLineColor <$> getAttr sty + opts' = opts + & headStyle %~ maybe id fillColor globalLC + & tailStyle %~ maybe id fillColor globalLC + & shaftStyle %~ maybe id lineColor globalLC + + -- Make the head and tail and save their widths. + (h, hWidth') = mkHead opts' + (t, tWidth') = mkTail opts' + + rawShaftTrail = opts^.arrowShaft + shaftTrail + = rawShaftTrail + -- rotate it so it is pointing in the positive X direction + # rotateBy (- direction (trailOffset rawShaftTrail)) + -- apply the context transformation -- in case it includes + -- things like flips and shears (the possibility of shears + -- is why we must rotate it to a neutral position first) + # transform tr + + -- Adjust the head width and tail width to take gaps into account + tWidth = tWidth' + opts^.tailGap + hWidth = hWidth' + opts^.headGap + + -- Calculate the angles that the head and tail should point. + tAngle = direction . tangentAtStart $ shaftTrail :: Turn + hAngle = direction . tangentAtEnd $ shaftTrail :: Turn + + -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire + -- arrow will be of length len. Then apply it to the shaft and make the + -- shaft into a Diagram with using its style. + sf = scaleFactor shaftTrail tWidth hWidth (magnitude (q .-. p)) + shaftTrail' = shaftTrail # scale sf + shaft = strokeT shaftTrail' # applyStyle (shaftSty opts) + + -- Adjust the head and tail to point in the directions of the shaft ends. + h' = h # rotateBy hAngle + # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') + t' = t # rotateBy tAngle + + -- Find out what direction the arrow is pointing so we can set it back + -- to point in the direction unitX when we are done. + dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) + +-- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ +-- with default parameters. +arrowBetween :: Renderable (Path R2) b => P2 -> P2 -> Diagram b R2 +arrowBetween = arrowBetween' def + +-- | @arrowBetween' opts s e@ creates an arrow pointing from @s@ to +-- @e@ using the given options. In particular, it scales and +-- rotates @arrowShaft@ to go between @s@ and @e@, taking head, +-- tail, and gaps into account. +arrowBetween' + :: Renderable (Path R2) b => + ArrowOpts -> P2 -> P2 -> Diagram b R2 +arrowBetween' opts s e = arrowAt' opts s (e .-. s) + +-- | Create an arrow starting at s with length and direction determined by +-- the vectore v. +arrowAt :: Renderable (Path R2) b => P2 -> R2 -> Diagram b R2 +arrowAt s v = arrowAt' def s v + +arrowAt' + :: Renderable (Path R2) b => + ArrowOpts -> P2 -> R2 -> Diagram b R2 +arrowAt' opts s v = arrow' opts len # rotateBy dir # moveTo s + where + len = magnitude v + dir = direction v + +-- | Connect two diagrams with a straight arrow. +connect + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => n1 -> n2 -> (Diagram b R2 -> Diagram b R2) +connect = connect' def + +-- | Connect two diagrams with an arbitrary arrow. +connect' + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) +connect' opts n1 n2 = + withName n1 $ \sub1 -> + withName n2 $ \sub2 -> + let [s,e] = map location [sub1, sub2] + in atop (arrowBetween' opts s e) + +-- | Connect two diagrams at point on the perimeter of the diagrams, choosen +-- by angle. +connectPerim + :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a) + => n1 -> n2 -> a -> a + -> (Diagram b R2 -> Diagram b R2) +connectPerim = connectPerim' def + +connectPerim' + :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a) + => ArrowOpts -> n1 -> n2 -> a -> a + -> (Diagram b R2 -> Diagram b R2) +connectPerim' opts n1 n2 a1 a2 = + withName n1 $ \sub1 -> + withName n2 $ \sub2 -> + let [os, oe] = map location [sub1, sub2] + s = fromMaybe os (maxTraceP os (unitX # rotate a1) sub1) + e = fromMaybe oe (maxTraceP oe (unitX # rotate a2) sub2) + in atop (arrowBetween' opts s e) + +-- | Draw an arrow from diagram named "n1" to diagram named "n2". The +-- arrow lies on the line between the centres of the diagrams, but is +-- drawn so that it stops at the boundaries of the diagrams, using traces +-- to find the intersection points. +connectOutside + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => n1 -> n2 -> (Diagram b R2 -> Diagram b R2) +connectOutside = connectOutside' def + +connectOutside' + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => ArrowOpts -> n1 -> n2 -> (Diagram b R2 -> Diagram b R2) +connectOutside' opts n1 n2 = + withName n1 $ \b1 -> + withName n2 $ \b2 -> + let v = location b2 .-. location b1 + midpoint = location b1 .+^ (v/2) + s = fromJust $ traceP midpoint (-v) b1 + e = fromJust $ traceP midpoint v b2 + in atop (arrowBetween' opts s e) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Arrowheads +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Standard arrowheads and tails. Each arrowhead or tail is designed +-- to be drawn filled, with a line width of 0, and is normalized to +-- fit inside a circle of diameter 1. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Arrowheads + ( + -- * Arrowheads + -- ** Standard arrowheads + tri + , dart + , spike + , thorn + , missile + , noHead + + -- ** Configurable arrowheads + -- | Creates arrowheads of the same shape as the standard heads but + -- where the angle parameter is used to specify the angle to the top + -- left point of the arrowhead. + , arrowheadTriangle + , arrowheadDart + , arrowheadSpike + , arrowheadThorn + , arrowheadMissile + + -- * Arrow tails + -- ** Standard arrow tails + , tri' + , dart' + , spike' + , thorn' + , missile' + , noTail + , quill + , block + + -- ** Configurable arrow tails + + , arrowtailQuill + , arrowtailBlock + + -- * Internals + , ArrowHT + ) where + +import Control.Lens ((&), (.~)) +import Data.Default.Class +import Data.AffineSpace +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, (<>)) +import Data.VectorSpace + +import Diagrams.Core +import Diagrams.CubicSpline (cubicSpline) +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail +import Diagrams.TwoD.Align +import Diagrams.TwoD.Arc (arc') +import Diagrams.TwoD.Path () +import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (e, unitX, 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) +-- > origin (r2 (0.001, 0)) +-- > <> square 0.5 # alignL # lw 0 + +-- | Isoceles triangle style. The above example specifies an angle of `2/5 Turn`. + +-- | <> + +-- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 :: Turn) & shaftStyle %~ lw 0) +-- > origin (r2 (0.001, 0)) +-- > <> square 0.6 # alignL # lw 0 +arrowheadTriangle :: Angle a => a -> ArrowHT +arrowheadTriangle theta = aHead + where + aHead size _ = (p, mempty) + where + p = polygon (def & polyType .~ PolyPolar [theta, (-2 * theta)] + (repeat (htRadius * size)) & polyOrient .~ NoOrient) # alignL + +-- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. +arrowheadDart :: Angle a => a -> ArrowHT +arrowheadDart theta = aHead + where + aHead size shaftWidth = (dartP # moveOriginTo (dartVertices !! 2), joint) + where + a = toTurn theta + r = htRadius * size + dartP = polygon (def & polyType .~ PolyPolar [a, 1/2 - a, 1/2 - a] + [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 + +-- | Isoceles triangle with curved concave base. Inkscape type 2. +arrowheadSpike :: Angle a => a -> ArrowHT +arrowheadSpike theta = aHead + 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 (-theta) + barb = (closedPath $ (l1 <> c <> l2)) # scale size + m = xWidth barb --c `atParam` 0.5 + b = Rad $ asin ((shaftWidth / 2) / (htRadius * size)) + c' = arc' htRadius (-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) + +-- | Curved sides, linear concave base. Illustrator CS5 #3 +arrowheadThorn :: Angle a => a -> Double -> ArrowHT +arrowheadThorn theta r = aHead + 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 (-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 + +-- | Make a side for the thorn head. +curvedSide :: Angle a => a -> 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) + 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 a => a -> ArrowHT +arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta + +-- Standard heads --------------------------------------------------------- +noHead :: ArrowHT +noHead _ _ = (mempty, mempty) + +-- | <> + +-- > triEx = drawHead tri +tri :: ArrowHT +tri = arrowheadTriangle (1/3 :: Turn) + +-- | <> + +-- > spikeEx = drawHead spike +spike :: ArrowHT +spike = arrowheadSpike (3/8 :: Turn) + +-- | <> + +-- > thornEx = drawHead thorn +thorn :: ArrowHT +thorn = arrowheadThorn (3/8 :: Turn) 1 + +-- | <> + +-- > dartEx = drawHead dart +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) +-- > origin (r2 (0.001, 0)) +-- > <> square 0.5 # alignL # lw 0 + +-- | Utility function to convert any arrowhead to an arrowtail, i.e. +-- attached at the start of the trail. +headToTail :: ArrowHT -> ArrowHT +headToTail hd = tl + where + tl size shaftWidth = (t, j) + where + (t', j') = hd size shaftWidth + t = reflectX t' + j = reflectX j' + +arrowtailBlock :: Angle a => a -> ArrowHT +arrowtailBlock theta = aTail + where + aTail size _ = (t, mempty) + where + t = square 1 # scaleX x # scaleY y # scale size # alignR + a' = e theta # scaleR + a = a' ^-^ (reflectY a') + y = magnitude a + b = a' ^-^ (reflectX a') + x = magnitude b + +-- | The angle is where the top left corner intersects the circle. +arrowtailQuill :: Angle a => a -> ArrowHT +arrowtailQuill theta =aTail + where + aTail size shaftWidth = (t, j) + where + t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] ) + # scale size # alignR + theta' = toTurn theta + v0 = p2 (0.5, 0) + v2 = p2 (unr2 $ e theta' # scaleR) + v1 = v2 # translateX (5/4 * htRadius) + v3 = p2 (-0.1, 0) + v4 = v2 # reflectY + v5 = v4 # translateX (5/4 * htRadius) + s = 1 - shaftWidth / magnitude (v1 .-. v5) + n1 = v0 # translateY (0.5 * shaftWidth) + n2 = v1 .-^ ((v1 .-. v0) # scale s) + n3 = v5 .-^ ((v5 .-. v0) # scale s) + n4 = n1 # reflectY + j = ( closedPath $ trailFromVertices + [ v0, n1, n2, v0, n3, n4, v0 ]) + +-- Standard tails --------------------------------------------------------- + +noTail :: ArrowHT +noTail _ _ = (mempty, mempty) + +-- | <> + +-- > tri'Ex = drawTail tri' +tri' :: ArrowHT +tri' = headToTail tri + +-- | <> + +-- > spike'Ex = drawTail spike' +spike' :: ArrowHT +spike' = headToTail spike + +-- | <> + +-- > thorn'Ex = drawTail thorn' +thorn' :: ArrowHT +thorn' = headToTail thorn + +-- | <> + +-- > dart'Ex = drawTail dart' +dart' :: ArrowHT +dart' = headToTail dart + +-- | <> + +-- > missile'Ex = drawTail missile' +missile' :: ArrowHT +missile' = headToTail missile + +-- | <> + +-- > quillEx = drawTail quill +quill :: ArrowHT +quill = arrowtailQuill (2/5 :: Turn) + +-- | <> + +-- > blockEx = drawTail block +block :: ArrowHT +block = arrowtailBlock (2/5 :: Turn) 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 @@ -54,7 +54,6 @@ import Diagrams.TrailLike import Diagrams.TwoD.Align import Diagrams.TwoD.Path () -import Diagrams.TwoD.Segment import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types @@ -77,7 +76,7 @@ -- -- to place @c@ above @d@. The local origin of the resulting -- combined diagram is the same as the local origin of the first. --- @(===)@ is associative and has 'mempty' as an identity. See the +-- @(|||)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. (===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) @@ -158,13 +157,13 @@ -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. strutX :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m -strutX d = strut (d & 0) +strutX d = strut (d ^& 0) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m -strutY d = strut (0 & d) +strutY d = strut (0 ^& d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its -- envelope horizontally by a factor of @s@ (factors between 0 and 1 @@ -193,6 +192,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeLeft :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s @@ -202,6 +202,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeRight :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s @@ -211,6 +212,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeBottom :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s @@ -220,6 +222,7 @@ -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. +extrudeTop :: Monoid' m => Double -> QDiagram b R2 m -> QDiagram b R2 m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -19,18 +19,16 @@ , squaredRadiusOfCurvature ) where -import Data.AffineSpace import Data.Monoid.Inf +import Data.NumInstances.Tuple () import Data.VectorSpace import Control.Arrow (first, second) import Control.Monad (join) -import Diagrams.Core - import Diagrams.Segment +import Diagrams.Tangent import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car @@ -51,19 +49,19 @@ -- -- Lets consider the following curve: -- --- <> +-- <> -- -- The curve starts with positive curvature, -- --- <> +-- <> -- -- approaches zero curvature -- --- <> +-- <> -- -- then has negative curvature -- --- <> +-- <> -- -- > {-# LANGUAGE GADTs #-} -- > @@ -71,7 +69,7 @@ -- > import Data.Monoid.Inf -- > import Diagrams.Coordinates -- > --- > segmentA = Cubic (12 & 0) (8 & 10) (OffsetClosed (20 & 8)) +-- > segmentA = Cubic (12 ^& 0) (8 ^& 10) (OffsetClosed (20 ^& 8)) -- > -- > curveA = lw 0.1 . stroke . fromSegments $ [segmentA] -- > @@ -79,7 +77,7 @@ -- > -- > diagramPos = diagramWithRadius 0.2 -- > --- > diagramZero = diagramWithRadius 0.5 +-- > diagramZero = diagramWithRadius 0.45 -- > -- > diagramNeg = diagramWithRadius 0.8 -- > @@ -94,7 +92,7 @@ -- > | otherwise = go (radiusOfCurvature bez t) -- > where -- > v@(x,y) = unr2 $ firstDerivative b c d t --- > vp = (-y) & x +-- > vp = (-y) ^& x -- > -- > firstDerivative b c d t = let tt = t*t in (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d -- > @@ -144,17 +142,12 @@ -- the denominator respectively. curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) => Segment Closed (t, t) -> Scalar t -> (t, t) -curvaturePair (Linear _) t = (0,1) -- Linear segments always have zero curvature (infinite radius). -curvaturePair (Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) +curvaturePair (Linear _) _ = (0,1) -- Linear segments always have zero curvature (infinite radius). +curvaturePair seg@(Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) where - (x' ,y' ) = firstDerivative b c d t -- TODO: Use the generalized unr2 - (x'',y'') = secondDerivative b c d t - - firstDerivative b c d t = (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d - where - tt = t * t - - secondDerivative b c d t = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d + (x' ,y' ) = seg `tangentAtParam` t + (x'',y'') = secondDerivative + secondDerivative = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d -- TODO: We should be able to generalize this to higher dimensions. See -- 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 @@ -25,7 +25,6 @@ import Diagrams.Core import Diagrams.Located (at) -import Diagrams.Path import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform 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,7 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , MultiParamTypeClasses - #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Image @@ -15,10 +15,12 @@ module Diagrams.TwoD.Image ( - Image(..) + Image(..), imgFile, imgSize, imgTransf , image ) where +import Control.Lens (makeLenses) + import Diagrams.Core import Diagrams.Path @@ -33,10 +35,12 @@ -- | 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 +data Image = Image { _imgFile :: FilePath + , _imgSize :: SizeSpec2D + , _imgTransf :: T2 } + +makeLenses ''Image type instance V Image = R2 diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model @@ -15,16 +16,15 @@ ( -- * Showing the local origin showOrigin , showOrigin' - , OriginOpts(..) + , OriginOpts(..), oColor, oScale, oMinSize , showLabels ) where -import Diagrams.Core -import Diagrams.Core.Names - -import Diagrams.Path +import Control.Lens (makeLenses, (^.)) +import Diagrams.Core import Diagrams.Attributes +import Diagrams.Path import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path import Diagrams.TwoD.Size (size2D) @@ -47,6 +47,16 @@ -- Marking the origin ------------------------------------------------------------ +data OriginOpts = OriginOpts { _oColor :: Colour Double + , _oScale :: Double + , _oMinSize :: Double + } + +makeLenses ''OriginOpts + +instance Default OriginOpts where + def = OriginOpts red (1/50) 0.001 + -- | Mark the origin of a diagram by placing a red dot 1/50th its size. showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m) => QDiagram b R2 m -> QDiagram b R2 m @@ -58,26 +68,17 @@ => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m showOrigin' oo d = o <> d where o = stroke (circle sz) - # fc (oColor oo) + # fc (oo^.oColor) # lw 0 # fmap (const mempty) - (w,h) = size2D d ^* oScale oo - sz = maximum [w, h, oMinSize oo] - -data OriginOpts = OriginOpts { oColor :: Colour Double - , oScale :: Double - , oMinSize :: Double - } - -instance Default OriginOpts where - def = OriginOpts red (1/50) 0.001 - + (w,h) = size2D d ^* oo^.oScale + sz = maximum [w, h, oo^.oMinSize] ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ -showLabels :: (Renderable Text b, Backend b R2) +showLabels :: (Renderable Text b, Backend b R2, Semigroup m) => QDiagram b R2 m -> QDiagram b R2 Any showLabels d = ( mconcat @@ -89,4 +90,4 @@ ) <> fmap (const (Any False)) d where - SubMap m = subMap d + SubMap m = d^.subMap diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -1,41 +1,73 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset --- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Compute offsets to segments in two dimensions. --- +-- Compute offsets to segments in two dimensions. More details can be +-- found in the manual at +-- . +-- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Offset - ( offsetSegment +module Diagrams.TwoD.Offset + ( + -- * Offsets + + offsetSegment + + , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon + , offsetTrail + , offsetTrail' + , offsetPath + , offsetPath' + + -- * Expansions + + , ExpandOpts(..), expandJoin, expandMiterLimit, expandCap, expandEpsilon + , expandTrail + , expandTrail' + , expandPath + , expandPath' + ) where +import Control.Applicative +import Control.Lens hiding (at, moveTo) + import Data.AffineSpace +import Data.Monoid import Data.Monoid.Inf import Data.VectorSpace +import Data.Default.Class + import Diagrams.Core +import Diagrams.Attributes +import Diagrams.Located import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment -import Diagrams.Trail +import Diagrams.Trail hiding (offset, isLoop) +import Diagrams.TrailLike +import Diagrams.TwoD.Arc import Diagrams.TwoD.Curvature -import Diagrams.TwoD.Transform +import Diagrams.TwoD.Path () import Diagrams.TwoD.Types - -perp :: R2 -> R2 -perp v = rotateBy (-1/4) v +import Diagrams.TwoD.Vector (perp, direction) unitPerp :: R2 -> R2 unitPerp = normalized . perp perpAtParam :: Segment Closed R2 -> Double -> R2 -perpAtParam (Linear (OffsetClosed a)) t = unitPerp a -perpAtParam s@(Cubic _ _ _) t = unitPerp a +perpAtParam (Linear (OffsetClosed a)) _ = -unitPerp a +perpAtParam s@(Cubic _ _ _) t = -unitPerp a where (Cubic a _ _) = snd $ splitAtParam s t @@ -46,7 +78,9 @@ -- length. -- -- Cubic segments require a search for a subdivision of cubic segments that --- gives an approximation of the offset within the given epsilon tolerance. +-- gives an approximation of the offset within the given epsilon factor +-- (the given epsilon factor is applied to the radius giving a concrete epsilon +-- value). -- We must do this because the offset of a cubic is not a cubic itself (the -- degree of the curve increases). Cubics do, however, approach constant -- curvature as we subdivide. In light of this we scale the handles of @@ -57,39 +91,96 @@ -- In the following example the blue lines are the original segments and -- the alternating green and red lines are the resulting offset trail segments. -- --- <> +-- <> -- -- Note that when the original curve has a cusp, the offset curve forms a -- radius around the cusp, and when there is a loop in the original curve, -- there can be two cusps in the offset curve. -- -offsetSegment :: Double -- ^ Epsilon value that represents the maximum + +-- | Options for specifying line join and segment epsilon for an offset +-- involving multiple segments. +data OffsetOpts = OffsetOpts + { _offsetJoin :: LineJoin + , _offsetMiterLimit :: Double + , _offsetEpsilon :: Double + } deriving (Eq, Show) + +makeLensesWith (lensRules & generateSignatures .~ False) ''OffsetOpts + +-- | Specifies the style of join for between adjacent offset segments. +offsetJoin :: Lens' OffsetOpts LineJoin + +-- | Specifies the miter limit for the join. +offsetMiterLimit :: Lens' OffsetOpts Double + +-- | Epsilon perimeter for 'offsetSegment'. +offsetEpsilon :: Lens' OffsetOpts Double + +-- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a +-- miter limit of 10, and epsilon factor of 0.01. +instance Default OffsetOpts where + def = OffsetOpts def 10 0.01 + +-- | Options for specifying how a 'Trail' should be expanded. +data ExpandOpts = ExpandOpts + { _expandJoin :: LineJoin + , _expandMiterLimit :: Double + , _expandCap :: LineCap + , _expandEpsilon :: Double + } deriving (Eq, Show) + +makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts + +-- | Specifies the style of join for between adjacent offset segments. +expandJoin :: Lens' ExpandOpts LineJoin + +-- | Specifies the miter limit for the join. +expandMiterLimit :: Lens' ExpandOpts Double + +-- | Specifies how the ends are handled. +expandCap :: Lens' ExpandOpts LineCap + +-- | Epsilon perimeter for 'offsetSegment'. +expandEpsilon :: Lens' ExpandOpts Double + + + +-- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), +-- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon factor +-- of 0.01. +instance Default ExpandOpts where + def = ExpandOpts def 10 def 0.01 + +offsetSegment :: Double -- ^ Epsilon factor that when multiplied to the + -- absolute value of the radius gives a + -- value that represents the maximum -- allowed deviation from the true offset. In -- the current implementation each result segment -- should be bounded by arcs that are plus or - -- minus epsilon from the radius of curvature of + -- minus epsilon factor from the radius of curvature of -- the offset. -> Double -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. - -> Segment Closed R2 -- ^ Original segment - -> (Point R2, Trail R2) -- ^ Resulting offset point and trail. -offsetSegment _ r s@(Linear (OffsetClosed a)) = (origin .+^ va, trailFromSegments [s]) - where va = r *^ unitPerp a + -> Segment Closed R2 -- ^ Original segment + -> Located (Trail R2) -- ^ Resulting located (at the offset) trail. +offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va + where va = -r *^ unitPerp a -offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = (origin .+^ va, t) +offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va where t = trailFromSegments (go (radiusOfCurvature s 0.5)) -- Perpendiculars to handles. - va = r *^ unitPerp a - vc = r *^ unitPerp (c - b) + va = -r *^ unitPerp a + vc = -r *^ unitPerp (c ^-^ b) -- Split segments. - ss = (\(a,b) -> [a,b]) $ splitAtParam s 0.5 - subdivided = concatMap (trailSegments . snd . offsetSegment epsilon r) ss + ss = (\(x,y) -> [x,y]) $ splitAtParam s 0.5 + subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss -- Offset with handles scaled based on curvature. - offset factor = bezier3 (a^*factor) ((b - c)^*factor + c + vc - va) (c + vc - va) - + offset factor = bezier3 (a^*factor) ((b ^-^ c)^*factor ^+^ c ^+^ vc ^-^ va) (c ^+^ vc ^-^ va) + -- We observe a corner. Subdivide right away. go (Finite 0) = subdivided -- We have some curvature @@ -104,30 +195,349 @@ -- o = offset $ case roc of Infinity -> 1 -- Do the right thing. - Finite sr -> 1 + r / sr + Finite sr -> 1 + r / sr - close = and [epsilon > (magnitude (p o + va - p s - pp s)) - | t <- [0.25, 0.5, 0.75] - , let p = (`atParam` t) - , let pp = (r *^) . (`perpAtParam` t) + close = and [epsilon * abs r > (magnitude (p o ^+^ va ^-^ p s ^-^ pp s)) + | t' <- [0.25, 0.5, 0.75] + , let p = (`atParam` t') + , let pp = (r *^) . (`perpAtParam` t') ] -- > import Diagrams.TwoD.Offset -- > --- > showExample :: Segment R2 -> Diagram SVG R2 +-- > showExample :: Segment Closed R2 -> Diagram SVG R2 -- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 -- > where --- > d = stroke $ Path [(origin, Trail [s] False)] --- > d' = mconcat . zipWith lc colors . map stroke . uncurry explodeTrail +-- > d = stroke . fromSegments $ [s] +-- > d' = mconcat . zipWith lc colors . map stroke . explodeTrail -- > $ offsetSegment 0.1 (-1) s --- > +-- > -- > colors = cycle [green, red] --- > +-- > -- > cubicOffsetExample :: Diagram SVG R2 -- > cubicOffsetExample = hcat . map showExample $ --- > [ Cubic (10 & 0) ( 5 & 18) (10 & 20) --- > , Cubic ( 0 & 20) ( 10 & 10) ( 5 & 10) --- > , Cubic (10 & 20) ( 0 & 10) (10 & 0) --- > , Cubic (10 & 20) ((-5) & 10) (10 & 0) +-- > [ bezier3 (10 ^& 0) ( 5 ^& 18) (10 ^& 20) +-- > , bezier3 ( 0 ^& 20) ( 10 ^& 10) ( 5 ^& 10) +-- > , bezier3 (10 ^& 20) ( 0 ^& 10) (10 ^& 0) +-- > , bezier3 (10 ^& 20) ((-5) ^& 10) (10 ^& 0) -- > ] + +-- Similar to (=<<). This is when we want to map a function across something +-- located, but the result of the mapping will be transformable so we can +-- collapse the Located into the result. This assumes that Located has the +-- meaning of merely taking something that cannot be translated and lifting +-- it into a space with translation. +bindLoc :: (Transformable b, V a ~ V b) => (a -> b) -> Located a -> b +bindLoc f = join' . mapLoc f + where + join' (viewLoc -> (p,a)) = translate (p .-. origin) a + +-- While we build offsets and expansions we will use the [Located (Segment Closed R2)] +-- and [Located (Trail R2)] intermediate representations. +locatedTrailSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [Located (Segment Closed v)] +locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) + +-- | Offset a 'Trail' with options and by a given radius. This generates a new +-- trail that is always radius 'r' away from the given 'Trail' (depending on +-- the line join option) on the right. +-- +-- The styles applied to an outside corner can be seen here (with the original +-- trail in blue and the result of 'offsetTrail'' in green): +-- +-- <> +-- +-- When a negative radius is given, the offset trail will be on the left: +-- +-- <> +-- +-- When offseting a counter-clockwise loop a positive radius gives an outer loop +-- while a negative radius gives an inner loop (both counter-clockwise). +-- +-- <> +-- +offsetTrail' :: OffsetOpts + -> Double -- ^ Radius of offset. A negative value gives an offset on + -- the left for a line and on the inside for a counter-clockwise + -- loop. + -> Located (Trail R2) + -> Located (Trail R2) +offsetTrail' opts r t = joinSegments j isLoop (opts^.offsetMiterLimit) r ends . offset $ t + where + offset = map (bindLoc (offsetSegment (opts^.offsetEpsilon) r)) . locatedTrailSegments + ends | isLoop = (\(a:as) -> as ++ [a]) . trailVertices $ t + | otherwise = tail . trailVertices $ t + j = fromLineJoin (opts^.offsetJoin) + + isLoop = withTrail (const False) (const True) (unLoc t) + +-- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. +offsetTrail :: Double -> Located (Trail R2) -> Located (Trail R2) +offsetTrail = offsetTrail' def + +-- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. +offsetPath' :: OffsetOpts -> Double -> Path R2 -> Path R2 +offsetPath' opts r = mconcat + . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) + . op Path + +-- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. +offsetPath :: Double -> Path R2 -> Path R2 +offsetPath = offsetPath' def + +-- TODO: Include arrowheads on examples to indicate direction so the "left" and +-- "right" make sense. +-- +-- > import Diagrams.TwoD.Offset +-- > import Data.Default.Class +-- > +-- > corner :: Located (Trail R2) +-- > 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 ) +-- > . map (uncurry showStyle) +-- > $ [ (LineJoinMiter, "LineJoinMiter") +-- > , (LineJoinRound, "LineJoinRound") +-- > , (LineJoinBevel, "LineJoinBevel") +-- > ] +-- > where +-- > showStyle j s = centerXY (trailLike corner # lc blue +-- > <> trailLike (offsetTrail' (def & offsetJoin .~ j) 2 corner) # lc green) +-- > === (strutY 3 <> text s # font "Helvetica" # bold) +-- > +-- > offsetTrailLeftExample :: Diagram SVG R2 +-- > offsetTrailLeftExample = pad 1.1 . centerXY . lw 0.2 +-- > $ (trailLike c # lc blue) +-- > <> (lc green . trailLike +-- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) (-2) $ c) +-- > where +-- > c = reflectY corner +-- > +-- > offsetTrailOuterExample :: Diagram SVG R2 +-- > offsetTrailOuterExample = pad 1.1 . centerXY . lw 0.2 +-- > $ (trailLike c # lc blue) +-- > <> (lc green . trailLike +-- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) 2 $ c) +-- > where +-- > c = hexagon 5 + +withTrailL :: (Located (Trail' Line v) -> r) -> (Located (Trail' Loop v) -> r) -> Located (Trail v) -> r +withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) + where + p = loc l + +-- | Expand a 'Trail' with the given options and radius 'r' around a given 'Trail'. +-- Expanding can be thought of as generating the loop that, when filled, represents +-- stroking the trail with a radius 'r' brush. +-- +-- The cap styles applied to an outside corner can be seen here (with the original +-- trail in white and the result of 'expandTrail'' filled in green): +-- +-- <> +-- +-- Loops result in a path with an inner and outer loop: +-- +-- <> +-- +expandTrail' :: ExpandOpts + -> Double -- ^ Radius of offset. Only non-negative values allowed. + -- For a line this gives a loop of the offset. For a + -- loop this gives two loops, the outer counter-clockwise + -- and the inner clockwise. + -> Located (Trail R2) + -> Path R2 +expandTrail' o r t + | r < 0 = error "expandTrail' with negative radius" + -- TODO: consider just reversing the path instead of this error. + | otherwise = withTrailL (pathFromLocTrail . expandLine o r) (expandLoop o r) t + +expandLine :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) +expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) + where + offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments + f r' = joinSegments (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t + ends = tail . trailVertices $ t + s = atStart t + e = atEnd t + cap = fromLineCap (opts^.expandCap) + +expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 +expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) + where + offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments + f r' = joinSegments (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t + ends = (\(a:as) -> as ++ [a]) . trailVertices $ t + +-- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. +expandTrail :: Double -> Located (Trail R2) -> Path R2 +expandTrail = expandTrail' def + +-- | Expand a 'Path' using 'expandTrail'' on each trail in the path. +expandPath' :: ExpandOpts -> Double -> Path R2 -> Path R2 +expandPath' opts r = mconcat + . map (bindLoc (expandTrail' opts r) . (`at` origin)) + . op Path + +-- | Expand a 'Path' with the given radius and default options. See 'expandPath''. +expandPath :: Double -> Path R2 -> Path R2 +expandPath = expandPath' def + +-- > import Diagrams.TwoD.Offset +-- > import Data.Default.Class +-- > +-- > expandTrailExample :: Diagram SVG R2 +-- > expandTrailExample = pad 1.1 . centerXY . hcat' (def & sep .~ 1) +-- > . map (uncurry showStyle) +-- > $ [ (LineCapButt, "LineCapButt") +-- > , (LineCapRound, "LineCapRound") +-- > , (LineCapSquare, "LineCapSquare") +-- > ] +-- > where +-- > showStyle c s = centerXY (trailLike corner # lc white # lw 0.2 +-- > <> stroke (expandTrail' +-- > (def & expandJoin .~ LineJoinRound +-- > & expandCap .~ c +-- > ) 2 corner) +-- > # lw 0 # 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)) +-- > where +-- > t = mapLoc glueTrail $ fromVertices (map p2 [(0, 0), (5, 0), (10, 5), (10, 10), (0, 0)]) +-- > t' = expandTrail' (def & expandJoin .~ LineJoinRound) 1 t + + +-- | When we expand a line (the original line runs through the center of offset +-- lines at r and -r) there is some choice in what the ends will look like. +-- If we are using a circle brush we should see a half circle at each end. +-- Similar caps could be made for square brushes or simply stopping exactly at +-- the end with a straight line (a perpendicular line brush). +-- +-- caps takes the radius and the start and end points of the original line and +-- the offset trails going out and coming back. The result is a new list of +-- trails with the caps included. +caps :: (Double -> P2 -> P2 -> P2 -> Trail R2) + -> Double -> P2 -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Located (Trail R2) +caps cap r s e fs bs = mapLoc glueTrail $ mconcat + [ cap r s (atStart bs) (atStart fs) + , unLoc fs + , cap r e (atEnd fs) (atEnd bs) + , reverseDomain (unLoc bs) + ] `at` atStart bs + +-- | Take a LineCap style and give a function for building the cap from +fromLineCap :: LineCap -> Double -> P2 -> P2 -> P2 -> Trail R2 +fromLineCap c = case c of + LineCapButt -> capCut + LineCapRound -> capArc + LineCapSquare -> capSquare + +-- | Builds a cap that directly connects the ends. +capCut :: Double -> P2 -> P2 -> P2 -> Trail R2 +capCut _r _c a b = fromSegments [straight (b .-. a)] + +-- | Builds a cap with a square centered on the end. +capSquare :: Double -> P2 -> P2 -> P2 -> Trail R2 +capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] + where + v = perp (a .-. c) + +-- | Builds an arc to fit with a given radius, center, start, and end points. +-- A Negative r means a counter-clockwise arc +capArc :: Double -> P2 -> P2 -> P2 -> Trail R2 +capArc r c a b = trailLike . moveTo c $ fs + where + fs | r < 0 = scale (-r) $ arcVCW (a .-. c) (b .-. c) + | otherwise = scale r $ arcV (a .-. c) (b .-. c) + +-- Arc helpers +arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t +arcV u v = arc (direction u) (direction v :: Turn) + +arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t +arcVCW u v = arcCW (direction u) (direction v :: Turn) + + +-- | Join together a list of located trails with the given join style. The +-- style is given as a function to compute the join given the local information +-- of the original vertex, the previous trail, and the next trail. The result +-- is a single located trail. A join radius is also given to aid in arc joins. +-- +-- Note: this is not a general purpose join and assumes that we are joining an +-- offset trail. For instance, a fixed radius arc will not fit between arbitrary +-- trails without trimming or extending. +joinSegments :: (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) + -> Bool + -> Double + -> Double + -> [Point R2] + -> [Located (Trail R2)] + -> Located (Trail R2) +joinSegments _ _ _ _ _ [] = mempty `at` origin +joinSegments _ _ _ _ [] _ = mempty `at` origin +joinSegments j isLoop ml r es ts@(t:_) = t' + where + t' | isLoop = mapLoc (glueTrail . (<> mconcat (take (length ts) $ ss es (ts ++ [t])))) t + | otherwise = mapLoc (<> mconcat (ss es ts)) t + ss es' ts' = [j ml r e a b <> unLoc b | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + +-- | Take a join style and give the join function to be used by joinSegments. +fromLineJoin + :: LineJoin -> Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +fromLineJoin j = case j of + LineJoinMiter -> joinSegmentIntersect + LineJoinRound -> joinSegmentArc + LineJoinBevel -> joinSegmentClip + +-- TODO: The joinSegmentCut option is not in our standard line joins. I don't know +-- how useful it is graphically, I mostly had it as it was useful for debugging +{- +-- | Join with segments going back to the original corner. +joinSegmentCut :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentCut _ _ e a b = fromSegments + [ straight (e .-. atEnd a) + , straight (atStart b .-. e) + ] +-} + +-- | Join by directly connecting the end points. On an inside corner this +-- creates negative space for even-odd fill. Here is where we would want to +-- use an arc or something else in the future. +joinSegmentClip :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] + +-- | Join with a radius arc. On an inside corner this will loop around the interior +-- of the offset trail. With a winding fill this will not be visible. +joinSegmentArc :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) + +-- | Join to the intersection of the incoming trails projected tangent to their ends. +-- If the intersection is beyond the miter limit times the radius, stop at the limit. +joinSegmentIntersect + :: Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2 +joinSegmentIntersect miterLimit r e a b = + if cross < 0.000001 + then clip + else case traceP pa va t of + -- clip join when we excede the miter limit. We could instead + -- Join at exactly the miter limit, but standard behavior seems + -- to be clipping. + Nothing -> clip + Just p + -- If trace gave us garbage... + | p `distance` pb > abs (miterLimit * r) -> clip + | otherwise -> unLoc $ fromVertices [ pa, p, pb ] + where + t = straight (miter vb) `at` pb + va = unitPerp (pa .-. e) + vb = -unitPerp (pb .-. e) + pa = atEnd a + pb = atStart b + miter v = (abs (miterLimit * r)) *^ v + clip = joinSegmentClip miterLimit r e a b + cross = let (xa,ya) = unr2 va; (xb,yb) = unr2 vb in abs (xa * yb - xb * ya) + diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -23,14 +25,15 @@ module Diagrams.TwoD.Path ( -- * Constructing path-based diagrams - stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop - , strokeLocT, strokeLocLine, strokeLocLoop + stroke, stroke', strokeTrail, strokeT, strokeTrail', strokeT' + , strokeLine, strokeLoop + , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop -- ** Stroke options , FillRule(..) , FillRuleA(..), getFillRule, fillRule - , StrokeOpts(..) + , StrokeOpts(..), vertexNames, queryFillRule -- ** Inside/outside testing @@ -42,6 +45,9 @@ ) where import Control.Applicative (liftA2) +import Control.Lens ( makeWrapped, makeLensesWith, (.~), (^.) + , generateSignatures, lensRules, op + , Lens, Lens', unwrapped) import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable @@ -59,7 +65,7 @@ import Diagrams.Solve import Diagrams.Trail import Diagrams.TrailLike -import Diagrams.TwoD.Segment +import Diagrams.TwoD.Segment () import Diagrams.TwoD.Types import Diagrams.Util (tau) @@ -79,12 +85,66 @@ . lineSegments instance Traced (Path R2) where - getTrace = F.foldMap getTrace . pathTrails + getTrace = F.foldMap getTrace . op Path ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- ------------------------------------------------------------ +-- | Enumeration of algorithms or \"rules\" for determining which +-- points lie in the interior of a (possibly self-intersecting) +-- closed path. +data FillRule = Winding -- ^ Interior points are those with a nonzero + -- /winding/ /number/. See + -- . + | EvenOdd -- ^ Interior points are those where a ray + -- extended infinitely in a particular + -- direction crosses the path an odd number + -- of times. See + -- . + deriving (Eq, Show) + +instance Default FillRule where + def = Winding + +-- | A record of options that control how a path is stroked. +-- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ +-- records can be created using @'with' { ... }@ notation. +data StrokeOpts a + = StrokeOpts + { _vertexNames :: [[a]] + + , _queryFillRule :: FillRule + + } + +makeLensesWith (generateSignatures .~ False $ lensRules) ''StrokeOpts + +-- | Atomic names that should be assigned to the vertices of the path so that +-- they can be referenced later. If there are not enough names, the extra +-- vertices are not assigned names; if there are too many, the extra names +-- are ignored. Note that this is a /list of lists/ of names, since paths +-- can consist of multiple trails. The first list of names are assigned to +-- the vertices of the first trail, the second list to the second trail, and +-- so on. +-- +-- The default value is the empty list. + +vertexNames :: forall a a'. Lens (StrokeOpts a) (StrokeOpts a') [[a]] [[a']] + +-- | The fill rule used for determining which points are inside the path. +-- The default is 'Winding'. NOTE: for now, this only affects the resulting +-- diagram's 'Query', /not/ how it will be drawn! To set the fill rule +-- determining how it is to be drawn, use the 'fillRule' function. +queryFillRule :: forall a. Lens' (StrokeOpts a) FillRule + + +instance Default (StrokeOpts a) where + def = StrokeOpts + { _vertexNames = [] + , _queryFillRule = def + } + -- | Convert a path into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices. -- @@ -111,75 +171,46 @@ -- ... }@ syntax may be used. stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts path - | null (pathTrails p1) = mkP p2 - | null (pathTrails p2) = mkP p1 - | otherwise = mkP p1 <> mkP p2 + | null (pLines ^. unwrapped) = mkP pLoops + | null (pLoops ^. unwrapped) = mkP pLines + | otherwise = mkP pLines <> mkP pLoops where - (p1,p2) = partitionPath (isLine . unLoc) path + (pLines,pLoops) = partitionPath (isLine . unLoc) path mkP p = mkQD (Prim p) (getEnvelope p) (getTrace p) (fromNames . concat $ - zipWith zip (vertexNames opts) ((map . map) subPoint (pathVertices p)) + zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) ) - (Query $ Any . flip (runFillRule (queryFillRule opts)) p) + (Query $ Any . flip (runFillRule (opts^.queryFillRule)) p) --- | A record of options that control how a path is stroked. --- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ --- records can be created using @'with' { ... }@ notation. -data StrokeOpts a - = StrokeOpts - { vertexNames :: [[a]] -- ^ Atomic names that should be assigned - -- to the vertices of the path so that - -- they can be referenced later. If - -- there are not enough names, the extra - -- vertices are not assigned names; if - -- there are too many, the extra names - -- are ignored. Note that this is a - -- /list of lists/ of names, since paths - -- can consist of multiple trails. The - -- first list of names are assigned to - -- the vertices of the first trail, the - -- second list to the second trail, and - -- so on. - -- - -- The default value is the empty list. - , queryFillRule :: FillRule - -- ^ The fill rule used for determining - -- which points are inside the path. - -- The default is 'Winding'. NOTE: for - -- now, this only affects the resulting - -- diagram's 'Query', /not/ how it will - -- be drawn! To set the fill rule - -- determining how it is to be drawn, - -- use the 'fillRule' function. - } - -instance Default (StrokeOpts a) where - def = StrokeOpts - { vertexNames = [] - , queryFillRule = Winding - } - -- | A composition of 'stroke' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -- -- Note that a bug in GHC 7.0.1 causes a context stack overflow when --- inferring the type of 'stroke' and hence of @strokeT@ as well. +-- inferring the type of 'stroke' and hence of @strokeTrail@ as well. -- The solution is to give a type signature to expressions involving --- @strokeT@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 +-- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). -strokeT :: (Renderable (Path R2) b) - => Trail R2 -> Diagram b R2 -strokeT = stroke . pathFromTrail +strokeTrail :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 +strokeTrail = stroke . pathFromTrail +-- | Deprecated synonym for 'strokeTrail'. +strokeT :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 +strokeT = strokeTrail + -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. +strokeTrail' :: (Renderable (Path R2) b, IsName a) + => StrokeOpts a -> Trail R2 -> Diagram b R2 +strokeTrail' opts = stroke' opts . pathFromTrail + +-- | Deprecated synonym for 'strokeTrail''. strokeT' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Trail R2 -> Diagram b R2 -strokeT' opts = stroke' opts . pathFromTrail +strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. @@ -192,9 +223,13 @@ strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly --- into a diagram; @strokeLocT = stroke . trailLike@. +-- into a diagram; @strokeLocTrail = stroke . trailLike@. +strokeLocTrail :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 +strokeLocTrail = stroke . trailLike + +-- | Deprecated synonym for 'strokeLocTrail'. strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 -strokeLocT = stroke . trailLike +strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. @@ -210,27 +245,19 @@ -- Inside/outside testing ------------------------------------------------------------ --- | Enumeration of algorithms or \"rules\" for determining which --- points lie in the interior of a (possibly self-intersecting) --- closed path. -data FillRule = Winding -- ^ Interior points are those with a nonzero - -- /winding/ /number/. See - -- . - | EvenOdd -- ^ Interior points are those where a ray - -- extended infinitely in a particular - -- direction crosses the path an odd number - -- of times. See - -- . - deriving (Eq) + runFillRule :: FillRule -> P2 -> Path R2 -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd newtype FillRuleA = FillRuleA (Last FillRule) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Show) instance AttributeClass FillRuleA +instance Default FillRuleA where + def = FillRuleA $ Last $ def + -- | Extract the fill rule from a 'FillRuleA' attribute. getFillRule :: FillRuleA -> FillRule getFillRule (FillRuleA (Last r)) = r @@ -263,7 +290,7 @@ -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. crossings :: P2 -> Path R2 -> Int -crossings p = F.sum . map (trailCrossings p) . pathTrails +crossings p = F.sum . map (trailCrossings p) . op Path -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. @@ -313,8 +340,11 @@ -- concatenation, so applying multiple clipping paths is sensible. -- The clipping region is the intersection of all the applied -- clipping paths. -newtype Clip = Clip { getClip :: [Path R2] } +newtype Clip = Clip [Path R2] deriving (Typeable, Semigroup) + +makeWrapped ''Clip + instance AttributeClass Clip type instance V Clip = R2 diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -20,7 +21,7 @@ -- * Polygons PolyType(..) , PolyOrientation(..) - , PolygonOpts(..) + , PolygonOpts(..), polyType, polyOrient, polyCenter , polygon , polyTrail @@ -44,13 +45,12 @@ ) where +import Control.Lens hiding (transform, at, (<.>), (&), (#)) import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, writeArray) -import qualified Data.Foldable as F import Data.List (maximumBy, minimumBy) -import qualified Data.List.NonEmpty as NEL import Data.Maybe (catMaybes) import Data.Monoid (mconcat, mempty) import Data.Ord (comparing) @@ -64,7 +64,6 @@ import Diagrams.Located import Diagrams.Path import Diagrams.Points (centroid) -import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform @@ -138,20 +137,24 @@ -- | Options for specifying a polygon. data PolygonOpts = PolygonOpts - { polyType :: PolyType - -- ^ Specification for the polygon's vertices. + { _polyType :: PolyType + , _polyOrient :: PolyOrientation + , _polyCenter :: P2 + } - , polyOrient :: PolyOrientation - -- ^ Should a rotation be applied to the - -- polygon in order to orient it in a - -- particular way? +makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts - , polyCenter :: P2 - -- ^ Should a translation be applied to the - -- polygon in order to place the center at a - -- particular location? - } +-- | Specification for the polygon's vertices. +polyType :: Lens' PolygonOpts PolyType +-- | Should a rotation be applied to the polygon in order to orient it in a +-- particular way? +polyOrient :: Lens' PolygonOpts PolyOrientation + +-- | Should a translation be applied to the polygon in order to place the center +-- at a particular location? +polyCenter :: Lens' PolygonOpts P2 + -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. instance Default PolygonOpts where @@ -161,11 +164,11 @@ polyTrail :: PolygonOpts -> Located (Trail R2) polyTrail po = transform ori tr where - tr = case polyType po of + tr = case po^.polyType of PolyPolar ans szs -> polyPolarTrail ans szs PolySides ans szs -> polySidesTrail ans szs PolyRegular n r -> polyRegularTrail n r - ori = case polyOrient po of + ori = case po^.polyOrient of OrientH -> orient unit_Y tr OrientV -> orient unitX tr OrientTo v -> orient v tr @@ -219,7 +222,7 @@ (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) - sndOf3 (_,x,_) = x + sndOf3 (_,b,_) = b a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v angleFromNormal o diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -2,6 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Orphan Traced instances for Segment Closed R2 and FixedSegment R2. +-- They can't go in Traced; but they shouldn't really go in +-- Diagrams.Segment either because we only have Traced instances for +-- the special case of R2. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Segment @@ -23,7 +28,6 @@ import Data.VectorSpace import Diagrams.Core -import Diagrams.Core.Trace import Diagrams.Located import Diagrams.Parametric @@ -64,7 +68,6 @@ let v0 = p0' .-. p0 det = perp v1 <.> v0 - perp v = rotateBy (-1/4) v p = p1 .-. p0 t0 = (perp v1 <.> p) / det t1 = (perp v0 <.> p) / det diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ , square , pentagon , hexagon + , heptagon , septagon , octagon , nonagon @@ -39,13 +41,12 @@ -- * Other shapes , roundedRect - , RoundedRectOpts(..) + , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR , roundedRect' ) where import Diagrams.Core -import Diagrams.Coordinates import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment @@ -58,53 +59,54 @@ import Diagrams.Util +import Control.Lens (makeLenses, op, (.~), (^.), (&)) import Data.Default.Class import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. -- --- <> +-- <> -- --- > hruleEx = vcat' with {sep = 0.2} (map hrule [1..5]) +-- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 hrule :: (TrailLike t, V t ~ R2) => Double -> t -hrule d = trailLike $ trailFromSegments [straight (d & 0)] `at` (p2 (-d/2,0)) +hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` (p2 (-d/2,0)) -- | Create a centered vertical (T-B) line of the given length. -- --- <> +-- <> -- --- > vruleEx = hcat' with {sep = 0.2} (map vrule [1, 1.2 .. 2]) +-- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 vrule :: (TrailLike t, V t ~ R2) => Double -> t -vrule d = trailLike $ trailFromSegments [straight (0 & (-d))] `at` (p2 (0,d/2)) +vrule d = trailLike $ trailFromSegments [straight $ r2 (0, (-d))] `at` (p2 (0,d/2)) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- --- <> +-- <> unitSquare :: (TrailLike t, V t ~ R2) => t -unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) - , polyOrient = OrientH } +unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) + & polyOrient .~ OrientH) -- > unitSquareEx = unitSquare # pad 1.1 # showOrigin -- | A square with its center at the origin and sides of the given -- length, oriented parallel to the axes. -- --- <> +-- <> square :: (TrailLike t, Transformable t, V t ~ R2) => Double -> t square d = rect d d --- > squareEx = hcat' with {sep = 0.5} [square 1, square 2, square 3] +-- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] -- > # centerXY # pad 1.1 # lw 0.03 -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. -- --- <> +-- <> rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t -rect w h = trailLike . head . pathTrails $ unitSquare # scaleX w # scaleY h +rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 @@ -136,18 +138,18 @@ -- -- The polygon will be oriented with one edge parallel to the x-axis. regPoly :: (TrailLike t, V t ~ R2) => Int -> Double -> t -regPoly n l = polygon with { polyType = +regPoly n l = polygon (def & polyType .~ PolySides (repeat (1/ fromIntegral n :: Turn)) (replicate (n-1) l) - , polyOrient = OrientH - } + & polyOrient .~ OrientH + ) -- > shapeEx sh = sh 1 # pad 1.1 -- > triangleEx = shapeEx triangle -- > pentagonEx = shapeEx pentagon -- > hexagonEx = shapeEx hexagon --- > septagonEx = shapeEx septagon +-- > heptagonEx = shapeEx heptagon -- > octagonEx = shapeEx octagon -- > nonagonEx = shapeEx nonagon -- > decagonEx = shapeEx decagon @@ -161,70 +163,86 @@ -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> triangle :: (TrailLike t, V t ~ R2) => Double -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> pentagon :: (TrailLike t, V t ~ R2) => Double -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> hexagon :: (TrailLike t, V t ~ R2) => Double -> t hexagon = regPoly 6 --- | A regular septagon, with sides of the given length and base +-- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> +heptagon :: (TrailLike t, V t ~ R2) => Double -> t +heptagon = regPoly 7 + +-- | A synonym for 'heptagon'. It is, however, completely inferior, +-- being a base admixture of the Latin /septum/ (seven) and the +-- Greek γωνία (angle). septagon :: (TrailLike t, V t ~ R2) => Double -> t -septagon = regPoly 7 +septagon = heptagon -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> octagon :: (TrailLike t, V t ~ R2) => Double -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> nonagon :: (TrailLike t, V t ~ R2) => Double -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> decagon :: (TrailLike t, V t ~ R2) => Double -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> hendecagon :: (TrailLike t, V t ~ R2) => Double -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- --- <> +-- <> dodecagon :: (TrailLike t, V t ~ R2) => Double -> t dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ +data RoundedRectOpts = RoundedRectOpts { _radiusTL :: Double + , _radiusTR :: Double + , _radiusBL :: Double + , _radiusBR :: Double + } +makeLenses ''RoundedRectOpts + +instance Default RoundedRectOpts where + def = RoundedRectOpts 0 0 0 0 + -- | @roundedRect w h r@ generates a closed trail, or closed path -- centered at the origin, of an axis-aligned rectangle with width -- @w@, height @h@, and circular rounded corners of radius @r@. If @@ -236,21 +254,21 @@ -- a different radius for each corner individually, use -- 'roundedRect'' instead. -- --- <> +-- <> -- --- > roundedRectEx = pad 1.1 . centerXY $ hcat' with { sep = 0.2 } +-- > roundedRectEx = pad 1.1 . centerXY $ hcat' (with & sep .~ 0.2) -- > [ roundedRect 0.5 0.4 0.1 -- > , roundedRect 0.5 0.4 (-0.1) --- > , roundedRect' 0.7 0.4 with { radiusTL = 0.2 --- > , radiusTR = -0.2 --- > , radiusBR = 0.1 } +-- > , roundedRect' 0.7 0.4 (with & radiusTL .~ 0.2 +-- > & radiusTR .~ -0.2 +-- > & radiusBR .~ 0.1) -- > ] roundedRect :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> t -roundedRect w h r = roundedRect' w h (with { radiusTL = r, - radiusBR = r, - radiusTR = r, - radiusBL = r}) +roundedRect w h r = roundedRect' w h (def & radiusTL .~ r + & radiusBR .~ r + & radiusTR .~ r + & radiusBL .~ r) -- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. @@ -279,7 +297,7 @@ rBL = clampCnr radiusBR radiusTL radiusTR radiusBL rTR = clampCnr radiusTL radiusBR radiusBL radiusTR rBR = clampCnr radiusBL radiusTR radiusTL radiusBR - clampCnr rx ry ro r = let (rx',ry',ro',r') = (rx opts, ry opts, ro opts, r opts) + clampCnr rx ry ro r = let (rx',ry',ro',r') = (opts^.rx, opts^.ry, opts^.ro, opts^.r) in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r' -- prevent curves of adjacent corners from overlapping clampAdj len adj r = if abs r > len/2 @@ -294,11 +312,3 @@ | r < 0 = doArc 3 2 | otherwise = doArc 0 1 where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn) - -data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double - , radiusTR :: Double - , radiusBL :: Double - , radiusBR :: Double - } -instance Default RoundedRectOpts where - def = RoundedRectOpts 0 0 0 0 diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Size @@ -78,15 +80,15 @@ ------------------------------------------------------------ -- | A specification of a (requested) rectangular size. -data SizeSpec2D = Width Double -- ^ Specify an explicit +data SizeSpec2D = Width !Double -- ^ Specify an explicit -- width. The height should be -- determined automatically (so -- as to preserve aspect ratio). - | Height Double -- ^ Specify an explicit + | Height !Double -- ^ Specify an explicit -- height. The width should be -- determined automatically (so -- as to preserve aspect ratio). - | Dims Double Double -- ^ An explicit specification + | Dims !Double !Double -- ^ An explicit specification -- of a width and height. | Absolute -- ^ Absolute size: use whatever -- size an object already has; diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable - , GeneralizedNewtypeDeriving - , FlexibleContexts - , TypeFamilies - , MultiParamTypeClasses - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text @@ -31,15 +30,16 @@ , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold ) where -import Diagrams.Attributes -import Diagrams.Core -import Diagrams.TwoD.Types +import Diagrams.Attributes +import Diagrams.Core +import Diagrams.Core.Envelope (pointEnvelope) +import Diagrams.TwoD.Types -import Data.AffineSpace ((.-.)) +import Data.AffineSpace ((.-.)) -import Data.Semigroup +import Data.Semigroup -import Data.Colour +import Data.Colour import Data.Default.Class @@ -72,9 +72,11 @@ data TextAlignment = BaselineText | BoxAlignedText Double Double mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 -mkText a t = recommendFillColor black -- See Note [recommendFillColor] +mkText a t = recommendFillColor (black :: Colour Double) + -- See Note [recommendFillColor] + $ mkQD (Prim (Text mempty a t)) - mempty + (pointEnvelope origin) mempty mempty mempty 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 @@ -45,29 +45,22 @@ , shearingX, shearX , shearingY, shearY - -- * Scale invariance - , ScaleInv(..), scaleInv, scaleInvPrim - - -- * component-wise + -- * Utilities , onBasis + , avgScale ) where import Diagrams.Core import qualified Diagrams.Core.Transform as T -import Control.Newtype (over) - -import Diagrams.Coordinates import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction) - -import Data.Semigroup +import Diagrams.Coordinates import Data.AffineSpace - -import Control.Arrow (first, second) +import Data.Semigroup -- Rotation ------------------------------------------------ @@ -78,7 +71,7 @@ where r = rot theta <-> rot (-theta) Rad theta = convertAngle ang - rot th (coords -> x :& y) = (cos th * x - sin th * y) & (sin th * x + cos th * y) + rot th (coords -> x :& y) = (cos th * x - sin th * y) ^& (sin th * x + cos th * y) -- | Rotate about the local origin by the given angle. Positive angles -- correspond to counterclockwise rotation, negative to @@ -118,7 +111,7 @@ -- the x (horizontal) direction. scalingX :: Double -> T2 scalingX c = fromLinear s s - where s = (over r2 . first) (*c) <-> (over r2 . first) (/c) + where s = (\(R2 x y) -> R2 (x*c) y) <-> (\(R2 x y) -> R2 (x/c) y) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. @@ -129,7 +122,7 @@ -- the y (vertical) direction. scalingY :: Double -> T2 scalingY c = fromLinear s s - where s = (over r2 . second) (*c) <-> (over r2 . second) (/c) + where s = (\(R2 x y) -> R2 x (y*c)) <-> (\(R2 x y) -> R2 x (y/c)) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. @@ -167,7 +160,7 @@ -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. translationX :: Double -> T2 -translationX x = translation (x & 0) +translationX x = translation (x ^& 0) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. @@ -177,7 +170,7 @@ -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. translationY :: Double -> T2 -translationY y = translation (0 & y) +translationY y = translation (0 ^& y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. @@ -223,11 +216,11 @@ -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. shearingX :: Double -> T2 -shearingX d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) - (over r2 (sh' d) <-> over r2 (sh' (-d))) - where sh k (x, y) = (x+k*y, y) - sh' k = swap . sh k . swap - swap (x,y) = (y,x) +shearingX d = fromLinear (sh d <-> sh (-d)) + (sh' d <-> sh' (-d)) + where sh k (R2 x y) = R2 (x+k*y) y + sh' k = swap . sh k . swap + swap (R2 x y) = R2 y x -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. @@ -237,122 +230,58 @@ -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. shearingY :: Double -> T2 -shearingY d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) - (over r2 (sh' d) <-> over r2 (sh' (-d))) - where sh k (x,y) = (x, y+k*x) - sh' k = swap . sh k . swap - swap (x,y) = (y,x) +shearingY d = fromLinear (sh d <-> sh (-d)) + (sh' d <-> sh' (-d)) + where sh k (R2 x y) = R2 x (y+k*x) + sh' k = swap . sh k . swap + swap (R2 x y) = R2 y x -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. shearY :: (Transformable t, V t ~ R2) => Double -> t -> t shearY = transform . shearingY - --- Scale invariance ---------------------------------------- +-- | Get the matrix equivalent of the linear transform, +-- (as a pair of columns) and the translation vector. This +-- is mostly useful for implementing backends. +onBasis :: Transformation R2 -> ((R2, R2), R2) +onBasis t = ((x, y), v) + where ((x:y:[]), v) = T.onBasis t --- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ --- objects. Intuitively, a scale-invariant object is affected by --- transformations like translations and rotations, but not by scales. --- --- However, this is problematic when it comes to /non-uniform/ --- scales (/e.g./ @scaleX 2 . scaleY 3@) since they can introduce a --- perceived rotational component. The prototypical example is an --- arrowhead on the end of a path, which should be scale-invariant. --- However, applying a non-uniform scale to the path but not the --- arrowhead would leave the arrowhead pointing in the wrong --- direction. --- --- Moreover, for objects whose local origin is not at the local --- origin of the parent diagram, any scale can result in a --- translational component as well. --- --- The solution is to also store a point (indicating the location, --- /i.e./ the local origin) and a unit vector (indicating the --- /direction/) along with a scale-invariant object. A --- transformation to be applied is decomposed into rotational and --- translational components as follows: +-- | Compute the \"average\" amount of scaling performed by a +-- transformation. Satisfies the properties -- --- * The transformation is applied to the direction vector, and the --- difference in angle between the original direction vector and its --- image under the transformation determines the rotational --- component. The rotation is applied with respect to the stored --- location, rather than the global origin. +-- @ +-- avgScale (scaling k) == k +-- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 +-- @ -- --- * The vector from the location to the image of the location under --- the transformation determines the translational component. - -data ScaleInv t = - ScaleInv - { unScaleInv :: t - , scaleInvDir :: R2 - , scaleInvLoc :: P2 - } - deriving (Show) - --- | Create a scale-invariant object pointing in the given direction, --- located at the origin. -scaleInv :: t -> R2 -> ScaleInv t -scaleInv t d = ScaleInv t d origin - -type instance V (ScaleInv t) = R2 - -instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where - moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) - -instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where - transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' - where - angle :: Rad - angle = direction (transform tr v) - direction v - rot :: (Transformable t, V t ~ R2) => t -> t - rot = rotateAbout l angle - l' = transform tr l - trans = translate (l' .-. l) +-- 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 --- 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' +avgScale is computed as the square root of the positive +determinant. Proofs for the specified properties: - -- but apply t1 directly to the underlying thing, scales and all. - t'' = transform t1 t' +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)|) -instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where - render b = render b . unScaleInv +From wikipedia: --- | Create a diagram from a single scale-invariant primitive. The --- vector argument specifies the direction in which the primitive is --- \"pointing\" (for the purpose of keeping it rotated correctly --- under non-uniform scaling). The primitive is assumed to be --- \"located\" at the origin (for the purpose of translating it --- correctly under scaling). --- --- Note that the resulting diagram will have an /empty/ envelope, --- trace, and query. The reason is that the envelope, trace, and --- query cannot be cached---applying a transformation would cause --- the cached envelope, etc. to get \"out of sync\" with the --- scale-invariant object. The intention, at any rate, is that --- scale-invariant things will be used only as \"decorations\" (/e.g./ --- arrowheads) which should not affect the envelope, trace, and --- query. -scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) - => t -> R2 -> QDiagram b R2 m -scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty + 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. --- | Get the matrix equivalent of the linear transform, --- (as a pair of columns) and the translation vector. This --- is mostly useful for implementing backends. -onBasis :: Transformation R2 -> ((R2, R2), R2) -onBasis t = ((x, y), v) - where ((x:y:[]), v) = T.onBasis t +-} diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Transform.ScaleInv +-- Copyright : (c) 2012-2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Wrapper for creating scale-invariant objects in two dimensions. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Transform.ScaleInv + ( ScaleInv(..) + , scaleInvObj, scaleInvDir, scaleInvLoc + , scaleInv, scaleInvPrim ) + where + +import Control.Lens (makeLenses, view) +import Data.AffineSpace ((.-.)) +import Data.Semigroup + +import Diagrams.Core +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector + +-- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ +-- objects. Intuitively, a scale-invariant object is affected by +-- transformations like translations and rotations, but not by scales. +-- +-- However, this is problematic when it comes to /non-uniform/ +-- scales (/e.g./ @scaleX 2 . scaleY 3@) since they can introduce a +-- perceived rotational component. The prototypical example is an +-- arrowhead on the end of a path, which should be scale-invariant. +-- However, applying a non-uniform scale to the path but not the +-- arrowhead would leave the arrowhead pointing in the wrong +-- direction. +-- +-- Moreover, for objects whose local origin is not at the local +-- origin of the parent diagram, any scale can result in a +-- translational component as well. +-- +-- The solution is to also store a point (indicating the location, +-- /i.e./ the local origin) and a unit vector (indicating the +-- /direction/) along with a scale-invariant object. A +-- transformation to be applied is decomposed into rotational and +-- translational components as follows: +-- +-- * The transformation is applied to the direction vector, and the +-- difference in angle between the original direction vector and its +-- image under the transformation determines the rotational +-- component. The rotation is applied with respect to the stored +-- location, rather than the global origin. +-- +-- * The vector from the location to the image of the location under +-- the transformation determines the translational component. + +data ScaleInv t = + ScaleInv + { _scaleInvObj :: t + , _scaleInvDir :: R2 + , _scaleInvLoc :: P2 + } + deriving (Show) + +makeLenses ''ScaleInv + +-- | Create a scale-invariant object pointing in the given direction, +-- located at the origin. +scaleInv :: t -> R2 -> ScaleInv t +scaleInv t d = ScaleInv t d origin + +type instance V (ScaleInv t) = R2 + +instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where + moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) + +instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where + transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' + where + angle :: Rad + angle = direction (transform tr v) - direction v + rot :: (Transformable t, V t ~ R2) => t -> t + rot = rotateAbout l angle + l' = transform tr l + trans = translate (l' .-. l) + +{- Proof that the above satisfies the monoid action laws. + + 1. transform mempty (ScaleInv t v l) + = ScaleInv (trans . rot $ t) (rot v) l' + { l' = transform mempty l = l } + { trans = translate (l' .-. l) + = translate (l .-. l) + = translate zeroV + = id + } + { rot = rotateAbout l angle + = rotateAbout l (direction (transform mempty v) - direction v) + = rotateAbout l (direction v - direction v) + = rotateAbout l 0 + = id + } + = ScaleInv t v l + + 2. transform t1 (transform t2 (ScaleInv t v l)) + = let angle = direction (transform t2 v) - direction v + rot = rotateAbout l angle + l' = transform t2 l + trans = translate (l' .-. l) + in + transform t1 (ScaleInv (trans . rot $ t) (rot v) l') + + = let angle = direction (transform t2 v) - direction v + rot = rotateAbout l angle + l' = transform t2 l + trans = translate (l' .-. l) + angle2 = direction (transform t1 (rot v)) - direction (rot v) + rot2 = rotateAbout l' angle2 + l'2 = transform t1 l' + trans2 = translate (l'2 .-. l') + in + ScaleInv (trans2 . rot2 . trans . rot $ t) (rot2 . rot $ v) l'2 + + { l'2 = transform t1 l' + = transform t1 (transform t2 l) + = transform (t1 <> t2) l + } + { trans2 = translate (l'2 .-. l') + = translate (transform (t1 <> t2) l .-. transform t2 l) + = translate (transform t1 l .-. l) + } + { rot v = rotateAbout l angle v + = rotate angle `under` translation (origin .-. l) $ v + = rotate angle v + } + { angle2 = direction (transform t1 (rot v)) - direction (rot v) + = direction (transform t1 (rotate angle v)) - direction (rotate angle v) + = direction (transform t1 (rotate angle v)) - direction v - angle + } + { rot2 = rotateAbout l' angle2 + = ??? + } + +-} + +-- 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 + +-- | Create a diagram from a single scale-invariant primitive. The +-- vector argument specifies the direction in which the primitive is +-- \"pointing\" (for the purpose of keeping it rotated correctly +-- under non-uniform scaling). The primitive is assumed to be +-- \"located\" at the origin (for the purpose of translating it +-- correctly under scaling). +-- +-- Note that the resulting diagram will have an /empty/ envelope, +-- trace, and query. The reason is that the envelope, trace, and +-- query cannot be cached---applying a transformation would cause +-- the cached envelope, etc. to get \"out of sync\" with the +-- scale-invariant object. The intention, at any rate, is that +-- scale-invariant things will be used only as \"decorations\" (/e.g./ +-- arrowheads) which should not affect the envelope, trace, and +-- query. +scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) + => t -> R2 -> QDiagram b R2 m +scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty 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 @@ -2,10 +2,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -21,39 +21,44 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - R2, r2, unr2 - , P2, p2, unp2 + R2(..), r2, unr2, mkR2, r2Iso + , P2, p2, mkP2, unp2, p2Iso , T2 -- * Angles , Angle(..) - , Turn(..), CircleFrac, Rad(..), Deg(..) - , fullCircle, convertAngle + + , Turn(..), asTurn, CircleFrac + , Rad(..), asRad + , Deg(..), asDeg + , fullTurn, fullCircle, convertAngle, angleRatio ) where +import Control.Lens (Iso', Wrapped, iso, makeWrapped, op, + wrapped, _1, _2) + import Diagrams.Coordinates import Diagrams.Core import Diagrams.Util (tau) -import Control.Newtype - +import Data.AffineSpace.Point import Data.Basis +import Data.MemoTrie (HasTrie (..)) import Data.NumInstances.Tuple () import Data.VectorSpace import Data.Typeable - ------------------------------------------------------------ -- 2D Euclidean space -- | The two-dimensional Euclidean vector space R^2. This type is -- intentionally abstract. -- --- * To construct a vector, use 'r2', or '&' (from "Diagrams.Coordinates"): +-- * To construct a vector, use 'r2', or '^&' (from "Diagrams.Coordinates"): -- -- @ -- r2 (3,4) :: R2 --- 3 & 4 :: R2 +-- 3 ^& 4 :: R2 -- @ -- -- Note that "Diagrams.Coordinates" is not re-exported by @@ -74,71 +79,120 @@ -- foo (coords -> x :& y) = ... -- @ -newtype R2 = R2 { unR2 :: (Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Typeable, Num, Fractional) +data R2 = R2 {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + deriving (Eq, Ord, Typeable) +instance AdditiveGroup R2 where + zeroV = R2 0 0 + R2 x1 y1 ^+^ R2 x2 y2 = R2 (x1 + x2) (y1 + y2) + negateV (R2 x y) = R2 (-x) (-y) + +instance Num R2 where + (+) = (^+^) + R2 x1 y1 * R2 x2 y2 = R2 (x1 * x2) (y1 * y2) -- this is sort of bogus + (-) = (^-^) + negate = negateV + abs (R2 x y) = R2 (abs x) (abs y) + signum (R2 x y) = R2 (signum x) (signum y) + fromInteger i = R2 i' i' + where i' = fromInteger i + +instance Fractional R2 where + R2 x1 y1 / R2 x2 y2 = R2 (x1/x2) (y1/y2) + recip (R2 x y) = R2 (recip x) (recip y) + fromRational r = R2 r' r' + where r' = fromRational r + instance Show R2 where - showsPrec p (R2 (x,y)) = showParen (p >= 7) $ - showCoord x . showString " & " . showCoord y + showsPrec p (R2 x y) = showParen (p >= 7) $ + showCoord x . showString " ^& " . showCoord y where - showCoord x | x < 0 = showParen True (shows x) - | otherwise = shows x + showCoord c | c < 0 = showParen True (shows c) + | otherwise = shows c instance Read R2 where readsPrec d r = readParen (d > app_prec) - (\r -> [ (R2 (x,y), r''') - | (x,r') <- readsPrec (amp_prec + 1) r - , ("&",r'') <- lex r' - , (y,r''') <- readsPrec (amp_prec + 1) r'' - ]) + (\rr -> [ (R2 x y, r''') + | (x,r') <- readsPrec (amp_prec + 1) rr + , ("^&",r'') <- lex r' + , (y,r''') <- readsPrec (amp_prec + 1) r'' + ]) r where app_prec = 10 amp_prec = 7 -instance Newtype R2 (Double, Double) where - pack = R2 - unpack = unR2 - -- | Construct a 2D vector from a pair of components. See also '&'. r2 :: (Double, Double) -> R2 -r2 = pack +r2 (x,y) = R2 x y -- | Convert a 2D vector back into a pair of components. See also 'coords'. unr2 :: R2 -> (Double, Double) -unr2 = unpack +unr2 (R2 x y) = (x,y) +-- | Curried form of `r2`. +mkR2 :: Double -> Double -> R2 +mkR2 = curry r2 + +-- | Lens wrapped isomorphisms for R2. +instance Wrapped (Double, Double) (Double, Double) R2 R2 where + wrapped = iso r2 unr2 + {-# INLINE wrapped #-} + type instance V R2 = R2 instance VectorSpace R2 where type Scalar R2 = Double - (*^) = over R2 . (*^) + s *^ R2 x y = R2 (s*x) (s*y) +data R2Basis = XB | YB deriving (Eq, Ord, Enum) + +instance HasTrie R2Basis where + data R2Basis :->: x = R2Trie x x + trie f = R2Trie (f XB) (f YB) + untrie (R2Trie x _y) XB = x + untrie (R2Trie _x y) YB = y + enumerate (R2Trie x y) = [(XB,x),(YB,y)] + instance HasBasis R2 where - type Basis R2 = Either () () -- = Basis (Double, Double) - basisValue = R2 . basisValue - decompose = decompose . unR2 - decompose' = decompose' . unR2 + type Basis R2 = R2Basis + basisValue XB = R2 1 0 + basisValue YB = R2 0 1 + decompose (R2 x y) = [(XB, x), (YB, y)] + + decompose' (R2 x _) (XB) = x + decompose' (R2 _ y) (YB) = y + instance InnerSpace R2 where - (unR2 -> vec1) <.> (unR2 -> vec2) = vec1 <.> vec2 + (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2 instance Coordinates R2 where type FinalCoord R2 = Double type PrevDim R2 = Double type Decomposition R2 = Double :& Double - x & y = r2 (x,y) - coords (unR2 -> (x,y)) = x :& y + x ^& y = R2 x y + coords (R2 x y) = x :& y +r2Iso :: Iso' R2 (Double, Double) +r2Iso = iso unr2 r2 + +instance HasX R2 where + _x = r2Iso . _1 + +instance HasY R2 where + _y = r2Iso . _2 + -- | Points in R^2. This type is intentionally abstract. -- --- * To construct a point, use 'p2', or '&' (see +-- * To construct a point, use 'p2', or '^&' (see -- "Diagrams.Coordinates"): -- -- @ -- p2 (3,4) :: P2 --- 3 & 4 :: P2 +-- 3 ^& 4 :: P2 -- @ -- -- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. @@ -156,39 +210,93 @@ -- @ type P2 = Point R2 --- | Construct a 2D point from a pair of coordinates. See also '&'. +-- | Construct a 2D point from a pair of coordinates. See also '^&'. p2 :: (Double, Double) -> P2 -p2 = pack . pack +p2 = P . r2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. unp2 :: P2 -> (Double, Double) -unp2 = unpack . unpack +unp2 (P v) = unr2 v +-- | Curried form of `p2`. +mkP2 :: Double -> Double -> P2 +mkP2 = curry p2 + -- | Transformations in R^2. type T2 = Transformation R2 instance Transformable R2 where transform = apply +p2Iso :: Iso' P2 (Double, Double) +p2Iso = iso unp2 p2 + +instance HasX P2 where + _x = p2Iso . _1 + +instance HasY P2 where + _y = p2Iso . _2 ------------------------------------------------------------ -- Angles -- | Newtype wrapper used to represent angles as fractions of a -- circle. For example, 1\/3 turn = tau\/3 radians = 120 degrees. -newtype Turn = Turn { getTurn :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) +newtype Turn = Turn Double + deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup) +makeWrapped ''Turn + +instance VectorSpace Turn where + type Scalar Turn = Double + s *^ Turn t = Turn (s*t) + +-- | The identity function with a restricted type, for conveniently +-- declaring that some value should have type 'Turn'. For example, +-- @rotation . asTurn . fromRational@ constructs a rotation from a +-- rational value considered as a @Turn@. Without @asTurn@, the angle +-- type would be ambiguous. +asTurn :: Turn -> Turn +asTurn = id + -- | Deprecated synonym for 'Turn', retained for backwards compatibility. type CircleFrac = Turn -- | Newtype wrapper for representing angles in radians. -newtype Rad = Rad { getRad :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) +newtype Rad = Rad Double + deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac, AdditiveGroup) +makeWrapped ''Rad + +instance VectorSpace Rad where + type Scalar Rad = Double + s *^ Rad r = Rad (s*r) + +-- | The identity function with a restricted type, for conveniently +-- declaring that some value should have type 'Rad'. For example, +-- @rotation . asRad . fromRational@ constructs a rotation from a +-- rational value considered as a value in radians. Without @asRad@, +-- the angle type would be ambiguous. +asRad :: Rad -> Rad +asRad = id + -- | Newtype wrapper for representing angles in degrees. -newtype Deg = Deg { getDeg :: Double } - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) +newtype Deg = Deg Double + deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup) +makeWrapped ''Deg + +instance VectorSpace Deg where + type Scalar Deg = Double + s *^ Deg d = Deg (s*d) + +-- | The identity function with a restricted type, for conveniently +-- declaring that some value should have type 'Deg'. For example, +-- @rotation . asDeg . fromIntegral@ constructs a rotation from an +-- integral value considered as a value in degrees. Without @asDeg@, +-- the angle type would be ambiguous. +asDeg :: Deg -> Deg +asDeg = id + -- | Type class for types that measure angles. class Num a => Angle a where -- | Convert to a turn, /i.e./ a fraction of a circle. @@ -203,13 +311,13 @@ -- | tau radians = 1 full turn. instance Angle Rad where - toTurn = Turn . (/tau) . getRad - fromTurn = Rad . (*tau) . getTurn + toTurn = Turn . (/tau) . op Rad + fromTurn = Rad . (*tau) . op Turn -- | 360 degrees = 1 full turn. instance Angle Deg where - toTurn = Turn . (/360) . getDeg - fromTurn = Deg . (*360) . getTurn + toTurn = Turn . (/360) . op Deg + fromTurn = Deg . (*360) . op Turn -- | An angle representing one full turn. fullTurn :: Angle a => a @@ -222,3 +330,7 @@ -- | Convert between two angle representations. convertAngle :: (Angle a, Angle b) => a -> b convertAngle = fromTurn . toTurn + +-- | Calculate ratio between two angles +angleRatio :: Angle a => a -> a -> Double +angleRatio a b = op Turn (toTurn a) / op Turn (toTurn b) 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 @@ -16,32 +16,31 @@ unitX, unitY, unit_X, unit_Y -- * Converting between vectors and angles - , direction, fromDirection, e + , direction, angleBetween, fromDirection, e -- * 2D vector utilities , perp, leftTurn ) where import Data.VectorSpace ((<.>)) -import Diagrams.Coordinates import Diagrams.TwoD.Types -import Diagrams.Util (( # )) +import Diagrams.Coordinates -- | The unit vector in the positive X direction. unitX :: R2 -unitX = 1 & 0 +unitX = 1 ^& 0 -- | The unit vector in the positive Y direction. unitY :: R2 -unitY = 0 & 1 +unitY = 0 ^& 1 -- | The unit vector in the negative X direction. unit_X :: R2 -unit_X = (-1) & 0 +unit_X = (-1) ^& 0 -- | The unit vector in the negative Y direction. unit_Y :: R2 -unit_Y = 0 & (-1) +unit_Y = 0 ^& (-1) -- | Compute the direction of a vector, measured counterclockwise from -- the positive x-axis as a fraction of a full turn. The zero @@ -49,9 +48,18 @@ direction :: Angle a => R2 -> a direction (coords -> x :& y) = convertAngle . Rad $ atan2 y x +-- | Compute the counterclockwise angle from the first vector to the second. +angleBetween :: (Angle a, Num a, Ord a) => R2 -> R2 -> a +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 a => a -> R2 -fromDirection a = cos a' & sin a' +fromDirection a = cos a' ^& sin a' where Rad a' = convertAngle a -- | A convenient synonym for 'fromDirection'. @@ -61,7 +69,7 @@ -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. perp :: R2 -> R2 -perp (coords -> x :& y) = (-y) & x +perp (coords -> x :& y) = (-y) ^& x -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left -- turn from @v1@ (that is, if the direction of @v2@ can be obtained diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -21,7 +21,6 @@ , tau -- * Internal utilities - , Proxy(..) , foldB ) where @@ -86,10 +85,6 @@ -- digits or so), try . tau :: Floating a => a tau = 2*pi - --- | A value of @Proxy a@ carries no information; it's used only to --- fix the type @a@. -data Proxy a = Proxy -- | Given an associative binary operation and a default value to use -- in the case of an empty list, perform a /balanced/ fold over a