diagrams-lib-1.3.1.4/0000755000000000000000000000000012754644012012404 5ustar0000000000000000diagrams-lib-1.3.1.4/README.markdown0000644000000000000000000000043712754644012015111 0ustar0000000000000000[![Build Status](https://travis-ci.org/diagrams/diagrams-lib.png?branch=master)](https://travis-ci.org/diagrams/diagrams-lib) The standard library for [diagrams](http://projects.haskell.org/diagrams/), a Haskell embedded domain-specific language for compositional, declarative drawing. diagrams-lib-1.3.1.4/diagrams-lib.cabal0000644000000000000000000001546612754644012015737 0ustar0000000000000000Name: diagrams-lib Version: 1.3.1.4 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created in arbitrary vector spaces and rendered with multiple backends. diagrams-lib provides a standard library of primitives and operations for creating diagrams. To get started using it, see the "Diagrams" module, and refer to the tutorials and documentation on the diagrams website, . Homepage: http://projects.haskell.org/diagrams License: BSD3 License-file: LICENSE Author: Brent Yorgey Maintainer: diagrams-discuss@googlegroups.com Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics Build-type: Simple Cabal-version: >=1.10 Extra-source-files: CHANGELOG.md, README.markdown, diagrams/*.svg Extra-doc-files: diagrams/*.svg Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git Library Exposed-modules: Diagrams, Diagrams.Prelude, Diagrams.Align, Diagrams.Angle, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Attributes, Diagrams.Attributes.Compile, Diagrams.Backend.CmdLine, Diagrams.BoundingBox, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.CubicSpline, Diagrams.CubicSpline.Internal, Diagrams.Deform Diagrams.Direction, Diagrams.Envelope, Diagrams.LinearMap, Diagrams.Located, Diagrams.Names, Diagrams.Parametric, Diagrams.Parametric.Adjust, Diagrams.Path, Diagrams.Points, Diagrams.Query, Diagrams.Segment, Diagrams.Size, Diagrams.Tangent, Diagrams.ThreeD, Diagrams.ThreeD.Align, Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, Diagrams.ThreeD.Shapes, Diagrams.ThreeD.Size, Diagrams.ThreeD.Transform, Diagrams.ThreeD.Projection, Diagrams.ThreeD.Types, Diagrams.ThreeD.Vector, Diagrams.Trace, Diagrams.Trail, Diagrams.TrailLike, Diagrams.Transform, Diagrams.Transform.ScaleInv, Diagrams.Transform.Matrix, Diagrams.TwoD, Diagrams.TwoD.Adjust, Diagrams.TwoD.Align, Diagrams.TwoD.Arc, Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Attributes, Diagrams.TwoD.Combinators, Diagrams.TwoD.Curvature, Diagrams.TwoD.Deform, Diagrams.TwoD.Ellipse, Diagrams.TwoD.Image, Diagrams.TwoD.Model, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Points, Diagrams.TwoD.Polygons, Diagrams.TwoD.Segment, Diagrams.TwoD.Segment.Bernstein, Diagrams.TwoD.Size, Diagrams.TwoD.Shapes, Diagrams.TwoD.Text, Diagrams.TwoD.Transform, Diagrams.TwoD.Types, Diagrams.TwoD.Vector, Diagrams.Util Build-depends: base >= 4.2 && < 4.10, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.19, monoid-extras >= 0.3 && < 0.5, dual-tree >= 0.2 && < 0.3, diagrams-core >= 1.3 && < 1.4, diagrams-solve >= 0.1 && < 0.2, active >= 0.2 && < 0.3, colour >= 2.3.2 && < 2.4, data-default-class < 0.2, fingertree >= 0.1 && < 0.2, intervals >= 0.7 && < 0.8, lens >= 4.6 && < 4.15, tagged >= 0.7, optparse-applicative >= 0.11 && < 0.14, filepath, JuicyPixels >= 3.1.5 && < 3.3, hashable >= 1.1 && < 1.3, linear >= 1.20.1 && < 1.21, adjunctions >= 4.0 && < 5.0, distributive >=0.2.2 && < 1.0, process >= 1.1 && < 1.5, fsnotify >= 0.2.1 && < 0.3, directory >= 1.2 && < 1.3, unordered-containers >= 0.2 && < 0.3, text >= 0.7.1 && < 1.3, mtl >= 2.0 && < 2.3, transformers >= 0.3.0 && < 0.6.0, exceptions >= 0.6 && < 1.0 if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 other-extensions: BangPatterns, CPP, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, Rank2Types, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, TypeSynonymInstances, UndecidableInstances, ViewPatterns, LambdaCase test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs other-modules: Diagrams.TwoD.OffsetTest hs-source-dirs: test build-depends: base >= 4.2 && < 4.10, tasty >= 0.10, tasty-hunit >= 0.9.2, diagrams-lib default-language: Haskell2010 diagrams-lib-1.3.1.4/Setup.hs0000644000000000000000000000007012754644012014035 0ustar0000000000000000import Distribution.Simple main = defaultMain diagrams-lib-1.3.1.4/CHANGELOG.md0000644000000000000000000016373612754644012014235 0ustar0000000000000000## [v1.3.1.4](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.4) (2016-08-16) (16 August 2016) - allow `optparse-applicative-0.13` ## [v1.3.1.3](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.3) (2016-06-05) - allow `base-4.9` - allow `data-default-class-0.1` - test with GHC 8.0.1 [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.2...v1.3.1.3) ## [v1.3.1.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.2) (2016-05-01) - allow `lens-4.14` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.1...v1.3.1.2) ## [v1.3.1.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.2) (2016-02-19) - allow `unordered-containers-0.2.*` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.1.0...v1.3.1.1) ## [v1.3.1.0](https://github.com/diagrams/diagrams-lib/tree/v1.3.1.0) (2016-02-14) - improve path offset calculations [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.9...v1.3.1.0) ## [v1.3.0.9](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.9) (2016-01-14) - allow `unordered-containers-0.2.6` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.8...v1.3.0.9) ## [v1.3.0.8](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.8) (2015-11-10) - allow `semigroups-0.18` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.7...v1.3.0.8) ## [v1.3.0.7](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.7) (2015-10-08) ## - Add `LambdaCase` extension to `.cabal` file, so `cabal` correctly reports that `diagrams-lib` does not build on `GHC-7.4`. [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.6...v1.3.0.7) ## [v1.3.0.6](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.6) (2015-09-29) ## - Allow `optparse-applicative-0.12` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.5...v1.3.0.6) ## [v1.3.0.5](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.5) (2015-09-18) ## - Fix compilation problem with `lens-4.13` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.4...v1.3.0.5) ## [v1.3.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.4) (2015-09-17) ## **Dependency/version changes** - Allow `lens-1.13` - Allow `semigroups-0.17` - Require `linear-1.20` ## [v1.3.0.3](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.3) (2015-08-10) **Dependency/version changes** - Drop dependency on deprecated `system-filepath` package - Require `fsnotify-0.2.1` ## [v1.3.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.2) (2015-07-19) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3.0.1...v1.3.0.2) ## [v1.3.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.3.0.1) (2015-05-26) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.3...v1.3.0.1) ## [v1.3](https://github.com/diagrams/diagrams-lib/tree/v1.3) (2015-04-19) **New features** - Native image type that backends can specify. - Affine maps between spaces for path-like objects. A new `Diagrams.ThreeD.Projections` has some helper functions for orthographic and perspective projections. - Intersections for path-like objects using Bézier clipping. - Helper functions in `Diagrams.Matrix` for converting between transforms and matrices. - New `Diagrams` module that only exports functions defined in diagrams. - New `Direction` type. `Direction` is a vector that's forgot it's magnitude. Some functions have changed their type from `R2` to `Direction V2 n` to make it clear that magnitude has no effect. - Use the [`fsnotify`](https://hackage.haskell.org/package/fsnotify) package for command line looping. Command line looping now works on Windows. - `groupOpacity` function added for lowering the opacity of a diagram as a whole. - New `ToPath` class for converting path-like things to a `Path`. **New instances** - `Each` instances for `BoundingBox`, `Offset`, `Segment`, `FixedSegment` and `Path`. - `Reversing` instances for `Offset`, `Segment`, `FixedSegment`, `Trail` and `Path`. - `AsEmpty` instances for `BoundingBox`, `Trail` and `Path`. - `Cons` and `Snoc` instances for `Path` and `Line`. - New `Show` instances for `Angle`, `Segment`, `SomeColor`, `Trail'` and `at`. - `Tangent` instance for `(FixedSegment v n)`. - `Ord` instances for `LineMiterLimit`, `LineJoin` and `LineCap`. **New helper functions** - `_Line` and `_Loop` prisms. - Style lenses: `_fontSize`, `_lineWidth`, `_fillTexture`, `_lineTexture`, `_opacity`, `_font`, `_lineCap`, `_lineJoin` `_dashing`. - `_SomeColor` iso and `_AC` prism onto an `AlphaColour`. - `atPoints` function to zip points with diagrams. **API changes** - `Diagram` type synonym now only takes a backend token: `Diagram B` - Types that previously had a `v` variable now have `v` and `n`. - `Control.Lens` and `Data.Default.Class` are now exported from from `Diagrams.Prelude` - `Measure` has a new internal representation. `Local`, `Global`, `Normalized`, and `Output` have been renamed to `local`, `global`, `normalized` and `output` respectivly. - `SizeSpec2D` has moved to `SizeSpec v n` in `Diagrams.SizeSpec`. `Dims, Height, Width and `Absolute` have moved to `dims2D`, `mkHeight`, `mkWidth` and `absolute` respectively. - `Color` instances for `Colour` and `AlphaColour` are limited to `Double` for better type inference. - `under` has been renamed to `underT`. New `transformed`, `translated`, `movedTo`, `movedFrom` and `rotated` isomorphisms to use with lens's `under` function. - `stroke` is now polymorphic. Use `strokePath` or `strokeP` to get old `stroke` behaviour. - `angleBetween` now works for any vector space, which means the angle is always positive. The old behaviour can be retrieved from `signedAngleBetween` - `arc` now takes a starting `Direction` and a sweep `Angle`. `arcCW` and `arcCCW` take a start and finish `Direction`. **Dependency/version changes** - use `linear` instead of `vector-space` **Closed issues:** - Perspective deformation of square vertices yields extra point [\#244](https://github.com/diagrams/diagrams-lib/issues/244) - Local fontsize renders inconsistentl on diffrent backends [\#243](https://github.com/diagrams/diagrams-lib/issues/243) - Factor out Diagrams.Solve into a package? [\#235](https://github.com/diagrams/diagrams-lib/issues/235) **Merged pull requests:** - add pathPoints and pathVertices' functions [\#245](https://github.com/diagrams/diagrams-lib/pull/245) ([byorgey](https://github.com/byorgey)) - New loop [\#242](https://github.com/diagrams/diagrams-lib/pull/242) ([cchalmers](https://github.com/cchalmers)) - Pre 1.3 [\#241](https://github.com/diagrams/diagrams-lib/pull/241) ([cchalmers](https://github.com/cchalmers)) - Update CubicSpline.hs [\#240](https://github.com/diagrams/diagrams-lib/pull/240) ([fryguybob](https://github.com/fryguybob)) - updated changes for GHC-7.10 [\#239](https://github.com/diagrams/diagrams-lib/pull/239) ([bergey](https://github.com/bergey)) - split out new package diagrams-solve [\#237](https://github.com/diagrams/diagrams-lib/pull/237) ([byorgey](https://github.com/byorgey)) - Lens style [\#236](https://github.com/diagrams/diagrams-lib/pull/236) ([cchalmers](https://github.com/cchalmers)) - Half-dart arrowheads [\#234](https://github.com/diagrams/diagrams-lib/pull/234) ([byorgey](https://github.com/byorgey)) - TwoD.Points: Needs TypeFamilies [\#233](https://github.com/diagrams/diagrams-lib/pull/233) ([bgamari](https://github.com/bgamari)) - Projections [\#229](https://github.com/diagrams/diagrams-lib/pull/229) ([cchalmers](https://github.com/cchalmers)) ## [1.2.0.9]() (2 April 2015) - allow `lens-4.9` - allow `vector-space-0.10` ## [v1.2.0.8](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.8) (2015-01-13) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.7...v1.2.0.8) **Merged pull requests:** - typo in haddocks [\#232](https://github.com/diagrams/diagrams-lib/pull/232) ([ggreif](https://github.com/ggreif)) - Update diagrams-lib.cabal : bumping JuicyPixels dependency [\#230](https://github.com/diagrams/diagrams-lib/pull/230) ([Twinside](https://github.com/Twinside)) ## [v1.2.0.7](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.7) (2014-12-07) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.6...v1.2.0.7) ## [v1.2.0.6](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.6) (2014-12-04) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.5...v1.2.0.6) **Merged pull requests:** - Minor changes in documentation about Polygons. [\#228](https://github.com/diagrams/diagrams-lib/pull/228) ([alexDarcy](https://github.com/alexDarcy)) ## [v1.2.0.5](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.5) (2014-11-17) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.4...v1.2.0.5) **Implemented enhancements:** - Path/trail intersection [\#209](https://github.com/diagrams/diagrams-lib/issues/209) - Turn R2 into D2 \(Generalize R2 to any numeric type\) [\#50](https://github.com/diagrams/diagrams-lib/issues/50) **Fixed bugs:** - `Sectionable` instance for `SegTree` is not a linear reparameterization. [\#217](https://github.com/diagrams/diagrams-lib/issues/217) **Closed issues:** - bezierFromSweep very slow? [\#227](https://github.com/diagrams/diagrams-lib/issues/227) - All lines render at same width [\#222](https://github.com/diagrams/diagrams-lib/issues/222) - numerically stable cubic rootfinder [\#204](https://github.com/diagrams/diagrams-lib/issues/204) **Merged pull requests:** - Intersections [\#226](https://github.com/diagrams/diagrams-lib/pull/226) ([cchalmers](https://github.com/cchalmers)) - Linear update [\#225](https://github.com/diagrams/diagrams-lib/pull/225) ([cchalmers](https://github.com/cchalmers)) - Add arcCCW and friends. Fix offset joins. [\#221](https://github.com/diagrams/diagrams-lib/pull/221) ([fryguybob](https://github.com/fryguybob)) - Reparameterize section [\#220](https://github.com/diagrams/diagrams-lib/pull/220) ([fryguybob](https://github.com/fryguybob)) - Diagram b v n to QDiagram b v n Any [\#219](https://github.com/diagrams/diagrams-lib/pull/219) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - New stuff [\#218](https://github.com/diagrams/diagrams-lib/pull/218) ([cchalmers](https://github.com/cchalmers)) - Linear [\#215](https://github.com/diagrams/diagrams-lib/pull/215) ([cchalmers](https://github.com/cchalmers)) ## [v1.2.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.4) (2014-10-08) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.3...v1.2.0.4) **Merged pull requests:** - add semi-portable looping using fsnotify [\#213](https://github.com/diagrams/diagrams-lib/pull/213) ([bergey](https://github.com/bergey)) ## [v1.2.0.3](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.3) (2014-09-07) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.2...v1.2.0.3) **Closed issues:** - arrowFromLocatedTrail function [\#205](https://github.com/diagrams/diagrams-lib/issues/205) **Merged pull requests:** - Added `arrowFromLocatedTrail` [\#206](https://github.com/diagrams/diagrams-lib/pull/206) ([pnutus](https://github.com/pnutus)) ## [v1.2.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.2) (2014-08-22) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2.0.1...v1.2.0.2) **Implemented enhancements:** - Generalize Angle class? [\#38](https://github.com/diagrams/diagrams-lib/issues/38) **Fixed bugs:** - --selection and --src both use -s abbreviation [\#172](https://github.com/diagrams/diagrams-lib/issues/172) **Closed issues:** - Spike arrowhead and tail render with oversized joint [\#203](https://github.com/diagrams/diagrams-lib/issues/203) **Merged pull requests:** - Enable compilation with GHC HEAD \(v7.9\) [\#211](https://github.com/diagrams/diagrams-lib/pull/211) ([ggreif](https://github.com/ggreif)) - cli-options [\#200](https://github.com/diagrams/diagrams-lib/pull/200) ([bergey](https://github.com/bergey)) - Add Native images to Diagrams.TwoD.Image [\#199](https://github.com/diagrams/diagrams-lib/pull/199) ([taruti](https://github.com/taruti)) - add atPoints, deprecate decorateFoo [\#198](https://github.com/diagrams/diagrams-lib/pull/198) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Add bg' [\#197](https://github.com/diagrams/diagrams-lib/pull/197) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - add convenience synonyms \[hv\]sep for \[hv\]cat' \(with & sep .~ x\) [\#196](https://github.com/diagrams/diagrams-lib/pull/196) ([byorgey](https://github.com/byorgey)) - Vertices [\#192](https://github.com/diagrams/diagrams-lib/pull/192) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Direction type [\#186](https://github.com/diagrams/diagrams-lib/pull/186) ([bergey](https://github.com/bergey)) ## [v1.2.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.2.0.1) (2014-06-04) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.2...v1.2.0.1) **Closed issues:** - Local headLength / headGaps act like Output [\#193](https://github.com/diagrams/diagrams-lib/issues/193) **Merged pull requests:** - transform Local Measure in arrow styles [\#194](https://github.com/diagrams/diagrams-lib/pull/194) ([bergey](https://github.com/bergey)) ## [v1.2](https://github.com/diagrams/diagrams-lib/tree/v1.2) (2014-06-02) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.4...v1.2) **New features** - Several attributes (such as line width, dashing size, arrowhead size, and font size) that formerly had a value of type `Double` now have the more general type `Measure R2`. This allows the attributes to be specified relative to one of four measurement frames: `Local`, `Global`, `Normalized`, and `Output`. - New DSL for specifying measurements. - New synonyms for specifying measurements, *e.g.* `thin`, `thick`, and `medium`, `large`. - Support for radial and linear gradients for fills and strokes. - New `DImage` type that supports both embedded and external images in Backends that support them. - New `lengths` Traversal for setting `headLength` and `tailLength` simultaneously. - `Frustrum` and `Box` shapes added to `Diagrams.ThreeD.Shapes`. - New function `quartForm` to find roots of quartic polynomials. - New Lenses for polar coordinates. - New trig functions, `sinA`, `atanA`, etc. which take `Angle` as input or output. **New instances** - `Transformable` instances for `LineWidth`, `Dashing`, `LineTexture`, and `FillTexture`. **API changes** - `FillColor` and `LineColor` attributes have been replaced with the more general `FillTexture` and `LineTexture`. Use the `solid` function to convert a color to a texture. - The size of arrow heads and tails is now specified in terms of length instead of the radius of their circumcircle. - Gaps at the ends of arrows are now specified using `Measure R2`. - The `gap` traversal has been replaced by `gaps` for consistency in naming, though `gap` is still provided for backwards compatibility. - `fontSize` now takes a value of type `Measure R2`. - Get rid of (bitrotted) `Show` backend. - Functions in `TwoD.Adjust` now return the adjustment transformation itself in addition to the resized `Diagram` and `Options` record; this can be used, *e.g.* to convert screen coordinates back into diagram coordinates. - Export `pathLocSegments`. - The `avgScale` function has been moved to `Diagrams.Core`. - The `Angle` definition and related functions (*e.g.* `angleBetween`) have moved to a separate module, `Diagrams.Angle`. - A separate `Diagrams.TwoD.Attributes` module now contains most of the attributes that require 2D transformation instances. - The `splitColorFills` function has been replaced by `splitTextureFills`. **Dependency/version changes** - Allow `semigroups-0.15` - Allow `opt-parse-applicative-0.9.0 - Allow `lens-4.2` **Implemented enhancements:** - 'image' should be in IO [\#29](https://github.com/diagrams/diagrams-lib/issues/29) - Add gradient support [\#9](https://github.com/diagrams/diagrams-lib/issues/9) **Closed issues:** - fails to build against HP [\#190](https://github.com/diagrams/diagrams-lib/issues/190) - text does not scale [\#179](https://github.com/diagrams/diagrams-lib/issues/179) - Please add support for latest version of intervals library [\#170](https://github.com/diagrams/diagrams-lib/issues/170) - presence of arrowHead can tilt connection sideways [\#162](https://github.com/diagrams/diagrams-lib/issues/162) **Merged pull requests:** - Quartic formula, no obvious bugs [\#187](https://github.com/diagrams/diagrams-lib/pull/187) ([Mathnerd314](https://github.com/Mathnerd314)) - Arrow length [\#185](https://github.com/diagrams/diagrams-lib/pull/185) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - fix handling of text scaling [\#182](https://github.com/diagrams/diagrams-lib/pull/182) ([byorgey](https://github.com/byorgey)) - Texture [\#181](https://github.com/diagrams/diagrams-lib/pull/181) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - arrow envelopes [\#180](https://github.com/diagrams/diagrams-lib/pull/180) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - make headSize and tailSize back into ArrowOpts fields [\#177](https://github.com/diagrams/diagrams-lib/pull/177) ([byorgey](https://github.com/byorgey)) - updated the upper bounds of the .cabal constraints for 'semigroups' package [\#176](https://github.com/diagrams/diagrams-lib/pull/176) ([zgredzik](https://github.com/zgredzik)) - Image2 [\#174](https://github.com/diagrams/diagrams-lib/pull/174) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Image [\#173](https://github.com/diagrams/diagrams-lib/pull/173) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Preliminary implementation of Measure [\#159](https://github.com/diagrams/diagrams-lib/pull/159) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Gradient [\#136](https://github.com/diagrams/diagrams-lib/pull/136) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) ## [v1.1.0.7]() (2014-05-15) - Allow `semigroups-0.14` ## [v1.1.0.6]() (2014-04-10) - Allow `semigroups-0.13` ## [v1.1.0.4](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.4) (2014-04-04) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.2...v1.1.0.4) **Merged pull requests:** - Updates to work with `Backend` redesign [\#171](https://github.com/diagrams/diagrams-lib/pull/171) ([byorgey](https://github.com/byorgey)) - Rework of units [\#169](https://github.com/diagrams/diagrams-lib/pull/169) ([byorgey](https://github.com/byorgey)) - Make Diagrams.Transform.under more polymorphic [\#168](https://github.com/diagrams/diagrams-lib/pull/168) ([FlorentBecker](https://github.com/FlorentBecker)) ## [v1.1.0.3]() (2014-03-19) - Allow `lens-4.1` ## [v1.1.0.2](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.2) (2014-03-19) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1.0.1...v1.1.0.2) **Merged pull requests:** - move avgScale to core [\#167](https://github.com/diagrams/diagrams-lib/pull/167) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - 3d color & lighting, more solids, Angle utilities [\#166](https://github.com/diagrams/diagrams-lib/pull/166) ([bergey](https://github.com/bergey)) - Added bothSize function, lineHead and lineTail [\#165](https://github.com/diagrams/diagrams-lib/pull/165) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) ## [v1.1.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.1.0.1) (2014-03-09) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.1...v1.1.0.1) - Depend on `hashable` package, and add `Hashable` instance for `SizeSpec2D`. Technically, the PVP specifies that adding a new instance requires a major version bump. However, I highly doubt anyone was making their own orphan `Hashable` instances before. Feel free to yell at Brent if this breaks your build. ## [v1.1](https://github.com/diagrams/diagrams-lib/tree/v1.1) (2014-03-09) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0.1...v1.1) **New features** - Support for `Deformation`s, arbitrary (non-affine) transformations on objects such as points, paths, and located trails (though not on diagrams). - New functions `clipTo`, which clips a diagram's envelope and trace along with its visual representation, and `clipped`, which clips the diagram's visual representation but replaces its envelope and trace with those of the clipping path. - New `arrowV` function, for creating an arrow with the direction and magnitude of a given vector. - `gap` traversal, for setting the head and tail gaps of an arrow simultaneously. - Generalized types for `centerXY` and `snugXY`, based on new `basis` function from `diagrams-core - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. - New `frame` function similar to `pad`, but increases the envelope of a diagram by an amount specified in local units in every direction irrespective of the local origin. - New `splitFills` function for pushing fill attributes down to subtrees containing only loops (mostly of relevance only to backend implementors). **New instances** - `Typeable` instances for all data types that are used as diagram primitives. - `Sectionable` instance for `FixedSegment`. **API changes** - `Angle` is now a type, rather than a class. It uses a single internal representation for angles, and lenses `turn`, `rad,` and `deg` are supplied for constructing (using `@@`) and viewing (using `^.`) `Angle`s in various units. In addition, the `Num` instance for `Angle` has been removed, eliminating a class of errors where a bare number is interpreted in units other than what you expect. - Removed `Num` instance for angles. **Dependency/version changes** - Require `lens >= 4.0`. - Allow `array-0.5`. - Allow `hashable-1.1`. - Remove `NumInstances` dependency. **Bug fixes** - Exclude joins in offsets on close segments (#160). - Exclude extra segment when joining loops in offset (#155). **Performance improvements** - `colorToSRGBA` function now avoids expensive matrix operations, offering dramatic speedups in rendering diagrams with many color attributes. **Implemented enhancements:** - Better color model in 3D [\#121](https://github.com/diagrams/diagrams-lib/issues/121) - Projective/perspective transforms for points and paths [\#108](https://github.com/diagrams/diagrams-lib/issues/108) - clipTo function [\#35](https://github.com/diagrams/diagrams-lib/issues/35) **Fixed bugs:** - Offset Bug [\#155](https://github.com/diagrams/diagrams-lib/issues/155) **Closed issues:** - Expand of an expand [\#160](https://github.com/diagrams/diagrams-lib/issues/160) **Merged pull requests:** - fix doc for === and ||| [\#164](https://github.com/diagrams/diagrams-lib/pull/164) ([denys-duchier](https://github.com/denys-duchier)) - Split fills [\#161](https://github.com/diagrams/diagrams-lib/pull/161) ([byorgey](https://github.com/byorgey)) - Exclude extra segment when joining loops in offset. Fixes \#155. [\#158](https://github.com/diagrams/diagrams-lib/pull/158) ([fryguybob](https://github.com/fryguybob)) - added basis, generalized `centerXY` and `snugXY` [\#157](https://github.com/diagrams/diagrams-lib/pull/157) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - derive Typeable for all data types used in Prims [\#156](https://github.com/diagrams/diagrams-lib/pull/156) ([byorgey](https://github.com/byorgey)) - Lens4 [\#154](https://github.com/diagrams/diagrams-lib/pull/154) ([bergey](https://github.com/bergey)) - removed NumInstances dependency [\#153](https://github.com/diagrams/diagrams-lib/pull/153) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Remove Num instance for Angle [\#150](https://github.com/diagrams/diagrams-lib/pull/150) ([bergey](https://github.com/bergey)) - Change internal color representation to SRGBA [\#149](https://github.com/diagrams/diagrams-lib/pull/149) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Projections - non-affine transformations [\#148](https://github.com/diagrams/diagrams-lib/pull/148) ([bergey](https://github.com/bergey)) ## [v1.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.0.1) (2014-01-26) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0.0.1...v1.0.1) **Implemented enhancements:** - Module for generating nice colors/color schemes [\#77](https://github.com/diagrams/diagrams-lib/issues/77) **Closed issues:** - "Maybe.fromJust: Nothing" error when connecting translated small diagram [\#147](https://github.com/diagrams/diagrams-lib/issues/147) **Merged pull requests:** - Add Hashable instance for SizeSpec2D [\#146](https://github.com/diagrams/diagrams-lib/pull/146) ([byorgey](https://github.com/byorgey)) - return list of traces [\#145](https://github.com/diagrams/diagrams-lib/pull/145) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - added clipTo [\#144](https://github.com/diagrams/diagrams-lib/pull/144) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - Unified angle type [\#140](https://github.com/diagrams/diagrams-lib/pull/140) ([bergey](https://github.com/bergey)) ## [v1.0.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.0.0.1) (2013-11-28) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v1.0...v1.0.0.1) ## [v1.0](https://github.com/diagrams/diagrams-lib/tree/v1.0) (2013-11-25) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7.1.1...v1.0) **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)) - Arrows do not behave correctly under scaling [\#112](https://github.com/diagrams/diagrams-lib/issues/112) **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`. **Closed issues:** - diagrams-lib-0.7.1.1 fails to build with ghc-7.7 \(-HEAD\) [\#128](https://github.com/diagrams/diagrams-lib/issues/128) - Arrow misses target [\#126](https://github.com/diagrams/diagrams-lib/issues/126) **Merged pull requests:** - Lenses for setting arrow head, tail, and shaft colors [\#138](https://github.com/diagrams/diagrams-lib/pull/138) ([byorgey](https://github.com/byorgey)) - Delayed subtrees [\#137](https://github.com/diagrams/diagrams-lib/pull/137) ([byorgey](https://github.com/byorgey)) - Add helpers for common optparse-applicative backend command line. [\#135](https://github.com/diagrams/diagrams-lib/pull/135) ([fryguybob](https://github.com/fryguybob)) - add located lens for access into Located things [\#134](https://github.com/diagrams/diagrams-lib/pull/134) ([byorgey](https://github.com/byorgey)) - add b-\>a instance for Alignable [\#133](https://github.com/diagrams/diagrams-lib/pull/133) ([cscheid](https://github.com/cscheid)) - Strictness optimizations [\#132](https://github.com/diagrams/diagrams-lib/pull/132) ([JohnLato](https://github.com/JohnLato)) - Lens [\#131](https://github.com/diagrams/diagrams-lib/pull/131) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - 3D scaling, alignment, coordinate lenses [\#129](https://github.com/diagrams/diagrams-lib/pull/129) ([bergey](https://github.com/bergey)) - correctly \(?\) compute shaftScale by solving a quadratic [\#127](https://github.com/diagrams/diagrams-lib/pull/127) ([byorgey](https://github.com/byorgey)) - calculate arrow shaftScale using projection of ends onto shaft offset [\#125](https://github.com/diagrams/diagrams-lib/pull/125) ([bergey](https://github.com/bergey)) - Convert from newtype to lens [\#124](https://github.com/diagrams/diagrams-lib/pull/124) ([byorgey](https://github.com/byorgey)) - Version bump on lens [\#123](https://github.com/diagrams/diagrams-lib/pull/123) ([haasn](https://github.com/haasn)) ## [v0.7.1.1](https://github.com/diagrams/diagrams-lib/tree/v0.7.1.1) (2013-09-27) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7.1...v0.7.1.1) **Implemented enhancements:** - Use a point envelope for built-in text objects [\#116](https://github.com/diagrams/diagrams-lib/issues/116) - implement rotations in 3D [\#86](https://github.com/diagrams/diagrams-lib/issues/86) - Control over boundary conditions on cubic splines. [\#32](https://github.com/diagrams/diagrams-lib/issues/32) **Fixed bugs:** - diagrams with empty envelopes are not properly separated by struts [\#115](https://github.com/diagrams/diagrams-lib/issues/115) **Closed issues:** - calculate ratio between two angles [\#109](https://github.com/diagrams/diagrams-lib/issues/109) - Add primitives for arrows [\#73](https://github.com/diagrams/diagrams-lib/issues/73) **Merged pull requests:** - Three d render [\#114](https://github.com/diagrams/diagrams-lib/pull/114) ([bergey](https://github.com/bergey)) - API for computing tangent and normal vectors to segments and trails [\#113](https://github.com/diagrams/diagrams-lib/pull/113) ([byorgey](https://github.com/byorgey)) - change default styles for arrows [\#111](https://github.com/diagrams/diagrams-lib/pull/111) ([byorgey](https://github.com/byorgey)) - 3D utility functions [\#107](https://github.com/diagrams/diagrams-lib/pull/107) ([bergey](https://github.com/bergey)) ## [v0.7.1](https://github.com/diagrams/diagrams-lib/tree/v0.7.1) (2013-09-11) **New features** - New standard miter limit attribute - New functions `lineColorA`, `lineWidthA`, `lineMiterLimitA`, `fontSizeA` for directly applying attribute values - `setDefault2DAttributes` now sets default line cap (butt), line join (miter), and miter limit (10) attributes **New instances** - `Data.Default` instances for - `LineCap` - `LineJoin` - `LineMiterLimit` - `LineWidth` - `LineColor` - `FontSize` [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.7...v0.7.1) **Implemented enhancements:** - Path expansion. [\#55](https://github.com/diagrams/diagrams-lib/issues/55) - way to move diagrams closer together [\#18](https://github.com/diagrams/diagrams-lib/issues/18) **Fixed bugs:** - wedge should be closed [\#99](https://github.com/diagrams/diagrams-lib/issues/99) - Adjusting trail from the end has no effect [\#95](https://github.com/diagrams/diagrams-lib/issues/95) **Merged pull requests:** - Add offsetTrail and expandTrail. [\#103](https://github.com/diagrams/diagrams-lib/pull/103) ([fryguybob](https://github.com/fryguybob)) - change Codomain of Located to Point \(Codomain a\) [\#102](https://github.com/diagrams/diagrams-lib/pull/102) ([byorgey](https://github.com/byorgey)) - Default and Show instances for FillRule and FillRuleA [\#100](https://github.com/diagrams/diagrams-lib/pull/100) ([jbracker](https://github.com/jbracker)) - Changes required due to the introduction of Roles in GHC [\#98](https://github.com/diagrams/diagrams-lib/pull/98) ([co-dan](https://github.com/co-dan)) - removed default implementation of reverseDomain [\#97](https://github.com/diagrams/diagrams-lib/pull/97) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) - fixed issue \#95 [\#96](https://github.com/diagrams/diagrams-lib/pull/96) ([jeffreyrosenbluth](https://github.com/jeffreyrosenbluth)) ## [v0.7](https://github.com/diagrams/diagrams-lib/tree/v0.7) (2013-08-09) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.3...v0.7) **New features** - New module `Diagrams.TwoD.Curvature`, for computing the curvature of 2D segments at any given point. - New module `Diagrams.Offset`, containing an `offsetSegment` function that builds a trail a fixed distance from the original segment. This is a precursor to planned functions `offsetTrail` and `offsetPath`. - New function `Diagrams.TwoD.Transform.onBasis`, for extracting a matrix representation of a 2D transformation - New functions `extrudeEnvelope` and `intrudeEnvelope`, for extending or shrinking an envelope only in a certain direction. - Generalize the `Color` class to absolute colors. This addresses concerns raised in issue #66 by letting the backend choose which color space to render `Color` instances to. Functions are provided for backwards compatibility with the old semantics. - New function `scaleInvPrim` for creating a diagram from a single scale-invariant primitive. - New module `Diagrams.Parametric`, containing a collection of classes abstracting over "parametric" things: `Parametric`, `DomainBounds`, `EndValues`, `Sectionable`, and `HasArcLength`, with instances for segments, trails, and related things. - A big refactoring of segments and trails: - Segments can now be either "closed" or "open". - There are now two types of trails: "lines" (which travel from point A to point B) or "loops" (closed curves which end where they started). `Trail` is now a wrapper type which can contain both loops and lines. - There is a new `Located` wrapper type for adding locations to translation-invariant things. `Path`s now consist of a collection of `Located Trail`s. - The `PathLike` class is now renamed to `TrailLike`; the `trailLike` function takes a `Located Trail` as input. - New convenience functions `boundaryFrom` and `boundaryFromMay`, for computing boundaries of subdiagrams. - Re-export from `diagrams-lib` a lot of things defined in `diagrams-core`, to make them easier for users to find. Several new modules have been created as a result: `Diagrams.Query`, `Diagrams.Envelope`, `Diagrams.Trace`, and `Diagrams.Names`. - Export the `centroid` function from `Diagrams.Prelude`. - `triangle` is now a synonym for `eqTriangle`. **New instances** - `IsPrim` instances for `Path`, `Ellipsoid`, `Image`, `Text`, and `ScaleInv` - `Eq`, `Ord`, and `Show` instances for `SizeSpec2D` **API changes** - `CircleFrac` has been renamed `Turn` (though `CircleFrac` is retained as a deprecated synonym). - `Diagrams.Coordinates` is no longer exported from `Diagrams.Prelude`. This is for compatibility with `lens`, as `(&)` is a rather important lens operator and clashes with `Diagrams.Coordinates`. Users who want the `Coordinates` stuff can import `Diagrams.Coordinates` explicitly. **Dependency/version changes** - allow `base-4.7` - upgrade to `monoid-extras-0.3` - depend on `data-default-class` instead of `data-default` - Tested with GHC 7.7. **Bug fixes** - Added a special case that was a not handled properly by the quadratic solver, resulting in bogus envelopes in certain cases (#88). - Import only `Data.NumInstances.Tuple` instead of `Data.NumInstances`. Previously, `Diagrams.Prelude` exported `Eq`, `Show`, and `Num` instances for functions and tuples; now it only exports tuple instances. Users wishing to use `Diagrams.CubicSpline` with a vector space built over functions (!?) can import `Data.NumInstances.Function` themselves. (#48) - Do scaling on a `Path` *before* constructing a `TrailLike` in `rect` (#43) **Implemented enhancements:** - Split PathLike, Trail, and Path into separate modules [\#25](https://github.com/diagrams/diagrams-lib/issues/25) - Add support for path-oriented diagrams. [\#13](https://github.com/diagrams/diagrams-lib/issues/13) **Fixed bugs:** - Wrong envelope for cubic segment [\#88](https://github.com/diagrams/diagrams-lib/issues/88) - Fix documentation of beside, \(===\), and \(|||\) re: monoidal semantics [\#83](https://github.com/diagrams/diagrams-lib/issues/83) - reverseTrail should not generate extra segments for closed trails [\#24](https://github.com/diagrams/diagrams-lib/issues/24) **Closed issues:** - Test issue [\#91](https://github.com/diagrams/diagrams-lib/issues/91) **Merged pull requests:** - Add parametric generalizations for segments, trails, Located, etc. [\#92](https://github.com/diagrams/diagrams-lib/pull/92) ([byorgey](https://github.com/byorgey)) - Adding type signature so it compiles with GHC7.7 [\#90](https://github.com/diagrams/diagrams-lib/pull/90) ([co-dan](https://github.com/co-dan)) - bug fix: add special case for b==0 to quadform solver [\#89](https://github.com/diagrams/diagrams-lib/pull/89) ([byorgey](https://github.com/byorgey)) - Big refactoring of segments and trails. [\#87](https://github.com/diagrams/diagrams-lib/pull/87) ([byorgey](https://github.com/byorgey)) - Stop exporting Diagrams.Coordinates from Diagrams.Prelude [\#82](https://github.com/diagrams/diagrams-lib/pull/82) ([byorgey](https://github.com/byorgey)) - Generalization of R2 to D2 a [\#65](https://github.com/diagrams/diagrams-lib/pull/65) ([jbracker](https://github.com/jbracker)) ## [v0.6.0.3](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.3) (2013-05-04) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.2...v0.6.0.3) **Closed issues:** - Offset [\#80](https://github.com/diagrams/diagrams-lib/issues/80) **Merged pull requests:** - Added offsetSegment function [\#79](https://github.com/diagrams/diagrams-lib/pull/79) ([fryguybob](https://github.com/fryguybob)) - Working on adding curvature. [\#74](https://github.com/diagrams/diagrams-lib/pull/74) ([fryguybob](https://github.com/fryguybob)) - New `scaleInvPrim` function [\#71](https://github.com/diagrams/diagrams-lib/pull/71) ([byorgey](https://github.com/byorgey)) ## [v0.6.0.2](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.2) (2013-03-29) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/types-generalized...v0.6.0.2) **Implemented enhancements:** - Don't export Eq and Show instances for functions from Diagrams.Prelude [\#48](https://github.com/diagrams/diagrams-lib/issues/48) **Closed issues:** - radius is wrong [\#75](https://github.com/diagrams/diagrams-lib/issues/75) **Merged pull requests:** - Matrix basis rep [\#78](https://github.com/diagrams/diagrams-lib/pull/78) ([bergey](https://github.com/bergey)) ## [types-generalized](https://github.com/diagrams/diagrams-lib/tree/types-generalized) (2013-02-13) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6.0.1...types-generalized) ## [v0.6.0.1](https://github.com/diagrams/diagrams-lib/tree/v0.6.0.1) (2013-01-07) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/v0.6...v0.6.0.1) **Fixed bugs:** - text on zero width rect leads to nans [\#51](https://github.com/diagrams/diagrams-lib/issues/51) - wrong result when using `beside` with circle and vector \(1 & \(-1\)\) [\#46](https://github.com/diagrams/diagrams-lib/issues/46) - Handle `rect` with zero arguments. [\#43](https://github.com/diagrams/diagrams-lib/issues/43) **Closed issues:** - Generalization of color space used in rendering [\#66](https://github.com/diagrams/diagrams-lib/issues/66) **Merged pull requests:** - do scaling on a Path before constructing PathLike in 'rect' \(fixes \#43\) [\#70](https://github.com/diagrams/diagrams-lib/pull/70) ([byorgey](https://github.com/byorgey)) ## [v0.6](https://github.com/diagrams/diagrams-lib/tree/v0.6) (2012-12-12) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_5_0_1...v0.6) **New features** - `boundingRect` function for constructing a bounding rectangle - `bg` function for "setting the background color" (*i.e.* placing atop a colored bounding rectangle) - New functions `setDefault2DAttributes` and `adjustDiaSize2D`. `adjustDia2D` does both --- so the behavior of `adjustDia2D` has not changed, but it is now possible to apply just one of the two adjustments using the new functions. - `Diagrams.TwoD.Transform` now exports a `ScaleInv` type for creating scale-invariant objects, which are only affected by rotational and translational components of transformations. - The new `Diagrams.Coordinates` module provides nicer syntax for constructing and pattern-matching point and vector literals. - New `fromFixedSeg` function in `Diagrams.Segment`, which decomposes a `FixedSegment` into a starting point and a `Segment`. - New `withTrace` function for setting the `Trace` of a diagram. - Three new size-related functions: - New `sized` function for scaling an object to a particular size. One particularly nice use of this is to obviate the need to keep fiddling with the line width to get diagrams to "look right"; just set the line width relative to some arbitrary scale (*e.g.* assuming the final diagram will fit into a 1x1 box) and then apply `sized` to the final diagram to make it that given arbitrary size. It can also be used for easily making something (a diagram, path, trail, ...) the same size as something else, with the help of the new `sizeSpec2D` function. - New `sizedAs` function, for setting the size of some object to be "the same as" some other object. - New `sizeSpec2D` function for conveniently calculating the size of an object as a `SizeSpec2D` value (for use with the new `sized` funtion). - New `extrudeEnvelope` and `intrudeEnvelope` functions for modifying envelopes in a single direction only, as well as new functions `extrude{Left,Right,Bottom,Top}` specializing `extrudeEnvelope` to 2D. - `arcCW` draws clockwise arcs; `arc'` draws arcs counterclockwise or clockwise as the radius is positive or negative, respectively. - fill color attribute is generalized to support "recommended" and "committed" colors; text objects use a recommended fill color of black. **New instances** - The `Show` instance for `R2` now produces something like `2 & 6` instead of `R2 { unR2 = (2,6) }`. The `Read` instance has also been changed to match, so `read . show = id`. - `Enveloped` instance for `FixedSegment` - `Traced` instances for `Segment`, `FixedSegment`, `Trail`, and `Path` - New derived `Eq` instances for `LineCapA`, `LineJoinA`, `Dashing`, `DashingA`, `FillRule`, `Font`, `FontSize`, `FontSlant`, `FontSlantA`, `FontWeight`, and `FontWeightA` - `Renderable Ellipsoid NullBackend` instance **API changes** - `Data.Colour` (minus `atop` and `AffineSpace`) is now re-exported from Diagrams.Prelude for convenience. - The `beneath` function is now infixl 6. - The `BoundingBox` module has had a complete overhaul. There is now a special empty bounding box, and bounding boxes are an instance of `Monoid`. - The type of `withEnvelope` has been slightly generalized. - `Diagrams.TwoD.Adjust.adjustSize` is now deprecated; it has been renamed and moved to `Diagrams.TwoD.Size.requiredScaleT`. - `expandPath` has been renamed to `scalePath`. **Dependency/version changes** - Allow `data-default` 0.4 and 0.5 - Allow `base`-4.6 - Allow `containers`-0.5 **Bug fixes** - `arc` and `arcT` functions now always produce counterclockwise arcs, as claimed. **Implemented enhancements:** - Enhancements for `arc`s. [\#54](https://github.com/diagrams/diagrams-lib/issues/54) - align and friends should be in terms of a new 'Alignable' class instead of 'Boundable' [\#31](https://github.com/diagrams/diagrams-lib/issues/31) - Tools for more accurate boundary calculations in common cases [\#30](https://github.com/diagrams/diagrams-lib/issues/30) - Reimplement Diagrams.TwoD.Ellipse in terms of Diagrams.TwoD.Arc [\#27](https://github.com/diagrams/diagrams-lib/issues/27) - Function to convert angles into 2D unit vectors [\#23](https://github.com/diagrams/diagrams-lib/issues/23) - 2D specialization of 'beside' which takes an angle instead of a vector [\#22](https://github.com/diagrams/diagrams-lib/issues/22) - Generalize showOrigin function [\#21](https://github.com/diagrams/diagrams-lib/issues/21) - Add generic 'extent' and 'breadth' ? functions [\#20](https://github.com/diagrams/diagrams-lib/issues/20) - Add shearing transformations to standard library [\#19](https://github.com/diagrams/diagrams-lib/issues/19) - Add support for text [\#15](https://github.com/diagrams/diagrams-lib/issues/15) - Allow the user to choose the fill rule used for paths when stroking [\#14](https://github.com/diagrams/diagrams-lib/issues/14) - Image primitives [\#10](https://github.com/diagrams/diagrams-lib/issues/10) - Merge polygon code from Dmitry Olshansky [\#4](https://github.com/diagrams/diagrams-lib/issues/4) **Fixed bugs:** - Enhancements for `arc`s. [\#54](https://github.com/diagrams/diagrams-lib/issues/54) - boundingBox computes incorrect bounding box for transformed diagrams [\#39](https://github.com/diagrams/diagrams-lib/issues/39) - hcat is really \*terrible\* performance-wise [\#28](https://github.com/diagrams/diagrams-lib/issues/28) - stroke sets the fill rule attribute to a default value, so it can't be changed later [\#26](https://github.com/diagrams/diagrams-lib/issues/26) - Text alignment should be with respect to descent and ascent lines rather than text bounding box [\#17](https://github.com/diagrams/diagrams-lib/issues/17) - incorrect bounds for Bezier segments [\#11](https://github.com/diagrams/diagrams-lib/issues/11) - More combinators in D.Combinators [\#5](https://github.com/diagrams/diagrams-lib/issues/5) **Merged pull requests:** - clean up and fix bugs with ScaleInv wrapper [\#69](https://github.com/diagrams/diagrams-lib/pull/69) ([byorgey](https://github.com/byorgey)) - Patch proposal for generalized Color [\#67](https://github.com/diagrams/diagrams-lib/pull/67) ([haasn](https://github.com/haasn)) - Renamed `expandPath` to `scalePath` to make room [\#61](https://github.com/diagrams/diagrams-lib/pull/61) ([fryguybob](https://github.com/fryguybob)) - Envelope deformation [\#60](https://github.com/diagrams/diagrams-lib/pull/60) ([mgsloan](https://github.com/mgsloan)) - Added `Eq` instances for some data structures. [\#59](https://github.com/diagrams/diagrams-lib/pull/59) ([fryguybob](https://github.com/fryguybob)) - More involved diameter benchmark + better implementation [\#58](https://github.com/diagrams/diagrams-lib/pull/58) ([mgsloan](https://github.com/mgsloan)) - Add NullBackend for Ellipsoid [\#57](https://github.com/diagrams/diagrams-lib/pull/57) ([mgsloan](https://github.com/mgsloan)) - Fixed `arc` and `arcT` so they are always CCW. [\#56](https://github.com/diagrams/diagrams-lib/pull/56) ([fryguybob](https://github.com/fryguybob)) - new sized, sizedAs, and sizeSpec2D functions [\#52](https://github.com/diagrams/diagrams-lib/pull/52) ([byorgey](https://github.com/byorgey)) - Update to track with diagrams-core renaming, and a better Show instance for R2 [\#47](https://github.com/diagrams/diagrams-lib/pull/47) ([byorgey](https://github.com/byorgey)) - Minor tweaks due to monoid-extra and dual-tree changes [\#45](https://github.com/diagrams/diagrams-lib/pull/45) ([byorgey](https://github.com/byorgey)) - split out default attribute setting and size adjustment into separate functions [\#42](https://github.com/diagrams/diagrams-lib/pull/42) ([byorgey](https://github.com/byorgey)) - make beneath infixl 6 [\#41](https://github.com/diagrams/diagrams-lib/pull/41) ([byorgey](https://github.com/byorgey)) - scale invariant [\#3](https://github.com/diagrams/diagrams-lib/pull/3) ([ludflu](https://github.com/ludflu)) - BoundingBox is now Monoidal [\#2](https://github.com/diagrams/diagrams-lib/pull/2) ([mgsloan](https://github.com/mgsloan)) - New module enabling nice syntax for constructing and pattern-matching literal points and vectors [\#1](https://github.com/diagrams/diagrams-lib/pull/1) ([byorgey](https://github.com/byorgey)) ## [v0.5.0.1](https://github.com/diagrams/diagrams-lib/tree/0_5_0_1) (2012-07-24) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_5...0_5_0_1) ## [v0.5](https://github.com/diagrams/diagrams-lib/tree/0_5) (2012-03-09) [Full Changelog](https://github.com/diagrams/diagrams-lib/compare/0_4...0_5) **New features** - `mkSizeSpec` function for constructing a `SizeSpec2D` from two `Maybe Double`s - `beneath` as convenient synonym for `flip atop` - Improvements and extensions to rounded rectangles by Peter Hall: + `roundedRect'` allows rounded rectangles with a different radius specified for each corner + both `roundedRect'` and `roundedRect` now allow negative radii, resulting in "inverted" circular corners - [\#64](http://code.google.com/p/diagrams/issues/detail?id=64): New `Alignable` class for things that can be aligned. - `explodeTrail` and `explodePath` have been generalized to return any `PathLike` type. - New path functions `pathCentroid` (compute the centroid of a path's vertices) and `expandPath` (scale a path about its centroid). - Generalized `centroid` function now exported from new module `Diagrams.Points`. - Initial (experimental) support for animation: + `Animation` and `QAnimation` defined as synonyms for `Active` diagrams (see `active` package) + Instances for `Active`: `V`, `HasOrigin`, `Transformable`, `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` + `animEnvelope` and `animRect` functions for automatic bounding of animations - `addClosingSegment` function for making the implicit closing segment of a closed trail explicit - Improvements to `BoundingBox` module from Michael Sloan: querying of `BoundingBox` bounds, corners, extents, and transformation of objects to fit within a given box. - Text alignment options from Michael Sloan - `view` function for restricting a diagram's envelope to a rectangular region. - `iterateN` function for iterating a finite number of times - `atAngle` for placing two diagrams next to each other along a specified angle. - `padX` and `padY` functions for padding in the X- and Y-directions independently. - generalized `showOrigin` function from Ian Ross - [\#40](http://code.google.com/p/diagrams/issues/detail?id=40): add shears to `Diagrams.TwoD.Transform` **Performance improvements** - Use a balanced folding scheme for `cat'`, reducing time in some cases from \\(O(n^2)\\) to \\(O(n \\log n)\\) - More efficient implementation of `beside` **New instances** - `Alignable` instances for `QDiagram`, `Path`, `Envelope`, `Active`, `Set`, `Map`, `[]` - `Renderable` instances for `NullBackend` (`Trail`, `Path`, `Segment`, `Image`, `Text`) - Instances for `Active`: `V`, `HasOrigin`, `Transformable`, `HasStyle`, `PathLike`, `Juxtaposable`, `Alignable` **API changes** - `R2` used to be a synonym for `(Double, Double)` but is now abstract. To convert between pairs of `Doubles` and `R2`, use the new functions `r2` and `unr2`. There are two reasons for this change: 1. to allow for future changes to the implementation of `R2`; 2. `(Double, Double)` was an awkward special case getting in the way of useful tuple instances for classes like `HasOrigin`, `Enveloped`, and so on. - `circlePath` has been removed; its functionality has been subsumed by `circle`. - `adjustSegment` now takes an extra tolerance option. - Ellipses are now represented using Bezier approximations rather than a separate special type. - `BoundingBox` no longer has a `Transformable` instance; the old instance was misleading at best. - Change semantics of `beside` (hence also `(|||)` and `(===)`) so the result's origin is the same as that of the first argument. - `adjustDia2D` now takes a `SizeSpec2D`. - `beside` and related functions are now implemented in terms of `juxtapose`. - Instead of taking an `R2`, `roundedRect` now takes a pair of `Double`s, to be more consistent with `rect`. **Dependency/version changes** - Support for GHC 7.4.1: + depend on `colour` >= 2.3.2 + update `base` and `array` upper bounds - bump `vector-space` upper bound **Bug fixes** - Avoid scale by zero error in `showOrigin`. - Base `adjustDia2D` translation on output size rather than diagram size. ## [v0.4.0.1] () (30 October 2011) ------------------------ - bump `data-default` dependency to allow version 0.3 ## [v0.4]() (23 October 2011) -------------------- **documentation fixes** **New functions and primitives** + `wedge` shape primitive + `fromDirection` function for converting angles to 2D unit vectors; inverse function `direction` generalized to return any Angle type + New functions for computing and adjusting segment lengths + `scaleUToX` and `scaleUToY` for doing uniform scales resulting in a desired width or height. + `circlePath`, `reversePath`, `decoratePath` **New features** + Completely new and improved polygon generation API + Cubic splines + User-controllable path fill rules **Bug fixes** + fix incorrect corner case in arc generation + fix incorrect `reverseTrail` function ## [v0.3]() (18 June 2011) ----------------- **New features** + new customizable `stroke'` function which lets you assign names to path vertices + `circle` and `square` functions now take a size argument + function for adjusting 2D diagrams to requested size abstracted from cairo backend + generalize `PathLike` class to include an instance for diagrams, and collapse things like `polygon`/`polygonPath` into a single polymorphic function + basic text support + basic support for external images + very sketchy initial proof-of-concept library of 3D primitives. See also diagrams-povray package. **Bug fixes** + Issue 32 (`mempty` not behaving correctly within concatenations) ## [v0.2]() (3 June 2011) ---------------- **New functions and primitives** + `scaleToX` and `scaleToY` for scaling to an absolute width/height + `reverseTrail` + new `Angle` class and ability to use radians, degrees, or circle fractions for specifying angles + `rotateAbout` and `reflectAbout` transformations based on new conjugation functions + `rect` and `roundedRect` primitives + `explodeTrail`/`Path` for breaking trails and paths into individual segments **New features** + opacity attribute + support for path clipping * **New modules** + `Diagrams.BoundingBox` **Fixes and updates** + `withBounds` now properly uses the new bounds instead of just combining them with the old ## [v0.1.1]() (18 May 2011) ------------------ * minor documentation fixes * link to new website ## [v0.1]() [17 May 2011] ---------------- * initial preview release \* *This Change Log was automatically generated by (and then edited by hand) [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)* diagrams-lib-1.3.1.4/LICENSE0000644000000000000000000000456412754644012013422 0ustar0000000000000000Copyright (c) 2011-2015 diagrams-lib team: Jan Bracker Daniel Bergey Christopher Chalmers Denys Duchier Daniil Frumin Allan Gardner Pontus Granström 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 Scott Walck Ryan Yates Brent Yorgey All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Brent Yorgey nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diagrams-lib-1.3.1.4/test/0000755000000000000000000000000012754644012013363 5ustar0000000000000000diagrams-lib-1.3.1.4/test/Test.hs0000644000000000000000000000040312754644012014633 0ustar0000000000000000import Test.Tasty (defaultMain, testGroup, TestTree) import qualified Diagrams.TwoD.OffsetTest as TwoD.OffsetTest tests :: TestTree tests = testGroup "unit tests" [ testGroup "TwoD.Offset" TwoD.OffsetTest.tests ] main :: IO () main = defaultMain tests diagrams-lib-1.3.1.4/test/Diagrams/0000755000000000000000000000000012754644012015112 5ustar0000000000000000diagrams-lib-1.3.1.4/test/Diagrams/TwoD/0000755000000000000000000000000012754644012015767 5ustar0000000000000000diagrams-lib-1.3.1.4/test/Diagrams/TwoD/OffsetTest.hs0000644000000000000000000000337012754644012020414 0ustar0000000000000000module Diagrams.TwoD.OffsetTest ( tests ) where import Test.Tasty (TestTree) import Test.Tasty.HUnit import Diagrams.Prelude import Diagrams.TwoD.Offset tests :: [TestTree] tests = [ testCase "line" (offsetTrailVertices [p2 (0, 0), p2 (1, 0)] [p2 (0, -1), p2 (1, -1)]) , testCase "square" (offsetTrailVertices [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) , testCase "square loop" (offsetTrailLoopVertices [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) , testCase "redundant line" (offsetTrailVertices [p2 (0, 0), p2 (0.5, 0), p2 (1, 0)] [p2 (0, -1), p2 (1, -1)]) , testCase "redundant square" (offsetTrailVertices [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) , testCase "redundant square loop" (offsetTrailLoopVertices [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) ] offsetTrailVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion offsetTrailVertices orig off = (trailVertices . offsetTrail 1 . fromVertices $ orig) @?= off offsetTrailLoopVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion offsetTrailLoopVertices orig off = (trailVertices . offsetTrail 1 . loopTrailFromVertices $ orig) @?= off where loopTrailFromVertices = (`at` origin) . wrapTrail . glueLine . lineFromVertices diagrams-lib-1.3.1.4/diagrams/0000755000000000000000000000000012754644012014173 5ustar0000000000000000diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrow_example1.svg0000644000000000000000000001147712754644012023227 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg0000644000000000000000000000345712754644012023661 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg0000644000000000000000000000325512754644012024432 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg0000644000000000000000000000343212754644012024265 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg0000644000000000000000000000223012754644012024274 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg0000644000000000000000000000255612754644012022235 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg0000644000000000000000000000414712754644012024212 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Combinators_besideEx.svg0000644000000000000000000000470512754644012023470 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg0000644000000000000000000000171612754644012023534 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg0000644000000000000000000000164212754644012023571 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg0000644000000000000000000000130612754644012024074 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg0000644000000000000000000000371612754644012026461 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg0000644000000000000000000000402712754644012024134 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg0000644000000000000000000000140412754644012024277 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg0000644000000000000000000000360412754644012024602 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg0000644000000000000000000000137312754644012023746 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg0000644000000000000000000000320012754644012023241 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg0000644000000000000000000000125412754644012023736 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg0000644000000000000000000000514512754644012024412 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg0000644000000000000000000000415412754644012024141 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg0000644000000000000000000000366212754644012023744 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg0000644000000000000000000000160212754644012023560 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg0000644000000000000000000000264612754644012023437 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg0000644000000000000000000002115312754644012024411 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg0000644000000000000000000000470612754644012024034 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg0000644000000000000000000000371712754644012024126 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Trail_closeLineEx.svg0000644000000000000000000000224412754644012022741 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg0000644000000000000000000000413412754644012023472 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Combinators_strutEx.svg0000644000000000000000000000333112754644012023410 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg0000644000000000000000000000345112754644012023753 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg0000644000000000000000000000113512754644012024127 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg0000644000000000000000000000354512754644012024104 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg0000644000000000000000000000730312754644012025436 0ustar0000000000000000 LineJoinBevelLineJoinRoundLineJoinMiterdiagrams-lib-1.3.1.4/diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg0000644000000000000000000000426012754644012024702 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg0000644000000000000000000000357012754644012024535 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg0000644000000000000000000000325712754644012024642 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_cubicOffsetExample.svg0000644000000000000000000003527612754644012025422 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg0000644000000000000000000000176412754644012024232 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrow_example2.svg0000644000000000000000000001606012754644012023221 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg0000644000000000000000000000132112754644012024277 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg0000644000000000000000000000373312754644012024173 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Combinators_positionEx.svg0000644000000000000000000005345012754644012024102 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg0000644000000000000000000000360112754644012023264 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg0000644000000000000000000000671012754644012025266 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg0000644000000000000000000001366412754644012025436 0ustar0000000000000000 LineCapSquareLineCapRoundLineCapButtdiagrams-lib-1.3.1.4/diagrams/src_Diagrams_Trail_trailOffsetEx.svg0000644000000000000000000000204012754644012023300 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg0000644000000000000000000000151712754644012023740 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg0000644000000000000000000000240312754644012024266 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg0000644000000000000000000000367312754644012024015 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg0000644000000000000000000000145112754644012023561 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg0000644000000000000000000000342612754644012022511 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg0000644000000000000000000000344412754644012023606 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Trail_glueLineEx.svg0000644000000000000000000000214312754644012022566 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg0000644000000000000000000000133612754644012023067 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TrailLike_twiddleEx.svg0000644000000000000000000002506012754644012023266 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg0000644000000000000000000000133612754644012024127 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_Combinators_appendsEx.svg0000644000000000000000000001225212754644012023663 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg0000644000000000000000000000204612754644012024054 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg0000644000000000000000000000327212754644012024461 0ustar0000000000000000 diagrams-lib-1.3.1.4/diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg0000644000000000000000000000225312754644012026250 0ustar0000000000000000 diagrams-lib-1.3.1.4/src/0000755000000000000000000000000012754644012013173 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams.hs0000644000000000000000000001107312754644012015260 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams -- Copyright : (c) 2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module only contains exports defined in @diagrams-lib@ or -- @diagrams-core@. This module can be used if you want to avoid some -- potential conflicts with other modules, but importing -- "Diagrams.Prelude" (which includes re-exports from other packages) -- is often more convenient. -- ----------------------------------------------------------------------------- module Diagrams ( -- * Core library -- | The core definitions of transformations, diagrams, -- backends, and so on. module Diagrams.Core -- * Standard library -- | Attributes (color, line style, etc.) and styles. , module Diagrams.Attributes -- | Alignment of diagrams relative to their envelopes. , module Diagrams.Align -- | Creating and using bounding boxes. , module Diagrams.BoundingBox -- | Combining multiple diagrams into one. , module Diagrams.Combinators -- | Giving concrete locations to translation-invariant things. , module Diagrams.Located -- | Linear and cubic bezier segments. , module Diagrams.Segment -- | Trails. , module Diagrams.Trail -- | 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 -- | Paths. , module Diagrams.Path -- | Cubic splines. , module Diagrams.CubicSpline -- | Some additional transformation-related functions, like -- conjugation of transformations. , module Diagrams.Transform -- | Projective transformations and other deformations -- lacking an inverse. , module Diagrams.Deform -- | Giving names to subdiagrams and later retrieving -- subdiagrams by name. , module Diagrams.Names -- | Envelopes, aka functional bounding regions. , module Diagrams.Envelope -- | Traces, aka embedded raytracers, for finding points on -- the boundary of a diagram. , module Diagrams.Trace -- | A query is a function that maps points in a vector space -- to values in some monoid; they can be used to annotate -- the points of a diagram with some values. , module Diagrams.Query -- | Utilities for working with points. , module Diagrams.Points -- | Utilities for working with size. , module Diagrams.Size -- | Angles , module Diagrams.Angle -- | Convenience infix operators for working with coordinates. , module Diagrams.Coordinates -- | Directions, distinguished from angles or vectors , module Diagrams.Direction -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional -- diagrams. , module Diagrams.TwoD -- | Extra things for three-dimensional diagrams. , module Diagrams.ThreeD -- | Tools for making animations. , module Diagrams.Animation -- | Various utility definitions. , module Diagrams.Util ) where import Diagrams.Core import Diagrams.Align import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.BoundingBox hiding (contains, inside, intersection, outside, union) import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline import Diagrams.Deform import Diagrams.Direction hiding (dir) import Diagrams.Envelope import Diagrams.Located import Diagrams.Names import Diagrams.Parametric import Diagrams.Parametric.Adjust import Diagrams.Path hiding (pathPoints) import Diagrams.Points import Diagrams.Query import Diagrams.Segment import Diagrams.Size import Diagrams.Tangent import Diagrams.ThreeD import Diagrams.Trace import Diagrams.Trail hiding (linePoints, loopPoints, trailPoints) import Diagrams.TrailLike import Diagrams.Transform import Diagrams.TwoD import Diagrams.Util diagrams-lib-1.3.1.4/src/Diagrams/0000755000000000000000000000000012754644012014722 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Util.hs0000644000000000000000000002117612754644012016202 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Util -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Some miscellaneous utilities provided by the diagrams-lib package. -- ----------------------------------------------------------------------------- module Diagrams.Util ( -- * Utilities for users with , applyAll , (#) , (##) , iterateN , tau -- * Finding files , findHsFile -- * Finding sandboxes , findSandbox , globalPackage -- * Internal utilities , foldB ) where import Control.Applicative import Control.Lens hiding (( # )) import Control.Monad import Control.Monad.Catch import Control.Monad.Trans import Control.Monad.Trans.Maybe import Data.Default.Class import Data.List import Data.List.Lens import Data.Maybe import Data.Monoid import System.Directory import System.Environment import System.FilePath import System.FilePath.Lens import System.Process -- | Several functions exported by the diagrams library take a number -- of arguments giving the user control to \"tweak\" various aspects -- of their behavior. Rather than give such functions a long list -- of arguments, and to make it possible for the user to selectively -- override only certain arguments and use default values for -- others, such sets of arguments are collected into a record with -- named fields (see 'PolygonOpts' in "Diagrams.TwoD.Shapes" for an -- example). Such record types are made instances of the 'Default' -- class, which provides a single record structure ('def') -- collecting the \"default\" arguments to the function. @with@ is -- a synonym for 'def', which provides nice-looking syntax for -- simulating optional, named arguments in Haskell. For example, -- -- @ -- polygon with {sides = 7, edgeSkip = 2} -- @ -- -- calls the 'polygon' function with a single argument (note that -- record update binds more tightly than function application!), -- namely, 'with' (the record of default arguments) where the -- @sides@ and @edgeSkip@ fields have been updated. with :: Default d => d with = def -- | @applyAll@ takes a list of functions and applies them all to a -- value, in sequence from the last function in the list to the first. -- For example, @applyAll [f1, f2, f3] a == f1 . f2 . f3 $ a@. applyAll :: [a -> a] -> a -> a applyAll = appEndo . mconcat . map Endo infixl 8 # -- | Postfix function application, for conveniently applying -- attributes. Unlike @($)@, @(#)@ has a high precedence (8), so @d -- \# foo \# bar@ can be combined with other things using operators -- like @(|||)@ or @(\<\>)@ without needing parentheses. (#) :: a -> (a -> b) -> b (#) = flip ($) -- | A replacement for lenses' 'Control.Lens.Review.#' operator. (##) :: AReview t b -> b -> t (##) = review {-# INLINE (##) #-} infixr 8 ## -- | @iterateN n f x@ returns the list of the first @n@ iterates of -- @f@ starting at @x@, that is, the list @[x, f x, f (f x), ...]@ -- of length @n@. (Note that the last element of the list will be -- @f@ applied to @x@ @(n-1)@ times.) iterateN :: Int -> (a -> a) -> a -> [a] iterateN n f = take n . iterate f -- | The circle constant, the ratio of a circle's circumference to its -- /radius/. Note that @pi = tau/2@. -- -- For more information and a well-reasoned argument why we should -- all be using tau instead of pi, see /The Tau Manifesto/, -- . -- -- To hear what it sounds like (and to easily memorize the first 30 -- digits or so), try . tau :: Floating a => a tau = 2*pi -- | Given an associative binary operation and a default value to use -- in the case of an empty list, perform a /balanced/ fold over a -- list. For example, -- -- @ -- foldB (+) z [a,b,c,d,e,f] == ((a+b) + (c+d)) + (e+f) -- @ -- foldB :: (a -> a -> a) -> a -> [a] -> a foldB _ z [] = z foldB f _ as = foldB' as where foldB' [x] = x foldB' xs = foldB' (go xs) go [] = [] go [x] = [x] go (x1:x2:xs) = f x1 x2 : go xs ------------------------------------------------------------------------ -- Files ------------------------------------------------------------------------ -- | Given some file (no extension or otherwise) try to find a haskell -- source file. findHsFile :: FilePath -> IO (Maybe FilePath) findHsFile file = runMaybeT $ hs <|> lhs where hs = check (addExtension file "hs") lhs = check (addExtension file "lhs") check f = do lift (doesFileExist f) >>= guard pure f ------------------------------------------------------------------------ -- Sandbox ------------------------------------------------------------------------ -- | Parse cabal config file to find the location of the package -- database. parseConfig :: FilePath -> MaybeT IO FilePath parseConfig file = do config <- maybeIO $ readFile file hoistMaybe $ config ^? lined . prefixed "package-db: " -- | Seach the given directory and all parent directories until a cabal -- config file is found. First search for \"cabal.config\", then -- \"cabal.sandbox.config\". Return the location of the package -- database in the config file. configSearch :: FilePath -> MaybeT IO FilePath configSearch p0 = do p0' <- maybeIO $ canonicalizePath p0 let mkPaths p | all isPathSeparator p || p == "." = [] | otherwise = (p "cabal.sandbox.config") : mkPaths (p ^. directory) foldMaybeT parseConfig (mkPaths p0') -- | Check if the folder is a database, or if it contains a database. -- Returns the database location if it's found. isDB :: FilePath -> MaybeT IO FilePath isDB path = if isConf path then return path else maybeIO (getDirectoryContents path) >>= hoistMaybe . find isConf where isConf = isSuffixOf ".conf.d" -- | Search for a sandbox in the following order: -- -- * Test given FilePaths if they point directly to a database or -- contain a cabal config file (or any parent directory containing a -- config file). -- -- * Same test for @DIAGRAMS_SANDBOX@ environment value -- -- * Environment values of @GHC_PACKAGE_PATH@, @HSENV@ and -- @PACKAGE_DB_FOR_GHC@ that point to a database. -- -- * Test for config file (cabal.sandbox.config) in the current -- directory and its parents. -- findSandbox :: [FilePath] -> IO (Maybe FilePath) findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig where -- first path in environment lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv envDB = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"] -- test if path points directly to db or contains a config file test x = isDB x <|> configSearch x pathsTest = foldMaybeT test paths diaSB = lookEnv "DIAGRAMS_SANDBOX" >>= test wdConfig = maybeIO getCurrentDirectory >>= configSearch -- -- | Use the given path for the sandbox in the @GHC_PACKAGE_PATH@ -- -- environment (appending the ghc global package database from @ghc -- -- --info@. @GHC_PACKAGE_PATH@ if the variable ghc and other tools use -- -- to find the package database. (This is what @cabal exec@ sets) -- ghcPackagePath :: FilePath -> IO () -- ghcPackagePath db = do -- gdb <- globalPackage -- let dbs = intercalate [searchPathSeparator] [db,gdb] -- setEnv "GHC_PACKAGE_PATH" dbs -- -- setEnv is only in base > 4.7, either need to use setenv package or -- -- -package-db flag -- | Find ghc's global package database. Throws an error if it isn't -- found. globalPackage :: IO FilePath globalPackage = do info <- read <$> readProcess "ghc" ["--info"] "" return $ fromMaybe (error "Unable to parse ghc --info.") (lookup "Global Package DB" info) -- MaybeT utilities -- | Lift an 'IO' action. If any exceptions are raised, return Nothing. maybeIO :: (MonadCatch m, MonadIO m) => IO a -> MaybeT m a maybeIO io = liftIO io `catchAll` const mzero -- | Lift a maybe value to a MaybeT of any monad. hoistMaybe :: Monad m => Maybe a -> MaybeT m a hoistMaybe = MaybeT . return -- | Fold a list of 'MaybeT's that short-circuits as soon as a Just value -- is found (instead going through the whole list). foldMaybeT :: Monad m => (a -> MaybeT m b) -> [a] -> MaybeT m b foldMaybeT _ [] = mzero foldMaybeT f (a:as) = MaybeT $ do x <- runMaybeT (f a) if isJust x then return x else runMaybeT (foldMaybeT f as) diagrams-lib-1.3.1.4/src/Diagrams/Deform.hs0000644000000000000000000001142312754644012016473 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Diagrams.Deform ( Deformation(..) , Deformable(..) , asDeformation ) where import Control.Lens (mapped, over, _Wrapped) import Data.Monoid hiding ((<>)) import Data.Semigroup import Prelude import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Linear.Affine import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- Deformations -- | @Deformations@ are a superset of the affine transformations -- represented by the 'Transformation' type. In general they are not -- invertible. @Deformation@s include projective transformations. -- @Deformation@ can represent other functions from points to points -- which are "well-behaved", in that they do not introduce small wiggles. newtype Deformation v u n = Deformation (Point v n -> Point u n) instance Semigroup (Deformation v v n) where (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) instance Monoid (Deformation v v n) where mappend = (<>) mempty = Deformation id class Deformable a b where -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. -- If the type of @a@ is not closed under projection, approximate -- to accuracy @epsilon@. deform' :: N a -> Deformation (V a) (V b) (N a) -> a -> b -- | @deform d a@ transforms @a@ by the deformation @d@. -- If the type of @a@ is not closed under projection, @deform@ -- should call @deform'@ with some reasonable default value of -- @epsilon@. deform :: Deformation (V a) (V b) (N a) -> a -> b -- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by -- discarding the inverse transform. This allows reusing -- @Transformation@s in the construction of @Deformation@s. asDeformation :: (Additive v, Num n) => Transformation v n -> Deformation v v n asDeformation t = Deformation (papply t) ------------------------------------------------------------ -- Instances instance r ~ Point u n => Deformable (Point v n) r where deform' = const deform deform (Deformation l) = l -- | Cubic curves are not closed under perspective projections. -- Therefore @Segment@s are not an instance of Deformable. However, -- the deformation of a @Segment@ can be approximated to arbitrary -- precision by a series of @Segment@s. @deformSegment@ does this, -- which allows types built from lists of @Segment@s to themselves be -- @Deformable@. deformSegment :: (Metric v, Metric u, OrderedField n) => n -> Deformation v u n -> FixedSegment v n -> [FixedSegment u n] deformSegment epsilon t = go (0::Int) where go n s | n == 100 = [approx t s] | goodEnough epsilon t s = [approx t s] | otherwise = concatMap (go (n+1)) [s1, s2] where (s1, s2) = splitAtParam s 0.5 -- deformSegment epsilon t s -- | goodEnough epsilon t s = [approx t s] -- | otherwise = concatMap (deformSegment epsilon t) [s1, s2] -- where -- (s1, s2) = splitAtParam s 0.5 approx :: Deformation v u n -> FixedSegment v n -> FixedSegment u n approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where f = deform t goodEnough :: (Metric v, Metric u, OrderedField n) => n -> Deformation v u n -> FixedSegment v n -> Bool goodEnough e t s = all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u | u <- [0.25, 0.5, 0.75]] instance (Metric v, Metric u, OrderedField n, r ~ Located (Trail u n)) => Deformable (Located (Trail v n)) r where deform' eps p t | isLine $ unLoc t = line `at` p0 | otherwise = glueTrail line `at` p0 where segs = concatMap (deformSegment eps p) $ fixTrail t p0 = case segs of (FLinear start _:_) -> start (FCubic start _ _ _:_) -> start _ -> deform p (loc t) line = trailFromSegments $ map (unLoc . fromFixedSeg) segs deform p t = deform' (0.01 * extent) p t where -- estimate the "size" of the Trail' as -- the maximum distance to any vertex extent = maximum . map dist . trailVertices $ t dist pt = norm $ pt .-. loc t instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => Deformable (Path v n) r where deform' eps p = over (_Wrapped . mapped) (deform' eps p) deform p = over (_Wrapped . mapped) (deform p) diagrams-lib-1.3.1.4/src/Diagrams/Combinators.hs0000644000000000000000000003557512754644012017555 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Combinators -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Higher-level tools for combining diagrams. -- ----------------------------------------------------------------------------- module Diagrams.Combinators ( -- * Unary operations withEnvelope, withTrace , phantom, strut , pad, frame , extrudeEnvelope, intrudeEnvelope -- * Binary operations , atop , beneath , beside , atDirection -- * n-ary operations , appends , position, atPoints , cat, cat' , CatOpts(_catMethod, _sep), catMethod, sep , CatMethod(..) ) where import Control.Lens hiding (beside, ( # )) import Data.Default.Class import Data.Monoid.Deletable (toDeletable) import Data.Monoid.MList (inj) import Data.Proxy import Data.Semigroup import qualified Data.Tree.DUAL as D import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) import Diagrams.Direction import Diagrams.Segment (straight) import Diagrams.Util import Linear.Affine import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ -- | 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 # dashingG [0.1,0.1] 0 # lc white -- > <> square 2 # withEnvelope (c :: D V2 Double) # fc blue -- > ) -- > c = circle 0.8 -- > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5 withEnvelope :: (InSpace v n a, Monoid' m, Enveloped a) => a -> QDiagram b v n m -> QDiagram b v n m withEnvelope = setEnvelope . getEnvelope -- | Use the trace from some object as the trace for a diagram, in -- place of the diagram's default trace. withTrace :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) => a -> QDiagram b v n m -> QDiagram b v n m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. phantom :: (InSpace v n a, Monoid' m, Enveloped a, Traced a) => a -> QDiagram b v n m phantom a = QD $ D.leafU ((inj . toDeletable . getEnvelope $ a) <> (inj . toDeletable . getTrace $ a)) -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of -- @s@ (factors between 0 and 1 can be used to shrink the envelope). -- Note that the envelope will expand with respect to the local -- origin, so if the origin is not centered the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using, e.g., 'centerXY' for 2D diagrams) before applying @pad@. pad :: (Metric v, OrderedField n, Monoid' m) => n -> QDiagram b v n m -> QDiagram b v n m pad s d = withEnvelope (d # scale s) d -- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, -- s is in the local units of the diagram. This function is similar to @pad@, -- only it takes an absolute quantity and pre-centering should not be -- necessary. frame :: (Metric v, OrderedField n, Monoid' m) => n -> QDiagram b v n m -> QDiagram b v n m frame s = over envelope (onEnvelope $ \f x -> f x + s) -- | @strut v@ is a diagram which produces no output, but with respect -- to alignment and envelope acts like a 1-dimensional segment -- oriented along the vector @v@, with local origin at its -- center. (Note, however, that it has an empty trace; for 2D struts -- with a nonempty trace see 'strutR2', 'strutX', and 'strutY' from -- "Diagrams.TwoD.Combinators".) Useful for manually creating -- separation between two diagrams. -- -- <> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 strut :: (Metric v, OrderedField n) => v n -> QDiagram b v n m strut v = QD $ D.leafU (inj . toDeletable $ env) where env = translate ((-0.5) *^ v) . getEnvelope $ straight v -- note we can't use 'phantom' here because it tries to construct a -- trace as well, and segments do not have a trace in general (only -- in 2D; see Diagrams.TwoD.Segment). This is a good reason to have -- a special 'strut' combinator (before the introduction of traces -- it was mostly just for convenience). -- -- also note that we can't remove the call to getEnvelope, since -- translating a segment has no effect. -- | @extrudeEnvelope v d@ asymmetrically \"extrudes\" the envelope of -- a diagram in the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset outwards -- by the magnitude of the vector. -- -- This works by offsetting the envelope distance proportionally to -- the cosine of the difference in angle, and leaving it unchanged -- when this factor is negative. extrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m extrudeEnvelope = deformEnvelope 0.5 -- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of -- a diagram away from the given direction. All parts of the envelope -- within 90 degrees of this direction are modified, offset inwards -- by the magnitude of the vector. -- -- Note that this could create strange inverted envelopes, where -- @ diameter v d < 0 @. intrudeEnvelope :: (Metric v, OrderedField n, Monoid' m) => v n -> QDiagram b v n m -> QDiagram b v n m intrudeEnvelope = deformEnvelope (-0.5) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope :: (Metric v, OrderedField n, Monoid' m) => n -> v n -> QDiagram b v n m -> QDiagram b v n m deformEnvelope s v = over (envelope . _Wrapping Envelope) deformE where deformE = Option . fmap deformE' . getOption deformE' env v' | dp > 0 = Max $ getMax (env v') + (dp * s) / norm v' | otherwise = env v' where dp = v' `dot` v ------------------------------------------------------------ -- Combining two objects ------------------------------------------------------------ -- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is, -- @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of -- @d1@. beneath :: (Metric v, OrderedField n, Monoid' m) => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m beneath = flip atop infixl 6 `beneath` -- | Place two monoidal objects (/i.e./ diagrams, paths, -- animations...) next to each other along the given vector. In -- particular, place the second object so that the vector points -- from the local origin of the first object to the local origin of -- the second object, at a distance so that their envelopes are just -- tangent. The local origin of the new, combined object is the -- local origin of the first object (unless the first object is the -- identity element, in which case the second object is returned -- unchanged). -- -- <> -- -- > besideEx = beside (r2 (20,30)) -- > (circle 1 # fc orange) -- > (circle 1.5 # fc purple) -- > # showOrigin -- > # centerXY # pad 1.1 -- -- Note that @beside v@ is associative, so objects under @beside v@ -- form a semigroup for any given vector @v@. In fact, they also -- form a monoid: 'mempty' is clearly a right identity (@beside v d1 -- mempty === d1@), and there should also be a special case to make -- it a left identity, as described above. -- -- In older versions of diagrams, @beside@ put the local origin of -- the result at the point of tangency between the two inputs. That -- semantics can easily be recovered by performing an alignment on -- the first input before combining. That is, if @beside'@ denotes -- the old semantics, -- -- > beside' v x1 x2 = beside v (x1 # align v) x2 -- -- To get something like @beside v x1 x2@ whose local origin is -- identified with that of @x2@ instead of @x1@, use @beside -- (negateV v) x2 x1@. beside :: (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 -- | Place two diagrams (or other juxtaposable objects) adjacent to -- one another, with the second diagram placed in the direction 'd' -- from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. See the -- documentation of 'beside' for more information. atDirection :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a) => Direction v n -> a -> a -> a atDirection = beside . fromDirection ------------------------------------------------------------ -- Combining multiple objects ------------------------------------------------------------ -- | @appends x ys@ appends each of the objects in @ys@ to the object -- @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 -> [(Vn a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in -- the vector space of the combined object. -- -- <> -- -- > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat spot)) -- > where spot = circle 0.2 # fc black -- > mkPoint :: Double -> P2 Double -- > mkPoint x = p2 (x,x*x) position :: (InSpace v n a, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a position = mconcat . map (uncurry moveTo) -- | Curried version of @position@, takes a list of points and a list of -- objects. atPoints :: (InSpace v n a, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a atPoints ps as = position $ zip ps as -- | Methods for concatenating diagrams. data CatMethod = Cat -- ^ Normal catenation: simply put diagrams -- next to one another (possibly with a -- certain distance in between each). The -- distance between successive diagram -- /envelopes/ will be consistent; the -- distance between /origins/ may vary if -- the diagrams are of different sizes. | Distrib -- ^ Distribution: place the local origins of -- diagrams at regular intervals. With -- this method, the distance between -- successive /origins/ will be consistent -- but the distance between envelopes may -- not be. Indeed, depending on the amount -- of separation, diagrams may overlap. -- | Options for 'cat''. data CatOpts n = CatOpts { _catMethod :: CatMethod , _sep :: n , catOptsvProxy :: Proxy n } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a -- 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. Note -- this is not a problem when using the 'sep' lens, as its type is -- more restricted. makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts -- | Which 'CatMethod' should be used: -- normal catenation (default), or distribution? catMethod :: Lens' (CatOpts n) 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 :: Lens' (CatOpts n) n instance Num n => Default (CatOpts n) where def = CatOpts { _catMethod = Cat , _sep = 0 , catOptsvProxy = Proxy } -- | @cat v@ positions a list of objects so that their local origins -- lie along a line in the direction of @v@. Successive objects -- will have their envelopes just touching. The local origin -- of the result will be the same as the local origin of the first -- object. -- -- See also 'cat'', which takes an extra options record allowing -- certain aspects of the operation to be tweaked. cat :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) => v n -> [a] -> a cat v = cat' v def -- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the -- user to specify -- -- * The spacing method: catenation (uniform spacing between -- envelopes) or distribution (uniform spacing between local -- origins). The default is catenation. -- -- * The amount of separation between successive diagram -- envelopes/origins (depending on the spacing method). The -- default is 0. -- -- 'CatOpts' is an instance of 'Default', so 'with' may be used for -- the second argument, as in @cat' (1,2) (with & sep .~ 2)@. -- -- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). cat' :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a) => v n -> CatOpts n -> [a] -> a cat' v (CatOpts { _catMethod = Cat, _sep = s }) = foldB comb mempty where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs) vs = s *^ signorm (negated v) cat' v (CatOpts { _catMethod = Distrib, _sep = s }) = position . zip (iterate (.+^ (s *^ signorm v)) origin) diagrams-lib-1.3.1.4/src/Diagrams/BoundingBox.hs0000644000000000000000000002742412754644012017505 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Bounding boxes are not very compositional (/e.g./ it is not -- possible to do anything sensible with them under rotation), so they -- are not used in the diagrams core. However, they do have their -- uses; this module provides definitions and functions for working -- with them. -- ----------------------------------------------------------------------------- module Diagrams.BoundingBox ( -- * Bounding boxes BoundingBox -- * Constructing bounding boxes , emptyBox, fromCorners, fromPoint, fromPoints , boundingBox -- * Queries on bounding boxes , isEmptyBox , getCorners, getAllCorners , boxExtents, boxCenter , mCenterPoint, centerPoint , boxTransform, boxFit , contains, contains', boundingBoxQuery , inside, inside', outside, outside' -- * Operations on bounding boxes , union, intersection ) where import Control.Lens (AsEmpty (..), Each (..), nearly) import Data.Foldable as F import Data.Maybe (fromMaybe) import Data.Semigroup import Text.Read import Diagrams.Align import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Path import Diagrams.ThreeD.Shapes import Diagrams.ThreeD.Types import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types import Control.Applicative import Data.Traversable as T import Linear.Affine import Linear.Metric import Linear.Vector -- Unexported utility newtype newtype NonEmptyBoundingBox v n = NonEmptyBoundingBox (Point v n, Point v n) deriving (Eq, Functor) type instance V (NonEmptyBoundingBox v n) = v type instance N (NonEmptyBoundingBox v n) = n fromNonEmpty :: NonEmptyBoundingBox v n -> BoundingBox v n fromNonEmpty = BoundingBox . Option . Just fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v n) -> BoundingBox v n fromMaybeEmpty = maybe emptyBox fromNonEmpty nonEmptyCorners :: NonEmptyBoundingBox v n -> (Point v n, Point v n) nonEmptyCorners (NonEmptyBoundingBox x) = x instance (Additive v, Ord n) => Semigroup (NonEmptyBoundingBox v n) where (NonEmptyBoundingBox (ul, uh)) <> (NonEmptyBoundingBox (vl, vh)) = NonEmptyBoundingBox (liftU2 min ul vl, liftU2 max uh vh) -- | A bounding box is an axis-aligned region determined by two points -- indicating its \"lower\" and \"upper\" corners. It can also represent -- an empty bounding box - the points are wrapped in @Maybe@. newtype BoundingBox v n = BoundingBox (Option (NonEmptyBoundingBox v n)) deriving (Eq, Functor) deriving instance (Additive v, Ord n) => Semigroup (BoundingBox v n) deriving instance (Additive v, Ord n) => Monoid (BoundingBox v n) instance AsEmpty (BoundingBox v n) where _Empty = nearly emptyBox isEmptyBox -- | Only valid if the second point is not smaller than the first. instance (Additive v', Foldable v', Ord n') => Each (BoundingBox v n) (BoundingBox v' n') (Point v n) (Point v' n') where each f (getCorners -> Just (l, u)) = fromCorners <$> f l <*> f u each _ _ = pure emptyBox type instance V (BoundingBox v n) = v type instance N (BoundingBox v n) = n -- Map a function on a homogeneous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) instance (Additive v, Num n) => HasOrigin (BoundingBox v n) where moveOriginTo p b = fromMaybeEmpty (NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b) instance (Metric v, Traversable v, OrderedField n) => Enveloped (BoundingBox v n) where getEnvelope = getEnvelope . getAllCorners -- Feels like cheating. -- Should be possible to generalise this. instance RealFloat n => Traced (BoundingBox V2 n) where getTrace = getTrace . ((`boxFit` rect 1 1) . boundingBox :: Envelope V2 n -> Path V2 n) . getEnvelope instance TypeableFloat n => Traced (BoundingBox V3 n) where getTrace = getTrace . ((`boxFit` cube) . boundingBox :: Envelope V3 n -> D V3 n) . getEnvelope instance (Metric v, Traversable v, OrderedField n) => Alignable (BoundingBox v n) where defaultBoundary = envelopeP instance Show (v n) => Show (BoundingBox v n) where showsPrec d b = case getCorners b of Just (l, u) -> showParen (d > 10) $ showString "fromCorners " . showsPrec 11 l . showChar ' ' . showsPrec 11 u Nothing -> showString "emptyBox" instance Read (v n) => Read (BoundingBox v n) where readPrec = parens $ (do Ident "emptyBox" <- lexP pure emptyBox ) <|> (prec 10 $ do Ident "fromCorners" <- lexP l <- step readPrec h <- step readPrec pure . fromNonEmpty $ NonEmptyBoundingBox (l, h) ) -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't -- require the same type constraints that the @Monoid@ instance does. emptyBox :: BoundingBox v n emptyBox = BoundingBox $ Option Nothing -- | Create a bounding box from a point that is component-wise @(<=)@ than the -- other. If this is not the case, then @mempty@ is returned. fromCorners :: (Additive v, Foldable v, Ord n) => Point v n -> Point v n -> BoundingBox v n fromCorners l h | F.and (liftI2 (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) | otherwise = mempty -- | Create a degenerate bounding \"box\" containing only a single point. fromPoint :: Point v n -> BoundingBox v n fromPoint p = fromNonEmpty $ NonEmptyBoundingBox (p, p) -- | Create the smallest bounding box containing all the given points. fromPoints :: (Additive v, Ord n) => [Point v n] -> BoundingBox v n fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). boundingBox :: (InSpace v n a, HasBasis v, Enveloped a) => a -> BoundingBox v n boundingBox a = fromMaybeEmpty $ do env <- (appEnvelope . getEnvelope) a let h = fmap env eye l = negated $ fmap (env . negated) eye return $ NonEmptyBoundingBox (P l, P h) -- | Queries whether the BoundingBox is empty. isEmptyBox :: BoundingBox v n -> Bool isEmptyBox (BoundingBox (Option Nothing)) = True isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. getCorners :: BoundingBox v n -> Maybe (Point v n, Point v n) getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p -- | Computes all of the corners of the bounding box. getAllCorners :: (Additive v, Traversable v) => BoundingBox v n -> [Point v n] getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) = T.sequence (liftI2 (\a b -> [a,b]) l u) -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. boxExtents :: (Additive v, Num n) => BoundingBox v n -> v n boxExtents = maybe zero (\(l,u) -> u .-. l) . getCorners -- | Get the center point in a bounding box. boxCenter :: (Additive v, Fractional n) => BoundingBox v n -> Maybe (Point v n) boxCenter = fmap (uncurry (lerp 0.5)) . getCorners -- | Get the center of a the bounding box of an enveloped object, return -- 'Nothing' for object with empty envelope. mCenterPoint :: (InSpace v n a, HasBasis v, Enveloped a) => a -> Maybe (Point v n) mCenterPoint = boxCenter . boundingBox -- | Get the center of a the bounding box of an enveloped object, return -- the origin for object with empty envelope. centerPoint :: (InSpace v n a, HasBasis v, Enveloped a) => a -> Point v n centerPoint = fromMaybe origin . mCenterPoint -- | Create a transformation mapping points from one bounding box to the -- other. Returns 'Nothing' if either of the boxes are empty. boxTransform :: (Additive v, Fractional n) => BoundingBox v n -> BoundingBox v n -> Maybe (Transformation v n) boxTransform u v = do (P ul, _) <- getCorners u (P vl, _) <- getCorners v let i = s (v, u) <-> s (u, v) s = liftU2 (*) . uncurry (liftU2 (/)) . mapT boxExtents return $ Transformation i i (vl ^-^ s (v, u) ul) -- | Transforms an enveloped thing to fit within a @BoundingBox@. If the -- bounding box is empty, then the result is also @mempty@. boxFit :: (InSpace v n a, HasBasis v, Enveloped a, Transformable a, Monoid a) => BoundingBox v n -> a -> a boxFit b x = maybe mempty (`transform` x) $ boxTransform (boundingBox x) b -- | Check whether a point is contained in a bounding box (including its edges). contains :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains b p = maybe False check $ getCorners b where check (l, h) = F.and (liftI2 (<=) l p) && F.and (liftI2 (<=) p h) -- | Check whether a point is /strictly/ contained in a bounding box. contains' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Point v n -> Bool contains' b p = maybe False check $ getCorners b where check (l, h) = F.and (liftI2 (<) l p) && F.and (liftI2 (<) p h) boundingBoxQuery :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> Query v n Any boundingBoxQuery bb = Query $ Any . contains bb -- | Test whether the first bounding box is contained inside -- the second. inside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.and (liftI2 (>=) ul vl) && F.and (liftI2 (<=) uh vh) -- | Test whether the first bounding box is /strictly/ contained -- inside the second. inside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool inside' u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.and (liftI2 (>) ul vl) && F.and (liftI2 (<) uh vh) -- | Test whether the first bounding box lies outside the second -- (although they may intersect in their boundaries). outside :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.or (liftI2 (<=) uh vl) || F.or (liftI2 (>=) ul vh) -- | Test whether the first bounding box lies /strictly/ outside the second -- (they do not intersect at all). outside' :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> Bool outside' u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.or (liftI2 (<) uh vl) || F.or (liftI2 (>) ul vh) -- | Form the largest bounding box contained within this given two -- bounding boxes, or @Nothing@ if the two bounding boxes do not -- overlap at all. intersection :: (Additive v, Foldable v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n intersection u v = maybe mempty (uncurry fromCorners) $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return (liftI2 max ul vl, liftI2 min uh vh) -- | Form the smallest bounding box containing the given two bound union. This -- function is just an alias for @mappend@. union :: (Additive v, Ord n) => BoundingBox v n -> BoundingBox v n -> BoundingBox v n union = mappend diagrams-lib-1.3.1.4/src/Diagrams/Size.hs0000644000000000000000000001321512754644012016172 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Size -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Utilities for working with sizes of objects. -- ----------------------------------------------------------------------------- module Diagrams.Size ( -- * Size spec SizeSpec -- ** Making size spec , mkSizeSpec , dims , absolute -- ** Extracting size specs , getSpec , specToSize -- ** Functions on size specs , requiredScale , requiredScaling , sized , sizedAs , sizeAdjustment ) where import Control.Applicative import Control.Lens hiding (transform) import Control.Monad import Data.Foldable as F import Data.Hashable import Data.Semigroup import Data.Maybe import Data.Typeable import GHC.Generics (Generic) import Prelude import Diagrams.Core import Diagrams.BoundingBox import Linear.Affine import Linear.Vector ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | A 'SizeSpec' is a way of specifying a size without needed lengths for all -- the dimensions. newtype SizeSpec v n = SizeSpec (v n) deriving ( #if __GLASGOW_HASKELL__ >= 707 Typeable, #endif Functor, Generic, Hashable, Show) #if __GLASGOW_HASKELL__ < 707 instance forall v. Typeable1 v => Typeable1 (SizeSpec v) where typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Size" "Size") [] `mkAppTy` typeOf1 (undefined :: v n) #endif type instance V (SizeSpec v n) = v type instance N (SizeSpec v n) = n -- | Retrieve a size spec as a vector of maybe values. Only positive sizes are -- returned. getSpec :: (Functor v, Num n, Ord n) => SizeSpec v n -> v (Maybe n) getSpec (SizeSpec sp) = mfilter (>0) . Just <$> sp -- | Make a 'SizeSpec' from a vector of maybe values. Any negative values will -- be ignored. For 2D 'SizeSpec's see 'mkWidth' and 'mkHeight' from -- "Diagrams.TwoD.Size". mkSizeSpec :: (Functor v, Num n) => v (Maybe n) -> SizeSpec v n mkSizeSpec = dims . fmap (fromMaybe 0) -- | Make a 'SizeSpec' from a vector. Any negative values will be ignored. dims :: v n -> SizeSpec v n dims = SizeSpec -- | A size spec with no hints to the size. absolute :: (Additive v, Num n) => SizeSpec v n absolute = SizeSpec zero -- | @specToSize n spec@ extracts a size from a 'SizeSpec' @sz@. Any values not -- specified in the spec are replaced by the smallest of the values that are -- specified. If there are no specified values (i.e. 'absolute') then @n@ is -- used. specToSize :: (Foldable v, Functor v, Num n, Ord n) => n -> SizeSpec v n -> v n specToSize n (getSpec -> spec) = fmap (fromMaybe smallest) spec where smallest = fromMaybe n $ minimumOf (folded . _Just) spec -- | @requiredScale spec sz@ returns the largest scaling factor to make -- something of size @sz@ fit the requested size @spec@ without changing the -- aspect ratio. @sz@ should be non-zero (otherwise a scale of 1 is -- returned). For non-uniform scaling see 'boxFit'. requiredScale :: (Additive v, Foldable v, Fractional n, Ord n) => SizeSpec v n -> v n -> n requiredScale (getSpec -> spec) sz | allOf (folded . _Just) (<= 0) usedSz = 1 | otherwise = fromMaybe 1 mScale where usedSz = liftI2 (<$) sz spec scales = liftI2 (^/) spec sz mScale = minimumOf (folded . _Just) scales -- | Return the 'Transformation' calcuated from 'requiredScale'. requiredScaling :: (Additive v, Foldable v, Fractional n, Ord n) => SizeSpec v n -> v n -> Transformation v n requiredScaling spec = scaling . requiredScale spec -- | Uniformly scale any enveloped object so that it fits within the -- given size. For non-uniform scaling see 'boxFit'. sized :: (InSpace v n a, HasLinearMap v, Transformable a, Enveloped a) => SizeSpec v n -> a -> a sized spec a = transform (requiredScaling spec (size a)) a -- | Uniformly scale an enveloped object so that it \"has the same -- size as\" (fits within the width and height of) some other -- object. sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, Transformable a, Enveloped a, Enveloped b) => b -> a -> a sizedAs other = sized (dims $ size other) -- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The -- vector is the new size and the transformation to position the lower -- corner at the origin and scale to the size spec. sizeAdjustment :: (Additive v, Foldable v, OrderedField n) => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) sizeAdjustment spec bb = (sz', t) where v = (0.5 *^ P sz') .-. (s *^ fromMaybe origin (boxCenter bb)) sz = boxExtents bb sz' = if allOf folded isJust (getSpec spec) then specToSize 0 spec else s *^ sz s = requiredScale spec sz t = translation v <> scaling s diagrams-lib-1.3.1.4/src/Diagrams/Attributes.hs0000644000000000000000000004101612754644012017406 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Diagrams may have /attributes/ which affect the way they are -- rendered. This module defines some common attributes; particular -- backends may also define more backend-specific attributes. -- -- Every attribute type must have a /semigroup/ structure, that is, an -- associative binary operation for combining two attributes into one. -- Unless otherwise noted, all the attributes defined here use the -- 'Last' structure, that is, combining two attributes simply keeps -- the second one and throws away the first. This means that child -- attributes always override parent attributes. -- ----------------------------------------------------------------------------- module Diagrams.Attributes ( -- ** Standard measures ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, none , tiny, verySmall, small, normal, large, veryLarge, huge -- ** Line width , LineWidth, getLineWidth , _LineWidth, _LineWidthM , lineWidth, lineWidthM , _lineWidth, _lw, _lineWidthU , lw, lwN, lwO, lwL, lwG -- ** Dashing , Dashing(..), getDashing , dashing, dashingN, dashingO, dashingL, dashingG , _dashing, _dashingU -- * Color -- $color , Color(..), SomeColor(..), _SomeColor, someToAlpha -- ** Opacity , Opacity, _Opacity , getOpacity, opacity, _opacity -- ** Converting colors , colorToSRGBA, colorToRGBA -- * Line stuff -- ** Cap style , LineCap(..) , getLineCap, lineCap, _lineCap -- ** Join style , LineJoin(..) , getLineJoin, lineJoin, _lineJoin -- ** Miter limit , LineMiterLimit(..), _LineMiterLimit , getLineMiterLimit, lineMiterLimit, lineMiterLimitA, _lineMiterLimit -- * Recommend optics , _Recommend , _Commit , _recommend , isCommitted , committed ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Lens hiding (none, over) import Data.Colour import Data.Colour.RGBSpace (RGB (..)) import Data.Colour.SRGB (toSRGB) import Data.Default.Class import Data.Distributive import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable import Diagrams.Core ------------------------------------------------------------------------ -- Standard measures ------------------------------------------------------------------------ none, ultraThin, veryThin, thin, medium, thick, veryThick, ultraThick, tiny, verySmall, small, normal, large, veryLarge, huge :: OrderedField n => Measure n none = output 0 ultraThin = normalized 0.0005 `atLeast` output 0.5 veryThin = normalized 0.001 `atLeast` output 0.5 thin = normalized 0.002 `atLeast` output 0.5 medium = normalized 0.004 `atLeast` output 0.5 thick = normalized 0.0075 `atLeast` output 0.5 veryThick = normalized 0.01 `atLeast` output 0.5 ultraThick = normalized 0.02 `atLeast` output 0.5 tiny = normalized 0.01 verySmall = normalized 0.015 small = normalized 0.023 normal = normalized 0.035 large = normalized 0.05 veryLarge = normalized 0.07 huge = normalized 0.10 ------------------------------------------------------------------------ -- Line width ------------------------------------------------------------------------ -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth n = LineWidth (Last n) deriving (Typeable, Semigroup) _LineWidth :: Iso' (LineWidth n) n _LineWidth = iso getLineWidth (LineWidth . Last) _LineWidthM :: Iso' (LineWidthM n) (Measure n) _LineWidthM = mapping _LineWidth instance Typeable n => AttributeClass (LineWidth n) type LineWidthM n = Measured n (LineWidth n) instance OrderedField n => Default (LineWidthM n) where def = fmap (LineWidth . Last) medium getLineWidth :: LineWidth n -> n getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. lineWidth :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a lineWidth = applyMAttr . fmap (LineWidth . Last) -- | Apply a 'LineWidth' attribute. lineWidthM :: (N a ~ n, HasStyle a, Typeable n) => LineWidthM n -> a -> a lineWidthM = applyMAttr -- | Default for 'lineWidth'. lw :: (N a ~ n, HasStyle a, Typeable n) => Measure n -> a -> a lw = lineWidth -- | A convenient synonym for 'lineWidth (global w)'. lwG :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a lwG = lw . global -- | A convenient synonym for 'lineWidth (normalized w)'. lwN :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a lwN = lw . normalized -- | A convenient synonym for 'lineWidth (output w)'. lwO :: (N a ~ n, HasStyle a, Typeable n) => n -> a -> a lwO = lw . output -- | A convenient sysnonym for 'lineWidth (local w)'. lwL :: (N a ~ n, HasStyle a, Typeable n, Num n) => n -> a -> a lwL = lw . local -- | Lens onto a measured line width in a style. _lineWidth, _lw :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) _lineWidth = atMAttr . anon def (const False) . _LineWidthM _lw = _lineWidth -- | Lens onto the unmeasured linewith attribute. This is useful for -- backends to use on styles once they have been unmeasured. Using on -- a diagram style could lead to unexpected results. _lineWidthU :: Typeable n => Lens' (Style v n) (Maybe n) _lineWidthU = atAttr . mapping _LineWidth ------------------------------------------------------------------------ -- Dashing ------------------------------------------------------------------------ -- | Create lines that are dashing... er, dashed. data Dashing n = Dashing [n] n deriving (Functor, Typeable, Eq) instance Semigroup (Dashing n) where _ <> b = b instance Typeable n => AttributeClass (Dashing n) getDashing :: Dashing n -> Dashing n getDashing = id -- | Set the line dashing style. dashing :: (N a ~ n, HasStyle a, Typeable n) => [Measure n] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. -> Measure n -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a dashing ds offs = applyMAttr . distribute $ Dashing ds offs -- | A convenient synonym for 'dashing (global w)'. dashingG :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a dashingG w v = dashing (map global w) (global v) -- | A convenient synonym for 'dashing (normalized w)'. dashingN :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a dashingN w v = dashing (map normalized w) (normalized v) -- | A convenient synonym for 'dashing (output w)'. dashingO :: (N a ~ n, HasStyle a, Typeable n) => [n] -> n -> a -> a dashingO w v = dashing (map output w) (output v) -- | A convenient sysnonym for 'dashing (local w)'. dashingL :: (N a ~ n, HasStyle a, Typeable n, Num n) => [n] -> n -> a -> a dashingL w v = dashing (map local w) (local v) -- | Lens onto a measured dashing attribute in a style. _dashing :: Typeable n => Lens' (Style v n) (Maybe (Measured n (Dashing n))) _dashing = atMAttr -- | Lens onto the unmeasured 'Dashing' attribute. This is useful for -- backends to use on styles once they have been unmeasured. Using on -- a diagram style could lead to unexpected results. _dashingU :: Typeable n => Lens' (Style v n) (Maybe (Dashing n)) _dashingU = atAttr ------------------------------------------------------------------------ -- Color ------------------------------------------------------------------------ -- $color -- Diagrams outsources all things color-related to Russell O\'Connor\'s -- very nice colour package -- (). For starters, it -- provides a large collection of standard color names. However, it -- also provides a rich set of combinators for combining and -- manipulating colors; see its documentation for more information. -- | The 'Color' type class encompasses color representations which -- can be used by the Diagrams library. Instances are provided for -- 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. 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 instance Show SomeColor where showsPrec d (colorToSRGBA -> (r,g,b,a)) = showParen (d > 10) $ showString "SomeColor " . if a == 0 then showString "transparent" else showString "(sRGB " . showsPrec 11 r . showChar ' ' . showsPrec 11 g . showChar ' ' . showsPrec 11 b . (if a /= 1 then showString " `withOpacity` " . showsPrec 11 a else id) . showChar ')' -- | Isomorphism between 'SomeColor' and 'AlphaColour' 'Double'. _SomeColor :: Iso' SomeColor (AlphaColour Double) _SomeColor = iso toAlphaColour fromAlphaColour someToAlpha :: SomeColor -> AlphaColour Double someToAlpha (SomeColor c) = toAlphaColour c instance a ~ Double => Color (Colour a) where toAlphaColour = opaque fromAlphaColour = (`over` black) instance a ~ Double => Color (AlphaColour a) where toAlphaColour = id fromAlphaColour = id instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c fromAlphaColour = SomeColor -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) colorToSRGBA col = (r, g, b, a) where c' = toAlphaColour col c = alphaToColour c' a = alphaChannel c' RGB r g b = toSRGB c colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} alphaToColour :: (Floating a, Ord a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black | otherwise = darken (recip (alphaChannel ac)) (ac `over` black) ------------------------------------------------------------------------ -- Opacity ------------------------------------------------------------------------ -- | Although the individual colors in a diagram can have -- transparency, the opacity/transparency of a diagram as a whole -- can be specified with the @Opacity@ attribute. The opacity is a -- value between 1 (completely opaque, the default) and 0 -- (completely transparent). Opacity is multiplicative, that is, -- @'opacity' o1 . 'opacity' o2 === 'opacity' (o1 * o2)@. In other -- words, for example, @opacity 0.8@ means \"decrease this diagram's -- opacity to 80% of its previous opacity\". newtype Opacity = Opacity (Product Double) deriving (Typeable, Semigroup) instance AttributeClass Opacity _Opacity :: Iso' Opacity Double _Opacity = iso getOpacity (Opacity . Product) getOpacity :: Opacity -> Double getOpacity (Opacity (Product d)) = d -- | Multiply the opacity (see 'Opacity') by the given value. For -- example, @opacity 0.8@ means \"decrease this diagram's opacity to -- 80% of its previous opacity\". opacity :: HasStyle a => Double -> a -> a opacity = applyAttr . Opacity . Product -- | Lens onto the opacity in a style. _opacity :: Lens' (Style v n) Double _opacity = atAttr . mapping _Opacity . non 1 ------------------------------------------------------------------------ -- Line stuff ------------------------------------------------------------------------ -- line cap ------------------------------------------------------------ -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. | LineCapRound -- ^ Lines are capped with semicircles -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints. deriving (Eq, Ord, Show, Typeable) instance Default LineCap where def = LineCapButt instance AttributeClass LineCap -- | Last semigroup structure. instance Semigroup LineCap where _ <> b = b getLineCap :: LineCap -> LineCap getLineCap = id -- | Set the line end cap attribute. lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr -- | Lens onto the line cap in a style. _lineCap :: Lens' (Style v n) LineCap _lineCap = atAttr . non def -- line join ----------------------------------------------------------- -- | How should the join points between line segments be drawn? data LineJoin = LineJoinMiter -- ^ Use a \"miter\" shape (whatever that is). | LineJoinRound -- ^ Use rounded join points. | LineJoinBevel -- ^ Use a \"bevel\" shape (whatever -- that is). Are these... -- carpentry terms? deriving (Eq, Ord, Show, Typeable) instance AttributeClass LineJoin -- | Last semigroup structure. instance Semigroup LineJoin where _ <> b = b instance Default LineJoin where def = LineJoinMiter getLineJoin :: LineJoin -> LineJoin getLineJoin = id -- | Set the segment join style. lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr -- | Lens onto the line join type in a style. _lineJoin :: Lens' (Style v n) LineJoin _lineJoin = atAttr . non def -- miter limit --------------------------------------------------------- -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) deriving (Typeable, Semigroup, Eq, Ord) instance AttributeClass LineMiterLimit _LineMiterLimit :: Iso' LineMiterLimit Double _LineMiterLimit = iso getLineMiterLimit (LineMiterLimit . Last) instance Default LineMiterLimit where def = LineMiterLimit (Last 10) getLineMiterLimit :: LineMiterLimit -> Double getLineMiterLimit (LineMiterLimit (Last l)) = l -- | Set the miter limit for joins with 'LineJoinMiter'. lineMiterLimit :: HasStyle a => Double -> a -> a lineMiterLimit = applyAttr . LineMiterLimit . Last -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr -- | Lens onto the line miter limit in a style. _lineMiterLimit :: Lens' (Style v n) Double _lineMiterLimit = atAttr . non def . _LineMiterLimit ------------------------------------------------------------------------ -- Recommend optics ------------------------------------------------------------------------ -- | Prism onto a 'Recommend'. _Recommend :: Prism' (Recommend a) a _Recommend = prism' Recommend $ \case (Recommend a) -> Just a; _ -> Nothing -- | Prism onto a 'Commit'. _Commit :: Prism' (Recommend a) a _Commit = prism' Commit $ \case (Commit a) -> Just a; _ -> Nothing -- | Lens onto the value inside either a 'Recommend' or 'Commit'. Unlike -- 'committed', this is a valid lens. _recommend :: Lens (Recommend a) (Recommend b) a b _recommend f (Recommend a) = Recommend <$> f a _recommend f (Commit a) = Commit <$> f a -- | Lens onto whether something is committed or not. isCommitted :: Lens' (Recommend a) Bool isCommitted f r@(Recommend a) = f False <&> \b -> if b then Commit a else r isCommitted f r@(Commit a) = f True <&> \b -> if b then r else Recommend a -- | 'Commit' a value for any 'Recommend'. This is *not* a valid 'Iso' -- because the resulting @Recommend b@ is always a 'Commit'. This is -- useful because it means any 'Recommend' styles set with a lens will -- not be accidentally overridden. If you want a valid lens onto a -- recommend value use '_recommend'. -- -- Other lenses that use this are labeled with a warning. committed :: Iso (Recommend a) (Recommend b) a b committed = iso getRecommend Commit diagrams-lib-1.3.1.4/src/Diagrams/Trail.hs0000644000000000000000000014435112754644012016341 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- We have an orphan Transformable FingerTree instance here. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trail -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines /trails/, translationally invariant paths -- through space. Trails form a central part of the diagrams-lib API, -- so the documentation for this module merits careful study. -- -- Related modules include: -- -- * The 'TrailLike' class ("Diagrams.TrailLike") exposes a generic -- API for building a wide range of things out of trails. -- -- * 'Path's ("Diagrams.Path") are collections of 'Located' -- ("Diagrams.Located") trails. -- -- * Trails are composed of 'Segment's (see "Diagrams.Segment"), -- though most users should not need to work with segments directly. -- ----------------------------------------------------------------------------- module Diagrams.Trail ( -- * Type definitions -- ** Lines and loops Trail'(..) , glueLine , closeLine , cutLoop -- ** Generic trails , Trail(..) , _Line, _Loop , wrapTrail, wrapLine, wrapLoop , onTrail, onLine , glueTrail, closeTrail, cutTrail -- * Constructing trails , emptyLine, emptyTrail , lineFromVertices, trailFromVertices , lineFromOffsets, trailFromOffsets , lineFromSegments, trailFromSegments , loopFromSegments -- * Eliminating trails , withTrail', withTrail, withLine , isLineEmpty, isTrailEmpty , isLine, isLoop , trailSegments, lineSegments, loopSegments , onLineSegments , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailPoints, linePoints, loopPoints , trailVertices', lineVertices', loopVertices' , trailVertices, lineVertices, loopVertices , trailLocSegments, fixTrail -- * Modifying trails , reverseTrail, reverseLocTrail , reverseLine, reverseLocLine , reverseLoop, reverseLocLoop -- * Internals -- $internals -- ** Type tags , Line, Loop -- ** Segment trees , SegTree(..), trailMeasure, numSegs, offset -- ** Extracting segments , GetSegment(..), getSegment ) where import Control.Arrow ((***)) import Control.Lens hiding (at, transform, (<|), (|>)) import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT import Data.Fixed import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup import qualified Numeric.Interval.Kaucher as I import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.Tangent import Linear.Affine import Linear.Metric import Linear.Vector -- $internals -- -- Most users of diagrams should not need to use anything in this -- section directly, but they are exported on the principle that we -- can't forsee what uses people might have for them. ------------------------------------------------------------ -- FingerTree instances ------------------------------------------------------------ type instance V (FingerTree m a) = V a type instance N (FingerTree m a) = N a instance (FT.Measured m a, Transformable a) => Transformable (FingerTree m a) where transform = FT.fmap' . transform instance (FT.Measured m a, FT.Measured n b) => Cons (FingerTree m a) (FingerTree n b) a b where _Cons = prism (uncurry (FT.<|)) $ \aas -> case FT.viewl aas of a FT.:< as -> Right (a, as) EmptyL -> Left mempty {-# INLINE _Cons #-} instance (FT.Measured m a, FT.Measured n b) => Snoc (FingerTree m a) (FingerTree n b) a b where _Snoc = prism (uncurry (FT.|>)) $ \aas -> case FT.viewr aas of as FT.:> a -> Right (as, a) EmptyR -> Left mempty {-# INLINE _Snoc #-} ------------------------------------------------------------ -- Segment trees ----------------------------------------- ------------------------------------------------------------ -- | A @SegTree@ represents a sequence of closed segments, stored in a -- fingertree so we can easily recover various monoidal measures of -- the segments (number of segments, arc length, envelope...) and -- also easily slice and dice them according to the measures -- (/e.g./, split off the smallest number of segments from the -- beginning which have a combined arc length of at least 5). newtype SegTree v n = SegTree (FingerTree (SegMeasure v n) (Segment Closed v n)) deriving (Eq, Ord, Show, Monoid, Transformable, FT.Measured (SegMeasure v n)) instance Wrapped (SegTree v n) where type Unwrapped (SegTree v n) = FingerTree (SegMeasure v n) (Segment Closed v n) _Wrapped' = iso (\(SegTree x) -> x) SegTree {-# INLINE _Wrapped' #-} instance (Metric v, OrderedField n, Metric u, OrderedField n') => Cons (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where _Cons = _Wrapped . _Cons . bimapping id _Unwrapped {-# INLINE _Cons #-} instance (Metric v, OrderedField n, Metric u, OrderedField n') => Snoc (SegTree v n) (SegTree u n') (Segment Closed v n) (Segment Closed u n') where _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id {-# INLINE _Snoc #-} instance Rewrapped (SegTree v n) (SegTree v' n') type instance V (SegTree v n) = v type instance N (SegTree v n) = n type instance Codomain (SegTree v n) = v instance (Metric v, OrderedField n, Real n) => Parametric (SegTree v n) where atParam t p = offset . fst $ splitAtParam t p instance Num n => DomainBounds (SegTree v n) instance (Metric v, OrderedField n, Real n) => EndValues (SegTree v n) type SplitResult v n = ((SegTree v n, n -> n), (SegTree v n, n -> n)) splitAtParam' :: (Metric v, OrderedField n, Real n) => SegTree v n -> n -> SplitResult v n splitAtParam' tree@(SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit seg FT.:< t' -> case seg `splitAtParam` (p * tSegs) of (seg1, seg2) -> ( (SegTree $ FT.singleton seg1, (*p)) , (SegTree $ seg2 <| t', \u -> 1 - (1 - u) * tSegs / (tSegs + 1)) ) | p >= 1 = case FT.viewr t of EmptyR -> emptySplit t' FT.:> seg -> case seg `splitAtParam` (1 - (1 - p)*tSegs) of (seg1, seg2) -> ( (SegTree $ t' |> seg1, \u -> u * tSegs / (tSegs + 1)) , (SegTree $ FT.singleton seg2, \u -> (u - p) / (1 - p)) ) | otherwise = case FT.viewl after of EmptyL -> emptySplit seg FT.:< after' -> let (n, p') = propFrac $ p * tSegs f p n u | u * tSegs < n = u * tSegs / (n + 1) | otherwise = (n + (u * tSegs - n) / (p * tSegs - n)) / (n+1) in case seg `splitAtParam` p' of (seg1, seg2) -> ( ( SegTree $ before |> seg1 , f p n ) , ( SegTree $ seg2 <| after' , \v -> 1 - f (1 - p) (tSegs - n - 1) (1 - v) ) ) where (before, after) = FT.split ((p * tSegs <) . numSegs) t tSegs = numSegs t emptySplit = let t' = (tree, id) in (t',t') propFrac x = let m = signum x * mod1 x in (x - m, m) instance (Metric v, OrderedField n, Real n) => Sectionable (SegTree v n) where splitAtParam tree p = let ((a,_),(b,_)) = splitAtParam' tree p in (a,b) reverseDomain (SegTree t) = SegTree $ FT.reverse t' where t' = FT.fmap' reverseSegment t section x t1 t2 = let ((a,fa),_) = splitAtParam' x t2 in snd $ splitAtParam a (fa t1) -- XXX seems like it should be possible to collapse some of the -- above cases into one? instance (Metric v, OrderedField n, Real n) => HasArcLength (SegTree v n) where arcLengthBounded eps t -- Use the cached value if it is accurate enough; otherwise fall -- back to recomputing a more accurate value | I.width i <= eps = i | otherwise = fun (eps / numSegs t) where i = trailMeasure (I.singleton 0) getArcLengthCached t fun = trailMeasure (const 0) getArcLengthFun t arcLengthToParam eps st@(SegTree t) l | l < 0 = case FT.viewl t of EmptyL -> 0 seg FT.:< _ -> arcLengthToParam eps seg l / tSegs | l >= totalAL = case FT.viewr t of EmptyR -> 0 t' FT.:> seg -> let p = arcLengthToParam (eps/2) seg (l - arcLength (eps/2) (SegTree t')) in (p - 1)/tSegs + 1 | otherwise = case FT.viewl after of EmptyL -> 0 seg FT.:< _ -> let p = arcLengthToParam (eps/2) seg (l - arcLength (eps/2) (SegTree before)) in (numSegs before + p) / tSegs where totalAL = arcLength eps st tSegs = numSegs t before, after :: FingerTree (SegMeasure v n) (Segment Closed v n) (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . getArcLengthBounded eps)) t -- | Given a default result (to be used in the case of an empty -- trail), and a function to map a single measure to a result, -- extract the given measure for a trail and use it to compute a -- result. Put another way, lift a function on a single measure -- (along with a default value) to a function on an entire trail. trailMeasure :: ( SegMeasure v n :>: m, FT.Measured (SegMeasure v n) t ) => a -> (m -> a) -> t -> a trailMeasure d f = option d f . get . FT.measure -- | Compute the number of segments of anything measured by -- 'SegMeasure' (/e.g./ @SegMeasure@ itself, @Segment@, @SegTree@, -- @Trail@s...) numSegs :: (Num c, FT.Measured (SegMeasure v n) a) => a -> c numSegs = fromIntegral . trailMeasure 0 (getSum . op SegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. offset :: ( OrderedField n, Metric v, FT.Measured (SegMeasure v n) t ) => t -> v n offset = trailMeasure zero (op TotalOffset . view oeOffset) ------------------------------------------------------------ -- Trails ------------------------------------------------ ------------------------------------------------------------ -- Eventually we should use DataKinds for this, but not until we drop -- support for GHC 7.4. -- | Type tag for trails with distinct endpoints. data Line -- | Type tag for \"loopy\" trails which return to their starting -- point. data Loop -------------------------------------------------- -- The Trail' type -- | Intuitively, a trail is a single, continuous path through space. -- However, a trail has no fixed starting point; it merely specifies -- /how/ to move through space, not /where/. For example, \"take -- three steps forward, then turn right twenty degrees and take two -- more steps\" is an intuitive analog of a trail; these -- instructions specify a path through space from any given starting -- location. To be precise, trails are /translation-invariant/; -- applying a translation to a trail has no effect. -- -- A @'Located' Trail@, on the other hand, is a trail paired with -- some concrete starting location (\"start at the big tree on the -- corner, then take three steps forward, ...\"). See the -- "Diagrams.Located" module for help working with 'Located' values. -- -- Formally, the semantics of a trail is a continuous (though not -- necessarily differentiable) function from the real interval [0,1] -- to vectors in some vector space. (In contrast, a 'Located' trail -- is a continuous function from [0,1] to /points/ in some /affine/ -- space.) -- -- There are two types of trails: -- -- * A \"line\" (think of the \"train\", \"subway\", or \"bus\" -- variety, rather than the \"straight\" variety...) is a trail -- with two distinct endpoints. Actually, a line can have the -- same start and end points, but it is still /drawn/ as if it had -- distinct endpoints: the two endpoints will have the appropriate -- end caps, and the trail will not be filled. Lines have a -- @Monoid@ instance where @mappend@ corresponds to concatenation, -- /i.e./ chaining one line after the other. -- -- * A \"loop\" is required to end in the same place it starts (that -- is, t(0) = t(1)). Loops are filled and are drawn as one -- continuous loop, with the appropriate join at the -- start/endpoint rather than end caps. Loops do not have a -- @Monoid@ instance. -- -- To convert between lines and loops, see 'glueLine', -- 'closeLine', and 'cutLoop'. -- -- To construct trails, see 'emptyTrail', 'trailFromSegments', -- 'trailFromVertices', 'trailFromOffsets', and friends. You can -- also get any type of trail from any function which returns a -- 'TrailLike' (/e.g./ functions in "Diagrams.TwoD.Shapes", and many -- others; see "Diagrams.TrailLike"). -- -- To extract information from trails, see 'withLine', 'isLoop', -- 'trailSegments', 'trailOffsets', 'trailVertices', and friends. data Trail' l v n where Line :: SegTree v n -> Trail' Line v n Loop :: SegTree v n -> Segment Open v n -> Trail' Loop v n -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. withTrail' :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail' l v n -> r withTrail' line _ t@(Line{}) = line t withTrail' _ loop t@(Loop{}) = loop t deriving instance Eq (v n) => Eq (Trail' l v n) deriving instance Ord (v n) => Ord (Trail' l v n) instance Show (v n) => Show (Trail' l v n) where showsPrec d (Line (SegTree ft)) = showParen (d > 10) $ showString "lineFromSegments " . showList (F.toList ft) showsPrec d (Loop (SegTree ft) o) = showParen (d > 10) $ showString "loopFromSegments " . showList (F.toList ft) . showChar ' ' . showsPrec 11 o type instance V (Trail' l v n) = v type instance N (Trail' l v n) = n type instance Codomain (Trail' l v n) = v instance (OrderedField n, Metric v) => Semigroup (Trail' Line v n) where (Line t1) <> (Line t2) = Line (t1 `mappend` t2) -- | The empty trail is constantly the zero vector. Trails are -- composed via concatenation. Note that only lines have a monoid -- instance (and not loops). instance (Metric v, OrderedField n) => Monoid (Trail' Line v n) where mempty = emptyLine mappend = (<>) instance (Metric v, OrderedField n) => AsEmpty (Trail' Line v n) where _Empty = nearly emptyLine isLineEmpty instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Trail' l v n) where transform tr (Line t ) = Line (transform tr t) transform tr (Loop t s) = Loop (transform tr t) (transform tr s) -- | The envelope for a trail is based at the trail's start. instance (Metric v, OrderedField n) => Enveloped (Trail' l v n) where getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where ftEnv :: Trail' Line v n -> Envelope v n ftEnv (Line t) = trailMeasure mempty (view oeEnvelope) t instance (HasLinearMap v, Metric v, OrderedField n) => Renderable (Trail' o v n) NullBackend where render _ _ = mempty instance (Metric v, OrderedField n, Real n) => Parametric (Trail' l v n) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) (\l -> cutLoop l `atParam` mod1 p) t instance (Parametric (GetSegment (Trail' c v n)), Additive v, Num n) => Parametric (Tangent (Trail' c v n)) where Tangent tr `atParam` p = case GetSegment tr `atParam` p of GetSegmentCodomain Nothing -> zero GetSegmentCodomain (Just (_, seg, reparam)) -> Tangent seg `atParam` (p ^. cloneIso reparam) instance ( Parametric (GetSegment (Trail' c v n)) , EndValues (GetSegment (Trail' c v n)) , Additive v , Num n ) => EndValues (Tangent (Trail' c v n)) where atStart (Tangent tr) = case atStart (GetSegment tr) of GetSegmentCodomain Nothing -> zero GetSegmentCodomain (Just (_, seg, _)) -> atStart (Tangent seg) atEnd (Tangent tr) = case atEnd (GetSegment tr) of GetSegmentCodomain Nothing -> zero GetSegmentCodomain (Just (_, seg, _)) -> atEnd (Tangent seg) instance (Metric v , OrderedField n, Real n) => Parametric (Tangent (Trail v n)) where Tangent tr `atParam` p = withTrail ((`atParam` p) . Tangent) ((`atParam` p) . Tangent) tr instance (Metric v, OrderedField n, Real n) => EndValues (Tangent (Trail v n)) where atStart (Tangent tr) = withTrail (atStart . Tangent) (atStart . Tangent) tr atEnd (Tangent tr) = withTrail (atEnd . Tangent) (atEnd . Tangent) tr -- | Compute the remainder mod 1. Convenient for constructing loop -- parameterizations that wrap around. mod1 :: Real a => a -> a mod1 = (`mod'` 1) instance Num n => DomainBounds (Trail' l v n) instance (Metric v, OrderedField n, Real n) => EndValues (Trail' l v n) instance (Metric v, OrderedField n, Real n) => Sectionable (Trail' Line v n) where splitAtParam (Line t) p = (Line t1, Line t2) where (t1, t2) = splitAtParam t p reverseDomain = reverseLine instance (Metric v, OrderedField n, Real n) => HasArcLength (Trail' l v n) where arcLengthBounded eps = withTrail' (\(Line t) -> arcLengthBounded eps t) (arcLengthBounded eps . cutLoop) arcLengthToParam eps tr l = withTrail' (\(Line t) -> arcLengthToParam eps t l) (\lp -> arcLengthToParam eps (cutLoop lp) l) tr instance Rewrapped (Trail' Line v n) (Trail' Line v' n') instance Wrapped (Trail' Line v n) where type Unwrapped (Trail' Line v n) = SegTree v n _Wrapped' = iso (\(Line x) -> x) Line {-# INLINE _Wrapped' #-} instance (Metric v, OrderedField n, Metric u, OrderedField n') => Cons (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where _Cons = _Wrapped . _Cons . bimapping id _Unwrapped {-# INLINE _Cons #-} instance (Metric v, OrderedField n, Metric u, OrderedField n') => Snoc (Trail' Line v n) (Trail' Line u n') (Segment Closed v n) (Segment Closed u n') where _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id {-# INLINE _Snoc #-} -------------------------------------------------- -- Extracting segments -- | A newtype wrapper around trails which exists solely for its -- 'Parametric', 'DomainBounds' and 'EndValues' instances. The idea -- is that if @tr@ is a trail, you can write, /e.g./ -- -- @ -- getSegment tr `atParam` 0.6 -- @ -- -- or -- -- @ -- atStart (getSegment tr) -- @ -- -- to get the segment at parameter 0.6 or the first segment in the -- trail, respectively. -- -- The codomain for 'GetSegment', /i.e./ the result you get from -- calling 'atParam', 'atStart', or 'atEnd', is @Maybe (v, Segment -- Closed v, AnIso' n n)@. @Nothing@ results if -- the trail is empty; otherwise, you get: -- -- * the offset from the start of the trail to the beginning of the -- segment, -- -- * the segment itself, and -- -- * a reparameterization isomorphism: in the forward direction, it -- translates from parameters on the whole trail to a parameters -- on the segment. Note that for technical reasons you have to -- call 'cloneIso' on the @AnIso'@ value to get a real isomorphism -- you can use. newtype GetSegment t = GetSegment t newtype GetSegmentCodomain v n = GetSegmentCodomain (Maybe ( v n -- offset from trail start to segment start , Segment Closed v n -- the segment , AnIso' n n -- reparameterization, trail <-> segment )) -- | Create a 'GetSegment' wrapper around a trail, after which you can -- call 'atParam', 'atStart', or 'atEnd' to extract a segment. getSegment :: t -> GetSegment t getSegment = GetSegment type instance V (GetSegment t) = V t type instance N (GetSegment t) = N t type instance Codomain (GetSegment t) = GetSegmentCodomain (V t) -- | Parameters less than 0 yield the first segment; parameters -- greater than 1 yield the last. A parameter exactly at the -- junction of two segments yields the second segment (/i.e./ the -- one with higher parameter values). instance (Metric v, OrderedField n) => Parametric (GetSegment (Trail' Line v n)) where atParam (GetSegment (Line (SegTree ft))) p | p <= 0 = case FT.viewl ft of EmptyL -> GetSegmentCodomain Nothing seg FT.:< _ -> GetSegmentCodomain $ Just (zero, seg, reparam 0) | p >= 1 = case FT.viewr ft of EmptyR -> GetSegmentCodomain Nothing ft' FT.:> seg -> GetSegmentCodomain $ Just (offset ft', seg, reparam (n-1)) | otherwise = let (before, after) = FT.split ((p*n <) . numSegs) ft in case FT.viewl after of EmptyL -> GetSegmentCodomain Nothing seg FT.:< _ -> GetSegmentCodomain $ Just (offset before, seg, reparam (numSegs before)) where n = numSegs ft reparam k = iso (subtract k . (*n)) ((/n) . (+ k)) -- | The parameterization for loops wraps around, /i.e./ parameters -- are first reduced \"mod 1\". instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail' Loop v n)) where atParam (GetSegment l) p = atParam (GetSegment (cutLoop l)) (mod1 p) instance (Metric v, OrderedField n, Real n) => Parametric (GetSegment (Trail v n)) where atParam (GetSegment t) p = withTrail ((`atParam` p) . GetSegment) ((`atParam` p) . GetSegment) t instance DomainBounds t => DomainBounds (GetSegment t) where domainLower (GetSegment t) = domainLower t domainUpper (GetSegment t) = domainUpper t instance (Metric v, OrderedField n) => EndValues (GetSegment (Trail' Line v n)) where atStart (GetSegment (Line (SegTree ft))) = case FT.viewl ft of EmptyL -> GetSegmentCodomain Nothing seg FT.:< _ -> let n = numSegs ft in GetSegmentCodomain $ Just (zero, seg, iso (*n) (/n)) atEnd (GetSegment (Line (SegTree ft))) = case FT.viewr ft of EmptyR -> GetSegmentCodomain Nothing ft' FT.:> seg -> let n = numSegs ft in GetSegmentCodomain $ Just (offset ft', seg, iso (subtract (n-1) . (*n)) ((/n) . (+ (n-1))) ) instance (Metric v, OrderedField n, Real n) => EndValues (GetSegment (Trail' Loop v n)) where atStart (GetSegment l) = atStart (GetSegment (cutLoop l)) atEnd (GetSegment l) = atEnd (GetSegment (cutLoop l)) instance (Metric v, OrderedField n, Real n) => EndValues (GetSegment (Trail v n)) where atStart (GetSegment t) = withTrail (atStart . GetSegment) (atStart . GetSegment) t atEnd (GetSegment t) = withTrail (atEnd . GetSegment) (atEnd . GetSegment) t -------------------------------------------------- -- The Trail type -- | @Trail@ is a wrapper around @Trail'@, hiding whether the -- underlying @Trail'@ is a line or loop (though which it is can be -- recovered; see /e.g./ 'withTrail'). data Trail v n where Trail :: Trail' l v n -> Trail v n deriving instance Show (v n) => Show (Trail v n) instance Eq (v n) => Eq (Trail v n) where t1 == t2 = withTrail (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) t1 instance Ord (v n) => Ord (Trail v n) where compare t1 t2 = withTrail (\ln1 -> withTrail (compare ln1) (const LT) t2) (\lp1 -> withTrail (const GT) (compare lp1) t2) t1 -- | Two @Trail@s are combined by first ensuring they are both lines -- (using 'cutTrail' on loops) and then concatenating them. The -- result, in general, is a line. However, there is a special case -- for the empty line, which acts as the identity (so combining the -- empty line with a loop results in a loop). instance (OrderedField n, Metric v) => Semigroup (Trail v n) where (Trail (Line (SegTree ft))) <> t2 | FT.null ft = t2 t1 <> (Trail (Line (SegTree ft))) | FT.null ft = t1 t1 <> t2 = flip withLine t1 $ \l1 -> flip withLine t2 $ \l2 -> wrapLine (l1 <> l2) -- | @Trail@s are combined as described in the 'Semigroup' instance; -- the empty line is the identity element, with special cases so -- that combining the empty line with a loop results in the -- unchanged loop (in all other cases loops will be cut). Note that -- this does, in fact, satisfy the monoid laws, though it is a bit -- strange. Mostly it is provided for convenience, so one can work -- directly with @Trail@s instead of working with @Trail' Line@s and -- then wrapping. instance (Metric v, OrderedField n) => Monoid (Trail v n) where mempty = wrapLine emptyLine mappend = (<>) instance (Metric v, OrderedField n) => AsEmpty (Trail v n) where _Empty = nearly emptyTrail isTrailEmpty type instance V (Trail v n) = v type instance N (Trail v n) = n type instance Codomain (Trail v n) = v instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Trail v n) where transform t = onTrail (transform t) (transform t) instance (Metric v, OrderedField n) => Enveloped (Trail v n) where getEnvelope = withTrail getEnvelope getEnvelope instance (Metric v, OrderedField n, Real n) => Parametric (Trail v n) where atParam t p = withTrail (`atParam` p) (`atParam` p) t instance Num n => DomainBounds (Trail v n) instance (Metric v, OrderedField n, Real n) => EndValues (Trail v n) -- | Note that there is no @Sectionable@ instance for @Trail' Loop@, -- because it does not make sense (splitting a loop at a parameter -- results in a single line, not two loops). However, it's -- convenient to have a @Sectionable@ instance for @Trail@; if the -- @Trail@ contains a loop the loop will first be cut and then -- @splitAtParam@ called on the resulting line. This is -- semantically a bit silly, so please don't rely on it. (*E.g.* if -- this is really the behavior you want, consider first calling -- 'cutLoop' yourself.) instance (Metric v, OrderedField n, Real n) => Sectionable (Trail v n) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t reverseDomain = reverseTrail instance (Metric v, OrderedField n, Real n) => HasArcLength (Trail v n) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr -- lens instrances ----------------------------------------------------- -- | Prism onto a 'Line'. _Line :: Prism' (Trail v n) (Trail' Line v n) _Line = _Wrapped' . _Left -- | Prism onto a 'Loop'. _Loop :: Prism' (Trail v n) (Trail' Loop v n) _Loop = _Wrapped' . _Right instance Rewrapped (Trail v n) (Trail v' n') instance Wrapped (Trail v n) where type Unwrapped (Trail v n) = Either (Trail' Line v n) (Trail' Loop v n) _Wrapped' = iso getTrail (either Trail Trail) where getTrail :: Trail v n -> Either (Trail' Line v n) (Trail' Loop v n) getTrail (Trail t@(Line {})) = Left t getTrail (Trail t@(Loop {})) = Right t -------------------------------------------------- -- Constructors and eliminators for Trail -- | A generic eliminator for 'Trail', taking functions specifying -- what to do in the case of a line or a loop. withTrail :: (Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r withTrail line loop (Trail t) = withTrail' line loop t -- | Modify a @Trail@, specifying two separate transformations for the -- cases of a line or a loop. onTrail :: (Trail' Line v n -> Trail' l1 v n) -> (Trail' Loop v n -> Trail' l2 v n) -> Trail v n -> Trail v n onTrail o c = withTrail (wrapTrail . o) (wrapTrail . c) -- | An eliminator for @Trail@ based on eliminating lines: if the -- trail is a line, the given function is applied; if it is a loop, it -- is first converted to a line with 'cutLoop'. That is, -- -- @ -- withLine f === 'withTrail' f (f . 'cutLoop') -- @ withLine :: (Metric v, OrderedField n) => (Trail' Line v n -> r) -> Trail v n -> r withLine f = withTrail f (f . cutLoop) -- | Modify a @Trail@ by specifying a transformation on lines. If the -- trail is a line, the transformation will be applied directly. If -- it is a loop, it will first be cut using 'cutLoop', the -- transformation applied, and then glued back into a loop with -- 'glueLine'. That is, -- -- @ -- onLine f === onTrail f (glueLine . f . cutLoop) -- @ -- -- Note that there is no corresponding @onLoop@ function, because -- there is no nice way in general to convert a line into a loop, -- operate on it, and then convert back. onLine :: (Metric v, OrderedField n) => (Trail' Line v n -> Trail' Line v n) -> Trail v n -> Trail v n onLine f = onTrail f (glueLine . f . cutLoop) -- | Convert a 'Trail'' into a 'Trail', hiding the type-level -- distinction between lines and loops. wrapTrail :: Trail' l v n -> Trail v n wrapTrail = Trail -- | Convert a line into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. wrapLine :: Trail' Line v n -> Trail v n wrapLine = wrapTrail -- | Convert a loop into a 'Trail'. This is the same as 'wrapTrail', -- but with a more specific type, which can occasionally be -- convenient for fixing the type of a polymorphic expression. wrapLoop :: Trail' Loop v n -> Trail v n wrapLoop = wrapTrail ------------------------------------------------------------ -- Constructing trails ----------------------------------- ------------------------------------------------------------ -- | The empty line, which is the identity for concatenation of lines. emptyLine :: (Metric v, OrderedField n) => Trail' Line v n emptyLine = Line mempty -- | A wrapped variant of 'emptyLine'. emptyTrail :: (Metric v, OrderedField n) => Trail v n emptyTrail = wrapLine emptyLine -- | Construct a line from a list of closed segments. lineFromSegments :: (Metric v, OrderedField n) => [Segment Closed v n] -> Trail' Line v n lineFromSegments = Line . SegTree . FT.fromList -- | Construct a loop from a list of closed segments and an open segment -- that completes the loop. loopFromSegments :: (Metric v, OrderedField n) => [Segment Closed v n] -> Segment Open v n -> Trail' Loop v n loopFromSegments segs = Loop (SegTree (FT.fromList segs)) -- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for -- conveniently constructing a @Trail@ instead of a @Trail'@. trailFromSegments :: (Metric v, OrderedField n) => [Segment Closed v n] -> Trail v n trailFromSegments = wrapTrail . lineFromSegments -- | Construct a line containing only linear segments from a list of -- vectors, where each vector represents the offset from one vertex -- to the next. See also 'fromOffsets'. -- -- <> -- -- > import Diagrams.Coordinates -- > lineFromOffsetsEx = strokeLine $ lineFromOffsets [ 2 ^& 1, 2 ^& (-1), 2 ^& 0.5 ] lineFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail' Line v n lineFromOffsets = lineFromSegments . map straight -- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. trailFromOffsets :: (Metric v, OrderedField n) => [v n] -> Trail v n trailFromOffsets = wrapTrail . lineFromOffsets -- | Construct a line containing only linear segments from a list of -- vertices. Note that only the relative offsets between the -- vertices matters; the information about their absolute position -- will be discarded. That is, for all vectors @v@, -- -- @ -- lineFromVertices === lineFromVertices . 'translate' v -- @ -- -- If you want to retain the position information, you should -- instead use the more general 'fromVertices' function to -- construct, say, a @'Located' ('Trail'' 'Line' v)@ or a @'Located' -- ('Trail' v)@. -- -- <> -- -- > import Diagrams.Coordinates -- > lineFromVerticesEx = pad 1.1 . centerXY . strokeLine -- > $ lineFromVertices [origin, 0 ^& 1, 1 ^& 2, 5 ^& 1] lineFromVertices :: (Metric v, OrderedField n) => [Point v n] -> Trail' Line v n lineFromVertices [] = emptyLine lineFromVertices [_] = emptyLine lineFromVertices ps = lineFromSegments . map straight $ zipWith (.-.) (tail ps) ps -- | @trailFromVertices === 'wrapTrail' . 'lineFromVertices'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. trailFromVertices :: (Metric v, OrderedField n) => [Point v n] -> Trail v n trailFromVertices = wrapTrail . lineFromVertices ------------------------------------------------------------ -- Converting between lines and loops -------------------- ------------------------------------------------------------ -- | Make a line into a loop by \"gluing\" the endpoint to the -- starting point. In particular, the offset of the final segment -- is modified so that it ends at the starting point of the entire -- trail. Typically, you would first construct a line which you -- know happens to end where it starts, and then call 'glueLine' to -- turn it into a loop. -- -- <> -- -- > glueLineEx = pad 1.1 . hsep 1 -- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] -- > -- > almostClosed :: Trail' Line V2 Double -- > almostClosed = fromOffsets $ map r2 [(2, -1), (-3, -0.5), (-2, 1), (1, 0.5)] -- -- @glueLine@ is left inverse to 'cutLoop', that is, -- -- @ -- glueLine . cutLoop === id -- @ glueLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Loop v n glueLine (Line (SegTree t)) = case FT.viewr t of FT.EmptyR -> Loop mempty (Linear OffsetOpen) t' FT.:> Linear _ -> Loop (SegTree t') (Linear OffsetOpen) t' FT.:> Cubic c1 c2 _ -> Loop (SegTree t') (Cubic c1 c2 OffsetOpen) -- | @glueTrail@ is a variant of 'glueLine' which works on 'Trail's. -- It performs 'glueLine' on lines and is the identity on loops. glueTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n glueTrail = onTrail glueLine id -- | Make a line into a loop by adding a new linear segment from the -- line's end to its start. -- -- @closeLine@ does not have any particularly nice theoretical -- properties, but can be useful /e.g./ when you want to make a -- closed polygon out of a list of points where the initial point is -- not repeated at the end. To use 'glueLine', one would first have -- to duplicate the initial vertex, like -- -- @ -- 'glueLine' . 'lineFromVertices' $ ps ++ [head ps] -- @ -- -- Using @closeLine@, however, one can simply -- -- @ -- closeLine . lineFromVertices $ ps -- @ -- -- <> -- -- > closeLineEx = pad 1.1 . centerXY . hcat' (with & sep .~ 1) -- > $ [almostClosed # strokeLine, almostClosed # closeLine # strokeLoop] closeLine :: Trail' Line v n -> Trail' Loop v n closeLine (Line t) = Loop t (Linear OffsetOpen) -- | @closeTrail@ is a variant of 'closeLine' for 'Trail', which -- performs 'closeLine' on lines and is the identity on loops. closeTrail :: Trail v n -> Trail v n closeTrail = onTrail closeLine id -- | Turn a loop into a line by \"cutting\" it at the common start/end -- point, resulting in a line which just happens to start and end at -- the same place. -- -- @cutLoop@ is right inverse to 'glueLine', that is, -- -- @ -- glueLine . cutLoop === id -- @ cutLoop :: forall v n. (Metric v, OrderedField n) => Trail' Loop v n -> Trail' Line v n cutLoop (Loop (SegTree t) c) = case (FT.null t, c) of (True, Linear OffsetOpen) -> emptyLine (_ , Linear OffsetOpen) -> Line (SegTree (t |> Linear off)) (_ , Cubic c1 c2 OffsetOpen) -> Line (SegTree (t |> Cubic c1 c2 off)) where offV :: v n offV = negated . trailMeasure zero (op TotalOffset .view oeOffset) $ t off = OffsetClosed offV -- | @cutTrail@ is a variant of 'cutLoop' for 'Trail'; it is the is -- the identity on lines and performs 'cutLoop' on loops. cutTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n cutTrail = onTrail id cutLoop ------------------------------------------------------------ -- Eliminating trails ------------------------------------ ------------------------------------------------------------ -- | Test whether a line is empty. isLineEmpty :: (Metric v, OrderedField n) => Trail' Line v n -> Bool isLineEmpty (Line (SegTree t)) = FT.null t -- | Test whether a trail is empty. Note that loops are never empty. isTrailEmpty :: (Metric v, OrderedField n) => Trail v n -> Bool isTrailEmpty = withTrail isLineEmpty (const False) -- | Determine whether a trail is a line. isLine :: Trail v n -> Bool isLine = not . isLoop -- | Determine whether a trail is a loop. isLoop :: Trail v n -> Bool isLoop = withTrail (const False) (const True) -- | Extract the segments comprising a line. lineSegments :: Trail' Line v n -> [Segment Closed v n] lineSegments (Line (SegTree t)) = F.toList t -- | Modify a line by applying a function to its list of segments. onLineSegments :: (Metric v, OrderedField n) => ([Segment Closed v n] -> [Segment Closed v n]) -> Trail' Line v n -> Trail' Line v n onLineSegments f = lineFromSegments . f . lineSegments -- | Extract the segments comprising a loop: a list of closed -- segments, and one final open segment. loopSegments :: Trail' Loop v n -> ([Segment Closed v n], Segment Open v n) loopSegments (Loop (SegTree t) c) = (F.toList t, c) -- | Extract the segments of a trail. If the trail is a loop it will -- first have 'cutLoop' applied. trailSegments :: (Metric v, OrderedField n) => Trail v n -> [Segment Closed v n] trailSegments = withLine lineSegments -- | Extract the offsets of the segments of a trail. trailOffsets :: (Metric v, OrderedField n) => Trail v n -> [v n] trailOffsets = withLine lineOffsets -- | Compute the offset from the start of a trail to the end. Satisfies -- -- @ -- trailOffset === sumV . trailOffsets -- @ -- -- but is more efficient. -- -- <> -- -- > trailOffsetEx = (strokeLine almostClosed <> showOffset) # centerXY # pad 1.1 -- > where showOffset = fromOffsets [trailOffset (wrapLine almostClosed)] -- > # strokeP # lc red trailOffset :: (Metric v, OrderedField n) => Trail v n -> v n trailOffset = withLine lineOffset -- | Extract the offsets of the segments of a line. lineOffsets :: Trail' Line v n -> [v n] lineOffsets = map segOffset . lineSegments -- | Extract the offsets of the segments of a loop. loopOffsets :: (Metric v, OrderedField n) => Trail' Loop v n -> [v n] loopOffsets = lineOffsets . cutLoop -- | Compute the offset from the start of a line to the end. (Note, -- there is no corresponding @loopOffset@ function because by -- definition it would be constantly zero.) lineOffset :: (Metric v, OrderedField n) => Trail' Line v n -> v n lineOffset (Line t) = trailMeasure zero (op TotalOffset . view oeOffset) t -- | Extract the points of a concretely located trail, /i.e./ the points -- where one segment ends and the next begins. Note that for loops, -- the starting point will /not/ be repeated at the end. If you -- want this behavior, you can use 'cutTrail' to make the loop into -- a line first, which happens to repeat the same point at the start -- and end, /e.g./ with @trailPoints . mapLoc cutTrail@. -- -- Note that it does not make sense to ask for the points of a -- 'Trail' by itself; if you want the points of a trail -- with the first point at, say, the origin, you can use -- @trailPoints . (\`at\` origin)@. -- -- This function allows you "observe" the fact that trails are -- implemented as lists of segments, which may be problematic if we -- want to think of trails as parametric vector functions. This also -- means that the behavior of this function may not be stable under -- future changes to the implementation of trails. For an -- unproblematic version which only yields vertices at which there -- is a sharp corner, excluding points where the trail is -- differentiable, see 'trailVertices'. -- -- This function is not re-exported from "Diagrams.Prelude"; to use -- it, import "Diagrams.Trail". trailPoints :: (Metric v, OrderedField n) => Located (Trail v n) -> [Point v n] trailPoints (viewLoc -> (p,t)) = withTrail (linePoints . (`at` p)) (loopPoints . (`at` p)) t -- | Extract the segment join points of a concretely located line. See -- 'trailPoints' for more information. -- -- This function allows you "observe" the fact that lines are -- implemented as lists of segments, which may be problematic if we -- want to think of lines as parametric vector functions. This also -- means that the behavior of this function may not be stable under -- future changes to the implementation of trails. For an -- unproblematic version which only yields vertices at which there -- is a sharp corner, excluding points where the trail is -- differentiable, see 'lineVertices'. -- -- This function is not re-exported from "Diagrams.Prelude"; to use -- it, import "Diagrams.Trail". linePoints :: (Metric v, OrderedField n) => Located (Trail' Line v n) -> [Point v n] linePoints (viewLoc -> (p,t)) = segmentPoints p . lineSegments $ t -- | Extract the segment join points of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailPoints' for -- more information. -- -- This function allows you "observe" the fact that lines are -- implemented as lists of segments, which may be problematic if we -- want to think of lines as parametric vector functions. This also -- means that the behavior of this function may not be stable under -- future changes to the implementation of trails. For an -- unproblematic version which only yields vertices at which there -- is a sharp corner, excluding points where the trail is -- differentiable, see 'lineVertices'. -- -- This function is not re-exported from "Diagrams.Prelude"; to use -- it, import "Diagrams.Trail". loopPoints :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> [Point v n] loopPoints (viewLoc -> (p,t)) = segmentPoints p . fst . loopSegments $ t segmentPoints :: (Additive v, Num n) => Point v n -> [Segment Closed v n] -> [Point v n] segmentPoints p = scanl (.+^) p . map segOffset tolerance :: OrderedField a => a tolerance = 10e-16 -- | Extract the vertices of a concretely located trail. Here a /vertex/ -- is defined as a non-differentiable point on the trail, /i.e./ a -- sharp corner. (Vertices are thus a subset of the places where -- segments join; if you want all joins between segments, see -- 'trailPoints'.) The tolerance determines how close the tangents -- of two segments must be at their endpoints to consider the -- transition point to be differentiable. -- -- Note that for loops, the starting vertex will /not/ be repeated -- at the end. If you want this behavior, you can use 'cutTrail' to -- make the loop into a line first, which happens to repeat the same -- vertex at the start and end, /e.g./ with @trailVertices . mapLoc -- cutTrail@. -- -- It does not make sense to ask for the vertices of a 'Trail' by -- itself; if you want the vertices of a trail with the first vertex -- at, say, the origin, you can use @trailVertices . (\`at\` -- origin)@. trailVertices' :: (Metric v, OrderedField n) => n -> Located (Trail v n) -> [Point v n] trailVertices' toler (viewLoc -> (p,t)) = withTrail (lineVertices' toler . (`at` p)) (loopVertices' toler . (`at` p)) t -- | Like 'trailVertices'', with a default tolerance. trailVertices :: (Metric v, OrderedField n) => Located (Trail v n) -> [Point v n] trailVertices = trailVertices' tolerance -- | Extract the vertices of a concretely located line. See -- 'trailVertices' for more information. lineVertices' :: (Metric v, OrderedField n) => n -> Located (Trail' Line v n) -> [Point v n] lineVertices' toler (viewLoc -> (p,t)) = segmentVertices' toler p . lineSegments $ t -- | Like 'lineVertices'', with a default tolerance. lineVertices :: (Metric v, OrderedField n) => Located (Trail' Line v n) -> [Point v n] lineVertices = lineVertices' tolerance -- | Extract the vertices of a concretely located loop. Note that the -- initial vertex is not repeated at the end. See 'trailVertices' for -- more information. loopVertices' :: (Metric v, OrderedField n) => n -> Located (Trail' Loop v n) -> [Point v n] loopVertices' toler (viewLoc -> (p,t)) | length segs > 1 = if far > toler then init ps else init . drop 1 $ ps | otherwise = ps where far = quadrance ((signorm . tangentAtStart . head $ segs) ^-^ (signorm . tangentAtEnd . last $ segs)) segs = lineSegments . cutLoop $ t ps = segmentVertices' toler p segs -- | Same as 'loopVertices'', with a default tolerance. loopVertices :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> [Point v n] loopVertices = loopVertices' tolerance -- | The vertices of a list of segments laid end to end. -- The start and end points are always included in the list of -- vertices. The other points connecting segments are included if -- the slope at the end of a segment is not equal to the slope at -- the beginning of the next. The 'toler' parameter is used to -- control how close the slopes need to be in order to declare them -- equal. segmentVertices' :: (Metric v, OrderedField n) => n -> Point v n -> [Segment Closed v n] -> [Point v n] segmentVertices' toler p ts = case ps of (x:_:_) -> x : select (drop 1 ps) ds ++ [last ps] _ -> ps where ds = zipWith far tans (drop 1 tans) tans = [(signorm . tangentAtStart $ s ,signorm . tangentAtEnd $ s) | s <- ts] ps = scanl (.+^) p . map segOffset $ ts far p2 q2 = quadrance (snd p2 ^-^ fst q2) > toler select :: [a] -> [Bool] -> [a] select xs bs = map fst $ filter snd (zip xs bs) -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (Metric v, OrderedField n) => Located (Trail v n) -> [FixedSegment v n] fixTrail t = map mkFixedSeg (trailLocSegments t) -- | Convert a concretely located trail into a list of located segments. trailLocSegments :: (Metric v, OrderedField n) => Located (Trail v n) -> [Located (Segment Closed v n)] trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints t) ------------------------------------------------------------ -- Modifying trails -------------------------------------- ------------------------------------------------------------ -- | Reverse a trail. Semantically, if a trail given by a function t -- from [0,1] to vectors, then the reverse of t is given by t'(s) = -- t(1-s). @reverseTrail@ is an involution, that is, -- -- @ -- reverseTrail . reverseTrail === id -- @ reverseTrail :: (Metric v, OrderedField n) => Trail v n -> Trail v n reverseTrail = onTrail reverseLine reverseLoop -- | Reverse a concretely located trail. The endpoint of the original -- trail becomes the starting point of the reversed trail, so the -- original and reversed trails comprise exactly the same set of -- points. @reverseLocTrail@ is an involution, /i.e./ -- -- @ -- reverseLocTrail . reverseLocTrail === id -- @ reverseLocTrail :: (Metric v, OrderedField n) => Located (Trail v n) -> Located (Trail v n) reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) -- | Reverse a line. See 'reverseTrail'. reverseLine :: (Metric v, OrderedField n) => Trail' Line v n -> Trail' Line v n reverseLine = onLineSegments (reverse . map reverseSegment) -- | Reverse a concretely located line. See 'reverseLocTrail'. reverseLocLine :: (Metric v, OrderedField n) => Located (Trail' Line v n) -> Located (Trail' Line v n) reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) -- | Reverse a loop. See 'reverseTrail'. reverseLoop :: (Metric v, OrderedField n) => Trail' Loop v n -> Trail' Loop v n reverseLoop = glueLine . reverseLine . cutLoop -- | Reverse a concretely located loop. See 'reverseLocTrail'. Note -- that this is guaranteed to preserve the location. reverseLocLoop :: (Metric v, OrderedField n) => Located (Trail' Loop v n) -> Located (Trail' Loop v n) reverseLocLoop = mapLoc reverseLoop -- | Same as 'reverseLine' or 'reverseLoop'. instance (Metric v, OrderedField n) => Reversing (Trail' l v n) where reversing t@(Line _) = onLineSegments (reverse . map reversing) t reversing t@(Loop _ _) = glueLine . reversing . cutLoop $ t -- | Same as 'reverseTrail'. instance (Metric v, OrderedField n) => Reversing (Trail v n) where reversing (Trail t) = Trail (reversing t) -- | Same as 'reverseLocLine' or 'reverseLocLoop'. instance (Metric v, OrderedField n) => Reversing (Located (Trail' l v n)) where reversing l@(Loc _ Line {}) = reverseLocLine l reversing l@(Loc _ Loop {}) = reverseLocLoop l -- | Same as 'reverseLocTrail'. instance (Metric v, OrderedField n) => Reversing (Located (Trail v n)) where reversing = reverseLocTrail diagrams-lib-1.3.1.4/src/Diagrams/Names.hs0000644000000000000000000000336312754644012016326 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Names -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Names can be given to subdiagrams, and subdiagrams can later be -- queried by name. This module exports types for representing names -- and subdiagrams, and various functions for working with them. -- ----------------------------------------------------------------------------- module Diagrams.Names ( -- * Names AName, Name, IsName(..), (.>) , Qualifiable(..) -- * Subdiagrams , Subdiagram, mkSubdiagram, subPoint, getSub, rawSub, location -- * Subdiagram maps , SubMap, fromNames, rememberAs, lookupSub -- * Naming things , named, nameSub, namePoint, localize -- * Querying by name , names , lookupName , withName, withNameAll, withNames ) where import Data.Semigroup import Diagrams.Core (OrderedField, Point) import Diagrams.Core.Names import Diagrams.Core.Types import Linear.Metric -- | Attach an atomic name to a diagram. named :: (IsName nm, Metric v, OrderedField n, Semigroup m) => nm -> QDiagram b v n m -> QDiagram b v n m named = nameSub mkSubdiagram -- | Attach an atomic name to a certain point (which may be computed -- from the given diagram), treated as a subdiagram with no content -- and a point envelope. namePoint :: (IsName nm , Metric v, OrderedField n, Semigroup m) => (QDiagram b v n m -> Point v n) -> nm -> QDiagram b v n m -> QDiagram b v n m namePoint p = nameSub (subPoint . p) diagrams-lib-1.3.1.4/src/Diagrams/Path.hs0000644000000000000000000002667112754644012016166 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Path -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines /paths/, which are collections of concretely -- located 'Trail's. Many drawing systems (cairo, svg, ...) have a -- similar notion of \"path\". Note that paths with multiple trails -- are necessary for being able to draw /e.g./ filled objects with -- holes in them. -- ----------------------------------------------------------------------------- module Diagrams.Path ( -- * Paths Path(..), pathTrails -- * Constructing paths -- $construct , ToPath (..) , pathFromTrail , pathFromTrailAt , pathFromLocTrail -- * Eliminating paths , pathPoints , pathVertices' , pathVertices , pathOffsets , pathCentroid , pathLocSegments, fixPath -- * Modifying paths , scalePath , reversePath -- * Miscellaneous , explodePath , partitionPath ) where import Control.Arrow ((***)) import Control.Lens hiding ((#), transform, at) import qualified Data.Foldable as F import Data.List (partition) import Data.Semigroup import Data.Typeable import Diagrams.Align import Diagrams.Core import Diagrams.Located import Diagrams.Points import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- Paths ------------------------------------------------- ------------------------------------------------------------ -- | A /path/ is a (possibly empty) list of 'Located' 'Trail's. -- 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 n = Path [Located (Trail v n)] deriving (Semigroup, Monoid #if __GLASGOW_HASKELL__ >= 707 , Typeable #endif ) #if __GLASGOW_HASKELL__ < 707 -- This should really be Typeable2 Path but since Path has kind -- (* -> *) -> * -> * -- not -- * -> * -> * -- we can only do Typeable1 (Path v). This is why the instance cannot be -- derived. instance forall v. Typeable1 v => Typeable1 (Path v) where typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.Path" "Path") [] `mkAppTy` typeOf1 (undefined :: v n) #endif instance Wrapped (Path v n) where type Unwrapped (Path v n) = [Located (Trail v n)] _Wrapped' = iso (\(Path x) -> x) Path instance Rewrapped (Path v n) (Path v' n') instance Each (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where each = _Wrapped . traverse instance AsEmpty (Path v n) where _Empty = _Wrapped' . _Empty instance Cons (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where _Cons = _Wrapped . _Cons . bimapping id _Unwrapped {-# INLINE _Cons #-} instance Snoc (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id {-# INLINE _Snoc #-} -- | Extract the located trails making up a 'Path'. pathTrails :: Path v n -> [Located (Trail v n)] pathTrails = op Path deriving instance Show (v n) => Show (Path v n) deriving instance Eq (v n) => Eq (Path v n) deriving instance Ord (v n) => Ord (Path v n) type instance V (Path v n) = v type instance N (Path v n) = n instance (Additive v, Num n) => HasOrigin (Path v n) where moveOriginTo = over _Wrapped' . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. instance (Metric v, OrderedField n) => TrailLike (Path v n) where trailLike = Path . (:[]) -- See Note [Transforming paths] instance (HasLinearMap v, Metric v, OrderedField n) => Transformable (Path v n) where transform = over _Wrapped . map . transform instance (Metric v, OrderedField n) => Enveloped (Path v n) where getEnvelope = F.foldMap trailEnvelope . op Path -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 where trailEnvelope :: Located (Trail v n) -> Envelope v n trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) instance (Metric v, OrderedField n) => Juxtaposable (Path v n) where juxtapose = juxtaposeDefault instance (Metric v, OrderedField n) => Alignable (Path v n) where defaultBoundary = envelopeBoundary instance (HasLinearMap v, Metric v, OrderedField n) => Renderable (Path v n) NullBackend where render _ _ = mempty ------------------------------------------------------------ -- Constructing paths ------------------------------------ ------------------------------------------------------------ -- | Type class for things that can be converted to a 'Path'. -- -- Note that this class is very different from 'TrailLike'. 'TrailLike' is -- usually the result of a library function to give you a convenient, -- polymorphic result ('Path', 'Diagram' etc.). -- class ToPath t where -- | 'toPath' takes something that can be converted to 'Path' and returns -- the 'Path'. toPath :: (Metric (V t), OrderedField (N t)) => t -> Path (V t) (N t) instance ToPath (Path v n) where toPath = id instance ToPath (Trail v n) where toPath = pathFromTrail instance ToPath (Located (Trail v n)) where toPath = pathFromLocTrail instance ToPath (Located (Trail' l v n)) where toPath = pathFromLocTrail . mapLoc Trail instance ToPath (Located (Segment Closed v n)) where toPath (viewLoc -> (p,seg)) = Path [trailFromSegments [seg] `at` p] instance ToPath (Located [Segment Closed v n]) where toPath (viewLoc -> (p,segs)) = Path [trailFromSegments segs `at` p] instance ToPath (FixedSegment v n) where toPath = toPath . fromFixedSeg instance ToPath a => ToPath [a] where toPath = F.foldMap toPath -- $construct -- Since paths are 'TrailLike', any function producing a 'TrailLike' -- can be used to construct a (singleton) path. The functions in this -- section are provided for convenience. -- | Convert a trail to a path beginning at the origin. pathFromTrail :: (Metric v, OrderedField n) => Trail v n -> Path v n pathFromTrail = trailLike . (`at` origin) -- | Convert a trail to a path with a particular starting point. pathFromTrailAt :: (Metric v, OrderedField n) => Trail v n -> Point v n -> Path v n pathFromTrailAt t p = trailLike (t `at` p) -- | Convert a located trail to a singleton path. This is equivalent -- to 'trailLike', but provided with a more specific name and type -- for convenience. pathFromLocTrail :: (Metric v, OrderedField n) => Located (Trail v n) -> Path v n pathFromLocTrail = trailLike ------------------------------------------------------------ -- Eliminating paths ------------------------------------- ------------------------------------------------------------ -- | Extract the vertices of a path, resulting in a separate list of -- vertices for each component trail. Here a /vertex/ is defined as -- a non-differentiable point on the trail, /i.e./ a sharp corner. -- (Vertices are thus a subset of the places where segments join; if -- you want all joins between segments, see 'pathPoints'.) The -- tolerance determines how close the tangents of two segments must be -- at their endpoints to consider the transition point to be -- differentiable. See 'trailVertices' for more information. pathVertices' :: (Metric v, OrderedField n) => n -> Path v n -> [[Point v n]] pathVertices' toler = map (trailVertices' toler) . op Path -- | Like 'pathVertices'', with a default tolerance. pathVertices :: (Metric v, OrderedField n) => Path v n -> [[Point v n]] pathVertices = map trailVertices . op Path -- | Extract the points of a path, resulting in a separate list of -- points for each component trail. Here a /point/ is any place -- where two segments join; see also 'pathVertices' and 'trailPoints'. -- -- This function allows you "observe" the fact that trails are -- implemented as lists of segments, which may be problematic if we -- want to think of trails as parametric vector functions. This also -- means that the behavior of this function may not be stable under -- future changes to the implementation of trails and paths. For an -- unproblematic version which only yields vertices at which there -- is a sharp corner, excluding points differentiable points, see -- 'pathVertices'. -- -- This function is not re-exported from "Diagrams.Prelude"; to use -- it, import "Diagrams.Path". pathPoints :: (Metric v, OrderedField n) => Path v n -> [[Point v n]] pathPoints = map trailPoints . op Path -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). pathOffsets :: (Metric v, OrderedField n) => Path v n -> [v n] pathOffsets = map (trailOffset . unLoc) . op Path -- | Compute the /centroid/ of a path (/i.e./ the average location of -- its /vertices/; see 'pathVertices'). pathCentroid :: (Metric v, OrderedField n) => Path v n -> Point v n pathCentroid = centroid . concat . pathVertices -- | Convert a path into a list of lists of located segments. pathLocSegments :: (Metric v, OrderedField n) => Path v n -> [[Located (Segment Closed v n)]] pathLocSegments = map trailLocSegments . op Path -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (Metric v, OrderedField n) => Path v n -> [[FixedSegment v n]] fixPath = map fixTrail . op Path -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). explodePath :: (V t ~ v, N t ~ n, TrailLike t) => Path v n -> [[t]] 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 n) -> Bool) -> Path v n -> (Path v n, Path v n) partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Path ------------------------------------------------------------ -- Modifying paths --------------------------------------- ------------------------------------------------------------ -- | Scale a path using its centroid (see 'pathCentroid') as the base -- point for the scale. scalePath :: (HasLinearMap v, Metric v, OrderedField n) => n -> Path v n -> Path v n scalePath d p = under (movedFrom (pathCentroid p)) (scale d) p -- | Reverse all the component trails of a path. reversePath :: (Metric v, OrderedField n) => Path v n -> Path v n reversePath = _Wrapped . mapped %~ reverseLocTrail -- | Same as 'reversePath'. instance (Metric v, OrderedField n) => Reversing (Path v n) where reversing = _Wrapped' . mapped %~ reversing diagrams-lib-1.3.1.4/src/Diagrams/CubicSpline.hs0000644000000000000000000000551312754644012017462 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A /cubic spline/ is a smooth, connected sequence of cubic curves -- passing through a given sequence of points. This module provides -- the 'cubicSpline' method, which can be used to create closed or -- open cubic splines from a list of points. For access to the -- internals of the spline generation algorithm (including in -- particular a solver for cyclic tridiagonal systems of linear -- equations), see "Diagrams.CubicSpline.Internal". -- ----------------------------------------------------------------------------- module Diagrams.CubicSpline ( -- * Constructing paths from cubic splines cubicSpline ) where import Control.Lens (view) import Diagrams.Core import Diagrams.CubicSpline.Internal import Diagrams.Located (Located, at, mapLoc) import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) import Linear.Affine import Linear.Metric -- | 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)] -- > spot = circle 0.2 # fc blue # lw none -- > mkPath closed = position (zip pts (repeat spot)) -- > <> cubicSpline closed pts -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) -- > # centerXY # pad 1.1 -- -- For more information, see . cubicSpline :: (V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin cubicSpline closed [p] = trailLike . closeIf closed $ emptyLine `at` p cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) closeIf :: (Metric v, OrderedField n) => Bool -> Located (Trail' Line v n) -> Located (Trail v n) closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) diagrams-lib-1.3.1.4/src/Diagrams/Transform.hs0000644000000000000000000001046112754644012017233 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform -- Copyright : (c) 2011-15 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Affine transformations, parameterized by any vector space. For -- transformations on particular vector spaces, see /e.g./ -- "Diagrams.TwoD.Transform". -- ----------------------------------------------------------------------------- module Diagrams.Transform ( -- * Transformations Transformation, inv, transl, apply, papply -- * The Transformable class , Transformable(..) -- * Some specific transformations , translation, translate, moveTo, place, scaling, scale -- * Miscellaneous transformation-related utilities , conjugate, underT, transformed, translated, movedTo, movedFrom -- * The HasOrigin class , HasOrigin(..), moveOriginBy ) where import Control.Lens hiding (transform) import Data.Semigroup import Diagrams.Core import Linear.Vector -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the -- inverse of @t1@. conjugate :: (Additive v, Num n) => Transformation v n -> Transformation v n -> Transformation v n conjugate t1 t2 = inv t1 <> t2 <> t1 -- | Carry out some transformation \"under\" another one: @f ``underT`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For -- example, @'scaleX' 2 ``underT`` 'rotation' (-1/8 \@\@ Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- -- Note that -- -- @ -- (transform t2) `underT` t1 == transform (conjugate t1 t2) -- @ -- -- for all transformations @t1@ and @t2@. -- -- See also the isomorphisms like 'transformed', 'movedTo', -- 'movedFrom', and 'translated'. underT :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) => (a -> b) -> Transformation v n -> a -> b f `underT` t = transform (inv t) . f . transform t -- | Use a 'Transformation' to make an 'Iso' between an object -- transformed and untransformed. This is useful for carrying out -- functions 'under' another transform: -- -- @ -- under (transformed t) f == transform (inv t) . f . transform t -- under (transformed t1) (transform t2) == transform (conjugate t1 t2) -- transformed t ## a == transform t a -- a ^. transformed t == transform (inv t) a -- @ transformed :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) => Transformation v n -> Iso a b a b transformed t = iso (transform $ inv t) (transform t) -- | Use a 'Point' to make an 'Iso' between an object -- moved to and from that point: -- -- @ -- under (movedTo p) f == moveTo (-p) . f . moveTo p -- over (movedTo p) f == moveTo p . f . moveTo (-p) -- movedTo p == from (movedFrom p) -- movedTo p ## a == moveTo p a -- a ^. movedTo p == moveOriginTo p a -- @ movedTo :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) => Point v n -> Iso a b a b movedTo p = iso (moveTo (negated p)) (moveTo p) -- | Use a 'Transformation' to make an 'Iso' between an object -- transformed and untransformed. We have -- -- @ -- under (movedFrom p) f == moveTo p . f . moveTo (-p) -- movedFrom p == from (movedTo p) -- movedFrom p ## a == moveOriginTo p a -- a ^. movedFrom p == moveTo p a -- over (movedFrom p) f == moveTo (-p) . f . moveTo p -- @ movedFrom :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) => Point v n -> Iso a b a b movedFrom p = iso (moveOriginTo (negated p)) (moveOriginTo p) -- | Use a vector to make an 'Iso' between an object translated and -- untranslated. -- -- @ -- under (translated v) f == translate (-v) . f . translate v -- translated v ## a == translate v a -- a ^. translated v == translate (-v) a -- over (translated v) f == translate v . f . translate (-v) -- @ translated :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) => v n -> Iso a b a b translated = transformed . translation diagrams-lib-1.3.1.4/src/Diagrams/Located.hs0000644000000000000000000001527312754644012016641 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- \"Located\" things, /i.e./ things with a concrete location: -- intuitively, @Located a ~ (a, Point)@. Wrapping a translationally -- invariant thing (/e.g./ a 'Segment' or 'Trail') in @Located@ pins -- it down to a particular location and makes it no longer -- translationally invariant. -- ----------------------------------------------------------------------------- module Diagrams.Located ( Located (..) , at, viewLoc, mapLoc, located, _loc ) where import Control.Lens (Lens, Lens') #if __GLASGOW_HASKELL__ < 710 import Data.Functor ((<$>)) #endif import Text.Read import Linear.Affine import Linear.Vector import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Parametric -- | \"Located\" things, /i.e./ things with a concrete location: -- intuitively, @Located a ~ (Point, a)@. Wrapping a translationally -- invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins -- it down to a particular location and makes it no longer -- translationally invariant. -- -- @Located@ is intentionally abstract. To construct @Located@ -- values, use 'at'. To destruct, use 'viewLoc', 'unLoc', or 'loc'. -- To map, use 'mapLoc'. -- -- Much of the utility of having a concrete type for the @Located@ -- concept lies in the type class instances we can give it. The -- 'HasOrigin', 'Transformable', 'Enveloped', 'Traced', and -- 'TrailLike' instances are particularly useful; see the documented -- instances below for more information. data Located a = Loc { loc :: Point (V a) (N a) -- ^ Project out the -- location of a @Located@ -- value. , unLoc :: a -- ^ Project the value -- of type @a@ out of -- a @Located a@, -- discarding the -- location. } infix 5 `at` -- | Construct a @Located a@ from a value of type @a@ and a location. -- @at@ is intended to be used infix, like @x \`at\` origin@. at :: a -> Point (V a) (N a) -> Located a at a p = Loc p a -- | Deconstruct a @Located a@ into a location and a value of type -- @a@. @viewLoc@ can be especially useful in conjunction with the -- @ViewPatterns@ extension. viewLoc :: Located a -> (Point (V a) (N a), a) viewLoc (Loc p a) = (p,a) -- | 'Located' is not a @Functor@, since changing the type could -- change the type of the associated vector space, in which case the -- associated location would no longer have the right type. 'mapLoc' -- has an extra constraint specifying that the vector space must -- stay the same. -- -- (Technically, one can say that for every vector space @v@, -- @Located@ is a little-f (endo)functor on the category of types -- with associated vector space @v@; but that is not covered by the -- standard @Functor@ class.) mapLoc :: SameSpace a 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 :: SameSpace a b => Lens (Located a) (Located b) a b located f (Loc p a) = Loc p <$> f a -- | Lens onto the location of something 'Located'. _loc :: Lens' (Located a) (Point (V a) (N a)) _loc f (Loc p a) = flip Loc a <$> f p deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) instance (Show (V a (N a)), Show a) => Show (Located a) where showsPrec d (Loc p a) = showParen (d > 5) $ showsPrec 6 a . showString " `at` " . showsPrec 6 p instance (Read (V a (N a)), Read a) => Read (Located a) where readPrec = parens . prec 5 $ do a <- readPrec Punc "`" <- lexP Ident "at" <- lexP Punc "`" <- lexP p <- readPrec return (Loc p a) type instance V (Located a) = V a type instance N (Located a) = N a -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not. -- In particular, translating a @Located a@ simply translates the -- associated point (and does /not/ affect the value of type @a@). instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a -- | Applying a transformation @t@ to a @Located a@ results in the -- transformation being applied to the location, and the /linear/ -- /portion/ of @t@ being applied to the value of type @a@ (/i.e./ -- it is not translated). instance (Additive (V a), Num (N a), Transformable a) => Transformable (Located a) where transform t@(Transformation t1 t2 _) (Loc p a) = Loc (transform t p) (transform (Transformation t1 t2 zero) a) -- | The envelope of a @Located a@ is the envelope of the @a@, -- translated to the location. instance Enveloped a => Enveloped (Located a) where getEnvelope (Loc p a) = moveTo p (getEnvelope a) instance Enveloped a => Juxtaposable (Located a) where juxtapose = juxtaposeDefault -- | The trace of a @Located a@ is the trace of the @a@, -- translated to the location. instance (Traced a, Num (N a)) => Traced (Located a) where getTrace (Loc p a) = moveTo p (getTrace a) instance Qualifiable a => Qualifiable (Located a) where n .>> Loc p a = Loc p (n .>> a) type instance Codomain (Located a) = Point (Codomain a) instance (InSpace v n a, Parametric a, Codomain a ~ v) => 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 (InSpace v n a, EndValues a, Codomain a ~ v) => EndValues (Located a) instance (InSpace v n a, Fractional n, Parametric a, Sectionable a, Codomain a ~ v) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p reverseDomain (Loc x a) = Loc (x .+^ y) (reverseDomain a) where y = a `atParam` domainUpper a instance (InSpace v n a, Fractional n, HasArcLength a, Codomain a ~ v) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) = arcLengthToParam eps a diagrams-lib-1.3.1.4/src/Diagrams/Align.hs0000644000000000000000000001442012754644012016311 0ustar0000000000000000{-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Align -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The /alignment/ of an object refers to the position of its local -- origin with respect to its envelope. This module defines the -- 'Alignable' class for things which can be aligned, as well as a -- default implementation in terms of 'HasOrigin' and 'Enveloped', -- along with several utility methods for alignment. -- ----------------------------------------------------------------------------- module Diagrams.Align ( -- * Alignable class Alignable(..) , alignBy'Default , envelopeBoundary , traceBoundary -- * General alignment functions , align , snug , centerV, center , snugBy , snugCenterV, snugCenter ) where import Diagrams.Core import Diagrams.Util (applyAll) import Data.Maybe (fromMaybe) import Data.Ord (comparing) import Data.Traversable import Prelude import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S import Linear.Affine import Linear.Metric import Linear.Vector -- | 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 -- 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' :: (InSpace v n a, Fractional n, HasOrigin a) => (v n -> a -> Point v n) -> v n -> n -> a -> a alignBy' = alignBy'Default defaultBoundary :: (V a ~ v, N a ~ n) => v n -> a -> Point v n alignBy :: (InSpace v n a, Fractional n, HasOrigin a) => v n -> n -> a -> a alignBy = alignBy' defaultBoundary -- | Default implementation of 'alignBy' for types with 'HasOrigin' -- and 'AdditiveGroup' instances. alignBy'Default :: (InSpace v n a, Fractional n, HasOrigin a) => (v n -> a -> Point v n) -> v n -> n -> a -> a alignBy'Default boundary v d a = moveOriginTo (lerp ((d + 1) / 2) (boundary v a) (boundary (negated v) a) ) a {-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-} -- | Some standard functions which can be used as the `boundary` argument to -- `alignBy'`. envelopeBoundary :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n envelopeBoundary = envelopeP traceBoundary :: (V a ~ v, N a ~ n, Num n, Traced a) => v n -> a -> Point v n traceBoundary v a = fromMaybe origin (maxTraceP origin v a) combineBoundaries :: (InSpace v n a, Metric v, Ord n, F.Foldable f) => (v n -> a -> Point v n) -> v n -> f a -> Point v n combineBoundaries b v fa = b v $ F.maximumBy (comparing (quadrance . (.-. origin) . b v)) fa instance (Metric v, OrderedField n) => Alignable (Envelope v n) where defaultBoundary = envelopeBoundary instance (Metric v, OrderedField n) => Alignable (Trace v n) where defaultBoundary = traceBoundary instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable [b] where defaultBoundary = combineBoundaries defaultBoundary instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable (S.Set b) where defaultBoundary = combineBoundaries defaultBoundary instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable (M.Map k b) where defaultBoundary = combineBoundaries defaultBoundary instance (Metric v, OrderedField n, Monoid' m) => Alignable (QDiagram b v n m) where 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 (InSpace v n a, 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 :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a align v = alignBy v 1 -- | Version of @alignBy@ specialized to use @traceBoundary@ snugBy :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> n -> a -> a snugBy = alignBy' traceBoundary -- | Like align but uses trace. snug :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> a -> a snug v = snugBy v 1 -- | @centerV v@ centers an enveloped object along the direction of -- @v@. centerV :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a centerV v = alignBy v 0 -- | @center@ centers an enveloped object along all of its basis vectors. center :: (InSpace v n a, Fractional n, Traversable v, Alignable a, HasOrigin a) => a -> a center = applyAll fs where fs = map centerV basis -- | Like @centerV@ using trace. snugCenterV :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a) => v n -> a -> a snugCenterV v = alignBy' traceBoundary v 0 -- | Like @center@ using trace. snugCenter :: (InSpace v n a, Traversable v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugCenter = applyAll fs where fs = map snugCenterV basis {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} diagrams-lib-1.3.1.4/src/Diagrams/Segment.hs0000644000000000000000000005353512754644012016673 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Segment -- Copyright : (c) 2011-2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A /segment/ is a translation-invariant, atomic path. Currently, -- there are two types: linear (/i.e./ just a straight line to the -- endpoint) and cubic Bézier curves (/i.e./ a curve to an endpoint -- with two control points). This module contains tools for creating -- and manipulating segments, as well as a definition of segments with -- a fixed location (useful for backend implementors). -- -- Generally speaking, casual users of diagrams should not need this -- module; the higher-level functionality provided by -- "Diagrams.Trail", "Diagrams.TrailLike", and "Diagrams.Path" should -- usually suffice. However, directly manipulating segments can -- occasionally be useful. -- ----------------------------------------------------------------------------- module Diagrams.Segment ( -- * Open/closed tags Open, Closed -- * Segment offsets , Offset(..) , segOffset -- * Constructing and modifying segments , Segment(..), straight, bezier3, bézier3, reverseSegment, mapSegmentVectors , openLinear, openCubic -- * Fixed (absolutely located) segments , FixedSegment(..) , mkFixedSeg, fromFixedSeg , fixedSegIso -- * Segment measures -- $segmeas , SegCount(..) , ArcLength(..) , getArcLengthCached, getArcLengthFun, getArcLengthBounded , TotalOffset(..) , OffsetEnvelope(..), oeOffset, oeEnvelope , SegMeasure ) where import Control.Lens hiding (at, transform) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup import Numeric.Interval.Kaucher (Interval (..)) import qualified Numeric.Interval.Kaucher as I import Linear.Affine import Linear.Metric import Linear.Vector import Control.Applicative import Diagrams.Core hiding (Measured) import Diagrams.Located import Diagrams.Parametric import Diagrams.Solve.Polynomial ------------------------------------------------------------ -- Open/closed type tags --------------------------------- ------------------------------------------------------------ -- Eventually we should use DataKinds for this, but not until we drop -- support for GHC 7.4. -- | Type tag for open segments. data Open -- | Type tag for closed segments. data Closed ------------------------------------------------------------ -- Segment offsets --------------------------------------- ------------------------------------------------------------ -- | The /offset/ of a segment is the vector from its starting point -- to its end. The offset for an /open/ segment is determined by -- the context, /i.e./ its endpoint is not fixed. The offset for a -- /closed/ segment is stored explicitly, /i.e./ its endpoint is at -- a fixed offset from its start. data Offset c v n where OffsetOpen :: Offset Open v n OffsetClosed :: v n -> Offset Closed v n deriving instance Show (v n) => Show (Offset c v n) deriving instance Eq (v n) => Eq (Offset c v n) deriving instance Ord (v n) => Ord (Offset c v n) instance Functor v => Functor (Offset c v) where fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f v) instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where each f (OffsetClosed v) = OffsetClosed <$> f v each _ OffsetOpen = pure OffsetOpen {-# INLINE each #-} -- | Reverses the direction of closed offsets. instance (Additive v, Num n) => Reversing (Offset c v n) where reversing (OffsetClosed off) = OffsetClosed $ negated off reversing a@OffsetOpen = a type instance V (Offset c v n) = v type instance N (Offset c v n) = n instance Transformable (Offset c v n) where transform _ OffsetOpen = OffsetOpen transform t (OffsetClosed v) = OffsetClosed (apply t v) ------------------------------------------------------------ -- Constructing segments --------------------------------- ------------------------------------------------------------ -- | The atomic constituents of the concrete representation currently -- used for trails are /segments/, currently limited to -- single straight lines or cubic Bézier curves. Segments are -- /translationally invariant/, that is, they have no particular -- \"location\" and are unaffected by translations. They are, -- however, affected by other transformations such as rotations and -- scales. data Segment c v n = Linear !(Offset c v n) -- ^ A linear segment with given offset. | Cubic !(v n) !(v n) !(Offset c v n) -- ^ A cubic Bézier segment specified by -- three offsets from the starting -- point to the first control point, -- second control point, and ending -- point, respectively. deriving (Functor, Eq, Ord) instance Show (v n) => Show (Segment c v n) where showsPrec d seg = case seg of Linear (OffsetClosed v) -> showParen (d > 10) $ showString "straight " . showsPrec 11 v Cubic v1 v2 (OffsetClosed v3) -> showParen (d > 10) $ showString "bézier3 " . showsPrec 11 v1 . showChar ' ' . showsPrec 11 v2 . showChar ' ' . showsPrec 11 v3 Linear OffsetOpen -> showString "openLinear" Cubic v1 v2 OffsetOpen -> showParen (d > 10) $ showString "openCubic " . showsPrec 11 v1 . showChar ' ' . showsPrec 11 v2 instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where each f (Linear offset) = Linear <$> each f offset each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset {-# INLINE each #-} -- | Reverse the direction of a segment. instance (Additive v, Num n) => Reversing (Segment Closed v n) where reversing = reverseSegment -- | Map over the vectors of each segment. mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' mapSegmentVectors = over each -- Note, can't yet have Haddock comments on GADT constructors; see -- http://trac.haskell.org/haddock/ticket/43. For now we don't need -- Segment to be a GADT but we might in the future. (?) type instance V (Segment c v n) = v type instance N (Segment c v n) = n instance Transformable (Segment c v n) where transform = mapSegmentVectors . apply instance Renderable (Segment c v n) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. straight :: v n -> Segment Closed v n straight = Linear . OffsetClosed -- Note, if we didn't have a Linear constructor we could also create -- linear segments with @Cubic (v ^/ 3) (2 *^ (v ^/ 3)) v@. Those -- would not be precisely the same, however, since we can actually -- observe how segments are parametrized. -- | @bezier3 c1 c2 x@ constructs a translationally invariant cubic -- Bézier curve where the offsets from the first endpoint to the -- first and second control point and endpoint are respectively -- given by @c1@, @c2@, and @x@. bezier3 :: v n -> v n -> v n -> Segment Closed v n bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) -- | @bézier3@ is the same as @bezier3@, but with more snobbery. bézier3 :: v n -> v n -> v n -> Segment Closed v n bézier3 = bezier3 type instance Codomain (Segment Closed v n) = v -- | 'atParam' yields a parametrized view of segments as continuous -- functions @[0,1] -> v@, which give the offset from the start of -- the segment for each value of the parameter between @0@ and @1@. -- It is designed to be used infix, like @seg ``atParam`` 0.5@. instance (Additive v, Num n) => Parametric (Segment Closed v n) where atParam (Linear (OffsetClosed x)) t = t *^ x atParam (Cubic c1 c2 (OffsetClosed x2)) t = (3 * t'*t'*t ) *^ c1 ^+^ (3 * t'*t *t ) *^ c2 ^+^ ( t *t *t ) *^ x2 where t' = 1-t instance Num n => DomainBounds (Segment Closed v n) instance (Additive v, Num n) => EndValues (Segment Closed v n) where atStart = const zero atEnd (Linear (OffsetClosed v)) = v atEnd (Cubic _ _ (OffsetClosed v)) = v -- | Compute the offset from the start of a segment to the -- end. Note that in the case of a Bézier segment this is /not/ the -- same as the length of the curve itself; for that, see 'arcLength'. segOffset :: Segment Closed v n -> v n segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v -- | An open linear segment. This means the trail makes a straight line -- from the last segment the beginning to form a loop. openLinear :: Segment Open v n openLinear = Linear OffsetOpen -- | An open cubic segment. This means the trail makes a cubic bézier -- with control vectors @v1@ and @v2@ to form a loop. openCubic :: v n -> v n -> Segment Open v n openCubic v1 v2 = Cubic v1 v2 OffsetOpen ------------------------------------------------------------ -- Computing segment envelope ------------------------------ ------------------------------------------------------------ {- 3 (1-t)^2 t c1 + 3 (1-t) t^2 c2 + t^3 x2 Can we compute the projection of B(t) onto a given vector v? u.v = |u||v| cos th |proj_v u| = cos th * |u| = (u.v/|v|) so B_v(t) = (B(t).v/|v|) Then take the derivative of this wrt. t, get a quadratic, solve. B_v(t) = (1/|v|) * -- note this does not affect max/min, can solve for t first 3 (1-t)^2 t (c1.v) + 3 (1-t) t^2 (c2.v) + t^3 (x2.v) = t^3 ((3c1 - 3c2 + x2).v) + t^2 ((-6c1 + 3c2).v) + t (3c1.v) B_v'(t) = t^2 (3(3c1 - 3c2 + x2).v) + t (6(-2c1 + c2).v) + 3c1.v Set equal to zero, use quadratic formula. -} -- | The envelope for a segment is based at the segment's start. instance (Metric v, OrderedField n) => Enveloped (Segment Closed v n) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> maximum (map (\t -> (s `atParam` t) `dot` v) [0,1]) / quadrance v getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) `dot` v) / quadrance v) $ [0,1] ++ filter (liftA2 (&&) (>0) (<1)) (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) `dot` v)) (6 * (((-2) *^ c1 ^+^ c2) `dot` v)) ((3 *^ c1) `dot` v)) ------------------------------------------------------------ -- Manipulating segments ------------------------------------------------------------ instance (Additive v, Fractional n) => Sectionable (Segment Closed v n) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) p = lerp t x1 zero splitAtParam (Cubic c1 c2 (OffsetClosed x2)) t = (left, right) where left = bezier3 a b e right = bezier3 (c ^-^ e) (d ^-^ e) (x2 ^-^ e) p = lerp t c2 c1 a = lerp t c1 zero b = lerp t p a d = lerp t x2 c2 c = lerp t d p e = lerp t c b reverseDomain = reverseSegment -- | Reverse the direction of a segment. reverseSegment :: (Num n, Additive v) => Segment Closed v n -> Segment Closed v n reverseSegment (Linear (OffsetClosed v)) = straight (negated v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negated x2) instance (Metric v, OrderedField n) => HasArcLength (Segment Closed v n) where arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ norm x1 arcLengthBounded m s@(Cubic c1 c2 (OffsetClosed x2)) | ub - lb < m = I lb ub | otherwise = arcLengthBounded (m/2) l + arcLengthBounded (m/2) r where (l,r) = s `splitAtParam` 0.5 ub = sum (map norm [c1, c2 ^-^ c1, x2 ^-^ c2]) lb = norm x2 arcLengthToParam m s _ | arcLength m s == 0 = 0.5 arcLengthToParam m s@(Linear {}) len = len / arcLength m s arcLengthToParam m s@(Cubic {}) len | len `I.elem` I (-m/2) (m/2) = 0 | len < 0 = - arcLengthToParam m (fst (splitAtParam s (-1))) (-len) | len `I.elem` slen = 1 | len > I.sup slen = 2 * arcLengthToParam m (fst (splitAtParam s 2)) len | len < I.sup llen = (*0.5) $ arcLengthToParam m l len | otherwise = (+0.5) . (*0.5) $ arcLengthToParam (9*m/10) r (len - I.midpoint llen) where (l,r) = s `splitAtParam` 0.5 llen = arcLengthBounded (m/10) l slen = arcLengthBounded m s -- Note, the above seems to be quite slow since it duplicates a lot of -- work. We could trade off some time for space by building a tree of -- parameter values (up to a certain depth...) ------------------------------------------------------------ -- Fixed segments ------------------------------------------------------------ -- | @FixedSegment@s are like 'Segment's except that they have -- absolute locations. @FixedSegment v@ is isomorphic to @Located -- (Segment Closed v)@, as witnessed by 'mkFixedSeg' and -- 'fromFixedSeg', but @FixedSegment@ is convenient when one needs -- the absolute locations of the vertices and control points. data FixedSegment v n = FLinear (Point v n) (Point v n) | FCubic (Point v n) (Point v n) (Point v n) (Point v n) deriving Show type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1 each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 {-# INLINE each #-} -- | Reverses the control points. instance Reversing (FixedSegment v n) where reversing (FLinear p0 p1) = FLinear p1 p0 reversing (FCubic p0 p1 p2 p3) = FCubic p3 p2 p1 p0 instance (Additive v, Num n) => Transformable (FixedSegment v n) where transform t = over each (papply t) instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where moveOriginTo o = over each (moveOriginTo o) instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) where (p, s) = viewLoc $ fromFixedSeg f -- Eventually we might decide it's cleaner/more efficient (?) to -- have all the computation in the FixedSegment instance of -- Envelope, and implement the Segment instance in terms of it, -- instead of the other way around instance (Metric v, OrderedField n) => HasArcLength (FixedSegment v n) where arcLengthBounded m s = arcLengthBounded m (fromFixedSeg s) arcLengthToParam m s = arcLengthToParam m (fromFixedSeg s) -- | Create a 'FixedSegment' from a located 'Segment'. mkFixedSeg :: (Num n, Additive v) => Located (Segment Closed v n) -> FixedSegment v n mkFixedSeg ls = case viewLoc ls of (p, Linear (OffsetClosed v)) -> FLinear p (p .+^ v) (p, Cubic c1 c2 (OffsetClosed x2)) -> FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. fromFixedSeg :: (Num n, Additive v) => FixedSegment v n -> Located (Segment Closed v n) fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 -- | Use a 'FixedSegment' to make an 'Iso' between an -- a fixed segment and a located segment. fixedSegIso :: (Num n, Additive v) => Iso' (FixedSegment v n) (Located (Segment Closed v n)) fixedSegIso = iso fromFixedSeg mkFixedSeg type instance Codomain (FixedSegment v n) = Point v instance (Additive v, Num n) => Parametric (FixedSegment v n) where atParam (FLinear p1 p2) t = lerp t p2 p1 atParam (FCubic x1 c1 c2 x2) t = p3 where p11 = lerp t c1 x1 p12 = lerp t c2 c1 p13 = lerp t x2 c2 p21 = lerp t p12 p11 p22 = lerp t p13 p12 p3 = lerp t p22 p21 instance Num n => DomainBounds (FixedSegment v n) instance (Additive v, Num n) => EndValues (FixedSegment v n) where atStart (FLinear p0 _) = p0 atStart (FCubic p0 _ _ _) = p0 atEnd (FLinear _ p1) = p1 atEnd (FCubic _ _ _ p1 ) = p1 instance (Additive v, Fractional n) => Sectionable (FixedSegment v n) where splitAtParam (FLinear p0 p1) t = (left, right) where left = FLinear p0 p right = FLinear p p1 p = lerp t p1 p0 splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) where left = FCubic p0 a b cut right = FCubic cut c d p1 -- first round a = lerp t c1 p0 p = lerp t c2 c1 d = lerp t p1 c2 -- second round b = lerp t p a c = lerp t d p -- final round cut = lerp t c b reverseDomain (FLinear p0 p1) = FLinear p1 p0 reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 ------------------------------------------------------------ -- Segment measures -------------------------------------- ------------------------------------------------------------ -- $segmeas -- Trails store a sequence of segments in a fingertree, which can -- automatically track various monoidal \"measures\" on segments. -- | A type to track the count of segments in a 'Trail'. newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) instance Wrapped SegCount where type Unwrapped SegCount = Sum Int _Wrapped' = iso (\(SegCount x) -> x) SegCount instance Rewrapped SegCount SegCount -- | 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 n = ArcLength (Sum (Interval n), n -> Sum (Interval n)) instance Wrapped (ArcLength n) where type Unwrapped (ArcLength n) = (Sum (Interval n), n -> Sum (Interval n)) _Wrapped' = iso (\(ArcLength x) -> x) ArcLength instance Rewrapped (ArcLength n) (ArcLength n') -- | Project out the cached arc length, stored together with error -- bounds. getArcLengthCached :: ArcLength n -> Interval n getArcLengthCached = getSum . fst . op ArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. getArcLengthFun :: ArcLength n -> n -> Interval n 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 -- function with the given tolerance. getArcLengthBounded :: (Num n, Ord n) => n -> ArcLength n -> Interval n getArcLengthBounded eps al | I.width cached <= eps = cached | otherwise = getArcLengthFun al eps where cached = getArcLengthCached al deriving instance (Num n, Ord n) => Semigroup (ArcLength n) deriving instance (Num n, Ord n) => Monoid (ArcLength n) -- | A type to represent the total cumulative offset of a chain of -- segments. newtype TotalOffset v n = TotalOffset (v n) instance Wrapped (TotalOffset v n) where type Unwrapped (TotalOffset v n) = v n _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset instance Rewrapped (TotalOffset v n) (TotalOffset v' n') instance (Num n, Additive v) => Semigroup (TotalOffset v n) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) instance (Num n, Additive v) => Monoid (TotalOffset v n) where mempty = TotalOffset zero mappend = (<>) -- | A type to represent the offset and envelope of a chain of -- segments. They have to be paired into one data structure, since -- combining the envelopes of two consecutive chains needs to take -- the offset of the first into account. data OffsetEnvelope v n = OffsetEnvelope { _oeOffset :: !(TotalOffset v n) , _oeEnvelope :: Envelope v n } makeLenses ''OffsetEnvelope instance (Metric v, OrderedField n) => Semigroup (OffsetEnvelope v n) where (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = let !negOff = negated . op TotalOffset $ o1 e2Off = moveOriginBy negOff e2 !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. type SegMeasure v n = SegCount ::: ArcLength n ::: OffsetEnvelope v n ::: () -- unfortunately we can't cache Trace, since there is not a generic -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). instance (Metric v, OrderedField n) => Measured (SegMeasure v n) (SegMeasure v n) where measure = id instance (OrderedField n, Metric v) => Measured (SegMeasure v n) (Segment Closed v n) where measure s = (SegCount . Sum) 1 -- cache arc length with two orders of magnitude more -- accuracy than standard, so we have a hope of coming out -- with an accurate enough total arc length for -- reasonable-length trails *: ArcLength ( Sum $ arcLengthBounded (stdTolerance/100) s , Sum . flip arcLengthBounded s ) *: OffsetEnvelope (TotalOffset . segOffset $ s) (getEnvelope s) *: () diagrams-lib-1.3.1.4/src/Diagrams/TwoD.hs0000644000000000000000000002222012754644012016131 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines the two-dimensional vector space R^2, -- two-dimensional transformations, and various predefined -- two-dimensional shapes. This module re-exports useful -- functionality from a group of more specific modules: -- -- * "Diagrams.TwoD.Types" defines basic types for two-dimensional -- diagrams, including types representing the 2D Euclidean vector -- space and various systems of angle measurement. -- -- * "Diagrams.TwoD.Align" defines alignment combinators specialized -- to two dimensions (see "Diagrams.Align" for more general -- alignment). -- -- * "Diagrams.TwoD.Combinators" defines ways of combining diagrams -- specialized to two dimensions (see also "Diagrams.Combinators" -- for more general combining). -- -- * "Diagrams.TwoD.Attributes" defines attributes specific to two -- dimensions, *e.g.* fill color, line color, and gradients. -- -- * "Diagrams.TwoD.Transform" defines R^2-specific transformations -- such as rotation by an angle, and scaling, translation, and -- reflection in the X and Y directions. -- -- * "Diagrams.TwoD.Deform" defines some non-affine transformations -- specific to two dimensions, *e.g.* parallel and perspective -- projections. -- -- * "Diagrams.TwoD.Ellipse" defines circles and ellipses. -- -- * "Diagrams.TwoD.Arc" defines circular arcs. -- -- * "Diagrams.TwoD.Path" exports various operations on -- two-dimensional paths when viewed as regions of the plane. -- -- * "Diagrams.TwoD.Polygons" defines general algorithms for drawing -- various types of polygons. -- -- * "Diagrams.TwoD.Shapes" defines other two-dimensional shapes, -- e.g. various polygons. -- -- * "Diagrams.TwoD.Arrow" contains tools for drawing arrows between -- things, and "Diagrams.TwoD.Arrowheads" defines a collection of -- arrowheads. -- -- * "Diagrams.TwoD.Text" defines primitive text diagrams. -- -- * "Diagrams.TwoD.Image" allows importing external images into diagrams. -- -- * "Diagrams.TwoD.Vector" defines some special 2D vectors and -- functions for converting between vectors and angles. -- -- * "Diagrams.TwoD.Size" defines functions for working with the -- size of 2D objects. -- -- * "Diagrams.TwoD.Model" defines some aids for visualizing -- diagrams' internal model (local origins, envelopes, etc.) -- ----------------------------------------------------------------------------- module Diagrams.TwoD ( -- * R^2 V2 (..), R1 (..), R2 (..) , P2, T2 , r2, unr2, mkR2 , p2, unp2, mkP2 , unitX, unitY, unit_X, unit_Y , perp, leftTurn , xDir, yDir -- * Angles , tau , angleV , angleDir , signedAngleBetween , signedAngleBetweenDirs -- * Polar Coördinates , HasR(..), r2PolarIso -- * Paths -- ** Stroking , stroke, stroke' , strokePath, strokeP, strokePath', strokeP' , strokeTrail, strokeT, strokeTrail', strokeT' , strokeLine, strokeLoop , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule, _fillRule , StrokeOpts(..), vertexNames, queryFillRule , intersectPoints, intersectPoints' , intersectPointsP, intersectPointsP' , intersectPointsT, intersectPointsT' -- ** Clipping , clipBy, clipTo, clipped, _Clip, _clip -- * Shapes -- ** Rules , hrule, vrule -- ** Circle-ish things , unitCircle , circle , ellipse , ellipseXY , arc , arc' , arcCW , arcCCW , wedge , arcBetween , annularWedge -- ** General polygons , polygon, polyTrail , PolygonOpts(..), polyType, polyOrient, polyCenter , PolyType(..), PolyOrientation(..) -- ** Star polygons , StarOpts(..), star -- ** Regular polygons , regPoly , triangle , eqTriangle , square , pentagon , hexagon , heptagon , septagon , octagon , nonagon , decagon , hendecagon , dodecagon -- ** Other special polygons , unitSquare , rect -- ** Other shapes , roundedRect, roundedRect' , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR -- ** Arrows , arrowV, arrowV' , arrowAt, arrowAt' , arrowBetween, arrowBetween' , connect, connect' , connectPerim, connectPerim' , connectOutside, connectOutside' , arrow, arrow' , straightShaft , module Diagrams.TwoD.Arrowheads , ArrowOpts(..) , arrowHead , arrowTail , arrowShaft , headGap , tailGap , gaps, gap , headTexture , headStyle , tailTexture , tailStyle , shaftTexture , shaftStyle , headLength , tailLength , lengths -- * Text , text, topLeftText, alignedText, baselineText , font, italic, oblique, bold, fontSize , _font, _fontSizeR, _fontSize , fontSizeO, fontSizeL, fontSizeN, fontSizeG -- * Images , DImage(..), ImageData(..) , Embedded, External, Native , image , loadImageEmb , loadImageExt , uncheckedImageRef , raster , rasterDia -- * Transformations -- ** Rotation , rotation, rotate, rotateBy, rotated , rotationAround, rotateAround , rotationTo, rotateTo -- ** Scaling , scalingX, scaleX , scalingY, scaleY , scaling, scale , scaleToX, scaleToY , scaleUToX, scaleUToY -- ** Translation , translationX, translateX , translationY, translateY , translation, translate -- ** Reflection , reflectionX, reflectX , reflectionY, reflectY , reflectionAbout, reflectAbout -- ** Shears , shearingX, shearX , shearingY, shearY -- * Deformations - non-affine transforms , parallelX0, perspectiveX1, parallelY0, perspectiveY1 , facingX, facingY -- * Combinators -- ** Combining multiple diagrams , (===), (|||) , hcat, hcat', hsep , vcat, vcat', vsep -- ** Spacing and envelopes , strutX, strutY , padX, padY , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop , rectEnvelope -- ** Background , boundingRect, bg, bgFrame -- * Alignment , alignL, alignR, alignT, alignB, alignTL, alignTR, alignBL, alignBR , alignX, alignY , centerX, centerY, centerXY -- * Snugging , snugL, snugR, snugT, snugB, snugTL, snugTR, snugBL, snugBR , snugX, snugY , snugCenterX, snugCenterY, snugCenterXY -- * Size -- ** Computing size , width, height , extentX, extentY -- ** Specifying size , mkSizeSpec2D , mkWidth , mkHeight , dims2D -- * Textures , Texture(..), solid , SpreadMethod(..), GradientStop(..) , _FillTexture, fillTexture, _fillTexture, getFillTexture , _LineTexture, lineTexture, _lineTexture, lineTextureA, getLineTexture , stopFraction, stopColor, mkStops , LGradient(..), _LG, lGradStops, lGradTrans, lGradStart, lGradEnd , lGradSpreadMethod, defaultLG, mkLinearGradient , RGradient(..) , rGradStops, rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 , rGradTrans, rGradSpreadMethod, defaultRG, _RG, mkRadialGradient -- ** Colors , fillColor, _SC, _AC, fc, fcA, recommendFillColor , lineColor, lc, lcA -- * Visual aids for understanding the internal model , showOrigin , showOrigin' , OriginOpts(..), oColor, oScale, oMinSize , showEnvelope , showEnvelope' , EnvelopeOpts(..), eColor, eLineWidth, ePoints , showTrace , showTrace' , TraceOpts(..), tColor, tScale, tMinSize, tPoints , showLabels ) where import Diagrams.TwoD.Align import Diagrams.TwoD.Arc import Diagrams.TwoD.Arrow import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Combinators import Diagrams.TwoD.Deform import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image import Diagrams.TwoD.Model import Diagrams.TwoD.Path import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size import Diagrams.TwoD.Text import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util (tau) diagrams-lib-1.3.1.4/src/Diagrams/Envelope.hs0000644000000000000000000000165112754644012017036 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Envelope -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- \"Envelopes\", aka functional bounding regions. See -- "Diagrams.Core.Envelope" for internal implementation details. -- ----------------------------------------------------------------------------- module Diagrams.Envelope ( -- * Types Envelope, Enveloped -- * Diagram envelopes , envelope, setEnvelope, withEnvelope, phantom , pad, extrudeEnvelope, intrudeEnvelope -- * Querying envelopes , envelopeVMay, envelopeV, envelopePMay, envelopeP , diameter, radius ) where import Diagrams.Core (envelope, setEnvelope) import Diagrams.Core.Envelope import Diagrams.Combinators diagrams-lib-1.3.1.4/src/Diagrams/Coordinates.hs0000644000000000000000000001025612754644012017534 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Coordinates -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Nice syntax for constructing and pattern-matching on literal -- points and vectors. -- ----------------------------------------------------------------------------- module Diagrams.Coordinates ( (:&)(..), Coordinates(..) ) where import Diagrams.Points import Linear (V2 (..), V3 (..), V4 (..)) -- | 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 -- 'coords'. A common pattern is to use 'coords' in conjunction -- with the @ViewPatterns@ extension, like so: -- -- @ -- foo :: Vector3 -> ... -- foo (coords -> x :& y :& z) = ... -- @ class Coordinates c where -- | The type of the final coordinate. type FinalCoord c :: * -- | The type of everything other than the final coordinate. type PrevDim c :: * -- | Decomposition of @c@ into applications of ':&'. type Decomposition c :: * -- Decomposition c = Decomposition (PrevDim c) :& FinalCoord c (essentially) -- | 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, -- -- @ -- 2 ^& 3 :: P2 -- 3 ^& 5 ^& 6 :: V3 -- @ -- -- 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 ^& -- | A pair of values, with a convenient infix (left-associative) -- data constructor. data a :& b = a :& b deriving (Eq, Ord, Show) infixl 7 :& -- Instance for :& (the buck stops here) instance Coordinates (a :& b) where type FinalCoord (a :& b) = b type PrevDim (a :& b) = a type Decomposition (a :& b) = a :& b x ^& y = x :& y coords (x :& y) = x :& y -- Some standard instances for plain old tuples instance Coordinates (a,b) where type FinalCoord (a,b) = b type PrevDim (a,b) = a type Decomposition (a,b) = a :& b x ^& y = (x,y) coords (x,y) = x :& y instance Coordinates (a,b,c) where type FinalCoord (a,b,c) = c type PrevDim (a,b,c) = (a,b) type Decomposition (a,b,c) = Decomposition (a,b) :& c (x,y) ^& z = (x,y,z) coords (x,y,z) = coords (x,y) :& z instance Coordinates (a,b,c,d) where type FinalCoord (a,b,c,d) = d 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) coords (w,x,y,z) = coords (w,x,y) :& z instance Coordinates (v n) => Coordinates (Point v n) where type FinalCoord (Point v n) = FinalCoord (v n) type PrevDim (Point v n) = PrevDim (v n) type Decomposition (Point v n) = Decomposition (v n) x ^& y = P (x ^& y) coords (P v) = coords v -- instances for linear instance Coordinates (V2 n) where type FinalCoord (V2 n) = n type PrevDim (V2 n) = n type Decomposition (V2 n) = n :& n x ^& y = V2 x y coords (V2 x y) = x :& y instance Coordinates (V3 n) where type FinalCoord (V3 n) = n type PrevDim (V3 n) = V2 n type Decomposition (V3 n) = n :& n :& n V2 x y ^& z = V3 x y z coords (V3 x y z) = x :& y :& z instance Coordinates (V4 n) where type FinalCoord (V4 n) = n type PrevDim (V4 n) = V3 n type Decomposition (V4 n) = n :& n :& n :& n V3 x y z ^& w = V4 x y z w coords (V4 x y z w) = x :& y :& z :& w diagrams-lib-1.3.1.4/src/Diagrams/Direction.hs0000644000000000000000000000557312754644012017210 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Direction -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Type for representing directions, polymorphic in vector space -- ----------------------------------------------------------------------------- module Diagrams.Direction ( Direction , _Dir , direction, dir, fromDirection, fromDir , angleBetweenDirs , dirBetween ) where import Control.Lens (Iso', iso) import Diagrams.Angle import Diagrams.Core import Linear.Affine import Linear.Vector import Linear.Metric -------------------------------------------------------------------------------- -- Direction -- | A vector is described by a @Direction@ and a magnitude. So we -- can think of a @Direction@ as a vector that has forgotten its -- magnitude. @Direction@s can be used with 'fromDirection' and the -- lenses provided by its instances. newtype Direction v n = Dir (v n) deriving (Read, Show, Eq, Ord, Functor) -- todo: special instances type instance V (Direction v n) = v type instance N (Direction v n) = n instance (V (v n) ~ v, N (v n) ~ n, Transformable (v n)) => Transformable (Direction v n) where transform t (Dir v) = Dir (transform t v) instance HasTheta v => HasTheta (Direction v) where _theta = _Dir . _theta instance HasPhi v => HasPhi (Direction v) where _phi = _Dir . _phi -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it -- exposes too much information. _Dir :: Iso' (Direction v n) (v n) _Dir = iso (\(Dir v) -> v) Dir -- | @direction v@ is the direction in which @v@ points. Returns an -- unspecified value when given the zero vector as input. direction :: v n -> Direction v n direction = Dir -- | Synonym for 'direction'. dir :: v n -> Direction v n dir = Dir -- | @fromDirection d@ is the unit vector in the direction @d@. fromDirection :: (Metric v, Floating n) => Direction v n -> v n fromDirection (Dir v) = signorm v -- | Synonym for 'fromDirection'. fromDir :: (Metric v, Floating n) => Direction v n -> v n fromDir (Dir v) = signorm v -- | compute the positive angle between the two directions in their common plane angleBetweenDirs :: (Metric v, Floating n) => Direction v n -> Direction v n -> Angle n angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) -- | @dirBetween p q@ returns the directions from @p@ to @q@ dirBetween :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n dirBetween p q = dir $ p .-. q diagrams-lib-1.3.1.4/src/Diagrams/TrailLike.hs0000644000000000000000000001702212754644012017140 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TrailLike -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- The 'TrailLike' class abstracts over anything which can be -- constructed from a concretely located 'Trail', including -- lines, loops, trails, paths, vertex lists, and diagrams. -- ----------------------------------------------------------------------------- module Diagrams.TrailLike ( -- * The TrailLike class TrailLike(..) -- * Constructing TrailLikes , fromSegments, fromLocSegments, fromOffsets, fromLocOffsets, fromVertices , (~~), explodeTrail ) where import Control.Lens (view, _Unwrapped') import Diagrams.Core import Diagrams.Located import Diagrams.Segment import Diagrams.Trail import Linear.Affine import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- TrailLike class ------------------------------------------------------------ -- | A type class for trail-like things, /i.e./ things which can be -- constructed from a concretely located 'Trail'. Instances include -- lines, loops, trails, paths, lists of vertices, two-dimensional -- 'Diagram's, and 'Located' variants of all the above. -- -- Usually, type variables with 'TrailLike' constraints are used as -- the /output/ types of functions, like -- -- @ -- foo :: (TrailLike t) => ... -> t -- @ -- -- Functions with such a type can be used to construct trails, -- paths, diagrams, lists of points, and so on, depending on the -- context. -- -- To write a function with a signature like the above, you can of -- course call 'trailLike' directly; more typically, one would use -- one of the provided functions like 'fromOffsets', 'fromVertices', -- 'fromSegments', or '~~'. class (Metric (V t), OrderedField (N t)) => TrailLike t where trailLike :: Located (Trail (V t) (N t)) -- ^ The concretely located trail. Note -- that some trail-like things -- (e.g. 'Trail's) may ignore the -- location. -> t ------------------------------------------------------------ -- Instances --------------------------------------------- -- | A list of points is trail-like; this instance simply -- computes the vertices of the trail, using 'trailPoints'. instance (Metric v, OrderedField n) => TrailLike [Point v n] where trailLike = trailPoints -- | Lines are trail-like. If given a 'Trail' which contains a loop, -- the loop will be cut with 'cutLoop'. The location is ignored. instance (Metric v, OrderedField n) => TrailLike (Trail' Line v n) where trailLike = withTrail id cutLoop . unLoc -- | Loops are trail-like. If given a 'Trail' containing a line, the -- line will be turned into a loop using 'glueLine'. The location -- is ignored. instance (Metric v, OrderedField n) => TrailLike (Trail' Loop v n) where trailLike = withTrail glueLine id . unLoc -- | 'Trail's are trail-like; the location is simply ignored. instance (Metric v, OrderedField n) => TrailLike (Trail v n) where trailLike = unLoc -- | Translationally invariant things are trail-like as long as the -- underlying type is. instance TrailLike t => TrailLike (TransInv t) where trailLike = view _Unwrapped' . trailLike -- | 'Located' things are trail-like as long as the underlying type -- is. The location is taken to be the location of the input -- located trail. instance TrailLike t => TrailLike (Located t) where trailLike t = trailLike t `at` loc t ------------------------------------------------------------ -- Constructing TrailLike things ------------------------- ------------------------------------------------------------ -- | Construct a trail-like thing from a list of segments, with the -- origin as the location. -- -- <> -- -- > 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) (N t)] -> t fromSegments = fromLocSegments . (`at` origin) -- | Construct a trail-like thing from a located list of segments. fromLocSegments :: TrailLike t => Located [Segment Closed (V t) (N t)] -> t fromLocSegments = trailLike . mapLoc trailFromSegments -- | Construct a trail-like thing of linear segments from a list -- of offsets, with the origin as the location. -- -- <> -- -- > fromOffsetsEx = fromOffsets -- > [ unitX -- > , unitX # rotateBy (1/6) -- > , unitX # rotateBy (-1/6) -- > , unitX -- > ] -- > # centerXY # pad 1.1 fromOffsets :: TrailLike t => [Vn t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. fromLocOffsets :: (V t ~ v, N t ~ n, V (v n) ~ v, N (v n) ~ n, TrailLike t) => Located [v n] -> t fromLocOffsets = trailLike . mapLoc trailFromOffsets -- | Construct a trail-like thing connecting the given vertices with -- linear segments, with the first vertex as the location. If no -- vertices are given, the empty trail is used with the origin as -- the location. -- -- <> -- -- > 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) (N t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) segmentsFromVertices :: (Additive v, Num n) => [Point v n] -> [Segment Closed v n] segmentsFromVertices [] = [] 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 (~~) :: (V t ~ v, N t ~ n, TrailLike t) => Point v n -> Point v n -> 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 :: (V t ~ v, N t ~ n, TrailLike t) => Located (Trail v n) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diagrams-lib-1.3.1.4/src/Diagrams/Query.hs0000644000000000000000000000121412754644012016361 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Query -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A query is a function that maps points in a vector space to values -- in some monoid. Queries naturally form a monoid, with two queries -- being combined pointwise. -- ----------------------------------------------------------------------------- module Diagrams.Query ( Query(..), query, sample, value, resetValue, clearValue ) where import Diagrams.Core diagrams-lib-1.3.1.4/src/Diagrams/Tangent.hs0000644000000000000000000001161012754644012016655 0ustar0000000000000000{-# LANGUAGE GADTs #-} -- for ghc < 7.8, TypeFamilies covers GADT patten mathcing in > 7.8 {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# 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 ( -- ** Tangents tangentAtParam , tangentAtStart , tangentAtEnd -- ** Normals , normalAtParam , normalAtStart , normalAtEnd -- ** Tangent newtype , Tangent(..) ) where import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Linear.Vector import Linear.Metric import Linear.V2 ------------------------------------------------------------ -- 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 type instance N (Tangent t) = N t type instance Codomain (Tangent t) = V t instance DomainBounds t => DomainBounds (Tangent t) where domainLower (Tangent t) = domainLower t domainUpper (Tangent t) = domainUpper 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 V2 -> Double -> V2 Double@ -- -- * @Trail' Line V2 -> Double -> V2 Double@ -- -- * @Located (Trail V2) -> Double -> V2 Double@ -- -- See the instances listed for the 'Tangent' newtype for more. tangentAtParam :: Parametric (Tangent t) => t -> N t -> Vn 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 -> Vn t tangentAtStart = atStart . Tangent -- | Compute the tangent vector at the end of a segment or trail. tangentAtEnd :: EndValues (Tangent t) => t -> Vn t tangentAtEnd = atEnd . Tangent -------------------------------------------------- -- Segment instance (Additive v, Num n) => Parametric (Tangent (Segment Closed v n)) 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 (Additive v, Num n) => EndValues (Tangent (Segment Closed v n)) 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 instance (Additive v, Num n) => Parametric (Tangent (FixedSegment v n)) where atParam (Tangent fSeg) = atParam $ Tangent (fromFixedSeg fSeg) instance (Additive v, Num n) => EndValues (Tangent (FixedSegment v n)) where atStart (Tangent fSeg) = atStart $ Tangent (fromFixedSeg fSeg) atEnd (Tangent fSeg) = atEnd $ Tangent (fromFixedSeg fSeg) ------------------------------------------------------------ -- 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 V2 Double -> Double -> V2 Double@ -- -- * @Trail' Line V2 Double -> Double -> V2 Double@ -- -- * @Located (Trail V2 Double) -> Double -> V2 Double@ -- -- See the instances listed for the 'Tangent' newtype for more. normalAtParam :: (InSpace V2 n t, Parametric (Tangent t), Floating n) => t -> n -> V2 n normalAtParam t p = normize (t `tangentAtParam` p) -- | Compute the normal vector at the start of a segment or trail. normalAtStart :: (InSpace V2 n t, EndValues (Tangent t), Floating n) => t -> V2 n normalAtStart = normize . tangentAtStart -- | Compute the normal vector at the end of a segment or trail. normalAtEnd :: (InSpace V2 n t, EndValues (Tangent t), Floating n) => t -> V2 n normalAtEnd = normize . tangentAtEnd -- | Construct a normal vector from a tangent. normize :: Floating n => V2 n -> V2 n normize = negated . perp . signorm diagrams-lib-1.3.1.4/src/Diagrams/Trace.hs0000644000000000000000000000375012754644012016321 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trace -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- \"Traces\", aka embedded raytracers, for finding points on the edge -- of a diagram. See "Diagrams.Core.Trace" for internal -- implementation details. -- ----------------------------------------------------------------------------- module Diagrams.Trace ( -- * Types Trace, Traced -- * Diagram traces , trace, setTrace, withTrace -- * Querying traces , traceV, traceP, maxTraceV, maxTraceP -- * Subdiagram traces , boundaryFrom, boundaryFromMay ) where import Diagrams.Core (OrderedField, Point, Subdiagram, location, origin, setTrace, trace) import Diagrams.Core.Trace import Data.Maybe import Data.Semigroup import Diagrams.Combinators (withTrace) import Linear.Metric import Linear.Vector -- | 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 :: (OrderedField n, Metric v, Semigroup m) => Subdiagram b v n m -> v n -> Point v n 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 :: (Metric v, OrderedField n, Semigroup m) => Subdiagram b v n m -> v n -> Maybe (Point v n) boundaryFromMay s v = traceP (location s) (negated v) s diagrams-lib-1.3.1.4/src/Diagrams/Angle.hs0000644000000000000000000001551312754644012016311 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Angle -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Type for representing angles. -- ----------------------------------------------------------------------------- module Diagrams.Angle ( -- * Angle type Angle -- ** Using angles , (@@), rad, turn, deg -- ** Common angles , fullTurn, halfTurn, quarterTurn -- ** Trigonometric functions , sinA, cosA, tanA , asinA, acosA, atanA, atan2A, atan2A' -- ** Angle utilities , angleBetween, angleRatio, normalizeAngle -- ** Classes , HasTheta(..) , HasPhi(..) ) where import Control.Applicative import Control.Lens (AReview, Iso', Lens', iso, over, review, (^.)) import Data.Fixed import Data.Monoid hiding ((<>)) import Data.Semigroup import Text.Read import Prelude import Diagrams.Core (OrderedField) import Diagrams.Core.V import Diagrams.Points import Linear.Metric import Linear.Vector -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. newtype Angle n = Radians n deriving (Eq, Ord, Enum, Functor) instance Show n => Show (Angle n) where showsPrec d (Radians a) = showParen (d > 5) $ showsPrec 6 a . showString " @@ rad" instance Read n => Read (Angle n) where readPrec = parens . prec 5 $ do x <- readPrec Symbol "@@" <- lexP Ident "rad" <- lexP pure (Radians x) type instance N (Angle n) = n instance Applicative Angle where pure = Radians {-# INLINE pure #-} Radians f <*> Radians x = Radians (f x) {-# INLINE (<*>) #-} instance Additive Angle where zero = pure 0 {-# INLINE zero #-} instance Num n => Semigroup (Angle n) where (<>) = (^+^) {-# INLINE (<>) #-} instance Num n => Monoid (Angle n) where mappend = (<>) mempty = Radians 0 -- | The radian measure of an 'Angle' @a@ can be accessed as @a '^.' -- rad@. A new 'Angle' can be defined in radians as @pi \@\@ -- rad@. rad :: Iso' (Angle n) n rad = iso (\(Radians r) -> r) Radians {-# INLINE rad #-} -- | The measure of an 'Angle' @a@ in full circles can be accessed as -- @a '^.' turn@. A new 'Angle' of one-half circle can be defined in as -- @1/2 \@\@ turn@. turn :: Floating n => Iso' (Angle n) n turn = iso (\(Radians r) -> r / (2*pi)) (Radians . (*(2*pi))) {-# INLINE turn #-} -- | The degree measure of an 'Angle' @a@ can be accessed as @a -- '^.' deg@. A new 'Angle' can be defined in degrees as @180 \@\@ -- deg@. deg :: Floating n => Iso' (Angle n) n deg = iso (\(Radians r) -> r / (2*pi/360)) (Radians . ( * (2*pi/360))) {-# INLINE deg #-} -- | An angle representing one full turn. fullTurn :: Floating v => Angle v fullTurn = 1 @@ turn -- | An angle representing a half turn. halfTurn :: Floating v => Angle v halfTurn = 0.5 @@ turn -- | An angle representing a quarter turn. quarterTurn :: Floating v => Angle v quarterTurn = 0.25 @@ turn -- | Calculate ratio between two angles. angleRatio :: Floating n => Angle n -> Angle n -> n angleRatio a b = (a ^. rad) / (b ^. rad) -- | The sine of the given @Angle@. sinA :: Floating n => Angle n -> n sinA (Radians r) = sin r -- | The cosine of the given @Angle@. cosA :: Floating n => Angle n -> n cosA (Radians r) = cos r -- | The tangent function of the given @Angle@. tanA :: Floating n => Angle n -> n tanA (Radians r) = tan r -- | The @Angle@ with the given sine. asinA :: Floating n => n -> Angle n asinA = Radians . asin -- | The @Angle@ with the given cosine. acosA :: Floating n => n -> Angle n acosA = Radians . acos -- | The @Angle@ with the given tangent. atanA :: Floating n => n -> Angle n atanA = Radians . atan -- | @atan2A y x@ is the angle between the positive x-axis and the vector given -- by the coordinates (x, y). The 'Angle' returned is in the [-pi,pi] range. atan2A :: RealFloat n => n -> n -> Angle n atan2A y x = Radians $ atan2 y x -- | Similar to 'atan2A' but without the 'RealFloat' constraint. This means it -- doesn't handle negative zero cases. However, for most geometric purposes, -- the outcome will be the same. atan2A' :: OrderedField n => n -> n -> Angle n atan2A' y x = atan2' y x @@ rad -- atan2 without negative zero tests atan2' :: OrderedField n => n -> n -> n atan2' y x | x > 0 = atan (y/x) | x == 0 && y > 0 = pi/2 | x < 0 && y > 0 = pi + atan (y/x) | x <= 0 && y < 0 = -atan2' (-y) x | y == 0 && x < 0 = pi -- must be after the previous test on zero y | x==0 && y==0 = y -- must be after the other double zero tests | otherwise = x + y -- x or y is a NaN, return a NaN (via +) -- | @30 \@\@ deg@ is an 'Angle' of the given measure and units. -- -- >>> pi @@ rad -- 3.141592653589793 @@ rad -- -- >>> 1 @@ turn -- 6.283185307179586 @@ rad -- -- >>> 30 @@ deg -- 0.5235987755982988 @@ rad -- -- For 'Iso''s, ('@@') reverses the 'Iso'' on its right, and applies -- the 'Iso'' to the value on the left. 'Angle's are the motivating -- example where this order improves readability. -- -- This is the same as a flipped 'review'. -- -- @ -- ('@@') :: a -> 'Iso'' s a -> s -- ('@@') :: a -> 'Prism'' s a -> s -- ('@@') :: a -> 'Review' s a -> s -- ('@@') :: a -> 'Equality'' s a -> s -- @ (@@) :: b -> AReview a b -> a a @@ i = review i a infixl 5 @@ -- | Compute the positive angle between the two vectors in their common plane. -- Returns NaN if either of the vectors are zero. angleBetween :: (Metric v, Floating n) => v n -> v n -> Angle n angleBetween v1 v2 = acosA (signorm v1 `dot` signorm v2) -- N.B.: Currently discards the common plane information. -- | Normalize an angle so that it lies in the [0,tau) range. normalizeAngle :: (Floating n, Real n) => Angle n -> Angle n normalizeAngle = over rad (`mod'` (2 * pi)) ------------------------------------------------------------ -- Polar Coordinates -- | The class of types with at least one angle coordinate, called '_theta'. class HasTheta t where _theta :: RealFloat n => Lens' (t n) (Angle n) -- | The class of types with at least two angle coordinates, the second called -- '_phi'. '_phi' is the positive angle measured from the z axis. class HasTheta t => HasPhi t where _phi :: RealFloat n => Lens' (t n) (Angle n) -- Point instances instance HasTheta v => HasTheta (Point v) where _theta = lensP . _theta {-# INLINE _theta #-} instance HasPhi v => HasPhi (Point v) where _phi = lensP . _phi {-# INLINE _phi #-} diagrams-lib-1.3.1.4/src/Diagrams/Points.hs0000644000000000000000000000220712754644012016533 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Points -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Points in space. For more tools for working with points and -- vectors, see "Linear.Affine". -- ----------------------------------------------------------------------------- module Diagrams.Points ( -- * Points Point (..), origin, (*.) -- * Point-related utilities , centroid , pointDiagram , _Point, lensP ) where import Diagrams.Core (pointDiagram) import Diagrams.Core.Points import Data.Foldable as F import Linear.Affine import Linear.Vector -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (Additive v, Fractional n) => [Point v n] -> Point v n centroid = meanV meanV :: (Foldable f, Additive v, Fractional a) => f (v a) -> v a meanV = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) {-# INLINE meanV #-} diagrams-lib-1.3.1.4/src/Diagrams/Animation.hs0000644000000000000000000001207312754644012017200 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Animation -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- An animation is a time-varying diagram, together with start and end -- times. Most of the tools for working with animations can actually -- be found in the @active@ package, which defines the 'Active' type. -- -- XXX more documentation and examples should go here -- ----------------------------------------------------------------------------- module Diagrams.Animation ( -- * Types for animations QAnimation , Animation -- * Animation combinators and tools -- $animComb , animEnvelope, animEnvelope' , animRect, animRect' ) where import Data.Active #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) import Data.Foldable (foldMap) #endif import Data.Semigroup import Diagrams.Core import Diagrams.Animation.Active () import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.TrailLike import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types import Linear.Metric -- | A value of type @QAnimation b v m@ is an animation (a -- time-varying diagram with start and end times) that can be -- rendered by backspace @b@, with vector space @v@ and monoidal -- annotations of type @m@. type QAnimation b v n m = Active (QDiagram b v n m) -- | A value of type @Animation b v@ is an animation (a time-varying -- diagram with start and end times) in vector space @v@ that can be -- rendered by backspace @b@. -- -- Note that @Animation@ is actually a synonym for @QAnimation@ -- where the type of the monoidal annotations has been fixed to -- 'Any' (the default). type Animation b v n = QAnimation b v n Any -- $animComb -- Most combinators for working with animations are to be found in the -- @active@ package, which defines the 'Active' type. This module -- defines just a few combinators specifically for working with -- animated diagrams. -- It would be cool to have a variant of animEnvelope that tries to do -- some sort of smart adaptive sampling to get good results more -- quickly. One could also imagine trying to use some sort of -- automatic differentiation but that probably wouldn't work in all -- cases we want to handle. -- | Automatically assign fixed a envelope to the entirety of an -- animation by sampling the envelope at a number of points in time -- and taking the union of all the sampled envelopes to form the -- \"hull\". This hull is then used uniformly throughout the -- animation. -- -- This is useful when you have an animation that grows and shrinks -- in size or shape over time, but you want it to take up a fixed -- amount of space, /e.g./ so that the final rendered movie does not -- zoom in and out, or so that it occupies a fixed location with -- respect to another animation, when combining animations with -- something like '|||'. -- -- By default, 30 samples per time unit are used; to adjust this -- number see 'animEnvelope''. -- -- See also 'animRect' for help constructing a background to go -- behind an animation. animEnvelope :: (OrderedField n, Metric v, Monoid' m) => QAnimation b v n m -> QAnimation b v n m animEnvelope = animEnvelope' 30 -- | Like 'animEnvelope', but with an adjustible sample rate. The first -- 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. animEnvelope' :: (OrderedField n, Metric v, Monoid' m) => Rational -> QAnimation b v n m -> QAnimation b v n m animEnvelope' r a = withEnvelope (simulate r a) <$> a -- | @animRect@ works similarly to 'animEnvelope' for 2D diagrams, but -- instead of adjusting the envelope, simply returns the smallest -- bounding rectangle which encloses the entire animation. Useful -- for /e.g./ creating a background to go behind an animation. -- -- Uses 30 samples per time unit by default; to adjust this number -- see 'animRect''. animRect :: (InSpace V2 n t, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t) => QAnimation b V2 n m -> t animRect = animRect' 30 -- | Like 'animRect', but with an adjustible sample rate. The first -- 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' :: (InSpace V2 n t, Monoid' m, TrailLike t, Enveloped t, Transformable t, Monoid t) => Rational -> QAnimation b V2 n m -> t animRect' r anim | null results = rect 1 1 | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) where results = simulate r anim diagrams-lib-1.3.1.4/src/Diagrams/ThreeD.hs0000644000000000000000000000506712754644012016441 0ustar0000000000000000{-# 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.Deform" defines several R^3-specific -- non-affine transformations, such as projections. -- -- * "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. -- -- * "Diagrams.ThreeD.Align" defines many alignment combinators -- specialized to three dimensions. -- -- * "Diagrams.ThreeD.Attributes" defines 3D-specific attributes -- such as surface color, diffuse reflectance, and specular -- highlights. ----------------------------------------------------------------------------- module Diagrams.ThreeD ( module Diagrams.ThreeD.Align , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Deform , module Diagrams.ThreeD.Light , module Diagrams.ThreeD.Shapes , module Diagrams.ThreeD.Transform , module Diagrams.ThreeD.Types , module Diagrams.ThreeD.Vector ) where import Diagrams.ThreeD.Align import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera import Diagrams.ThreeD.Deform import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes import Diagrams.ThreeD.Transform import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector diagrams-lib-1.3.1.4/src/Diagrams/LinearMap.hs0000644000000000000000000001467012754644012017136 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.LinearMap -- Copyright : (c) 2014-2015 diagrams team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Linear maps. Unlike 'Transformation's these are not restricted to the -- same space. In practice these are used for projections in -- "Diagrams.ThreeD.Projection". Unless you want to work with -- projections you're probably better off using 'Diagrams.Transform'. -- -- Currently only path-like things can be projected. In the future we -- hope to support projecting diagrams. -- ----------------------------------------------------------------------------- module Diagrams.LinearMap ( -- * Linear maps LinearMap (..) , LinearMappable (..) -- ** Applying linear maps , linmap -- * Affine maps , AffineMap (..) , AffineMappable (..) -- ** Constructing affine maps , mkAffineMap , toAffineMap ) where import Control.Lens import Data.FingerTree as FT import qualified Data.Foldable as F import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Located import Diagrams.Path import Diagrams.Segment import Diagrams.Trail hiding (offset) import Linear.Affine import Linear.Metric import Linear.Vector -- | Type for holding linear maps. Note that these are not affine transforms so -- attemping apply a translation with 'LinearMap' will likely produce incorrect -- results. newtype LinearMap v u n = LinearMap { lapply :: v n -> u n } toLinearMap :: Transformation v n -> LinearMap v v n toLinearMap (Transformation (m :-: _) _ _) = LinearMap m -- | Class of things that have vectors that can be mapped over. class LinearMappable a b where -- | Apply a linear map to an object. If the map is not linear, -- behaviour will likely be wrong. vmap :: (Vn a -> Vn b) -> a -> b -- this uses a function instead of LinearMap so we can also use this -- class to change number types -- Note: instances need to be of the form -- -- r ~ A u m => LinearMappable (A v n) r -- -- so ghc knows there's only one possible result from calling vmap. -- | Apply a linear map. linmap :: (InSpace v n a, LinearMappable a b, N b ~ n) => LinearMap v (V b) n -> a -> b linmap = vmap . lapply instance r ~ Offset c u m => LinearMappable (Offset c v n) r where vmap f (OffsetClosed v) = OffsetClosed (f v) vmap _ OffsetOpen = OffsetOpen {-# INLINE vmap #-} instance r ~ Segment c u m => LinearMappable (Segment c v n) r where vmap f (Linear offset) = Linear (vmap f offset) vmap f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (vmap f offset) {-# INLINE vmap #-} instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ SegTree u m) => LinearMappable (SegTree v n) r where vmap f = over _Wrapped (fmap' (vmap f)) {-# INLINE vmap #-} instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail' l u m) => LinearMappable (Trail' l v n) r where vmap f (Line st) = Line (vmap f st) vmap f (Loop st offset) = Loop (vmap f st) (vmap f offset) {-# INLINE vmap #-} instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m) => LinearMappable (Trail v n) r where vmap f (Trail (Line st)) = Trail $ Line (vmap f st) vmap f (Trail (Loop st offset)) = Trail $ Loop (vmap f st) (vmap f offset) {-# INLINE vmap #-} instance LinearMappable (Point v n) (Point u m) where vmap f (P v) = P (f v) {-# INLINE vmap #-} instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where vmap f (FLinear p0 p1) = FLinear (vmap f p0) (vmap f p1) vmap f (FCubic p0 p1 p2 p3) = FCubic (vmap f p0) (vmap f p1) (vmap f p2) (vmap f p3) {-# INLINE vmap #-} instance (LinearMappable a b, r ~ Located b) => LinearMappable (Located a) r where vmap f (Loc p a) = Loc (vmap f p) (vmap f a) {-# INLINE vmap #-} instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m) => LinearMappable (Path v n) r where vmap f = _Wrapped . mapped %~ vmap f {-# INLINE vmap #-} -- | Affine linear maps. Unlike 'Transformation' these do not have to be -- invertible so we can map between spaces. data AffineMap v u n = AffineMap (LinearMap v u n) (u n) -- | Make an affine map from a linear function and a translation. mkAffineMap :: (v n -> u n) -> u n -> AffineMap v u n mkAffineMap f = AffineMap (LinearMap f) toAffineMap :: Transformation v n -> AffineMap v v n toAffineMap t = AffineMap (toLinearMap t) (transl t) class (LinearMappable a b, N a ~ N b) => AffineMappable a b where -- | Affine map over an object. Has a default implimentation of only -- applying the linear map amap :: (Additive (V a), F.Foldable (V a), Additive (V b), Num (N b)) => AffineMap (V a) (V b) (N b) -> a -> b amap (AffineMap f _) = linmap f {-# INLINE amap #-} instance r ~ Offset c u n => AffineMappable (Offset c v n) r instance r ~ Segment c u n => AffineMappable (Segment c v n) r instance (Metric v, Metric u, OrderedField n, r ~ SegTree u n) => AffineMappable (SegTree v n) r instance (Metric v, Metric u, OrderedField n, r ~ Trail' l u n) => AffineMappable (Trail' l v n) r instance (Metric v, Metric u, OrderedField n, r ~ Trail u n) => AffineMappable (Trail v n) r instance (Additive v, Num n, r ~ Point u n) => AffineMappable (Point v n) r where amap (AffineMap f v) p = linmap f p .+^ v {-# INLINE amap #-} instance r ~ FixedSegment u n => AffineMappable (FixedSegment v n) r where amap m (FLinear p0 p1) = FLinear (amap m p0) (amap m p1) amap m (FCubic p0 p1 p2 p3) = FCubic (amap m p0) (amap m p1) (amap m p2) (amap m p3) {-# INLINE amap #-} instance (LinearMappable a b, N a ~ N b, r ~ Located b) => AffineMappable (Located a) r where amap m@(AffineMap l _) (Loc p x) = Loc (amap m p) (linmap l x) {-# INLINE amap #-} instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => AffineMappable (Path v n) r where amap m = _Wrapped . mapped %~ amap m {-# INLINE amap #-} diagrams-lib-1.3.1.4/src/Diagrams/Prelude.hs0000644000000000000000000000712512754644012016663 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Prelude -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A module to re-export most of the functionality of the diagrams -- core and standard library. -- ----------------------------------------------------------------------------- module Diagrams.Prelude ( -- * Diagrams library -- | Exports from this library for working with diagrams. module Diagrams -- * Convenience re-exports from other packages -- | For working with default values. Diagrams also exports 'with', -- an alias for 'def'. , module Data.Default.Class -- | For representing and operating on colors. , module Data.Colour -- | A large list of color names. , module Data.Colour.Names -- | Specify your own colours. , module Data.Colour.SRGB -- | Semigroups and monoids show up all over the place, so things from -- Data.Semigroup and Data.Monoid often come in handy. , module Data.Semigroup -- | For computing with vectors. , module Linear.Vector -- | For computing with points and vectors. , module Linear.Affine -- | For computing with dot products and norm. , module Linear.Metric -- | For working with 'Active' (i.e. animated) things. , module Data.Active -- | Most of the lens package. The following functions are not -- exported from lens because they either conflict with -- diagrams or may conflict with other libraries: -- -- * 'Control.Lens.At.at' -- * 'Control.Lens.At.contains' -- * 'Control.Lens.Indexed..>' -- * 'Control.Lens.Indexed.<.>' -- * 'Control.Lens.Indexed.index' -- * 'Control.Lens.Indexed.indices' -- * 'Control.Lens.Indexed.none' -- * 'Control.Lens.Internal.Getter.coerce' -- * 'Control.Lens.Internal.Indexed.indexed' -- * 'Control.Lens.Lens.inside' -- * 'Control.Lens.Level.levels' -- * 'Control.Lens.Plated....' -- * 'Control.Lens.Plated.children' -- * 'Control.Lens.Plated.transform' -- * 'Control.Lens.Prism.outside' -- * 'Control.Lens.Setter.argument' -- * 'Control.Lens.Traversal.beside' -- * 'Control.Lens.Traversal.singular' , module Control.Lens , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where import Diagrams import Control.Applicative #if MIN_VERSION_lens(4,13,0) import Control.Lens hiding (argument, at, backwards, beside, children, contains, indexed, indices, inside, levels, none, outside, singular, transform, ( # ), (...), (.>), (<.>)) #else import Control.Lens hiding (argument, at, backwards, beside, children, coerce, contains, indexed, indices, inside, levels, none, outside, singular, transform, ( # ), (...), (.>), (<.>)) #endif import Data.Active import Data.Colour hiding (AffineSpace (..), atop, over) import Data.Colour.Names hiding (tan) import Data.Colour.SRGB import Data.Default.Class import Data.Semigroup import Linear.Affine import Linear.Metric import Linear.Vector diagrams-lib-1.3.1.4/src/Diagrams/Parametric.hs0000644000000000000000000001560212754644012017351 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Parametric -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Type classes for things which are parameterized in some way, /e.g./ -- segments and trails. -- ----------------------------------------------------------------------------- module Diagrams.Parametric ( stdTolerance , Codomain, Parametric(..) , DomainBounds(..), domainBounds, EndValues(..), Sectionable(..), HasArcLength(..) ) where import Diagrams.Core.V import qualified Numeric.Interval.Kaucher as I -- | Codomain of parametric classes. This is usually either @(V p)@, for relative -- vector results, or @(Point (V p))@, for functions with absolute coordinates. type family Codomain p :: * -> * -- | Type class for parametric functions. class Parametric p where -- | 'atParam' yields a parameterized view of an object as a -- continuous function. It is designed to be used infix, like @path -- ``atParam`` 0.5@. atParam :: p -> N p -> Codomain p (N p) -- | Type class for parametric functions with a bounded domain. The -- default bounds are @[0,1]@. -- -- Note that this domain indicates the main \"interesting\" portion of the -- function. It must be defined within this range, but for some instances may -- still have sensible values outside. class DomainBounds p where -- | 'domainLower' defaults to being constantly 0 (for vector spaces with -- numeric scalars). domainLower :: p -> N p default domainLower :: Num (N p) => p -> N p domainLower = const 0 -- | 'domainUpper' defaults to being constantly 1 (for vector spaces -- with numeric scalars). domainUpper :: p -> N p default domainUpper :: Num n => p -> n domainUpper = const 1 -- | Type class for querying the values of a parametric object at the -- ends of its domain. class (Parametric p, DomainBounds p) => EndValues p where -- | 'atStart' is the value at the start of the domain. That is, -- -- > atStart x = x `atParam` domainLower x -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. atStart :: p -> Codomain p (N p) atStart x = x `atParam` domainLower x -- | 'atEnd' is the value at the end of the domain. That is, -- -- > atEnd x = x `atParam` domainUpper x -- -- This is the default implementation, but some representations will -- have a more efficient and/or precise implementation. atEnd :: p -> Codomain p (N p) atEnd x = x `atParam` domainUpper x -- | Return the lower and upper bounds of a parametric domain together -- as a pair. domainBounds :: DomainBounds p => p -> (N p, N p) domainBounds x = (domainLower x, domainUpper x) -- | Type class for parametric objects which can be split into -- subobjects. -- -- 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 -- portion of @p@ for parameter values from @0@ to @t@ and @r@ for -- to that from @t@ to @1@. The following property should hold: -- -- @ -- prop_splitAtParam f t u = -- | u < t = atParam f u == atParam l (u / t) -- | otherwise = atParam f u == atParam f t ??? atParam l ((u - t) / (domainUpper f - t)) -- where (l,r) = splitAtParam f t -- @ -- -- where @(???) = (^+^)@ if the codomain is a vector type, or -- @const flip@ if the codomain is a point type. Stated more -- intuitively, all this is to say that the parameterization -- scales linearly with splitting. -- -- 'splitAtParam' can also be used with parameters outside the -- range of the domain. For example, using the parameter @2@ with -- a path (where the domain is the default @[0,1]@) gives two -- result paths where the first is the original path extended to -- the parameter 2, and the second result path travels /backwards/ -- from the end of the first to the end of the original path. splitAtParam :: p -> N p -> (p, p) splitAtParam x t = ( section x (domainLower x) t , section x t (domainUpper x)) -- | Extract a particular section of the domain, linearly -- reparameterized to the same domain as the original. Should -- satisfy the property: -- -- > prop_section x l u t = -- > let s = section x l u -- > in domainBounds x == domainBounds x -- > && (x `atParam` lerp l u t) == (s `atParam` t) -- -- That is, the section should have the same domain as the -- original, and the reparameterization should be linear. section :: p -> N p -> N p -> p default section :: Fractional (N p) => p -> N p -> N p -> p section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) -- | Flip the parameterization on the domain. reverseDomain :: p -> p -- | The standard tolerance used by @std...@ functions (like -- 'stdArcLength' and 'stdArcLengthToParam', currently set at -- @1e-6@. stdTolerance :: Fractional a => a stdTolerance = 1e-6 -- | Type class for parametric things with a notion of arc length. class Parametric p => HasArcLength p where -- | @arcLengthBounded eps x@ approximates the arc length of @x@. -- The true arc length is guaranteed to lie within the interval -- returned, which will have a size of at most @eps@. arcLengthBounded :: N p -> p -> I.Interval (N p) -- | @arcLength eps s@ approximates the arc length of @x@ up to the -- accuracy @eps@ (plus or minus). arcLength :: N p -> p -> N p default arcLength :: Fractional (N p) => N p -> p -> N p arcLength eps = I.midpoint . arcLengthBounded eps -- | Approximate the arc length up to a standard accuracy of -- 'stdTolerance' (@1e-6@). stdArcLength :: p -> N p default stdArcLength :: Fractional (N p) => p -> N p stdArcLength = arcLength stdTolerance -- | @'arcLengthToParam' eps s l@ converts the absolute arc length -- @l@, measured from the start of the domain, to a parameter on -- the object @s@. The true arc length at the parameter returned -- is guaranteed to be within @eps@ of the requested arc length. -- -- This should work for /any/ arc length, and may return any -- parameter value (not just parameters in the domain). arcLengthToParam :: N p -> p -> N p -> N p -- | A simple interface to convert arc length to a parameter, -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. stdArcLengthToParam :: p -> N p -> N p default stdArcLengthToParam :: Fractional (N p) => p -> N p -> N p stdArcLengthToParam = arcLengthToParam stdTolerance diagrams-lib-1.3.1.4/src/Diagrams/CubicSpline/0000755000000000000000000000000012754644012017122 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/CubicSpline/Internal.hs0000644000000000000000000000445412754644012021241 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.CubicSpline -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A /cubic spline/ is a smooth, connected sequence of cubic curves -- passing through a given sequence of points. This module implements -- a straightforward spline generation algorithm based on solving -- tridiagonal systems of linear equations. -- ----------------------------------------------------------------------------- module Diagrams.CubicSpline.Internal ( -- * Solving for spline coefficents solveCubicSplineDerivatives , solveCubicSplineDerivativesClosed , solveCubicSplineCoefficients ) where import Diagrams.Solve.Tridiagonal import Data.List -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. solveCubicSplineDerivatives :: Fractional a => [a] -> [a] solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds where as = replicate (l - 1) 1 bs = 2 : replicate (l - 2) 4 ++ [2] l = length ds ds = zipWith f (xs ++ [last xs]) (x:x:xs) f a b = 3*(a - b) solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives must be nonempty" -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 where as = replicate (l - 1) 1 bs = replicate l 4 l = length xs xs' = cycle xs ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') f a b = 3*(a - b) -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] solveCubicSplineCoefficients closed xs = [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1] | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds') ] where ds | closed = solveCubicSplineDerivativesClosed xs | otherwise = solveCubicSplineDerivatives xs close as | closed = as ++ [head as] | otherwise = as xs' = close xs ds' = close ds diagrams-lib-1.3.1.4/src/Diagrams/TwoD/0000755000000000000000000000000012754644012015577 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Arrowheads.hs0000644000000000000000000002740412754644012020241 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- 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 , halfDart , spike , thorn , lineHead , noHead -- ** Configurable arrowheads -- | Creates arrowheads of the same shape as the standard heads but -- where the angle parameter is used to specify the angle to the top -- left point of the arrowhead. , arrowheadTriangle , arrowheadDart , arrowheadHalfDart , arrowheadSpike , arrowheadThorn -- * Arrow tails -- ** Standard arrow tails , tri' , dart' , halfDart' , spike' , thorn' , lineTail , noTail , quill , block -- ** Configurable arrow tails , arrowtailQuill , arrowtailBlock -- * Internals , ArrowHT ) where import Control.Lens ((&), (.~), (<>~), (^.)) import Data.Default.Class import Data.Monoid (mempty, (<>)) import Diagrams.Angle import Diagrams.Core import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (fromOffsets) import Diagrams.TwoD.Align import Diagrams.TwoD.Arc (arc') import Diagrams.TwoD.Path () import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) import Linear.Affine import Linear.Metric import Linear.Vector ----------------------------------------------------------------------------- type ArrowHT n = n -> n -> (Path V2 n, Path V2 n) closedPath :: OrderedField n => Trail V2 n -> Path V2 n closedPath = pathFromTrail . closeTrail -- Heads ------------------------------------------------------------------ -- > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw none -- > & headLength .~ local 0.5) -- > origin (r2 (1, 0)) -- > <> square 0.5 # alignL # lw none # frame 0.1 -- | Isoceles triangle style. The above example specifies an angle of `2/5 Turn`. -- | <> -- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn) -- > & shaftStyle %~ lw none & headLength .~ local 0.5) -- > origin (r2 (0.5, 0)) -- > <> square 0.6 # alignL # lw none # frame 0.1 arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n arrowheadTriangle theta = aHead where aHead len _ = (p, mempty) where psi = pi - (theta ^. rad) r = len / (1 + cos psi) p = polygon (def & polyType .~ PolyPolar [theta, (-2) *^ theta] (repeat r) & polyOrient .~ NoOrient) # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. arrowheadDart :: RealFloat n => Angle n -> ArrowHT n arrowheadDart theta len shaftWidth = (hd # scale sz, jt) where hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] v = rotate theta unitX (t1, t2) = (unit_X ^+^ v, V2 (-0.5) 0 ^-^ v) [b1, b2] = map (reflectY . negated) [t1, t2] psi = pi - negated t2 ^. _theta . rad jLength = shaftWidth / (2 * tan psi) -- If the shaft is too wide, set the size to a default value of 1. sz = max 1 ((len - jLength) / 1.5) -- | Top half of an 'arrowheadDart'. arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n arrowheadHalfDart theta len shaftWidth = (hd, jt) where hd = fromOffsets [t1, t2] # closeTrail # pathFromTrail # translateX 1.5 # scale sz # translateY (-shaftWidth/2) # snugL jt = snugR . translateY (-shaftWidth/2) . pathFromTrail . closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 shaftWidth] v = rotate theta unitX (t1, t2) = (unit_X ^+^ v, (0.5 *^ unit_X) ^-^ v) psi = pi - negated t2 ^. _theta . rad jLength = shaftWidth / tan psi -- If the shaft is too wide, set the size to a default value of 1. sz = max 1 ((len - jLength) / 1.5) -- | Isoceles triangle with curved concave base. Inkscape type 2. arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 jt = alignR . centerY . pathFromTrail . closeTrail $ arc' 1 (xDir & _theta <>~ negated phi) (2 *^ phi) l1 = trailFromSegments [straight $ unit_X ^+^ v] l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ reflectY v)] c = arc' 1 (rotate α xDir) ((-2) *^ α) α = (1/2 @@ turn) ^-^ theta v = rotate theta unitX -- The length of the head without its joint is, -2r cos theta and -- the length of the joint is r - sqrt (r^2 - y^2). So the total -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2). -- Solving the quadratic gives two roots, we want the larger one. -- 1/4 turn < theta < 2/3 turn. a = 1 - 2 * cos (theta ^. rad) y = shaftWidth / 2 -- If the shaft is too wide for the head, we default the radius r to -- 2/3 * len by setting d=1 and phi=pi/2. d = max 1 (len**2 + (1 - a**2) * y**2) r = (a * len + sqrt d) / (a**2 -1) phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n arrowheadThorn theta len shaftWidth = (hd # scale sz, jt) where hd = snugL . pathFromTrail . glueTrail $ hTop <> reflectY hTop hTop = closeTrail . trailFromSegments $ [c, l] jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [V2 (-jLength) 0, V2 0 (shaftWidth / 2)] c = curvedSide theta v = rotate theta unitX l = reverseSegment . straight $ t t = v ^-^ V2 (-0.5) 0 psi = fullTurn ^/ 2 ^-^ (negated t ^. _theta) jLength = shaftWidth / (2 * tanA psi) -- If the shaft if too wide, set the size to a default value of 1. sz = max 1 ((len - jLength) / 1.5) -- | Make a side for the thorn head. curvedSide :: Floating n => Angle n -> Segment Closed V2 n curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X v1 = rotate theta unitX ctrl1 = v0 ctrl2 = v0 ^+^ v1 end = v0 ^+^ v1 -- Standard heads --------------------------------------------------------- -- | A line the same width as the shaft. lineHead :: RealFloat n => ArrowHT n lineHead s w = (square 1 # scaleX s # scaleY w # alignL, mempty) noHead :: ArrowHT n noHead _ _ = (mempty, mempty) -- | <> -- > triEx = drawHead tri tri :: RealFloat n => ArrowHT n tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike spike :: RealFloat n => ArrowHT n spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn thorn :: RealFloat n => ArrowHT n thorn = arrowheadThorn (3/8 @@ turn) -- | <> -- > dartEx = drawHead dart dart :: RealFloat n => ArrowHT n dart = arrowheadDart (2/5 @@ turn) -- | <> -- > halfDartEx = drawHead halfDart halfDart :: RealFloat n => ArrowHT n halfDart = arrowheadHalfDart (2/5 @@ turn) -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw none -- > & arrowHead .~ noHead & tailLength .~ local 0.5) -- > origin (r2 (1, 0)) -- > <> square 0.5 # alignL # lw none # frame 0.1 -- | Utility function to convert any arrowhead to an arrowtail, i.e. -- attached at the start of the trail. headToTail :: OrderedField n => ArrowHT n -> ArrowHT n headToTail hd = tl where tl sz shaftWidth = (t, j) where (t', j') = hd sz shaftWidth t = reflectX t' j = reflectX j' arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n arrowtailBlock theta = aTail where aTail len _ = (t, mempty) where t = rect len (len * x) # alignR a' :: V2 n a' = rotate theta unitX a = a' ^-^ reflectY a' x = norm a -- | The angle is where the top left corner intersects the circle. arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n arrowtailQuill theta = aTail where aTail len shaftWidth = (t, j) where t = closedPath (trailFromVertices [v0, v1, v2, v3, v4, v5, v0]) # scale sz # alignR sz = len / 0.6 v0 = p2 (0.5, 0) v2 = origin .+^ (rotate theta unitX # scale 0.5) v1 = v2 # translateX (5/8) v3 = p2 (-0.1, 0) v4 = v2 # reflectY v5 = v4 # translateX (5/8) s = 1 - shaftWidth / norm (v1 .-. v5) n1 = v0 # translateY (0.5 * shaftWidth) n2 = v1 .-^ ((v1 .-. v0) # scale s) n3 = v5 .-^ ((v5 .-. v0) # scale s) n4 = n1 # reflectY j = closedPath $ trailFromVertices [v0, n1, n2, v0, n3, n4, v0] -- Standard tails --------------------------------------------------------- -- | A line the same width as the shaft. lineTail :: RealFloat n => ArrowHT n lineTail s w = (square 1 # scaleY w # scaleX s # alignR, mempty) noTail :: ArrowHT n noTail _ _ = (mempty, mempty) -- | <> -- > tri'Ex = drawTail tri' tri' :: RealFloat n => ArrowHT n tri' = headToTail tri -- | <> -- > spike'Ex = drawTail spike' spike' :: RealFloat n => ArrowHT n spike' = headToTail spike -- | <> -- > thorn'Ex = drawTail thorn' thorn' :: RealFloat n => ArrowHT n thorn' = headToTail thorn -- | <> -- > dart'Ex = drawTail dart' dart' :: RealFloat n => ArrowHT n dart' = headToTail dart -- | <> -- > halfDart'Ex = drawTail halfDart' halfDart' :: RealFloat n => ArrowHT n halfDart' = headToTail halfDart -- | <> -- > quillEx = drawTail quill quill :: (Floating n, Ord n) => ArrowHT n quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block block :: RealFloat n => ArrowHT n block = arrowtailBlock (7/16 @@ turn) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Deform.hs0000644000000000000000000000255012754644012017351 0ustar0000000000000000module Diagrams.TwoD.Deform where import Control.Lens import Diagrams.Deform import Linear.V2 import Linear.Vector -- | The parallel projection onto the plane x=0 parallelX0 :: (R1 v, Num n) => Deformation v v n parallelX0 = Deformation (_x .~ 0) -- | The perspective division onto the plane x=1 along lines going -- through the origin. perspectiveX1 :: (R1 v, Functor v, Fractional n) => Deformation v v n perspectiveX1 = Deformation $ \p -> p ^/ (p ^. _x) -- | The parallel projection onto the plane y=0 parallelY0 :: (R2 v, Num n) => Deformation v v n parallelY0 = Deformation (_y .~ 0) -- | The perspective division onto the plane y=1 along lines going -- through the origin. perspectiveY1 :: (R2 v, Functor v, Floating n) => Deformation v v n perspectiveY1 = Deformation $ \p -> p ^/ (p ^. _y) -- | The viewing transform for a viewer facing along the positive X -- axis. X coördinates stay fixed, while Y coördinates are compressed -- with increasing distance. @asDeformation (translation unitX) <> -- parallelX0 <> frustrumX = perspectiveX1@ facingX :: (R1 v, Functor v, Fractional n) => Deformation v v n facingX = Deformation $ \p -> let x = p ^. _x in p ^/ x & _x .~ x facingY :: (R2 v, Functor v, Fractional n) => Deformation v v n facingY = Deformation $ \p -> let y = p ^. _y in p ^/ y & _y .~ y diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Combinators.hs0000644000000000000000000002536412754644012020425 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Combinators -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Diagram combinators specialized to two dimensions. For more general -- combinators, see "Diagrams.Combinators". -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Combinators ( -- * Binary combinators (===), (|||) -- * n-ary combinators , hcat, hcat', hsep , vcat, vcat', vsep -- * Spacing/envelopes , strutR2 , strutX, strutY , padX, padY , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop , rectEnvelope , boundingRect, bg, bgFrame ) where import Control.Lens ((&), (.~)) import Data.Colour import Data.Default.Class import Data.Semigroup import Diagrams.Core import Diagrams.Attributes (lwO) import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align import Diagrams.TwoD.Attributes (fc) import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util (( # )) import Linear.Affine import Linear.Metric import Linear.Vector infixl 6 === infixl 6 ||| -- | Place two diagrams (or other objects) vertically adjacent to one -- another, with the first diagram above the second. Since Haskell -- ignores whitespace in expressions, one can thus write -- -- @ -- c -- === -- d -- @ -- -- 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 -- documentation of 'beside' for more information. (===) :: (InSpace V2 n a, Juxtaposable a, Semigroup a) => a -> a -> a (===) = beside unit_Y -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of -- the second. 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 -- documentation of 'beside' for more information. (|||) :: (InSpace V2 n a, Juxtaposable a, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Lay out a list of juxtaposable objects in a row from left to right, -- so that their local origins lie along a single horizontal line, -- with successive envelopes tangent to one another. -- -- * For more control over the spacing, see 'hcat''. -- -- * To align the diagrams vertically (or otherwise), use alignment -- combinators (such as 'alignT' or 'alignB') from -- "Diagrams.TwoD.Align" before applying 'hcat'. -- -- * For non-axis-aligned layout, see 'cat'. hcat :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a hcat = hcat' def -- | A variant of 'hcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'hsep'. hcat' :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => CatOpts n -> [a] -> a hcat' = cat' unitX -- | A convenient synonym for horizontal concatenation with -- separation: @hsep s === hcat' (with & sep .~ s)@. hsep :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => n -> [a] -> a hsep s = hcat' (def & sep .~ s) -- | Lay out a list of juxtaposable objects in a column from top to -- bottom, so that their local origins lie along a single vertical -- line, with successive envelopes tangent to one another. -- -- * For more control over the spacing, see 'vcat''. -- -- * To align the diagrams horizontally (or otherwise), use alignment -- combinators (such as 'alignL' or 'alignR') from -- "Diagrams.TwoD.Align" before applying 'vcat'. -- -- * For non-axis-aligned layout, see 'cat'. vcat :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => [a] -> a vcat = vcat' def -- | A variant of 'vcat' taking an extra 'CatOpts' record to control -- the spacing. See the 'cat'' documentation for a description of -- the possibilities. For the common case of setting just a -- separation amount, see 'vsep'. vcat' :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => CatOpts n -> [a] -> a vcat' = cat' unit_Y -- | A convenient synonym for vertical concatenation with -- separation: @vsep s === vcat' (with & sep .~ s)@. vsep :: (InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a, Monoid' a) => n -> [a] -> a vsep s = vcat' (def & sep .~ s) -- | @strutR2 v@ is a two-dimensional diagram which produces no -- output, but with respect to alignment, envelope, /and trace/ acts -- like a 1-dimensional segment oriented along the vector @v@, with -- local origin at its center. If you don't care about the trace -- then there's no difference between @strutR2@ and the more general -- 'strut'. strutR2 :: (RealFloat n, Monoid' m) => V2 n -> QDiagram b V2 n m strutR2 v = phantom seg where seg = FLinear (origin .+^ 0.5 *^ v) (origin .+^ (-0.5) *^ v) -- | @strutX w@ is an empty diagram with width @w@, height 0, and a -- centered local origin. Note that @strutX (-w)@ behaves the same as -- @strutX w@. strutX :: (Metric v, R1 v, OrderedField n) => n -> QDiagram b v n m strutX d = strut (zero & _x .~ d) -- | @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 :: (Metric v, R2 v, OrderedField n) => n -> QDiagram b v n m strutY d = strut (zero & _y .~ d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its -- envelope horizontally by a factor of @s@ (factors between 0 and 1 -- can be used to shrink the envelope). Note that the envelope will -- expand with respect to the local origin, so if the origin is not -- centered horizontally the padding may appear \"uneven\". If this -- is not desired, the origin can be centered (using 'centerX') -- before applying @padX@. padX :: (Metric v, R2 v, OrderedField n, Monoid' m) => n -> QDiagram b v n m -> QDiagram b v n m padX s d = withEnvelope (d # scaleX s) d -- | @padY s@ \"pads\" a diagram in the y-direction, expanding its -- envelope vertically by a factor of @s@ (factors between -- 0 and 1 can be used to shrink the envelope). Note that -- the envelope will expand with respect to the local origin, -- so if the origin is not centered vertically the padding may appear -- \"uneven\". If this is not desired, the origin can be centered -- (using 'centerY') before applying @padY@. padY :: (Metric v, R2 v, Monoid' m, OrderedField n) => n -> QDiagram b v n m -> QDiagram b v n m padY s d = withEnvelope (d # scaleY s) d -- | @extrudeLeft s@ \"extrudes\" a diagram in the negative x-direction, -- offsetting its envelope by the provided distance. When @ s < 0 @, -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. extrudeLeft :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeLeft s | s >= 0 = extrudeEnvelope $ unitX ^* negate s | otherwise = intrudeEnvelope $ unitX ^* negate s -- | @extrudeRight s@ \"extrudes\" a diagram in the positive x-direction, -- offsetting its envelope by the provided distance. When @ s < 0 @, -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. extrudeRight :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeRight s | s >= 0 = extrudeEnvelope $ unitX ^* s | otherwise = intrudeEnvelope $ unitX ^* s -- | @extrudeBottom s@ \"extrudes\" a diagram in the negative y-direction, -- offsetting its envelope by the provided distance. When @ s < 0 @, -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. extrudeBottom :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeBottom s | s >= 0 = extrudeEnvelope $ unitY ^* negate s | otherwise = intrudeEnvelope $ unitY ^* negate s -- | @extrudeTop s@ \"extrudes\" a diagram in the positive y-direction, -- offsetting its envelope by the provided distance. When @ s < 0 @, -- the envelope is inset instead. -- -- See the documentation for 'extrudeEnvelope' for more information. extrudeTop :: (OrderedField n, Monoid' m) => n -> QDiagram b V2 n m -> QDiagram b V2 n m extrudeTop s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s -- | @rectEnvelope p v@ sets the envelope of a diagram to a rectangle whose -- lower-left corner is at @p@ and whose upper-right corner is at @p -- .+^ v@. Useful for selecting the rectangular portion of a -- diagram which should actually be \"viewed\" in the final render, -- if you don't want to see the entire diagram. rectEnvelope :: forall b n m. (OrderedField n, Monoid' m) => Point V2 n -> V2 n -> QDiagram b V2 n m -> QDiagram b V2 n m rectEnvelope p (V2 w h) = withEnvelope (rect w h # alignBL # moveTo p :: Path V2 n) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. boundingRect :: ( InSpace V2 n a, SameSpace a t , Enveloped t, Transformable t, TrailLike t, Monoid t , Enveloped a) => a -> t boundingRect = (`boxFit` rect 1 1) . boundingBox -- | \"Set the background color\" of a diagram. That is, place a -- diagram atop a bounding rectangle of the given color. bg :: (TypeableFloat n, Renderable (Path V2 n) b) => Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any bg c d = d <> boundingRect d # lwO 0 # fc c -- | Similar to 'bg' but makes the colored background rectangle larger than -- the diagram. The first parameter is used to set how far the background -- extends beyond the diagram. bgFrame :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any bgFrame f c d = d <> boundingRect (frame f d) # lwO 0 # fc c diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Text.hs0000644000000000000000000003116412754644012017064 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Very basic text primitives along with associated attributes. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Text ( -- * Creating text diagrams Text(..), TextAlignment(..) , text, topLeftText, alignedText, baselineText, mkText -- * Text attributes -- ** Font family , Font(..), _Font , getFont, font, _font -- ** Font size , FontSize(..), _FontSize , getFontSize, fontSizeM, fontSize , fontSizeN, fontSizeO, fontSizeL, fontSizeG , _fontSizeR, _fontSize, _fontSizeU -- ** Font slant , FontSlant(..) , getFontSlant, fontSlant, italic, oblique, _fontSlant -- ** Font weight , FontWeight(..) , getFontWeight, fontWeight, bold, _fontWeight ) where import Control.Lens hiding (transform) import Diagrams.Attributes (committed) import Diagrams.Core import Diagrams.Core.Envelope (pointEnvelope) import Diagrams.TwoD.Attributes (recommendFillColor) import Diagrams.TwoD.Types import Data.Colour hiding (over) import Data.Default.Class #if __GLASGOW_HASKELL__ < 710 import Data.Functor #endif import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable import Linear.Affine ------------------------------------------------------------ -- Text diagrams ------------------------------------------------------------ -- | A 'Text' primitive consists of the string contents, text alignment -- and the transformation to be applied. The transformation is scale -- invarient, the average scale of the transform should always be 1. -- All text scaling is obtained from the 'FontSize' attribute. -- -- This constructor should not be used directly. Use 'text', -- 'alignedText' or 'baselineText'. data Text n = Text (T2 n) (TextAlignment n) String deriving Typeable type instance V (Text n) = V2 type instance N (Text n) = n instance Floating n => Transformable (Text n) where transform t (Text tt a s) = Text (t <> tt <> t') a s where t' = scaling (1 / avgScale t) instance Floating n => HasOrigin (Text n) where moveOriginTo p = translate (origin .-. p) instance Floating n => Renderable (Text n) NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment n = BaselineText | BoxAlignedText n n -- | Make a text from a 'TextAlignment'. mkText :: (TypeableFloat n, Renderable (Text n) b) => TextAlignment n -> String -> QDiagram b V2 n Any mkText a t = recommendFillColor black -- See Note [recommendFillColor] . recommendFontSize (local 1) -- See Note [recommendFontSize] $ mkQD (Prim $ Text mempty a t) (pointEnvelope origin) mempty mempty mempty -- ~~~~ Note [recommendFillColor] -- The reason we "recommend" a fill color of black instead of setting -- it directly (or instead of simply not specifying a fill color at -- all) was originally to support the SVG backend, though it is -- actually in some sense the "right thing" to do, and other backends -- we add later may conceivably need it as well. The cairo backend -- defaults happen to be to use a transparent fill for paths and a -- black fill for text. The SVG standard, however, specifies a -- default fill of black for everything (both text and paths). In -- order to correctly render paths with no fill set, the SVG backend -- must therefore explicitly set the fill to transparent -- but this -- meant that it was also drawing text with a transparent fill. The -- solution is that we now explicitly inform all backends that the -- *default* ("recommended") fill color for text should be black; an -- absence of fill specification now consistently means to use a -- "transparent" fill no matter what the primitive. The reason we -- need the special recommend/commit distinction is because if the -- user explicitly sets a fill color later it should override this -- recommendation; normally, the innermost occurrence of an attribute -- would override all outer occurrences. -- -- The reason we "recommend" a fill color of black instead of setting -- it directly (or instead of simply not specifying a fill color at -- | Create a primitive text diagram from the given string, with center -- alignment, equivalent to @'alignedText' 0.5 0.5@. -- -- Note that it /takes up no space/, as text size information is not -- available. text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any text = alignedText 0.5 0.5 -- | Create a primitive text diagram from the given string, origin at -- the top left corner of the text's bounding box, equivalent to -- @'alignedText' 0 1@. -- -- Note that it /takes up no space/. topLeftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any topLeftText = alignedText 0 1 -- | Create a primitive text diagram from the given string, with the -- origin set to a point interpolated within the bounding box. The -- first parameter varies from 0 (left) to 1 (right), and the second -- parameter from 0 (bottom) to 1 (top). Some backends do not -- implement this and instead snap to closest corner or the center. -- -- The height of this box is determined by the font's potential ascent -- and descent, rather than the height of the particular string. -- -- Note that it /takes up no space/. alignedText :: (TypeableFloat n, Renderable (Text n) b) => n -> n -> String -> QDiagram b V2 n Any alignedText w h = mkText (BoxAlignedText w h) -- | Create a primitive text diagram from the given string, with the -- origin set to be on the baseline, at the beginning (although not -- bounding). This is the reference point of showText in the Cairo -- graphics library. -- -- Note that it /takes up no space/. baselineText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any baselineText = mkText BaselineText ------------------------------------------------------------ -- Text attributes ------------------------------------------------------------ -------------------------------------------------- -- Font family -- | The @Font@ attribute specifies the name of a font family. Inner -- @Font@ attributes override outer ones. newtype Font = Font (Last String) deriving (Typeable, Semigroup, Eq) _Font :: Iso' Font String _Font = iso getFont (Font . Last) instance AttributeClass Font -- | Extract the font family name from a @Font@ attribute. getFont :: Font -> String getFont (Font (Last f)) = f -- | Specify a font family to be used for all text within a diagram. font :: HasStyle a => String -> a -> a font = applyAttr . Font . Last -- | Lens onto the font name of a style. _font :: Lens' (Style v n) (Maybe String) _font = atAttr . mapping _Font -------------------------------------------------- -- Font size -- | The @FontSize@ attribute specifies the size of a font's -- em-square. Inner @FontSize@ attributes override outer ones. newtype FontSize n = FontSize (Recommend (Last n)) deriving (Typeable, Semigroup) -- not sure why this can't be derived instance Functor FontSize where fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a))) fmap f (FontSize (Commit (Last a))) = FontSize (Commit (Last (f a))) _FontSize :: Iso' (FontSize n) (Recommend n) _FontSize = iso getter setter where getter (FontSize (Recommend (Last a))) = Recommend a getter (FontSize (Commit (Last a))) = Commit a setter (Recommend a) = FontSize $ Recommend (Last a) setter (Commit a) = FontSize $ Commit (Last a) -- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped -- once we depend on monoid-extras-0.4 _FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n)) _FontSizeM = mapping _FontSize type FontSizeM n = Measured n (FontSize n) instance Typeable n => AttributeClass (FontSize n) instance Num n => Default (FontSizeM n) where def = FontSize . Recommend . Last <$> local 1 -- | Extract the size from a @FontSize@ attribute. getFontSize :: FontSize n -> n getFontSize (FontSize (Recommend (Last s))) = s getFontSize (FontSize (Commit (Last s))) = s -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. fontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a fontSize = applyMAttr . fmap (FontSize . Commit . Last) -- | A convenient synonym for 'fontSize (Global w)'. fontSizeG :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a fontSizeG = fontSize . global -- | A convenient synonym for 'fontSize (Normalized w)'. fontSizeN :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a fontSizeN = fontSize . normalized -- | A convenient synonym for 'fontSize (Output w)'. fontSizeO :: (N a ~ n, Typeable n, HasStyle a) => n -> a -> a fontSizeO = fontSize . output -- | A convenient sysnonym for 'fontSize (Local w)'. fontSizeL :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a fontSizeL = fontSize . local -- | Apply a 'FontSize' attribute. fontSizeM :: (N a ~ n, Typeable n, HasStyle a) => FontSizeM n -> a -> a fontSizeM = applyMAttr recommendFontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a recommendFontSize = applyMAttr . fmap (FontSize . Recommend . Last) _fontSizeR :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n)) _fontSizeR = atMAttr . anon def (const False) . _FontSizeM -- | Lens to commit a font size. This is *not* a valid lens (see -- 'commited'. _fontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n) _fontSize = _fontSizeR . mapping committed _fontSizeU :: (Typeable n) => Lens' (Style v n) (Maybe n) _fontSizeU = atAttr . mapping (_FontSize . committed) -------------------------------------------------- -- Font slant -- | The @FontSlantA@ attribute specifies the slant (normal, italic, -- or oblique) that should be used for all text within a diagram. -- Inner @FontSlantA@ attributes override outer ones. data FontSlant = FontSlantNormal | FontSlantItalic | FontSlantOblique deriving (Eq, Show, Typeable, Ord) instance AttributeClass FontSlant where instance Semigroup FontSlant where _ <> b = b instance Default FontSlant where def = FontSlantNormal -- | Extract the font slant from a 'FontSlantA' attribute. getFontSlant :: FontSlant -> FontSlant getFontSlant = id -- | Specify the slant (normal, italic, or oblique) that should be -- used for all text within a diagram. See also 'italic' and -- 'oblique' for useful special cases. fontSlant :: HasStyle a => FontSlant -> a -> a fontSlant = applyAttr -- | Lens onto the font slant in a style. _fontSlant :: Lens' (Style v n) FontSlant _fontSlant = atAttr . non def -- | Set all text in italics. italic :: HasStyle a => a -> a italic = fontSlant FontSlantItalic -- | Set all text using an oblique slant. oblique :: HasStyle a => a -> a oblique = fontSlant FontSlantOblique -------------------------------------------------- -- Font weight -- | The @FontWeightA@ attribute specifies the weight (normal or bold) -- that should be used for all text within a diagram. Inner -- @FontWeightA@ attributes override outer ones. data FontWeight = FontWeightNormal | FontWeightBold deriving (Eq, Ord, Show, Typeable) instance AttributeClass FontWeight -- | Last semigroup structure instance Semigroup FontWeight where _ <> b = b instance Default FontWeight where def = FontWeightNormal -- | Extract the font weight. getFontWeight :: FontWeight -> FontWeight getFontWeight = id -- | Specify the weight (normal or bold) that should be -- used for all text within a diagram. See also 'bold' -- for a useful special case. fontWeight :: HasStyle a => FontWeight -> a -> a fontWeight = applyAttr -- | Set all text using a bold font weight. bold :: HasStyle a => a -> a bold = fontWeight FontWeightBold -- | Lens onto the font weight in a style. _fontWeight :: Lens' (Style v n) FontWeight _fontWeight = atAttr . non def diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Polygons.hs0000644000000000000000000003335512754644012017756 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Polygons -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- This module defines a general API for creating various types of -- polygons. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Polygons( -- * Polygons PolyType(..) , PolyOrientation(..) , PolygonOpts(..), polyType, polyOrient, polyCenter , polygon , polyTrail -- ** Generating polygon vertices , polyPolarTrail , polySidesTrail , polyRegularTrail , orient -- * Star polygons , StarOpts(..) , star -- ** Function graphs -- $graphs , GraphPart(..) , orbits, mkGraph ) where import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, view, (.~), (^.)) import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, writeArray) import Data.Default.Class import Data.List (maximumBy, minimumBy) import Data.Maybe (catMaybes) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty) #endif import Data.Ord (comparing) import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path import Diagrams.Points (centroid) import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y) import Diagrams.Util (tau, ( # )) import Linear.Affine import Linear.Metric import Linear.Vector -- | Method used to determine the vertices of a polygon. data PolyType n = PolyPolar [Angle n] [n] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ -- /angles/ from each vertex to the next. -- -- * The second argument is a list of /radii/ from -- the origin to each successive vertex. -- -- To construct an /n/-gon, use a list of /n-1/ -- angles and /n/ radii. Extra angles or radii -- are ignored. -- -- Cyclic polygons (with all vertices lying on a -- circle) can be constructed using a second -- argument of @(repeat r)@. | PolySides [Angle n] [n] -- ^ A polygon determined by the distance between -- successive vertices and the external angles formed -- by each three successive vertices. In other -- words, a polygon specified by \"turtle -- graphics\": go straight ahead x1 units; turn by -- external angle a1; go straight ahead x2 units; turn by -- external angle a2; etc. The polygon will be centered -- at the /centroid/ of its vertices. -- -- * The first argument is a list of /vertex/ -- /angles/, giving the external angle at each vertex -- from the previous vertex to the next. The -- first angle in the list is the external angle at -- the /second/ vertex; the first edge always starts -- out heading in the positive y direction from -- the first vertex. -- -- * The second argument is a list of distances -- between successive vertices. -- -- To construct an /n/-gon, use a list of /n-2/ -- angles and /n-1/ edge lengths. Extra angles or -- lengths are ignored. | PolyRegular Int n -- ^ A regular polygon with the given number of -- sides (first argument) and the given radius -- (second argument). -- | Determine how a polygon should be oriented. data PolyOrientation n = NoOrient -- ^ No special orientation; the first -- vertex will be at (1,0). -- This is the default. | OrientH -- ^ Orient /horizontally/, so the -- bottommost edge is parallel to -- the x-axis. | OrientV -- ^ Orient /vertically/, so the -- leftmost edge is parallel to the -- y-axis. | OrientTo (V2 n) -- ^ Orient so some edge is -- /facing/ /in/ /the/ /direction/ -- /of/, that is, perpendicular -- to, the given vector. deriving (Eq, Ord, Show, Read) -- | Options for specifying a polygon. data PolygonOpts n = PolygonOpts { _polyType :: PolyType n , _polyOrient :: PolyOrientation n , _polyCenter :: Point V2 n } makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts -- | Specification for the polygon's vertices. polyType :: Lens' (PolygonOpts n) (PolyType n) -- | Should a rotation be applied to the polygon in order to orient it in a -- particular way? polyOrient :: Lens' (PolygonOpts n) (PolyOrientation n) -- | Should a translation be applied to the polygon in order to place the center -- at a particular location? polyCenter :: Lens' (PolygonOpts n) (Point V2 n) -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. instance Num n => Default (PolygonOpts n) where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. polyTrail :: OrderedField n => PolygonOpts n -> Located (Trail V2 n) polyTrail po = transform ori tr where tr = case po^.polyType of PolyPolar ans szs -> polyPolarTrail ans szs PolySides ans szs -> polySidesTrail ans szs PolyRegular n r -> polyRegularTrail n r ori = case po^.polyOrient of OrientH -> orient unit_Y tr OrientV -> orient unitX tr OrientTo v -> orient v tr NoOrient -> mempty -- | Generate the polygon described by the given options. polygon :: (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 where p1 = p2 (1,0) # scale r tr = closeTrail . trailFromVertices $ zipWith (\a l -> rotate a . scale l $ p2 (1,0)) (scanl (^+^) zero ans) (r:rs) -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where ans' = scanl (^+^) zero ans offsets = zipWith rotate ans' (map (unitY ^*) ls) ps = scanl (.+^) origin offsets tr = closeTrail . trailFromOffsets $ offsets -- | Generate the vertices of a regular polygon. See 'PolyRegular'. polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n) polyRegularTrail n r = polyPolarTrail (replicate (n - 1) $ fullTurn ^/ fromIntegral n) (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ -- generates the smallest rotation such that one of the segments -- adjacent to the vertex furthest in the direction of @v@ is -- perpendicular to @v@. orient :: OrderedField n => V2 n -> Located (Trail V2 n) -> Transformation V2 n orient v = orientPoints v . trailVertices orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n orientPoints v xs = rotation a where (n1,x,n2) = maximumBy (comparing (distAlong v . sndOf3)) (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w `dot` p) * norm (project w p) sndOf3 (_,b,_) = b -- a :: Angle (Scalar v) a = minimumBy (comparing $ abs . view rad) . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = signorm v -- angleFromNormal :: v -> Angle (Scalar v) angleFromNormal o | leftTurn o' v' = phi | otherwise = negated phi where o' = signorm o theta = acos (v' `dot` o') -- phi :: Angle (Scalar v) phi | theta <= tau/4 = tau/4 - theta @@ rad | otherwise = theta - tau/4 @@ rad ------------------------------------------------------------ -- Function graphs ------------------------------------------------------------ -- $graphs -- These functions are used to implement 'star', but are exported on -- the offchance that someone else finds them useful. -- | Pieces of a function graph can either be cycles or \"hairs\". data GraphPart a = Cycle [a] | Hair [a] deriving (Show, Functor) -- | @orbits f n@ computes the graph of @f@ on the integers mod @n@. orbits :: (Int -> Int) -> Int -> [GraphPart Int] orbits f n = runST genOrbits where f_n i = f i `mod` n genOrbits :: ST s [GraphPart Int] genOrbits = newArray (0,n-1) False >>= genOrbits' genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int] genOrbits' marks = liftM (concat . catMaybes) (forM [0 .. n-1] (genPart marks)) genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int]) genPart marks i = do tr <- markRho i marks case tr of [] -> return Nothing _ -> return . Just . splitParts $ tr markRho :: Int -> STUArray s Int Bool -> ST s [Int] markRho i marks = do isMarked <- readArray marks i if isMarked then return [] else writeArray marks i True >> liftM (i:) (markRho (f_n i) marks) splitParts :: [Int] -> [GraphPart Int] splitParts tr = hair ++ cyc where hair | not (null tl) = [Hair $ tl ++ [f_n (last tl)]] | otherwise = [] cyc | not (null body) = [Cycle body] | otherwise = [] l = last tr (tl, body) = span (/= f_n l) tr -- | Generate a function graph from the given function and labels. mkGraph :: (Int -> Int) -> [a] -> [GraphPart a] mkGraph f xs = (map . fmap) (xs!!) $ orbits f (length xs) ------------------------------------------------------------ -- Star polygons ------------------------------------------------------------ -- | Options for creating \"star\" polygons, where the edges connect -- possibly non-adjacent vertices. data StarOpts = StarFun (Int -> Int) -- ^ Specify the order in which the vertices should be -- connected by a function that maps each vertex -- index to the index of the vertex that should come -- next. Indexing of vertices begins at 0. | StarSkip Int -- ^ Specify a star polygon by a \"skip\". A skip of -- 1 indicates a normal polygon, where edges go -- between successive vertices. A skip of 2 means -- that edges will connect every second vertex, -- skipping one in between. Generally, a skip of -- /n/ means that edges will connect every /n/th -- vertex. -- | Create a generalized /star/ /polygon/. The 'StarOpts' are used -- to determine in which order the given vertices should be -- connected. The intention is that the second argument of type -- @[Point v]@ could be generated by a call to 'polygon', 'regPoly', or -- the like, since a list of vertices is 'TrailLike'. But of course -- the list can be generated any way you like. A @'Path' 'v'@ is -- returned (instead of any 'TrailLike') because the resulting path -- may have more than one component, for example if the vertices are -- to be connected in several disjoint cycles. star :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n star sOpts vs = graphToPath $ mkGraph f vs where f = case sOpts of StarFun g -> g StarSkip k -> (+k) graphToPath = mconcat . map partToPath partToPath (Cycle ps) = pathFromLocTrail . mapLoc closeTrail . fromVertices $ ps partToPath (Hair ps) = fromVertices ps diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Size.hs0000644000000000000000000000451612754644012017053 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Size -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Utilities for working with sizes of two-dimensional objects. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Size ( -- ** Computing sizes width, height , extentX, extentY -- ** Specifying sizes , mkSizeSpec2D , mkWidth , mkHeight , dims2D ) where import Diagrams.Core import Diagrams.Core.Envelope import Diagrams.Size import Diagrams.TwoD.Types import Diagrams.TwoD.Vector ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. -- -- Note this is just @diameter unitX@. width :: (InSpace V2 n a, Enveloped a) => a -> n width = diameter unitX -- | Compute the height of an enveloped object. height :: (InSpace V2 n a, Enveloped a) => a -> n height = diameter unitY -- | Compute the absolute x-coordinate range of an enveloped object in -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty -- envelope. -- -- Note this is just @extent unitX@. extentX :: (InSpace v n a, R1 v, Enveloped a) => a -> Maybe (n, n) extentX = extent unitX -- | Compute the absolute y-coordinate range of an enveloped object in -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty -- envelope. extentY :: (InSpace v n a, R2 v, Enveloped a) => a -> Maybe (n, n) extentY = extent unitY -- | Make a 'SizeSpec' from possibly-specified width and height. mkSizeSpec2D :: Num n => Maybe n -> Maybe n -> SizeSpec V2 n mkSizeSpec2D x y = mkSizeSpec (V2 x y) -- | Make a 'SizeSpec' from a width and height. dims2D :: n -> n -> SizeSpec V2 n dims2D x y = dims (V2 x y) -- | Make a 'SizeSpec' with only width defined. mkWidth :: Num n => n -> SizeSpec V2 n mkWidth w = dims (V2 w 0) -- | Make a 'SizeSpec' with only height defined. mkHeight :: Num n => n -> SizeSpec V2 n mkHeight h = dims (V2 0 h) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Vector.hs0000644000000000000000000000536712754644012017410 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Two-dimensional vectors. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Vector ( -- * Special 2D vectors unitX, unitY, unit_X, unit_Y , xDir, yDir -- * Converting between vectors and angles , angleV, angleDir, e, signedAngleBetween, signedAngleBetweenDirs -- * 2D vector utilities , perp, leftTurn, cross2 ) where import Control.Lens (view, (&), (.~), (^.)) import Diagrams.Angle import Diagrams.Direction import Diagrams.TwoD.Types import Linear.Metric import Linear.V2 import Linear.Vector -- | The unit vector in the positive X direction. unitX :: (R1 v, Additive v, Num n) => v n unitX = zero & _x .~ 1 -- | The unit vector in the negative X direction. unit_X :: (R1 v, Additive v, Num n) => v n unit_X = zero & _x .~ (-1) -- | The unit vector in the positive Y direction. unitY :: (R2 v, Additive v, Num n) => v n unitY = zero & _y .~ 1 -- | The unit vector in the negative Y direction. unit_Y :: (R2 v, Additive v, Num n) => v n unit_Y = zero & _y .~ (-1) -- | A 'Direction' pointing in the X direction. xDir :: (R1 v, Additive v, Num n) => Direction v n xDir = dir unitX -- | A 'Direction' pointing in the Y direction. yDir :: (R2 v, Additive v, Num n) => Direction v n yDir = dir unitY -- | A direction at a specified angle counter-clockwise from the 'xDir'. angleDir :: Floating n => Angle n -> Direction V2 n angleDir = dir . angleV -- | A unit vector at a specified angle counter-clockwise from the -- positive x-axis angleV :: Floating n => Angle n -> V2 n angleV = angle . view rad -- | A unit vector at a specified angle counter-clockwise from the -- positive X axis. e :: Floating n => Angle n -> V2 n e = angleV -- | @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 -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool leftTurn v1 v2 = (v1 `dot` perp v2) < 0 -- | Cross product on vectors in R2. cross2 :: Num n => V2 n -> V2 n -> n cross2 (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2 signedAngleBetween :: RealFloat n => V2 n -> V2 n -> Angle n signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) signedAngleBetweenDirs :: RealFloat n => Direction V2 n -> Direction V2 n -> Angle n signedAngleBetweenDirs u v = (u ^. _theta) ^-^ (v ^. _theta) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Attributes.hs0000644000000000000000000004131612754644012020266 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Attributes -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Diagrams may have /attributes/ which affect the way they are -- rendered. This module defines /Textures/ (Gradients and Colors) in two -- dimensions. Like the attributes defined in the Diagrams.Attributes module, -- all attributes defined here use the 'Last' or 'Recommend' /semigroup/ structure. -- 'FillColor' and 'LineColor' attributes are provided so that backends that -- don't support gradients need not be concerned with using textures. Backends -- should only implement color attributes or textures attributes, not both. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Attributes ( -- * Textures Texture(..), solid, _SC, _AC, _LG, _RG, defaultLG, defaultRG , GradientStop(..), stopColor, stopFraction, mkStops , SpreadMethod(..), lineLGradient, lineRGradient -- ** Linear Gradients , LGradient(..), lGradStops, lGradTrans, lGradStart, lGradEnd , lGradSpreadMethod, mkLinearGradient -- ** Radial Gradients , RGradient(..), rGradStops, rGradTrans , rGradCenter0, rGradRadius0, rGradCenter1, rGradRadius1 , rGradSpreadMethod, mkRadialGradient -- ** Line texture , LineTexture(..), _LineTexture, getLineTexture, lineTexture, lineTextureA , mkLineTexture, _lineTexture -- ** Line color , lineColor, lc, lcA -- ** Fill texture , FillTexture(..), _FillTexture, getFillTexture, fillTexture , mkFillTexture, _fillTexture, _fillTextureR -- ** Fill color , fillColor, fc, fcA, recommendFillColor -- * Compilation utilities , splitTextureFills ) where import Control.Lens hiding (transform) import Data.Colour hiding (AffineSpace, over) import Data.Data import Data.Default.Class import Data.Monoid.Recommend import Data.Semigroup import Diagrams.Attributes import Diagrams.Attributes.Compile import Diagrams.Core import Diagrams.Core.Types (RTree) import Diagrams.Located (unLoc) import Diagrams.Path (Path, pathTrails) import Diagrams.Trail (isLoop) import Diagrams.TwoD.Types import Diagrams.Util ----------------------------------------------------------------- -- Gradients -------------------------------------------------- ----------------------------------------------------------------- -- | A gradient stop contains a color and fraction (usually between 0 and 1) data GradientStop d = GradientStop { _stopColor :: SomeColor , _stopFraction :: d } makeLensesWith (lensRules & generateSignatures .~ False) ''GradientStop -- | A color for the stop. stopColor :: Lens' (GradientStop n) SomeColor -- | The fraction for stop. stopFraction :: Lens' (GradientStop n) n -- | The 'SpreadMethod' determines what happens before 'lGradStart' and after -- 'lGradEnd'. 'GradPad' fills the space before the start of the gradient -- with the color of the first stop and the color after end of the gradient -- with the color of the last stop. 'GradRepeat' restarts the gradient and -- 'GradReflect' restarts the gradient with the stops in reverse order. data SpreadMethod = GradPad | GradReflect | GradRepeat -- | Linear Gradient data LGradient n = LGradient { _lGradStops :: [GradientStop n] , _lGradStart :: Point V2 n , _lGradEnd :: Point V2 n , _lGradTrans :: Transformation V2 n , _lGradSpreadMethod :: SpreadMethod } type instance V (LGradient n) = V2 type instance N (LGradient n) = n makeLensesWith (lensRules & generateSignatures .~ False) ''LGradient instance Fractional n => Transformable (LGradient n) where transform = over lGradTrans . transform -- | A list of stops (colors and fractions). lGradStops :: Lens' (LGradient n) [GradientStop n] -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. lGradTrans :: Lens' (LGradient n) (Transformation V2 n) -- | The starting point for the first gradient stop. The coordinates are in -- 'local' units and the default is (-0.5, 0). lGradStart :: Lens' (LGradient n) (Point V2 n) -- | The ending point for the last gradient stop.The coordinates are in -- 'local' units and the default is (0.5, 0). lGradEnd :: Lens' (LGradient n) (Point V2 n) -- | For setting the spread method. lGradSpreadMethod :: Lens' (LGradient n) SpreadMethod -- | Radial Gradient data RGradient n = RGradient { _rGradStops :: [GradientStop n] , _rGradCenter0 :: Point V2 n , _rGradRadius0 :: n , _rGradCenter1 :: Point V2 n , _rGradRadius1 :: n , _rGradTrans :: Transformation V2 n , _rGradSpreadMethod :: SpreadMethod } makeLensesWith (lensRules & generateSignatures .~ False) ''RGradient type instance V (RGradient n) = V2 type instance N (RGradient n) = n instance Fractional n => Transformable (RGradient n) where transform = over rGradTrans . transform -- | A list of stops (colors and fractions). rGradStops :: Lens' (RGradient n) [GradientStop n] -- | The center point of the inner circle. rGradCenter0 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the inner cirlce in 'local' coordinates. rGradRadius0 :: Lens' (RGradient n) n -- | The center of the outer circle. rGradCenter1 :: Lens' (RGradient n) (Point V2 n) -- | The radius of the outer circle in 'local' coordinates. rGradRadius1 :: Lens' (RGradient n) n -- | A transformation to be applied to the gradient. Usually this field will -- start as the identity transform and capture the transforms that are applied -- to the gradient. rGradTrans :: Lens' (RGradient n) (Transformation V2 n) -- | For setting the spread method. rGradSpreadMethod :: Lens' (RGradient n) SpreadMethod ----------------------------------------------------------------- -- Textures --------------------------------------------------- ----------------------------------------------------------------- -- | A Texture is either a color 'SC', linear gradient 'LG', or radial gradient 'RG'. -- An object can have only one texture which is determined by the 'Last' -- semigroup structure. data Texture n = SC SomeColor | LG (LGradient n) | RG (RGradient n) deriving Typeable type instance V (Texture n) = V2 type instance N (Texture n) = n makePrisms ''Texture -- | Prism onto an 'AlphaColour' 'Double' of a 'SC' texture. _AC :: Prism' (Texture n) (AlphaColour Double) _AC = _SC . _SomeColor instance Floating n => Transformable (Texture n) where transform t (LG lg) = LG $ transform t lg transform t (RG rg) = RG $ transform t rg transform _ sc = sc -- | Convert a solid colour into a texture. solid :: Color a => a -> Texture n solid = SC . SomeColor -- | A default is provided so that linear gradients can easily be created using -- lenses. For example, @lg = defaultLG & lGradStart .~ (0.25 ^& 0.33)@. Note that -- no default value is provided for @lGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. defaultLG :: Fractional n => Texture n defaultLG = LG LGradient { _lGradStops = [] , _lGradStart = mkP2 (-0.5) 0 , _lGradEnd = mkP2 0.5 0 , _lGradTrans = mempty , _lGradSpreadMethod = GradPad } -- | A default is provided so that radial gradients can easily be created using -- lenses. For example, @rg = defaultRG & rGradRadius1 .~ 0.25@. Note that -- no default value is provided for @rGradStops@, this must be set before -- the gradient value is used, otherwise the object will appear transparent. defaultRG :: Fractional n => Texture n defaultRG = RG RGradient { _rGradStops = [] , _rGradCenter0 = mkP2 0 0 , _rGradRadius0 = 0.0 , _rGradCenter1 = mkP2 0 0 , _rGradRadius1 = 0.5 , _rGradTrans = mempty , _rGradSpreadMethod = GradPad } -- | A convenient function for making gradient stops from a list of triples. -- (An opaque color, a stop fraction, an opacity). mkStops :: [(Colour Double, d, Double)] -> [GradientStop d] mkStops = map (\(x, y, z) -> GradientStop (SomeColor (withOpacity x z)) y) -- | Make a linear gradient texture from a stop list, start point, end point, -- and 'SpreadMethod'. The 'lGradTrans' field is set to the identity -- transfrom, to change it use the 'lGradTrans' lens. mkLinearGradient :: Num n => [GradientStop n] -> Point V2 n -> Point V2 n -> SpreadMethod -> Texture n mkLinearGradient stops start end spreadMethod = LG (LGradient stops start end mempty spreadMethod) -- | Make a radial gradient texture from a stop list, radius, start point, -- end point, and 'SpreadMethod'. The 'rGradTrans' field is set to the identity -- transfrom, to change it use the 'rGradTrans' lens. mkRadialGradient :: Num n => [GradientStop n] -> Point V2 n -> n -> Point V2 n -> n -> SpreadMethod -> Texture n mkRadialGradient stops c0 r0 c1 r1 spreadMethod = RG (RGradient stops c0 r0 c1 r1 mempty spreadMethod) -- Line Texture -------------------------------------------------------- -- | The texture with which lines are drawn. Note that child -- textures always override parent textures. -- More precisely, the semigroup structure on line texture attributes -- is that of 'Last'. newtype LineTexture n = LineTexture (Last (Texture n)) deriving (Typeable, Semigroup) instance (Typeable n) => AttributeClass (LineTexture n) type instance V (LineTexture n) = V2 type instance N (LineTexture n) = n _LineTexture :: Iso (LineTexture n) (LineTexture n') (Texture n) (Texture n') _LineTexture = iso getLineTexture (LineTexture . Last) -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. instance Floating n => Transformable (LineTexture n) where transform t (LineTexture (Last tx)) = LineTexture (Last $ transform t tx) instance Default (LineTexture n) where def = _LineTexture . _SC ## SomeColor black mkLineTexture :: Texture n -> LineTexture n mkLineTexture = LineTexture . Last getLineTexture :: LineTexture n -> Texture n getLineTexture (LineTexture (Last t)) = t lineTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a lineTexture = applyTAttr . LineTexture . Last lineTextureA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LineTexture n -> a -> a lineTextureA = applyTAttr _lineTexture :: (Floating n, Typeable n) => Lens' (Style V2 n) (Texture n) _lineTexture = atTAttr . anon def isDef . _LineTexture where isDef = anyOf (_LineTexture . _AC) (== opaque black) -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. lineColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a lineColor = lineTexture . SC . SomeColor -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment in 'lineColor' about backends. lc :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment in 'lineColor' -- about backends. lcA :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => AlphaColour Double -> a -> a lcA = lineColor -- | Apply a linear gradient. lineLGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => LGradient n -> a -> a lineLGradient g = lineTexture (LG g) -- | Apply a radial gradient. lineRGradient :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => RGradient n -> a -> a lineRGradient g = lineTexture (RG g) -- Fill Texture -------------------------------------------------------- -- | The texture with which objects are filled. -- The semigroup structure on fill texture attributes -- is that of 'Recommed . Last'. newtype FillTexture n = FillTexture (Recommend (Last (Texture n))) deriving (Typeable, Semigroup) instance Typeable n => AttributeClass (FillTexture n) _FillTexture :: Iso' (FillTexture n) (Recommend (Texture n)) _FillTexture = iso getter setter where getter (FillTexture (Recommend (Last t))) = Recommend t getter (FillTexture (Commit (Last t))) = Commit t setter (Recommend t) = FillTexture (Recommend (Last t)) setter (Commit t) = FillTexture (Commit (Last t)) -- = iso (\(FillTexture a) -> a) FillTexture . mapping _Wrapped -- -- once we depend on monoid-extras-0.4 type instance V (FillTexture n) = V2 type instance N (FillTexture n) = n -- Only gradients get transformed. The transform is applied to the gradients -- transform field. Colors are left unchanged. instance Floating n => Transformable (FillTexture n) where transform = over (_FillTexture . _recommend) . transform instance Default (FillTexture n) where def = mkFillTexture $ _AC ## transparent getFillTexture :: FillTexture n -> Texture n getFillTexture (FillTexture tx) = getLast . getRecommend $ tx fillTexture :: (InSpace V2 n a, Typeable n, Floating n, HasStyle a) => Texture n -> a -> a fillTexture = applyTAttr . mkFillTexture mkFillTexture :: Texture n -> FillTexture n mkFillTexture = FillTexture . Commit . Last -- | Lens onto the 'Recommend' of a fill texture in a style. _fillTextureR :: (Typeable n, Floating n) => Lens' (Style V2 n) (Recommend (Texture n)) _fillTextureR = atTAttr . anon def isDef . _FillTexture where isDef = anyOf (_FillTexture . _Recommend . _AC) (== transparent) -- | Commit a fill texture in a style. This is /not/ a valid setter -- because it doesn't abide the functor law (see 'committed'). _fillTexture :: (Typeable n, Floating n) => Lens' (Style V2 n) (Texture n) _fillTexture = _fillTextureR . committed -- | 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 :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a fillColor = fillTexture . SC . SomeColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. -- See comment after 'fillColor' about backends. recommendFillColor :: (InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) => c -> a -> a recommendFillColor = applyTAttr . FillTexture . Recommend . Last . SC . SomeColor -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). See comment after 'fillColor' about backends. fc :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => Colour Double -> a -> a fc = fillColor -- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). See comment after 'fillColor' about backends. fcA :: (InSpace V2 n a, Floating n, Typeable n, HasStyle a) => AlphaColour Double -> a -> a fcA = fillColor -- Split fills --------------------------------------------------------- data FillTextureLoops n = FillTextureLoops instance Typeable n => SplitAttribute (FillTextureLoops n) where type AttrType (FillTextureLoops n) = FillTexture n type PrimType (FillTextureLoops n) = Path V2 n primOK _ = all (isLoop . unLoc) . pathTrails -- | Push fill attributes down until they are at the root of subtrees -- containing only loops. This makes life much easier for backends, -- which typically have a semantics where fill attributes are -- applied to lines/non-closed paths as well as loops/closed paths, -- whereas in the semantics of diagrams, fill attributes only apply -- to loops. splitTextureFills :: forall b v n a. ( Typeable n) => RTree b v n a -> RTree b v n a splitTextureFills = splitAttr (FillTextureLoops :: FillTextureLoops n) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Path.hs0000644000000000000000000004415712754644012017042 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Path -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Paths in two dimensions are special since we may stroke them to -- create a 2D diagram, and (eventually) perform operations such as -- intersection and union. They also have a trace, whereas paths in -- higher dimensions do not. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Path ( -- * Constructing path-based diagrams stroke, stroke' , strokePath, strokeP, strokePath', strokeP' , strokeTrail, strokeT, strokeTrail', strokeT' , strokeLine, strokeLoop , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop -- ** Stroke options , FillRule(..) , getFillRule, fillRule, _fillRule , StrokeOpts(..), vertexNames, queryFillRule -- ** Inside/outside testing , isInsideWinding, isInsideEvenOdd -- * Clipping , Clip(..), _Clip, _clip , clipBy, clipTo, clipped -- * Intersections , intersectPoints, intersectPoints' , intersectPointsP, intersectPointsP' , intersectPointsT, intersectPointsT' ) where import Control.Applicative (liftA2) import Control.Lens hiding (at, transform) import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable import Data.Default.Class import Diagrams.Angle import Diagrams.Combinators (withEnvelope, withTrace) import Diagrams.Core import Diagrams.Core.Trace import Diagrams.Located (Located, mapLoc, unLoc) import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Solve.Polynomial import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Segment import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util (tau) import Linear.Affine import Linear.Vector ------------------------------------------------------------ -- Trail and path traces --------------------------------- ------------------------------------------------------------ -- Only 2D trails and paths have a trace. -- XXX can the efficiency of this be improved? See the comment in -- Diagrams.Path on the Enveloped instance for Trail. instance RealFloat n => Traced (Trail V2 n) where getTrace = withLine $ foldr (\seg bds -> moveOriginBy (negated . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments instance RealFloat n => Traced (Path V2 n) where 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) -- path. data FillRule = Winding -- ^ Interior points are those with a nonzero -- /winding/ /number/. See -- . | EvenOdd -- ^ Interior points are those where a ray -- extended infinitely in a particular -- direction crosses the path an odd number -- of times. See -- . deriving (Show, Typeable, Eq, Ord) instance AttributeClass FillRule instance Semigroup FillRule where _ <> b = b 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 'ToPath' object into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices. -- -- See also 'stroke'', which takes an extra options record allowing -- its behaviour to be customized. stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) => t -> QDiagram b V2 n Any stroke = strokeP . toPath -- | A variant of 'stroke' that takes an extra record of options to -- customize its behaviour. In particular: -- -- * Names can be assigned to the path's vertices -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. stroke' :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> t -> QDiagram b V2 n Any stroke' opts = strokeP' opts . toPath -- | 'stroke' specialised to 'Path'. strokeP :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> QDiagram b V2 n Any strokeP = strokeP' (def :: StrokeOpts ()) -- | 'stroke' specialised to 'Path'. strokePath :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> QDiagram b V2 n Any strokePath = strokeP instance (TypeableFloat n, Renderable (Path V2 n) b) => TrailLike (QDiagram b V2 n Any) where trailLike = strokeP . trailLike -- | 'stroke'' specialised to 'Path'. strokeP' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any strokeP' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines | otherwise = mkP pLines <> mkP pLoops where (pLines,pLoops) = partitionPath (isLine . unLoc) path mkP p = mkQD (Prim p) (getEnvelope p) (getTrace p) (fromNames . concat $ zipWith zip (opts^.vertexNames) ((map . map) subPoint (pathVertices p)) ) (Query $ Any . flip (runFillRule (opts^.queryFillRule)) p) -- | 'stroke'' specialised to 'Path'. strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any strokePath' = strokeP' -- | 'stroke' specialised to 'Trail'. strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> QDiagram b V2 n Any strokeTrail = stroke . pathFromTrail -- | 'stroke' specialised to 'Trail'. strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> QDiagram b V2 n Any strokeT = strokeTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. strokeTrail' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any strokeTrail' opts = stroke' opts . pathFromTrail -- | Deprecated synonym for 'strokeTrail''. strokeT' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Trail V2 n -> QDiagram b V2 n Any strokeT' = strokeTrail' -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. strokeLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Line V2 n -> QDiagram b V2 n Any strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. strokeLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail' Loop V2 n -> QDiagram b V2 n Any strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocTrail = stroke . trailLike@. strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> QDiagram b V2 n Any strokeLocTrail = strokeP . trailLike -- | Deprecated synonym for 'strokeLocTrail'. strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> QDiagram b V2 n Any strokeLocT = strokeLocTrail -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> QDiagram b V2 n Any strokeLocLine = strokeP . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any strokeLocLoop = strokeP . trailLike . mapLoc wrapLoop ------------------------------------------------------------ -- Inside/outside testing ------------------------------------------------------------ runFillRule :: RealFloat n => FillRule -> Point V2 n -> Path V2 n -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd -- | Extract the fill rule from a 'FillRuleA' attribute. getFillRule :: FillRule -> FillRule getFillRule = id -- | Specify the fill rule that should be used for determining which -- points are inside a path. fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr -- | Lens onto the fill rule of a style. _fillRule :: Lens' (Style V2 n) FillRule _fillRule = atAttr . non def -- XXX link to more info on this -- | Test whether the given point is inside the given path, -- by testing whether the point's /winding number/ is nonzero. Note -- that @False@ is /always/ returned for paths consisting of lines -- (as opposed to loops), regardless of the winding number. isInsideWinding :: RealFloat n => Point V2 n -> Path V2 n -> Bool isInsideWinding p = (/= 0) . crossings p -- | Test whether the given point is inside the given path, -- by testing whether a ray extending from the point in the positive -- x direction crosses the path an even (outside) or odd (inside) -- number of times. Note that @False@ is /always/ returned for -- paths consisting of lines (as opposed to loops), regardless of -- the number of crossings. isInsideEvenOdd :: RealFloat n => Point V2 n -> Path V2 n -> Bool isInsideEvenOdd p = odd . crossings p -- | Compute the sum of /signed/ crossings of a path as we travel in the -- positive x direction from a given point. crossings :: RealFloat n => Point V2 n -> Path V2 n -> Int crossings p = F.sum . map (trailCrossings p) . op Path -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. trailCrossings :: RealFloat n => Point V2 n -> Located (Trail V2 n) -> Int -- non-loop trails have no inside or outside, so don't contribute crossings trailCrossings _ t | not (isLoop (unLoc t)) = 0 trailCrossings p@(unp2 -> (x,y)) tr = sum . map test $ fixTrail tr where test (FLinear a@(unp2 -> (_,ay)) b@(unp2 -> (_,by))) | ay <= y && by > y && isLeft a b > 0 = 1 | by <= y && ay > y && isLeft a b < 0 = -1 | otherwise = 0 test c@(FCubic (P x1@(V2 _ x1y)) (P c1@(V2 _ c1y)) (P c2@(V2 _ c2y)) (P x2@(V2 _ x2y)) ) = sum . map testT $ ts where ts = filter (liftA2 (&&) (>=0) (<=1)) $ cubForm (- x1y + 3*c1y - 3*c2y + x2y) ( 3*x1y - 6*c1y + 3*c2y) (-3*x1y + 3*c1y) (x1y - y) testT t = let (unp2 -> (px,_)) = c `atParam` t in if px > x then signFromDerivAt t else 0 signFromDerivAt t = let v = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) ^+^ ((-3)*^x1 ^+^ 3*^c1) ang = v ^. _theta . rad in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 | -tau/2 < ang && ang < 0 && t > 0 -> -1 | otherwise -> 0 isLeft a b = cross2 (b .-. a) (p .-. a) ------------------------------------------------------------ -- Clipping ---------------------------------------------- ------------------------------------------------------------ -- | @Clip@ tracks the accumulated clipping paths applied to a -- diagram. Note that the semigroup structure on @Clip@ is list -- concatenation, so applying multiple clipping paths is sensible. -- The clipping region is the intersection of all the applied -- clipping paths. newtype Clip n = Clip [Path V2 n] deriving (Typeable, Semigroup) makeWrapped ''Clip instance Typeable n => AttributeClass (Clip n) instance AsEmpty (Clip n) where _Empty = _Clip . _Empty type instance V (Clip n) = V2 type instance N (Clip n) = n instance (OrderedField n) => Transformable (Clip n) where transform t (Clip ps) = Clip (transform t ps) _Clip :: Iso (Clip n) (Clip n') [Path V2 n] [Path V2 n'] _Clip = _Wrapped -- | Lens onto the Clip in a style. An empty list means no clipping. _clip :: (Typeable n, OrderedField n) => Lens' (Style V2 n) [Path V2 n] _clip = atTAttr . non' _Empty . _Clip -- | Clip a diagram by the given path: -- -- * Only the parts of the diagram which lie in the interior of the -- path will be drawn. -- -- * The envelope of the diagram is unaffected. clipBy :: (HasStyle a, V a ~ V2, N a ~ n, TypeableFloat n) => Path V2 n -> a -> a clipBy = applyTAttr . Clip . (:[]) -- | Clip a diagram to the given path setting its envelope to the -- pointwise minimum of the envelopes of the diagram and path. The -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. clipTo :: TypeableFloat n => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d where envP = appEnvelope . getEnvelope $ p envD = appEnvelope . getEnvelope $ d toEnvelope = case (envP, envD) of (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) (_, _) -> id intersectionTrace = Trace traceIntersections traceIntersections pt v = -- on boundary of d, inside p onSortedList (filter pInside) (appTrace (getTrace d) pt v) <> -- or on boundary of p, inside d onSortedList (filter dInside) (appTrace (getTrace p) pt v) where newPt dist = pt .+^ v ^* dist pInside dDist = runFillRule Winding (newPt dDist) p dInside pDist = getAny . sample d $ newPt pDist -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. clipped :: TypeableFloat n => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipped p = withTrace p . withEnvelope p . clipBy p ------------------------------------------------------------ -- Intersections ----------------------------------------- ------------------------------------------------------------ -- | Find the intersect points of two objects that can be converted to a path. intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) => t -> s -> [P2 n] intersectPoints = intersectPoints' 1e-10 -- | Find the intersect points of two objects that can be converted to a path -- within the given tolerance. intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) => n -> t -> s -> [P2 n] intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) -- | Compute the intersect points between two paths. intersectPointsP :: OrderedField n => Path V2 n -> Path V2 n -> [P2 n] intersectPointsP = intersectPointsP' 1e-10 -- | Compute the intersect points between two paths within given tolerance. intersectPointsP' :: OrderedField n => n -> Path V2 n -> Path V2 n -> [P2 n] intersectPointsP' eps as bs = do a <- pathTrails as b <- pathTrails bs intersectPointsT' eps a b -- | Compute the intersect points between two located trails. intersectPointsT :: OrderedField n => Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] intersectPointsT = intersectPointsT' 1e-10 -- | Compute the intersect points between two located trails within the given -- tolerance. intersectPointsT' :: OrderedField n => n -> Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] intersectPointsT' eps as bs = do a <- fixTrail as b <- fixTrail bs intersectPointsS' eps a b diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Transform.hs0000644000000000000000000002532012754644012020110 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Transformations specific to two dimensions, with a few generic -- transformations (uniform scaling, translation) also re-exported for -- convenience. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Transform ( T2 -- * Rotation , rotation, rotate, rotateBy, rotated , rotationAround, rotateAround , rotationTo, rotateTo -- * Scaling , scalingX, scaleX , scalingY, scaleY , scaling, scale , scaleToX, scaleToY , scaleUToX, scaleUToY -- * Translation , translationX, translateX , translationY, translateY , translation, translate -- * Reflection , reflectionX, reflectX , reflectionY, reflectY , reflectionAbout, reflectAbout -- * Shears , shearingX, shearX , shearingY, shearY ) where import Diagrams.Angle import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Direction import Diagrams.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Control.Lens hiding (at, transform) import Data.Semigroup import Linear.Affine import Linear.Vector -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. rotation :: Floating n => Angle n -> T2 n rotation theta = fromLinear r (linv r) where r = rot theta <-> rot (negated theta) rot th (V2 x y) = V2 (cosA th * x - sinA th * y) (sinA th * x + cosA th * y) -- | Rotate about the local origin by the given angle. Positive angles -- correspond to counterclockwise rotation, negative to -- clockwise. The angle can be expressed using any of the 'Iso's on -- 'Angle'. For example, @rotate (1\/4 \@\@ 'turn')@, @rotate -- (tau\/4 \@\@ rad)@, and @rotate (90 \@\@ deg)@ all -- represent the same transformation, namely, a counterclockwise -- rotation by a right angle. To rotate about some point other than -- the local origin, see 'rotateAbout'. -- -- Note that writing @rotate (1\/4)@, with no 'Angle' constructor, -- will yield an error since GHC cannot figure out which sort of -- angle you want to use. In this common situation you can use -- 'rotateBy', which interprets its argument as a number of turns. rotate :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', interpreting its argument in units of -- turns; it can be more convenient to write @rotateBy (1\/4)@ than -- @'rotate' (1\/4 \@\@ 'turn')@. rotateBy :: (InSpace V2 n t, Transformable t, Floating n) => n -> t -> t rotateBy = transform . rotation . review turn -- | Use an 'Angle' to make an 'Iso' between an object -- rotated and unrotated. This us useful for performing actions -- 'under' a rotation: -- -- @ -- under (rotated t) f = rotate (negated t) . f . rotate t -- rotated t ## a = rotate t a -- a ^. rotated t = rotate (-t) a -- over (rotated t) f = rotate t . f . rotate (negated t) -- @ rotated :: (InSpace V2 n a, Floating n, SameSpace a b, Transformable a, Transformable b) => Angle n -> Iso a b a b rotated = transformed . rotation -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). rotationAround :: Floating n => P2 n -> Angle n -> T2 n rotationAround p theta = conjugate (translation (origin .-. p)) (rotation theta) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. rotateAround :: (InSpace V2 n t, Transformable t, Floating n) => P2 n -> Angle n -> t -> t rotateAround p theta = transform (rotationAround p theta) -- | The rotation that aligns the x-axis with the given direction. rotationTo :: OrderedField n => Direction V2 n -> T2 n rotationTo (view _Dir -> V2 x y) = rotation (atan2A' y x) -- | Rotate around the local origin such that the x axis aligns with the -- given direction. rotateTo :: (InSpace V2 n t, OrderedField n, Transformable t) => Direction V2 n -> t -> t rotateTo = transform . rotationTo -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. scalingX :: (Additive v, R1 v, Fractional n) => n -> Transformation v n scalingX c = fromSymmetric $ (_x *~ c) <-> (_x //~ c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. scaleX :: (InSpace v n t, R2 v, Fractional n, Transformable t) => n -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. scalingY :: (Additive v, R2 v, Fractional n) => n -> Transformation v n scalingY c = fromSymmetric $ (_y *~ c) <-> (_y //~ c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. scaleY :: (InSpace v n t, R2 v, Fractional n, Transformable t) => n -> t -> t scaleY = transform . scalingY -- | @scaleToX w@ scales a diagram in the x (horizontal) direction by -- whatever factor required to make its width @w@. @scaleToX@ -- should not be applied to diagrams with a width of 0, such as -- 'vrule'. scaleToX :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t scaleToX w d = scaleX (w / diameter unitX d) d -- | @scaleToY h@ scales a diagram in the y (vertical) direction by -- whatever factor required to make its height @h@. @scaleToY@ -- should not be applied to diagrams with a height of 0, such as -- 'hrule'. scaleToY :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t scaleToY h d = scaleY (h / diameter unitY d) d -- | @scaleUToX w@ scales a diagram /uniformly/ by whatever factor -- required to make its width @w@. @scaleUToX@ should not be -- applied to diagrams with a width of 0, such as 'vrule'. scaleUToX :: (InSpace v n t, R1 v, Enveloped t, Transformable t) => n -> t -> t scaleUToX w d = scale (w / diameter unitX d) d -- | @scaleUToY h@ scales a diagram /uniformly/ by whatever factor -- required to make its height @h@. @scaleUToY@ should not be applied -- to diagrams with a height of 0, such as 'hrule'. scaleUToY :: (InSpace v n t, R2 v, Enveloped t, Transformable t) => n -> t -> t scaleUToY h d = scale (h / diameter unitY d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. translationX :: (Additive v, R1 v, Num n) => n -> Transformation v n translationX x = translation (zero & _x .~ x) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. translateX :: (InSpace v n t, R1 v, Transformable t) => n -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. translationY :: (Additive v, R2 v, Num n) => n -> Transformation v n translationY y = translation (zero & _y .~ y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. translateY :: (InSpace v n t, R2 v, Transformable t) => n -> t -> t translateY = transform . translationY -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram from left to -- right, i.e. sends the point (x,y) to (-x,y). reflectionX :: (Additive v, R1 v, Num n) => Transformation v n reflectionX = fromSymmetric $ (_x *~ (-1)) <-> (_x *~ (-1)) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). reflectX :: (InSpace v n t, R1 v, Transformable t) => t -> t reflectX = transform reflectionX -- | Construct a transformation which flips a diagram from top to -- bottom, i.e. sends the point (x,y) to (x,-y). reflectionY :: (Additive v, R2 v, Num n) => Transformation v n reflectionY = fromSymmetric $ (_y *~ (-1)) <-> (_y *~ (-1)) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). reflectY :: (InSpace v n t, R2 v, Transformable t) => t -> t reflectY = transform reflectionY -- | @reflectionAbout p d@ is a reflection in the line determined by -- the point @p@ and direction @d@. reflectionAbout :: OrderedField n => P2 n -> Direction V2 n -> T2 n reflectionAbout p d = conjugate (rotationTo d <> translation (origin .-. p)) reflectionY -- | @reflectAbout p d@ reflects a diagram in the line determined by -- the point @p@ and direction @d@. reflectAbout :: (InSpace V2 n t, OrderedField n, Transformable t) => P2 n -> Direction V2 n -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- -- auxiliary functions for shearingX/shearingY sh :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n sh f g k (V2 x y) = V2 (f k x y) (g k x y) sh' :: (n -> n -> n -> n) -> (n -> n -> n -> n) -> n -> V2 n -> V2 n sh' f g k = swap . sh f g k . swap swap :: V2 n -> V2 n swap (V2 x y) = V2 y x {-# INLINE swap #-} -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. shearingX :: Num n => n -> T2 n shearingX d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) where f k x y = x + k*y g _ _ y = y -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. shearX :: (InSpace V2 n t, Transformable t) => n -> t -> t shearX = transform . shearingX -- | @shearingY d@ is the linear transformation which is the identity on -- x coordinates and sends @(1,0)@ to @(1,d)@. shearingY :: Num n => n -> T2 n shearingY d = fromLinear (sh f g d <-> sh f g (-d)) (sh' f g d <-> sh' f g (-d)) where f _ x _ = x g k x y = y + k*x -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. shearY :: (InSpace V2 n t, Transformable t) => n -> t -> t shearY = transform . shearingY diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Image.hs0000644000000000000000000001232112754644012017154 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Image -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Importing external images into diagrams. Usage example: To create -- a diagram from an embedded image with width 1 and height set -- according to the aspect ratio, use @image img # scaleUToX 1@, where -- @img@ is a value of type @DImage n e@, created with a function like -- 'loadImageEmb', 'loadImageExt', or 'raster'. ----------------------------------------------------------------------------- module Diagrams.TwoD.Image ( DImage(..), ImageData(..) , Embedded, External, Native , image , loadImageEmb , loadImageExt , uncheckedImageRef , raster , rasterDia ) where import Codec.Picture import Codec.Picture.Types (dynamicMap) import Data.Colour (AlphaColour) import Data.Semigroup import Data.Typeable (Typeable) import Diagrams.Core import Diagrams.Attributes (colorToSRGBA) import Diagrams.TwoD.Path (isInsideEvenOdd) import Diagrams.TwoD.Shapes (rect) import Diagrams.TwoD.Types import Linear.Affine data Embedded deriving Typeable data External deriving Typeable data Native (t :: *) deriving Typeable -- | 'ImageData' is either a JuicyPixels @DynamicImage@ tagged as 'Embedded' or -- a reference tagged as 'External'. Additionally 'Native' is provided for -- external libraries to hook into. data ImageData :: * -> * where ImageRaster :: DynamicImage -> ImageData Embedded ImageRef :: FilePath -> ImageData External ImageNative :: t -> ImageData (Native t) ------------------------------------------------------------------------------- -- | An image primitive, the two ints are width followed by height. -- Will typically be created by @loadImageEmb@ or @loadImageExt@ which, -- will handle setting the width and height to the actual width and height -- of the image. data DImage :: * -> * -> * where DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t deriving Typeable type instance V (DImage n a) = V2 type instance N (DImage n a) = n instance Fractional n => Transformable (DImage n a) where transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2) instance Fractional n => HasOrigin (DImage n a) where moveOriginTo p = translate (origin .-. p) -- | Make a 'DImage' into a 'Diagram'. image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b) => DImage n a -> QDiagram b V2 n Any image img = mkQD (Prim img) (getEnvelope r) (getTrace r) mempty (Query $ \p -> Any (isInsideEvenOdd p r)) where r = rect (fromIntegral w) (fromIntegral h) DImage _ w h _ = img -- | Use JuicyPixels to read an image in any format and wrap it in a 'DImage'. -- The width and height of the image are set to their actual values. loadImageEmb :: Num n => FilePath -> IO (Either String (DImage n Embedded)) loadImageEmb path = do dImg <- readImage path return $ case dImg of Left msg -> Left msg Right img -> Right (DImage (ImageRaster img) w h mempty) where w = dynamicMap imageWidth img h = dynamicMap imageHeight img -- | Check that a file exists, and use JuicyPixels to figure out -- the right size, but save a reference to the image instead -- of the raster data loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External)) loadImageExt path = do dImg <- readImage path return $ case dImg of Left msg -> Left msg Right img -> Right $ DImage (ImageRef path) w h mempty where w = dynamicMap imageWidth img h = dynamicMap imageHeight img -- | Make an "unchecked" image reference; have to specify a -- width and height. Unless the aspect ratio of the external -- image is the w :: h, then the image will be distorted. uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External uncheckedImageRef path w h = DImage (ImageRef path) w h mempty -- | Crate a diagram from raw raster data. rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b) => (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any rasterDia f w h = image $ raster f w h -- | Create an image "from scratch" by specifying the pixel data raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty where img = generateImage g w h g x y = fromAlphaColour $ f x y fromAlphaColour :: AlphaColour Double -> PixelRGBA8 fromAlphaColour c = PixelRGBA8 r g b a where (r, g, b, a) = (int r', int g', int b', int a') (r', g', b', a') = colorToSRGBA c int x = round (255 * x) instance Fractional n => (Renderable (DImage n a) NullBackend) where render _ _ = mempty diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Types.hs0000644000000000000000000000453712754644012017250 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Types -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Basic types for two-dimensional Euclidean space. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Types ( -- * 2D Euclidean space V2 (..), R1 (..), R2 (..) , P2, T2 , r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso , r2PolarIso , HasR (..) ) where import Control.Lens (Iso', Lens', iso, _1, _2) import Diagrams.Angle import Diagrams.Points import Diagrams.Core.Transform import Diagrams.Core.V import Linear.Metric import Linear.V2 type P2 = Point V2 type T2 = Transformation V2 type instance V (V2 n) = V2 type instance N (V2 n) = n -- | Construct a 2D vector from a pair of components. See also '&'. r2 :: (n, n) -> V2 n r2 = uncurry V2 -- | Convert a 2D vector back into a pair of components. See also 'coords'. unr2 :: V2 n -> (n, n) unr2 (V2 x y) = (x, y) -- | Curried form of `r2`. mkR2 :: n -> n -> V2 n mkR2 = V2 r2Iso :: Iso' (V2 n) (n, n) r2Iso = iso unr2 r2 -- | Construct a 2D point from a pair of coordinates. See also '^&'. p2 :: (n, n) -> P2 n p2 = P . uncurry V2 -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. unp2 :: P2 n -> (n,n) unp2 (P (V2 x y)) = (x,y) -- | Curried form of `p2`. mkP2 :: n -> n -> P2 n mkP2 x y = P (V2 x y) p2Iso :: Iso' (Point V2 n) (n, n) p2Iso = iso unp2 p2 instance Transformable (V2 n) where transform = apply r2PolarIso :: RealFloat n => Iso' (V2 n) (n, Angle n) r2PolarIso = iso (\v@(V2 x y) -> (norm v, atan2A y x)) (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) {-# INLINE r2PolarIso #-} -- | A space which has magnitude '_r' that can be calculated numerically. class HasR t where _r :: RealFloat n => Lens' (t n) n instance HasR v => HasR (Point v) where _r = lensP . _r {-# INLINE _r #-} instance HasR V2 where _r = r2PolarIso . _1 {-# INLINE _r #-} instance HasTheta V2 where _theta = r2PolarIso . _2 {-# INLINE _theta #-} diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Align.hs0000644000000000000000000001200412754644012017162 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Align -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Alignment combinators specialized for two dimensions. See -- "Diagrams.Align" for more general alignment combinators. -- -- The basic idea is that alignment is achieved by moving diagrams' -- 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, snugX, alignY, snugY -- * Centering , centerX, centerY, centerXY , snugCenterX, snugCenterY, snugCenterXY ) where import Diagrams.Core import Diagrams.Align import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -- | 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 :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignL = align unit_X snugL :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugL = snug unit_X -- | Align along the right edge. alignR :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignR = align unitX snugR :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugR = snug unitX -- | Align along the top edge. alignT :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignT = align unitY snugT:: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugT = snug unitY -- | Align along the bottom edge. alignB :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignB = align unit_Y snugB :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugB = snug unit_Y alignTL, alignTR, alignBL, alignBR :: (InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR snugTL, snugTR, snugBL, snugBR :: (InSpace V2 n a, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugTL = snugT . snugL snugTR = snugT . snugR snugBL = snugB . snugL snugBR = snugB . snugR -- | @alignX@ and @snugX@ move the local origin horizontally as follows: -- -- * @alignX (-1)@ moves the local origin to the left edge of the boundary; -- -- * @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. -- -- * @snugX@ works the same way. alignX :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a alignX = alignBy unitX -- | See the documentation for 'alignX'. snugX :: (InSpace v n a, R1 v, Fractional n, Alignable a, Traced a, HasOrigin a) => n -> 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 :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a alignY = alignBy unitY -- | See the documentation for 'alignY'. snugY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => n -> a -> a snugY = snugBy unitY -- | Center the local origin along the X-axis. centerX :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerX = alignBy unitX 0 snugCenterX :: (InSpace v n a, R1 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugCenterX = snugBy unitX 0 -- | Center the local origin along the Y-axis. centerY :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerY = alignBy unitY 0 snugCenterY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugCenterY = snugBy unitY 0 -- | Center along both the X- and Y-axes. centerXY :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerXY = centerX . centerY snugCenterXY :: (InSpace v n a, R2 v, Fractional n, Alignable a, Traced a, HasOrigin a) => a -> a snugCenterXY = snugCenterX . snugCenterY diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Curvature.hs0000644000000000000000000001522412754644012020117 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Curvature -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Compute curvature for segments in two dimensions. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Curvature ( curvature , radiusOfCurvature , squaredCurvature , squaredRadiusOfCurvature ) where import Control.Lens (over) import Control.Monad import Data.Monoid.Inf import Diagrams.Segment import Diagrams.Tangent import Diagrams.TwoD.Types import Linear.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 -- along the curve. When the wheel is held straight there is zero curvature. -- When turning a corner to the left we will have positive curvature. When -- turning to the right we will have negative curvature. -- -- Another way to measure this idea is to find the largest circle that we can -- push up against the curve and have it touch (locally) at exactly the point -- and not cross the curve. This is a tangent circle. The radius of that -- circle is the \"Radius of Curvature\" and it is the reciprocal of curvature. -- Note that if the circle is on the \"left\" of the curve, we have a positive -- radius, and if it is to the right we have a negative radius. Straight -- segments have an infinite radius which leads us to our representation. We -- result in a pair of numerator and denominator so we can include infinity and -- zero for both the radius and the curvature. -- -- -- Lets consider the following curve: -- -- <> -- -- The curve starts with positive curvature, -- -- <> -- -- approaches zero curvature -- -- <> -- -- then has negative curvature -- -- <> -- -- > {-# LANGUAGE GADTs #-} -- > -- > import Diagrams.TwoD.Curvature -- > import Data.Monoid.Inf -- > import Diagrams.Coordinates -- > -- > segmentA :: Segment Closed V2 Double -- > segmentA = Cubic (12 ^& 0) (8 ^& 10) (OffsetClosed (20 ^& 8)) -- > -- > curveA = lw thick . strokeP . fromSegments $ [segmentA] -- > -- > diagramA = pad 1.1 . centerXY $ curveA -- > -- > diagramPos = diagramWithRadius 0.2 -- > -- > diagramZero = diagramWithRadius 0.45 -- > -- > diagramNeg = diagramWithRadius 0.8 -- > -- > diagramWithRadius t = pad 1.1 . centerXY -- > $ curveA -- > <> showCurvature segmentA t -- > # withEnvelope (curveA :: D V2 Double) -- > # lc red -- > -- > showCurvature :: Segment Closed V2 Double -> Double -> Diagram SVG -- > showCurvature bez@(Cubic b c (OffsetClosed d)) t -- > | v == (0,0) = mempty -- > | otherwise = go (radiusOfCurvature bez t) -- > where -- > v@(x,y) = unr2 $ firstDerivative b c d t -- > 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 -- > -- > go Infinity = mempty -- > go (Finite r) = (circle (abs r) # translate vpr -- > <> strokeP (origin ~~ (origin .+^ vpr))) -- > # moveTo (origin .+^ atParam bez t) -- > where -- > vpr = signorm vp ^* r -- > -- curvature :: RealFloat n => Segment Closed V2 n -- ^ Segment to measure on. -> n -- ^ Parameter to measure at. -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents -- infinite curvature or zero radius of curvature. curvature s = toPosInf . over _y sqrt . curvaturePair s -- | With @squaredCurvature@ we can compute values in spaces that do not support -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking -- for zeros. squaredCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n squaredCurvature s = toPosInf . over _x (join (*)) . curvaturePair s -- | Reciprocal of @curvature@. radiusOfCurvature :: RealFloat n => Segment Closed V2 n -- ^ Segment to measure on. -> n -- ^ Parameter to measure at. -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents -- infinite radius of curvature or zero curvature. radiusOfCurvature s = toPosInf . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s -- | Reciprocal of @squaredCurvature@ squaredRadiusOfCurvature :: RealFloat n => Segment Closed V2 n -> n -> PosInf n squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (p * p))) . curvaturePair s -- Package up problematic values with the appropriate infinity. toPosInf :: RealFloat a => V2 a -> PosInf a toPosInf (V2 _ 0) = Infinity toPosInf (V2 p q) | isInfinite r || isNaN r = Infinity | otherwise = Finite r where r = p / q -- Internal function that is not quite curvature or squaredCurvature but lets -- us get there by either taking the square root of the numerator or squaring -- the denominator respectively. curvaturePair :: Num n => Segment Closed V2 n -> n -> V2 n curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). curvaturePair seg@(Cubic b c (OffsetClosed d)) t = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Int)) where (V2 x' y' ) = seg `tangentAtParam` t (V2 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 -- -- -- TODO: I'm not sure what the best way to generalize squaredCurvature to other spaces is. -- curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) -- => Segment Closed (t, t) -> Scalar t -> (t, t) -- 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' ) = seg `tangentAtParam` t -- (x'',y'') = secondDerivative -- secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Segment.hs0000644000000000000000000003157612754644012017551 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Orphan Traced instances for Segment Closed V2 and FixedSegment V2. -- They can't go in Traced; but they shouldn't really go in -- Diagrams.Segment either because we only have Traced instances for -- the special case of R2. ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Segment -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Segments in two dimensions are special since we may meaningfully -- compute their point of intersection with a ray. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Segment ( -- * Segment intersections intersectPointsS , intersectPointsS' -- * Closest point on a segment , closestPoint , closestPoint' , closestDistance , closestDistance' , closestParam , closestParam' -- ** Low level functions , segmentSegment , lineSegment ) where import Control.Lens hiding (at, contains, transform, ( # )) import Data.Maybe import Diagrams.Core import Diagrams.Direction import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.TwoD.Points import Diagrams.TwoD.Segment.Bernstein import Diagrams.TwoD.Transform import Diagrams.TwoD.Types hiding (p2) import Diagrams.TwoD.Vector import Linear.Affine import Linear.Metric {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. -} instance OrderedField n => Traced (Segment Closed V2 n) where getTrace = getTrace . mkFixedSeg . (`at` origin) instance OrderedField n => Traced (FixedSegment V2 n) where getTrace seg = mkTrace $ \p v -> mkSortedList . map (view _1) $ lineSegment defEps (v `at` p) seg defEps :: Fractional n => n defEps = 1e-8 -- | Compute the intersections between two fixed segments. intersectPointsS :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] intersectPointsS = intersectPointsS' defEps -- | Compute the intersections between two segments using the given tolerance. intersectPointsS' :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] intersectPointsS' eps s1 s2 = map (view _3) $ segmentSegment eps s1 s2 -- | Get the closest distance(s) from a point to a 'FixedSegment'. closestDistance :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] closestDistance = closestDistance' defEps -- | Get the closest distance(s) from a point to a 'FixedSegment' within given -- tolerance. closestDistance' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] closestDistance' eps seg p = map (distanceA p) $ closestPoint' eps seg p -- | Get the closest point(s) on a 'FixedSegment' from a point. closestPoint :: OrderedField n => FixedSegment V2 n -> P2 n -> [P2 n] closestPoint = closestPoint' defEps -- | Get the closest point(s) on a 'FixedSegment' from a point within given -- tolerance. closestPoint' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [P2 n] closestPoint' eps seg = map (seg `atParam`) . closestParam' eps seg -- | Find the closest value(s) on the Bêzier to the given point. closestParam :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] closestParam = closestParam' defEps -- | Find the closest value(s) on the Bêzier to the given point within given -- tolerance. closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] closestParam' _ (FLinear p0 p1) p | t < 0 = [0] | t > 1 = [1] | otherwise = [t] where vp = p .-. p0 v = p1 .-. p0 dp = vp `dot` v t = dp / quadrance v closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1 where (bx, by) = bezierToBernstein cb bx' = bernsteinDeriv bx by' = bernsteinDeriv by poly = (bx - listToBernstein [px, px, px, px]) * bx' + (by - listToBernstein [py, py, py, py]) * by' ------------------------------------------------------------------------ -- Low level ------------------------------------------------------------------------ -- | Return the intersection points with the parameters at which each segment -- intersects. segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)] segmentSegment eps s1 s2 = case (s1,s2) of (FCubic{}, FCubic{}) -> map (\(t1,t2) -> (t1,t2, s1 `atParam` t1)) $ bezierClip eps s1 s2 (FCubic{}, FLinear{}) -> map flip12 $ linearSeg (segLine s2) s1 _ -> linearSeg (segLine s1) s2 -- s1 is linear where linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s flip12 (a,b,c) = (b,a,c) -- | Return the intersection points with the parameters at which the line and segment -- intersect. lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)] lineSegment _ l1 p@(FLinear p0 p1) = map (\(tl,tp) -> (tl, tp, p `atParam` tp)) . filter (inRange . snd) . maybeToList $ lineLine l1 (mkLine p0 p1) lineSegment eps (viewLoc -> (p,r)) cb = map addPoint params where params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1 cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb -- addPoint bt = (lt, bt, intersect) where intersect = cb `atParam` bt lt = (cb' `atParam` bt) ^. _x / norm r -- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier -- | Use the Bêzier clipping algorithm to return the parameters at which the -- Bêzier curves intersect. bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)] bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN $ go p_ q_ 0 1 0 1 0 False where go p q tmin tmax umin umax clip revCurves | isNothing chopInterval = [] -- split the curve if there isn't enough reduction | clip > 0.8 && clip' > 0.8 = if tmax' - tmin' > umax - umin -- split the longest segment then let (pl, pr) = p' `splitAtParam` 0.5 tmid = avg tmin' tmax' in go q pl umin umax tmin' tmid clip' (not revCurves) ++ go q pr umin umax tmid tmax' clip' (not revCurves) else let (ql, qr) = q `splitAtParam` 0.5 umid = avg umin umax in go ql p' umin umid tmin' tmax' clip' (not revCurves) ++ go qr p' umid umax tmin' tmax' clip' (not revCurves) | max (umax - umin) (tmax' - tmin') < eps = if revCurves -- return parameters in correct order then [ (avg umin umax, avg tmin' tmax') ] else [ (avg tmin' tmax', avg umin umax ) ] -- iterate with the curves reversed. | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves) where chopInterval = chopCubics p q Just (tminChop, tmaxChop) = chopInterval p' = section p tminChop tmaxChop clip' = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) -- | Find the zero of a 1D Bêzier curve of any degree. Note that this -- can be used as a Bernstein polynomial root solver by converting from -- the power basis to the Bernstein basis. bezierFindRoot :: OrderedField n => n -- ^ The accuracy -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial -> n -- ^ The lower bound of the interval -> n -- ^ The upper bound of the interval -> [n] -- ^ The roots found bezierFindRoot eps p tmin tmax | isNothing chopInterval = [] | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 tmid = tmin' + (tmax' - tmin') / 2 in bezierFindRoot eps p1 tmin' tmid ++ bezierFindRoot eps p2 tmid tmax' | tmax' - tmin' < eps = [avg tmin' tmax'] | otherwise = bezierFindRoot eps newP tmin' tmax' where chopInterval = chopYs (bernsteinCoeffs p) Just (tminChop, tmaxChop) = chopInterval newP = section p tminChop tmaxChop clip = tmaxChop - tminChop tmin' = tmax * tminChop + tmin * (1 - tminChop) tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) ------------------------------------------------------------------------ -- Internal ------------------------------------------------------------------------ -- | An approximation of the fat line for a cubic Bêzier segment. Returns -- @(0,0)@ for a linear segment. fatLine :: OrderedField n => FixedSegment V2 n -> (n,n) fatLine (FCubic p0 p1 p2 p3) = case (d1 > 0, d2 > 0) of (True, True) -> (0, 0.75 * max d1 d2) (False, False) -> (0.75 * min d1 d2, 0 ) (True, False) -> (4/9 * d2, 4/9 * d1 ) (False, True) -> (4/9 * d1, 4/9 * d2 ) where d = lineDistance p0 p3 d1 = d p1; d2 = d p2 fatLine _ = (0,0) chopYs :: OrderedField n => [n] -> Maybe (n, n) chopYs ds = chopHull 0 0 points where points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0..n]] ds n = length ds - 1 chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n,n) chopCubics p q@(FCubic q0 _ _ q3) = chopHull dmin dmax dps where dps = zipWith mkP2 [0, 1/3, 2/3, 1] ds ds = p ^.. each . to d d = lineDistance q0 q3 -- (dmin,dmax) = fatLine q chopCubics _ _ = Nothing -- Reduce the interval which the intersection is known to lie in using the fat -- line of one curve and convex hull of the points formed from the distance to -- the thin line of the other chopHull :: OrderedField n => n -> n -> [P2 n] -> Maybe (n, n) chopHull dmin dmax dps = do tL <- testBelow upper $ testBetween (head upper) $ testAbove lower tR <- testBelow (reverse upper) $ testBetween (last upper) $ testAbove (reverse lower) Just (tL, tR) where (upper, lower) = sortedConvexHull dps testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue | y1 >= dmin = continue | y1 > y2 = Nothing | y2 < dmin = testBelow (p2:ps) continue | otherwise = Just $ intersectPt dmin p1 p2 testBelow _ _ = Nothing testBetween (P (V2 x y)) continue | y <= dmax = Just x | otherwise = continue testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) | y1 < y2 = Nothing | y2 > dmax = testAbove (p2:ps) | otherwise = Just $ intersectPt dmax p1 p2 testAbove _ = Nothing bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n) bezierToBernstein seg = (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) where coeffs = toListOf each seg ------------------------------------------------------------------------ -- Lines ------------------------------------------------------------------------ -- Could split this into a separate module. -- | Returns @(a, b, c)@ such that @ax + by + c = 0@ is the line going through -- @p1@ and @p2@ with @a^2 + b^2 = 1@. lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n) lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c) where a = a' / d b = b' / d c = -(x1*a' + y1*b') / d a' = y1 - y2 b' = x2 - x1 d = sqrt $ a'*a' + b'*b' -- | Return the distance from a point to the line. lineDistance :: Floating n => P2 n -> P2 n -> P2 n -> n lineDistance p1 p2 (P (V2 x y)) = a*x + b*y + c where (a, b, c) = lineEquation p1 p2 -- find the x value where the line through the two points -- intersect the line y=d intersectPt :: OrderedField n => n -> P2 n -> P2 n -> n intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = x1 + (d - y1) * (x2 - x1) / (y2 - y1) -- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool -- clockwise a b = a `cross2` b <= 0 avg :: Fractional n => n -> n -> n avg a b = (a + b)/2 lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n,n) lineLine (viewLoc -> (p,r)) (viewLoc -> (q,s)) | x1 == 0 && x2 /= 0 = Nothing -- parallel | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear where x1 = r × s x2 = v × r x3 = v × s v = q .-. p (×) :: Num n => V2 n -> V2 n -> n (×) = cross2 mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n) mkLine p0 p1 = (p1 .-. p0) `at` p0 segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n) segLine (FLinear p0 p1) = mkLine p0 p1 segLine (FCubic p0 _ _ p3) = mkLine p0 p3 inRange :: (Fractional n, Ord n) => n -> Bool inRange x = x < (1+defEps) && x > (-defEps) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Shapes.hs0000644000000000000000000003046212754644012017363 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Shapes -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Various two-dimensional shapes. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Shapes ( -- * Miscellaneous hrule, vrule -- * Regular polygons , regPoly , triangle , eqTriangle , square , pentagon , hexagon , heptagon , septagon , octagon , nonagon , decagon , hendecagon , dodecagon -- * Other special polygons , unitSquare , rect -- * Other shapes , roundedRect , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR , roundedRect' ) where import Control.Lens (makeLenses, op, (&), (.~), (<>~), (^.)) import Data.Default.Class import Data.Semigroup import Diagrams.Core import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Polygons import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util -- | Create a centered horizontal (L-R) line of the given length. -- -- <> -- -- > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5]) -- > # centerXY # pad 1.1 hrule :: (InSpace V2 n t, TrailLike t) => n -> t hrule d = trailLike $ trailFromSegments [straight $ r2 (d, 0)] `at` p2 (-d/2,0) -- | Create a centered vertical (T-B) line of the given length. -- -- <> -- -- > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2]) -- > # centerXY # pad 1.1 vrule :: (InSpace V2 n t, TrailLike t) => n -> t vrule d = trailLike $ trailFromSegments [straight $ r2 (0, -d)] `at` p2 (0,d/2) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- -- <> unitSquare :: (InSpace V2 n t, TrailLike t) => t unitSquare = polygon (def & polyType .~ PolyRegular 4 (sqrt 2 / 2) & polyOrient .~ OrientH) -- > 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 :: (InSpace V2 n t, TrailLike t) => n -> t square d = rect d d -- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3] -- > # centerXY # pad 1.1 -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. -- -- <> rect :: (InSpace V2 n t, TrailLike t) => n -> n -> t rect w h = trailLike . head . op Path $ unitSquare # scaleX w # scaleY h -- > rectEx = rect 1 0.7 # pad 1.1 -- The above may seem a bit roundabout. In fact, we used to have -- -- rect w h = unitSquare # scaleX w # scaleY h -- -- since unitSquare can produce any TrailLike. The current code -- instead uses (unitSquare # scaleX w # scaleY h) to specifically -- produce a Path, which is then deconstructed and passed back into -- 'trailLike' to create any TrailLike. -- -- The difference is that while scaling by zero works fine for -- Path it does not work very well for, say, Diagrams (leading to -- NaNs or worse). This way, we force the scaling to happen on a -- Path, where we know it will behave properly, and then use the -- resulting geometry to construct an arbitrary TrailLike. -- -- See https://github.com/diagrams/diagrams-lib/issues/43 . ------------------------------------------------------------ -- Regular polygons ------------------------------------------------------------ -- | Create a regular polygon. The first argument is the number of -- sides, and the second is the /length/ of the sides. (Compare to the -- 'polygon' function with a 'PolyRegular' option, which produces -- polygons of a given /radius/). -- -- The polygon will be oriented with one edge parallel to the x-axis. regPoly :: (InSpace V2 n t, TrailLike t) => Int -> n -> t regPoly n l = polygon (def & polyType .~ PolySides (repeat (1/fromIntegral n @@ turn)) (replicate (n-1) l) & polyOrient .~ OrientH ) -- > shapeEx sh = sh 1 # pad 1.1 -- > triangleEx = shapeEx triangle -- > pentagonEx = shapeEx pentagon -- > hexagonEx = shapeEx hexagon -- > heptagonEx = shapeEx heptagon -- > octagonEx = shapeEx octagon -- > nonagonEx = shapeEx nonagon -- > decagonEx = shapeEx decagon -- > hendecagonEx = shapeEx hendecagon -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. eqTriangle :: (InSpace V2 n t, TrailLike t) => n -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- -- <> triangle :: (InSpace V2 n t, TrailLike t) => n -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> pentagon :: (InSpace V2 n t, TrailLike t) => n -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> hexagon :: (InSpace V2 n t, TrailLike t) => n -> t hexagon = regPoly 6 -- | A regular heptagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> heptagon :: (InSpace V2 n t, TrailLike t) => n -> 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 :: (InSpace V2 n t, TrailLike t) => n -> t septagon = heptagon -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> octagon :: (InSpace V2 n t, TrailLike t) => n -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> nonagon :: (InSpace V2 n t, TrailLike t) => n -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> decagon :: (InSpace V2 n t, TrailLike t) => n -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> hendecagon :: (InSpace V2 n t, TrailLike t) => n -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> dodecagon :: (InSpace V2 n t, TrailLike t) => n -> t dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ data RoundedRectOpts d = RoundedRectOpts { _radiusTL :: d , _radiusTR :: d , _radiusBL :: d , _radiusBR :: d } makeLenses ''RoundedRectOpts instance (Num d) => Default (RoundedRectOpts d) 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 -- @r@ is negative the corner will be cut out in a reverse arc. If -- the size of @r@ is larger than half the smaller dimension of @w@ -- and @h@, then it will be reduced to fit in that range, to prevent -- the corners from overlapping. The trail or path begins with the -- right edge and proceeds counterclockwise. If you need to specify -- a different radius for each corner individually, use -- 'roundedRect'' instead. -- -- <> -- -- > 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 :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> n -> t roundedRect w h r = roundedRect' w h (def & radiusTL .~ r & radiusBR .~ r & radiusTR .~ r & radiusBL .~ r) -- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of -- each corner indivually, using @RoundedRectOpts@. The default corner radius is 0. -- Each radius can also be negative, which results in the curves being reversed -- to be inward instead of outward. roundedRect' :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> RoundedRectOpts n -> t roundedRect' w h opts = trailLike . (`at` p2 (w/2, abs rBR - h/2)) . wrapTrail . glueLine $ seg (0, h - abs rTR - abs rBR) <> mkCorner 0 rTR <> seg (abs rTR + abs rTL - w, 0) <> mkCorner 1 rTL <> seg (0, abs rTL + abs rBL - h) <> mkCorner 2 rBL <> seg (w - abs rBL - abs rBR, 0) <> mkCorner 3 rBR where seg = lineFromOffsets . (:[]) . r2 diag = sqrt (w * w + h * h) -- to clamp corner radius, need to compare with other corners that share an -- edge. If the corners overlap then reduce the largest corner first, as far -- as 50% of the edge in question. rTL = clampCnr radiusTR radiusBL radiusBR radiusTL rBL = clampCnr radiusBR radiusTL radiusTR radiusBL rTR = clampCnr radiusTL radiusBR radiusBL radiusTR rBR = clampCnr radiusBL radiusTR radiusTL radiusBR clampCnr rx ry ro r = let (rx',ry',ro',r') = (opts^.rx, opts^.ry, opts^.ro, opts^.r) in clampDiag ro' . clampAdj h ry' . clampAdj w rx' $ r' -- prevent curves of adjacent corners from overlapping clampAdj len adj r = if abs r > len/2 then sign r * max (len/2) (min (len - abs adj) (abs r)) else r -- prevent inward curves of diagonally opposite corners from intersecting clampDiag opp r = if r < 0 && opp < 0 && abs r > diag / 2 then sign r * max (diag / 2) (min (abs r) (diag + opp)) else r sign n = if n < 0 then -1 else 1 mkCorner k r | r == 0 = mempty | r < 0 = doArc 3 (-1) | otherwise = doArc 0 1 where doArc d s = arc' r (xDir & _theta <>~ ((k+d)/4 @@ turn)) (s/4 @@ turn) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Model.hs0000644000000000000000000001423212754644012017175 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Model -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Tools for visualizing diagrams' internal model: local origins, -- envelopes, traces, /etc./ -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Model ( -- * Showing the local origin showOrigin , showOrigin' , OriginOpts(..), oColor, oScale, oMinSize -- * Showing an approximation of the envelope , showEnvelope , showEnvelope' , EnvelopeOpts(..), eColor, eLineWidth, ePoints -- * Showing an approximation of the trace , showTrace , showTrace' , TraceOpts(..), tColor, tScale, tMinSize, tPoints -- * Showing labels of all named subdiagrams , showLabels ) where import Control.Arrow (second) import Control.Lens (makeLenses, (^.)) import Data.Colour (Colour) import Data.Colour.Names import Data.Default.Class import Data.List (intercalate) import qualified Data.Map as M import Data.Maybe (catMaybes) import Data.Semigroup import Diagrams.Attributes import Diagrams.Combinators (atPoints) import Diagrams.Core import Diagrams.Core.Names import Diagrams.CubicSpline import Diagrams.Path import Diagrams.TwoD.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path import Diagrams.TwoD.Text import Diagrams.TwoD.Transform (rotateBy) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX) import Diagrams.Util import Linear.Affine import Linear.Vector ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ data OriginOpts n = OriginOpts { _oColor :: Colour Double , _oScale :: n , _oMinSize :: n } makeLenses ''OriginOpts instance Fractional n => Default (OriginOpts n) where def = OriginOpts red (1/50) 0.001 data EnvelopeOpts n = EnvelopeOpts { _eColor :: Colour Double , _eLineWidth :: Measure n , _ePoints :: Int } makeLenses ''EnvelopeOpts instance OrderedField n => Default (EnvelopeOpts n) where def = EnvelopeOpts red medium 32 data TraceOpts n = TraceOpts { _tColor :: Colour Double , _tScale :: n , _tMinSize :: n , _tPoints :: Int } makeLenses ''TraceOpts instance Floating n => Default (TraceOpts n) where def = TraceOpts red (1/100) 0.001 64 -- | Mark the origin of a diagram by placing a red dot 1/50th its size. showOrigin :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) => QDiagram b V2 n m -> QDiagram b V2 n m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. showOrigin' :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d where o = strokeP (circle sz) # fc (oo^.oColor) # lw none # fmap (const mempty) V2 w h = oo^.oScale *^ size d sz = maximum [w, h, oo^.oMinSize] -- | Mark the envelope with an approximating cubic spline with control -- over the color, line width and number of points. showEnvelope' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) => EnvelopeOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any showEnvelope' opts d = cubicSpline True pts # lc (opts^.eColor) # lw w <> d where pts = catMaybes [envelopePMay v d | v <- map (`rotateBy` unitX) [0,inc..top]] w = opts ^. eLineWidth inc = 1 / fromIntegral (opts^.ePoints) top = 1 - inc -- | Mark the envelope with an approximating cubic spline -- using 32 points, medium line width and red line color. showEnvelope :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) => QDiagram b V2 n Any -> QDiagram b V2 n Any showEnvelope = showEnvelope' def -- | Mark the trace of a diagram, with control over colour and scale -- of marker dot and the number of points on the trace. showTrace' :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) => TraceOpts n -> QDiagram b V2 n Any -> QDiagram b V2 n Any showTrace' opts d = atPoints ps (repeat pt) <> d where ps = concatMap p ts ts = zip rs vs p (r, v) = [origin .+^ (s *^ v) | s <- r] vs = map (`rotateBy` unitX) [0, inc..top] rs = [getSortedList $ (appTrace . getTrace) d origin v | v <- vs] pt = circle sz # fc (opts^.tColor) # lw none V2 w h = opts^.tScale *^ size d sz = maximum [w, h, opts^.tMinSize] inc = 1 / fromIntegral (opts^.tPoints) top = 1 - inc -- | Mark the trace of a diagram by placing 64 red dots 1/100th its size -- along the trace. showTrace :: (Enum n, TypeableFloat n, Renderable (Path V2 n) b) => QDiagram b V2 n Any -> QDiagram b V2 n Any showTrace = showTrace' def ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ showLabels :: (TypeableFloat n, Renderable (Text n) b, Semigroup m) => QDiagram b V2 n m -> QDiagram b V2 n Any showLabels d = ( mconcat . map (\(n,p) -> text (simpleName n) # translate (p .-. origin)) . concatMap (\(n,ps) -> zip (repeat n) ps) . (map . second . map) location . M.assocs $ m ) <> fmap (const (Any False)) d where SubMap m = d^.subMap simpleName (Name ns) = intercalate " .> " $ map simpleAName ns simpleAName (AName n) = show n diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Ellipse.hs0000644000000000000000000000417012754644012017532 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Ellipse -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Two-dimensional ellipses (and, as a special case, circles). -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Ellipse ( -- * Ellipse and circle diagrams unitCircle , circle , ellipse , ellipseXY ) where import Diagrams.Core import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Trail (glueTrail) import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ V2, N t ~ n) => t unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). circle :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t circle d = unitCircle # scale d -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by -- scaling the unit circle in the X direction. The eccentricity must -- be within the interval [0,1). ellipse :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t ellipse e | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the -- origin, with radius @x@ along the x-axis and radius @y@ along the -- y-axis. ellipseXY :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> n -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Arc.hs0000644000000000000000000002165312754644012016647 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arc -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Two-dimensional arcs, approximated by cubic bezier curves. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Arc ( arc , arc' , arcT , arcCCW , arcCW , bezierFromSweep , wedge , arcBetween , annularWedge ) where import Diagrams.Angle import Diagrams.Core import Diagrams.Direction import Diagrams.Located (at) import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unitY, unit_Y, e) import Diagrams.Util (( # )) import Control.Lens ((&), (<>~), (^.)) import Data.Semigroup ((<>)) import Linear.Affine import Linear.Metric import Linear.Vector -- For details of this approximation see: -- http://www.tinaja.com/glib/bezcirc2.pdf -- | @bezierFromSweepQ1 s@ constructs a 'Cubic' segment that starts in -- the positive y direction and sweeps counterclockwise through an -- angle @s@. The approximation is only valid for angles in the -- first quadrant. bezierFromSweepQ1 :: Floating n => Angle n -> Segment Closed V2 n bezierFromSweepQ1 s = mapSegmentVectors (^-^ unitX) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 where p0@(V2 x y) = e (s ^/ 2) c1 = V2 ((4-x)/3) ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise -- through the angle @s@. If @s@ is negative, it will start in the -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ -- later segments will overlap earlier segments. bezierFromSweep :: OrderedField n => Angle n -> [Segment Closed V2 n] bezierFromSweep s | s < zero = fmap reflectY . bezierFromSweep $ negated s | s < 0.0001 @@ rad = [] | s < fullTurn^/4 = [bezierFromSweepQ1 s] | otherwise = bezierFromSweepQ1 (fullTurn^/4) : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zero)) {- ~~~~ Note [segment spacing] There are a few obvious options for segment spacing: A. Evenly space segments each with sweep less than or equal to one quarter of a circle. This has the benefit of a better approximation (at least I think it is better). B. Use as much of the sweep in quarter-circle sized segments and one for the remainder. This potentially gives more opportunities for consistency (though not as much as option C) as the error in approximation would more often match the error from another arc in the diagram. C. Like option B but fixing the orientation and having a remnant at the beginning and the end. Option B is implemented and this note is for posterity if anyone comes across a situation with large enough arcs that they can actually see the approximation error. -} -- | Given a start direction @d@ and a sweep angle @s@, @'arcT' d s@ -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out -- the angle @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. arcT :: OrderedField n => Direction V2 n -> Angle n -> Trail V2 n arcT start sweep = trailFromSegments bs where bs = map (rotateTo start) . bezierFromSweep $ sweep -- | Given a start direction @d@ and a sweep angle @s@, @'arc' d s@ is the -- path of a radius one arc starting at @d@ and sweeping out the angle -- @s@ counterclockwise (for positive s). The resulting -- @Trail@ is allowed to wrap around and overlap itself. arc :: (InSpace V2 n t, OrderedField n, TrailLike t) => Direction V2 n -> Angle n -> t arc start sweep = trailLike $ arcT start sweep `at` P (fromDirection start) -- | Given a radus @r@, a start direction @d@ and an angle @s@, -- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at -- @d@ and sweeping out the angle @s@ counterclockwise (for positive -- s). The origin of the arc is its center. -- -- <> -- -- > arc'Ex = mconcat [ arc' r xDir (1/4 @@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 arc' :: (InSpace V2 n t, OrderedField n, TrailLike t) => n -> Direction V2 n -> Angle n -> t arc' (abs -> r) start sweep = trailLike $ scale r ts `at` P (r *^ fromDirection start) where ts = arcT start sweep arcCCWT :: RealFloat n => Direction V2 n -> Direction V2 n -> Trail V2 n arcCCWT start end = trailFromSegments bs where bs = map (rotateTo start) . bezierFromSweep $ sweep sweep = normalizeAngle $ end ^. _theta ^-^ start ^. _theta -- | Given a start direction @s@ and end direction @e@, @arcCCW s e@ is the -- path of a radius one arc counterclockwise between the two directions. -- The origin of the arc is its center. arcCCW :: (InSpace V2 n t, RealFloat n, TrailLike t) => Direction V2 n -> Direction V2 n -> t arcCCW start end = trailLike $ arcCCWT start end `at` P (fromDirection start) -- | Like 'arcAngleCCW' but clockwise. arcCW :: (InSpace V2 n t, RealFloat n, TrailLike t) => Direction V2 n -> Direction V2 n -> t arcCW start end = trailLike $ -- flipped arguments to get the path we want -- then reverse the trail to get the cw direction. reverseTrail (arcCCWT end start) `at` P (fromDirection start) -- | Create a circular wedge of the given radius, beginning at the -- given direction and extending through the given angle. -- -- <> -- -- > wedgeEx = hcat' (with & sep .~ 0.5) -- > [ wedge 1 xDir (1/4 @@ turn) -- > , wedge 1 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) -- > , wedge 1 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 wedge :: (InSpace V2 n t, OrderedField n, TrailLike t) => n -> Direction V2 n -> Angle n -> t wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r <> fromOffsets [r *^ negated (rotate s $ fromDirection d)] -- | @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 ~ V2, N t ~ n, RealFloat n) => Point V2 n -> Point V2 n -> n -> t arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht isStraight = h < 0.00001 v = q .-. p d = norm (q .-. p) th = acosA ((d*d - 4*h*h)/(d*d + 4*h*h)) r = d/(2*sinA th) mid | ht >= 0 = direction unitY | otherwise = direction unit_Y st = mid & _theta <>~ negated th a | isStraight = fromOffsets [d *^ unitX] | otherwise = arc st (2 *^ th) # 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 direction and extending through the given sweep angle. -- The radius of the outer circle is given first. -- -- <> -- -- > annularWedgeEx = hsep 0.50 -- > [ annularWedge 1 0.5 xDir (1/4 @@ turn) -- > , annularWedge 1 0.3 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) -- > , annularWedge 1 0.7 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 annularWedge :: (TrailLike t, V t ~ V2, N t ~ n, RealFloat n) => n -> n -> Direction V2 n -> Angle n -> t annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1' - r2') *^ fromDirection d1] <> arc d1 s # scale r1' <> fromOffsets [(r1' - r2') *^ negated (fromDirection d2)] <> arc d2 (negated s) # scale r2' where o = origin # translate (r2' *^ fromDirection d1) d2 = d1 & _theta <>~ s diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Adjust.hs0000644000000000000000000000651412754644012017373 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Adjust -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A default diagram-adjustment implementation for two-dimensional -- diagrams, useful for backend implementors. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Adjust ( setDefault2DAttributes , adjustSize2D , adjustDia2D ) where import Diagrams.Attributes import Diagrams.Core import Diagrams.TwoD.Attributes (lineTextureA) import Diagrams.TwoD.Types import Diagrams.Util (( # )) import Diagrams.Size import Diagrams.BoundingBox import Control.Lens (Lens', (^.), set) import Data.Default.Class import Data.Semigroup -- | Set default attributes of a 2D diagram (in case they have not -- been set): -- -- * 'LineWidth': 0.01 -- -- * 'LineTexture': solid black -- -- * 'LineCap': LineCapButt -- -- * 'LineJoin': miter -- -- * 'MiterLimit': 10 setDefault2DAttributes :: (TypeableFloat n, Semigroup m) => QDiagram b V2 n m -> QDiagram b V2 n m setDefault2DAttributes d = d # lineWidthM def # lineTextureA def # lineCap def # lineJoin def # lineMiterLimitA def -- | Adjust the size and position of a 2D diagram to fit within the -- requested size. The first argument is a lens into the output -- size contained in the rendering options. Returns an updated -- options record, any transformation applied to the diagram (the -- inverse of which can be used, say, to translate output/device -- coordinates back into local diagram coordinates), and the -- modified diagram itself. adjustSize2D :: (TypeableFloat n, Monoid' m) => Lens' (Options b V2 n) (SizeSpec V2 n) -> b -> Options b V2 n -> QDiagram b V2 n m -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) adjustSize2D szL _ opts d = (set szL spec opts, t, d # transform t) where spec = dims sz (sz, t) = sizeAdjustment (opts ^. szL) (boundingBox d) -- | @adjustDia2D@ provides a useful default implementation of -- the 'adjustDia' method from the 'Backend' type class. -- -- As its first argument it requires a lens into the output size -- contained in the rendering options. -- -- It then performs the following adjustments: -- -- * Set default attributes (see 'setDefault2DAttributes') -- -- * Scale and translate the diagram to fit within the requested -- size (see 'adjustDiaSize2D') -- -- It returns an updated options record, any transformation applied -- to the diagram (the inverse of which can be used, say, to -- translate output/device coordinates back into local diagram -- coordinates), and the modified diagram itself. adjustDia2D :: (TypeableFloat n, Monoid' m) => Lens' (Options b V2 n) (SizeSpec V2 n) -> b -> Options b V2 n -> QDiagram b V2 n m -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) adjustDia2D szL b opts d = adjustSize2D szL b opts (d # setDefault2DAttributes) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Points.hs0000644000000000000000000000376212754644012017417 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Points -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Special functions for points in R2. -- ----------------------------------------------------------------------------- {-# LANGUAGE TypeFamilies #-} module Diagrams.TwoD.Points where import Data.List import Diagrams.Core import Diagrams.TwoD.Vector import Diagrams.TwoD.Types (P2) import Linear.Affine -- | Find the convex hull of a list of points using Andrew's monotone chain -- algorithm O(n log n). -- -- Returns clockwise list of points starting from the left-most point. convexHull2D :: OrderedField n => [P2 n] -> [P2 n] convexHull2D ps = init upper ++ reverse (tail lower) where (upper, lower) = sortedConvexHull (sort ps) -- | Find the convex hull of a set of points already sorted in the x direction. -- The first list of the tuple is the upper hull going clockwise from -- left-most to right-most point. The second is the lower hull from -- right-most to left-most in the anti-clockwise direction. sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n]) sortedConvexHull ps = (chain True ps, chain False ps) where chain upper (p1_:p2_:rest_) = case go (p2_ .-. p1_) p2_ rest_ of Right l -> p1_:l Left l -> chain upper (p1_:l) where test = if upper then (>0) else (<0) -- find the convex hull by comparing the angles of the vectors with -- the cross product and backtracking if necessary go dir p1 l@(p2:rest) -- backtrack if the direction is outward | test $ dir `cross2` dir' = Left l | otherwise = case go dir' p2 rest of Left m -> go dir p1 m Right m -> Right (p1:m) where dir' = p2 .-. p1 go _ p1 p = Right (p1:p) chain _ l = l diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Arrow.hs0000644000000000000000000005503312754644012017233 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Arrow -- Copyright : (c) 2013-2015 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 ultraThick -- > ds = (sq # named "left") ||| strutX 3 ||| (sq # named "right") -- > -- > shaft = cubicSpline False ( map p2 [(0, 0), (1, 0), (1, 0.2), (2, 0.2)]) -- > -- > example1 = ds # connect' (with & arrowHead .~ dart & arrowTail .~ quill -- > & arrowShaft .~ shaft -- > & headLength .~ huge & tailLength .~ veryLarge) -- > "left" "right" # pad 1.1 -- ** Example 2 -- | <> -- -- > -- Comparing connect, connectPerim, and arrowAt. -- > -- > oct = octagon 1 # lc darkgray # lw ultraThick # showOrigin -- > dias = oct # named "first" ||| strut 3 ||| oct # named "second" -- > -- > -- Connect two diagrams and two points on their trails. -- > ex12 = dias # connect' (with & lengths .~ veryLarge) "first" "second" -- > # connectPerim' (with & lengths .~ veryLarge) -- > "first" "second" (15/16 @@ turn) (9/16 @@ turn) -- > -- > -- Place an arrow at (0,0) the size and direction of (0,1). -- > ex3 = arrowAt origin unit_Y -- > -- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 -- * Creating arrows arrowV , arrowV' , arrowAt , arrowAt' , arrowBetween , arrowBetween' , connect , connect' , connectPerim , connectPerim' , connectOutside , connectOutside' , arrow , arrow' , arrowFromLocatedTrail , arrowFromLocatedTrail' -- * Options , ArrowOpts(..) , arrowHead , arrowTail , arrowShaft , headGap , tailGap , gaps, gap , headTexture , headStyle , headLength , tailTexture , tailStyle , tailLength , lengths , shaftTexture , shaftStyle , straightShaft -- | See "Diagrams.TwoD.Arrowheads" for a list of standard -- arrowheads and help creating your own. , module Diagrams.TwoD.Arrowheads ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Control.Lens (Lens', Traversal', generateSignatures, lensRules, makeLensesWith, view, (%~), (&), (.~), (^.)) import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct (untangle) import Data.Semigroup import Data.Typeable import Data.Colour hiding (atop) import Diagrams.Core import Diagrams.Core.Style (unmeasureAttrs) import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Angle import Diagrams.Attributes import Diagrams.Direction hiding (dir) import Diagrams.Located (Located (..), unLoc) import Diagrams.Parametric import Diagrams.Path import Diagrams.Solve.Polynomial (quadForm) import Diagrams.Tangent (tangentAtEnd, tangentAtStart) import Diagrams.Trail import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Path (stroke, strokeT) import Diagrams.TwoD.Transform (reflectY, rotate, translateX) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) import Linear.Affine import Linear.Metric import Linear.Vector data ArrowOpts n = ArrowOpts { _arrowHead :: ArrowHT n , _arrowTail :: ArrowHT n , _arrowShaft :: Trail V2 n , _headGap :: Measure n , _tailGap :: Measure n , _headStyle :: Style V2 n , _headLength :: Measure n , _tailStyle :: Style V2 n , _tailLength :: Measure n , _shaftStyle :: Style V2 n } -- | Straight line arrow shaft. straightShaft :: OrderedField n => Trail V2 n straightShaft = trailFromOffsets [unitX] instance TypeableFloat n => Default (ArrowOpts n) where def = ArrowOpts { _arrowHead = dart , _arrowTail = noTail , _arrowShaft = straightShaft , _headGap = none , _tailGap = none -- See note [Default arrow style attributes] , _headStyle = mempty , _headLength = normal , _tailStyle = mempty , _tailLength = normal , _shaftStyle = mempty } makeLensesWith (lensRules & generateSignatures .~ False) ''ArrowOpts -- | A shape to place at the head of the arrow. arrowHead :: Lens' (ArrowOpts n) (ArrowHT n) -- | A shape to place at the tail of the arrow. arrowTail :: Lens' (ArrowOpts n) (ArrowHT n) -- | The trail to use for the arrow shaft. arrowShaft :: Lens' (ArrowOpts n) (Trail V2 n) -- | Distance to leave between the head and the target point. headGap :: Lens' (ArrowOpts n) (Measure n) -- | Distance to leave between the starting point and the tail. tailGap :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headGap@ and @tailGap@ simultaneously. gaps :: Traversal' (ArrowOpts n) (Measure n) gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) -- | Same as gaps, provided for backward compatiiblity. gap :: Traversal' (ArrowOpts n) (Measure n) gap = gaps -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change -- an opaque black arrowhead to translucent orange: -- @(with & headStyle %~ fc orange . opacity 0.75)@. headStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the tail. See `headStyle`. tailStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | Style to apply to the shaft. See `headStyle`. shaftStyle :: Lens' (ArrowOpts n) (Style V2 n) -- | The length from the start of the joint to the tip of the head. headLength :: Lens' (ArrowOpts n) (Measure n) -- | The length of the tail plus its joint. tailLength :: Lens' (ArrowOpts n) (Measure n) -- | Set both the @headLength@ and @tailLength@ simultaneously. lengths :: Traversal' (ArrowOpts n) (Measure n) lengths f opts = (\h t -> opts & headLength .~ h & tailLength .~ t) <$> f (opts ^. headLength) <*> f (opts ^. tailLength) -- | A lens for setting or modifying the texture of an arrowhead. For -- example, one may write @... (with & headTexture .~ grad)@ to get an -- arrow with a head filled with a gradient, assuming grad has been -- defined. Or @... (with & headTexture .~ solid blue@ to set the head -- color to blue. For more general control over the style of arrowheads, -- see 'headStyle'. headTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) headTexture = headStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- tail. This is *not* a valid lens (see 'committed'). tailTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) tailTexture = tailStyle . _fillTexture -- | A lens for setting or modifying the texture of an arrow -- shaft. shaftTexture :: TypeableFloat n => Lens' (ArrowOpts n) (Texture n) shaftTexture = shaftStyle . _lineTexture -- 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 n -> Style V2 n shaftSty opts = opts^.shaftStyle -- Set the default head style. See `shaftSty`. headSty :: TypeableFloat n => ArrowOpts n -> Style V2 n headSty opts = fc black (opts^.headStyle) -- Set the default tail style. See `shaftSty`. tailSty :: TypeableFloat n => ArrowOpts n -> Style V2 n tailSty opts = fc black (opts^.tailStyle) -- | Calculate the length of the portion of the horizontal line that passes -- through the origin and is inside of p. xWidth :: Floating n => (Traced t, V t ~ V2, N t ~ n) => t -> n xWidth p = a + b where a = fromMaybe 0 (norm <$> traceV origin unitX p) b = fromMaybe 0 (norm <$> traceV origin unit_X p) -- | Get the line color from the shaft to use as the fill color for the joint. -- And set the opacity of the shaft to the current opacity. colorJoint :: TypeableFloat n => Style V2 n -> Style V2 n colorJoint sStyle = let c = fmap getLineTexture . getAttr $ sStyle o = fmap getOpacity . getAttr $ sStyle in case (c, o) of (Nothing, Nothing) -> fillColor black mempty (Just t, Nothing) -> fillTexture t mempty (Nothing, Just o') -> opacity o' . fillColor black $ mempty (Just t, Just o') -> opacity o' . fillTexture t $ mempty -- | Get line width from a style. widthOfJoint :: forall n. TypeableFloat n => Style V2 n -> n -> n -> n widthOfJoint sStyle gToO nToO = fromMaybe (fromMeasured gToO nToO medium) -- should be same as default line width (fmap getLineWidth . getAttr . unmeasureAttrs gToO nToO $ sStyle) -- | Combine the head and its joint into a single scale invariant diagram -- and move the origin to the attachment point. Return the diagram -- and its width. mkHead :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkHead = mkHT unit_X arrowHead headSty mkTail :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkTail = mkHT unitX arrowTail tailSty mkHT :: (TypeableFloat n, Renderable (Path V2 n) b) => V2 n -> Lens' (ArrowOpts n) (ArrowHT n) -> (ArrowOpts n -> Style V2 n) -> n -> ArrowOpts n -> n -> n -> Bool -> (QDiagram b V2 n Any, n) mkHT xDir htProj styProj sz opts gToO nToO reflect = ( (j <> ht) # (if reflect then reflectY else id) # moveOriginBy (jWidth *^ xDir) # lwO 0 , htWidth + jWidth ) where (ht', j') = (opts^.htProj) sz (widthOfJoint (shaftSty opts) gToO nToO) htWidth = xWidth ht' jWidth = xWidth j' ht = stroke ht' # applyStyle (styProj opts) j = stroke j' # applyStyle (colorJoint (opts^.shaftStyle)) -- | 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 :: TypeableFloat n => Trail V2 n -> n -> n -> n -> Trail V2 n spine tr tw hw sz = tS <> tr # scale sz <> hS where tSpine = trailFromOffsets [signorm . tangentAtStart $ tr] # scale tw hSpine = trailFromOffsets [signorm . tangentAtEnd $ tr] # scale hw hS = if hw > 0 then hSpine else mempty tS = if tw > 0 then tSpine else mempty -- | 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 :: TypeableFloat n => Trail V2 n -> n -> n -> n -> n 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 (quadrance v) (2* (v `dot` (tv ^+^ hv))) (quadrance (tv ^+^ hv) - t*t) of [] -> 1 -- no scale works, just return 1 [s] -> s -- single solution ss -> maximum ss -- we will usually get both a positive and a negative solution; -- return the maximum (i.e. positive) solution where tv = tw *^ (tangentAtStart tr # signorm) hv = hw *^ (tangentAtEnd tr # signorm) v = trailOffset tr -- Calculate the approximate envelope of a horizontal arrow -- as if the arrow were made only of a shaft. arrowEnv :: TypeableFloat n => ArrowOpts n -> n -> Envelope V2 n arrowEnv opts len = getEnvelope horizShaft where horizShaft = shaft # rotate (negated (v ^. _theta)) # scale (len / m) m = norm v v = trailOffset shaft shaft = opts ^. arrowShaft -- | @arrow len@ creates an arrow of length @len@ with default -- parameters, starting at the origin and ending at the point -- @(len,0)@. arrow :: (TypeableFloat n, Renderable (Path V2 n) b) => n -> QDiagram b V2 n Any arrow = arrow' def -- | @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' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> n -> QDiagram b V2 n Any arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Currently we approximate the envelope of an arrow by using the -- envelope of its shaft (see 'arrowEnv'). The trace of an arrow is empty. (arrowEnv opts len) mempty mempty mempty where -- Once we learn the global transformation context (da) and the two scale -- factors, normal to output (n) and global to output (g), this arrow is -- drawn in, we can apply it to the origin and (len,0) to find out -- the actual final points between which this arrow should be -- drawn. We need to know this to draw it correctly, since the -- head and tail are scale invariant, and hence the precise points -- between which we need to draw the shaft do not transform -- uniformly as the transformation applied to the entire arrow. -- See https://github.com/diagrams/diagrams-lib/issues/112. delayedArrow da g n = let (trans, globalSty) = option mempty untangle . fst $ da in dArrow globalSty trans len g n -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) # rotate (((q .-. p)^._theta) ^-^ (dir^._theta)) # moveTo p where p = origin # transform tr q = origin # translateX ln # transform tr -- Use the existing line color for head, tail, and shaft by -- default (can be overridden by explicitly setting headStyle, -- tailStyle, or shaftStyle). Also use existing global line width -- for shaft if not explicitly set in shaftStyle. globalLC = getLineTexture <$> getAttr sty opts' = opts & headStyle %~ maybe id fillTexture globalLC & tailStyle %~ maybe id fillTexture globalLC & shaftStyle %~ applyStyle sty -- The head size, tail size, head gap, and tail gap are obtained -- from the style and converted to output units. scaleFromMeasure = fromMeasured gToO nToO . scaleLocal (avgScale tr) hSize = scaleFromMeasure $ opts ^. headLength tSize = scaleFromMeasure $ opts ^. tailLength hGap = scaleFromMeasure $ opts ^. headGap tGap = scaleFromMeasure $ opts ^. tailGap -- Make the head and tail and save their widths. (h, hWidth') = mkHead hSize opts' gToO nToO (isReflection tr) (t, tWidth') = mkTail tSize opts' gToO nToO (isReflection tr) rawShaftTrail = opts^.arrowShaft shaftTrail = rawShaftTrail -- rotate it so it is pointing in the positive X direction # rotate (negated . view _theta . trailOffset $ rawShaftTrail) -- apply the context transformation -- in case it includes -- things like flips and shears (the possibility of shears -- is why we must rotate it to a neutral position first) # transform tr -- Adjust the head width and tail width to take gaps into account tWidth = tWidth' + tGap hWidth = hWidth' + hGap -- Calculate the angles that the head and tail should point. tAngle = tangentAtStart shaftTrail ^. _theta hAngle = tangentAtEnd shaftTrail ^. _theta -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire -- arrow will be of length len. Then apply it to the shaft and make the -- shaft into a Diagram with using its style. sf = scaleFactor shaftTrail tWidth hWidth (norm (q .-. p)) shaftTrail' = shaftTrail # scale sf shaft = strokeT shaftTrail' # applyStyle (shaftSty opts') -- Adjust the head and tail to point in the directions of the shaft ends. h' = h # rotate hAngle # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') t' = t # rotate tAngle -- Find out what direction the arrow is pointing so we can set it back -- to point in the direction unitX when we are done. dir = direction (trailOffset $ spine shaftTrail tWidth hWidth sf) -- | @arrowBetween s e@ creates an arrow pointing from @s@ to @e@ -- with default parameters. arrowBetween :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> Point V2 n -> QDiagram b V2 n Any 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' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> Point V2 n -> Point V2 n -> QDiagram b V2 n Any arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by -- the vector v. arrowAt :: (TypeableFloat n, Renderable (Path V2 n) b) => Point V2 n -> V2 n -> QDiagram b V2 n Any arrowAt = arrowAt' def arrowAt' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> Point V2 n -> V2 n -> QDiagram b V2 n Any arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s where len = norm v dir = v ^. _theta -- | @arrowV v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin), using default -- parameters. arrowV :: (TypeableFloat n, Renderable (Path V2 n) b) => V2 n -> QDiagram b V2 n Any arrowV = arrowV' def -- | @arrowV' v@ creates an arrow with the direction and norm of -- the vector @v@ (with its tail at the origin). arrowV' :: (TypeableFloat n, Renderable (Path V2 n) b) => ArrowOpts n -> V2 n -> QDiagram b V2 n Any arrowV' opts = arrowAt' opts origin -- | Turn a located trail into a default arrow by putting an -- arrowhead at the end of the trail. arrowFromLocatedTrail :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) => Located (Trail V2 n) -> QDiagram b V2 n Any arrowFromLocatedTrail = arrowFromLocatedTrail' def -- | Turn a located trail into an arrow using the given options. arrowFromLocatedTrail' :: (Renderable (Path V2 n) b, RealFloat n, Typeable n) => ArrowOpts n -> Located (Trail V2 n) -> QDiagram b V2 n Any arrowFromLocatedTrail' opts trail = arrowBetween' opts' start end where opts' = opts & arrowShaft .~ unLoc trail start = atStart trail end = atEnd trail -- | Connect two diagrams with a straight arrow. connect :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connect = connect' def -- | Connect two diagrams with an arbitrary arrow. connect' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connect' 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 :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> Angle n -> Angle n -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectPerim = connectPerim' def connectPerim' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> Angle n -> Angle n -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectPerim' 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 :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectOutside = connectOutside' def connectOutside' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName n1, IsName n2) => ArrowOpts n -> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any connectOutside' opts n1 n2 = withName n1 $ \b1 -> withName n2 $ \b2 -> let v = location b2 .-. location b1 midpoint = location b1 .+^ (v ^/ 2) s' = fromMaybe (location b1) $ traceP midpoint (negated v) b1 e' = fromMaybe (location b2) $ traceP midpoint v b2 in atop (arrowBetween' opts s' e') diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Offset.hs0000644000000000000000000005766012754644012017377 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset -- 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. More details can be -- found in the manual at -- . -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Offset ( -- * Offsets offsetSegment , OffsetOpts(..), offsetJoin, offsetMiterLimit, offsetEpsilon , offsetTrail , offsetTrail' , offsetPath , offsetPath' -- * Expansions , ExpandOpts(..), expandJoin, expandMiterLimit, expandCap, expandEpsilon , expandTrail , expandTrail' , expandPath , expandPath' ) where import Control.Applicative import Control.Lens hiding (at) import Prelude import Data.Maybe (catMaybes) import Data.Monoid import Data.Monoid.Inf import Data.Default.Class import Diagrams.Core import Diagrams.Attributes import Diagrams.Direction import Diagrams.Located import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Trail hiding (isLoop, offset) import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Curvature import Diagrams.TwoD.Path () import Diagrams.TwoD.Types import Diagrams.TwoD.Vector hiding (e) import Linear.Affine import Linear.Metric import Linear.Vector unitPerp :: OrderedField n => V2 n -> V2 n unitPerp = signorm . perp perpAtParam :: OrderedField n => Segment Closed V2 n -> n -> V2 n perpAtParam (Linear (OffsetClosed a)) _ = negated $ unitPerp a perpAtParam cubic t = negated $ unitPerp a where (Cubic a _ _) = snd $ splitAtParam cubic t -- | Compute the offset of a segment. Given a segment compute the offset -- curve that is a fixed distance from the original curve. For linear -- segments nothing special happens, the same linear segment is returned -- with a point that is offset by a perpendicular vector of the given offset -- length. -- -- Cubic segments require a search for a subdivision of cubic segments that -- 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 -- the offset cubic segment in proportion to the radius of curvature difference -- between the original subsegment and the offset which will have a radius -- increased by the offset parameter. -- -- 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. -- -- | Options for specifying line join and segment epsilon for an offset -- involving multiple segments. data OffsetOpts d = OffsetOpts { _offsetJoin :: LineJoin , _offsetMiterLimit :: d , _offsetEpsilon :: d } deriving instance Eq d => Eq (OffsetOpts d) deriving instance Show d => Show (OffsetOpts d) makeLensesWith (lensRules & generateSignatures .~ False) ''OffsetOpts -- | Specifies the style of join for between adjacent offset segments. offsetJoin :: Lens' (OffsetOpts d) LineJoin -- | Specifies the miter limit for the join. offsetMiterLimit :: Lens' (OffsetOpts d) d -- | Epsilon perimeter for 'offsetSegment'. offsetEpsilon :: Lens' (OffsetOpts d) d -- | The default offset options use the default 'LineJoin' ('LineJoinMiter'), a -- miter limit of 10, and epsilon factor of 0.01. instance Fractional d => Default (OffsetOpts d) where def = OffsetOpts def 10 0.01 -- | Options for specifying how a 'Trail' should be expanded. data ExpandOpts d = ExpandOpts { _expandJoin :: LineJoin , _expandMiterLimit :: d , _expandCap :: LineCap , _expandEpsilon :: d } deriving (Eq, Show) makeLensesWith (lensRules & generateSignatures .~ False) ''ExpandOpts -- | Specifies the style of join for between adjacent offset segments. expandJoin :: Lens' (ExpandOpts d) LineJoin -- | Specifies the miter limit for the join. expandMiterLimit :: Lens' (ExpandOpts d) d -- | Specifies how the ends are handled. expandCap :: Lens' (ExpandOpts d) LineCap -- | Epsilon perimeter for 'offsetSegment'. expandEpsilon :: Lens' (ExpandOpts d) d -- | The default 'ExpandOpts' is the default 'LineJoin' ('LineJoinMiter'), -- miter limit of 10, default 'LineCap' ('LineCapButt'), and epsilon factor -- of 0.01. instance (Fractional d) => Default (ExpandOpts d) where def = ExpandOpts def 10 def 0.01 offsetSegment :: RealFloat n => n -- ^ Epsilon factor that when multiplied to the -- absolute value of the radius gives a -- value that represents the maximum -- allowed deviation from the true offset. In -- the current implementation each result segment -- should be bounded by arcs that are plus or -- minus epsilon factor from the radius of curvature of -- the offset. -> n -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. -> Segment Closed V2 n -- ^ Original segment -> Located (Trail V2 n) -- ^ Resulting located (at the offset) trail. offsetSegment _ r s@(Linear (OffsetClosed a)) = trailFromSegments [s] `at` origin .+^ va where va = (-r) *^ unitPerp a offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = t `at` origin .+^ va where t = trailFromSegments (go (radiusOfCurvature s 0.5)) -- Perpendiculars to handles. va = (-r) *^ unitPerp a vc = (-r) *^ unitPerp (c ^-^ b) -- Split segments. ss = (\(x,y) -> [x,y]) $ splitAtParam s 0.5 subdivided = concatMap (trailSegments . unLoc . offsetSegment epsilon r) ss -- Offset with handles scaled based on curvature. offset factor = bezier3 (a^*factor) ((b ^-^ c)^*factor ^+^ c ^+^ vc ^-^ va) (c ^+^ vc ^-^ va) -- We observe a corner. Subdivide right away. go (Finite 0) = subdivided -- We have some curvature go roc | close = [o] | otherwise = subdivided where -- We want the multiplicative factor that takes us from the original -- segment's radius of curvature roc, to roc + r. -- -- r + sr = x * sr -- o = offset $ case roc of Infinity -> 1 -- Do the right thing. Finite sr -> 1 + r / sr close = and [epsilon * abs r > norm (p o ^+^ va ^-^ p s ^-^ pp s) | t' <- [0.25, 0.5, 0.75] , let p = (`atParam` t') , let pp = (r *^) . (`perpAtParam` t') ] -- > import Diagrams.TwoD.Offset -- > -- > showExample :: Segment Closed V2 Double -> Diagram SVG -- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw thick <> d' # lw thick -- > where -- > d = strokeP . fromSegments $ [s] -- > d' = mconcat . zipWith lc colors . map strokeP . explodeTrail -- > $ offsetSegment 0.1 (-1) s -- > -- > colors = cycle [green, red] -- > -- > cubicOffsetExample :: Diagram SVG -- > cubicOffsetExample = hcat . map showExample $ -- > [ 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, N a ~ N b, V a ~ V2, N a ~ n, Num n) => (a -> b) -> Located a -> b bindLoc f = join' . mapLoc f where join' (viewLoc -> (p,a)) = translate (p .-. origin) a -- While we build offsets and expansions we will use the [Located (Segment Closed v)] -- and [Located (Trail V2 n)] intermediate representations. locatedTrailSegments :: OrderedField n => Located (Trail V2 n) -> [Located (Segment Closed V2 n)] locatedTrailSegments t = zipWith at (trailSegments (unLoc t)) (trailPoints 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' :: RealFloat n => OffsetOpts n -> n -- ^ Radius of offset. A negative value gives an offset on -- the left for a line and on the inside for a counter-clockwise -- loop. -> Located (Trail V2 n) -> Located (Trail V2 n) offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where eps = opts^.offsetEpsilon offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments ends | isLoop = (\(a:as) -> as ++ [a]) . trailPoints $ t | otherwise = tail . trailPoints $ t j = fromLineJoin (opts^.offsetJoin) isLoop = withTrail (const False) (const True) (unLoc t) -- | Offset a 'Trail' with the default options and a given radius. See 'offsetTrail''. offsetTrail :: RealFloat n => n -> Located (Trail V2 n) -> Located (Trail V2 n) offsetTrail = offsetTrail' def -- | Offset a 'Path' by applying 'offsetTrail'' to each trail in the path. offsetPath' :: RealFloat n => OffsetOpts n -> n -> Path V2 n -> Path V2 n offsetPath' opts r = mconcat . map (bindLoc (trailLike . offsetTrail' opts r) . (`at` origin)) . op Path -- | Offset a 'Path' with the default options and given radius. See 'offsetPath''. offsetPath :: RealFloat n => n -> Path V2 n -> Path V2 n 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 :: (OrderedField n) => Located (Trail V2 n) -- > corner = fromVertices (map p2 [(0, 0), (10, 0), (5, 6)]) `at` origin -- > -- > offsetTrailExample :: Diagram SVG -- > offsetTrailExample = pad 1.1 . centerXY . lwO 3 . 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 -- > offsetTrailLeftExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike -- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) (-2) $ c) -- > where -- > c = reflectY corner -- > -- > offsetTrailOuterExample :: Diagram SVG -- > offsetTrailOuterExample = pad 1.1 . centerXY . lwO 3 -- > $ (trailLike c # lc blue) -- > <> (lc green . trailLike -- > . offsetTrail' (def & offsetJoin .~ LineJoinRound) 2 $ c) -- > where -- > c = hexagon 5 withTrailL :: (Located (Trail' Line V2 n) -> r) -> (Located (Trail' Loop V2 n) -> r) -> Located (Trail V2 n) -> r withTrailL f g l = withTrail (f . (`at` p)) (g . (`at` p)) (unLoc l) where p = loc l -- | 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' :: (OrderedField n, RealFloat n, RealFrac n) => ExpandOpts n -> n -- ^ Radius of offset. Only non-negative values allowed. -- For a line this gives a loop of the offset. For a -- loop this gives two loops, the outer counter-clockwise -- and the inner clockwise. -> Located (Trail V2 n) -> Path V2 n expandTrail' 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 :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Line V2 n) -> Located (Trail V2 n) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where eps = opts^.expandEpsilon offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t ends = tail . trailPoints $ t s = atStart t e = atEnd t cap = fromLineCap (opts^.expandCap) expandLoop :: RealFloat n => ExpandOpts n -> n -> Located (Trail' Loop V2 n) -> Path V2 n expandLoop opts r (mapLoc wrapLoop -> t) = trailLike (f r) <> (trailLike . reverseDomain . f $ -r) where eps = opts^.expandEpsilon offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t ends = (\(a:as) -> as ++ [a]) . trailPoints $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. expandTrail :: RealFloat n => n -> Located (Trail V2 n) -> Path V2 n expandTrail = expandTrail' def -- | Expand a 'Path' using 'expandTrail'' on each trail in the path. expandPath' :: RealFloat n => ExpandOpts n -> n -> Path V2 n -> Path V2 n expandPath' opts r = mconcat . map (bindLoc (expandTrail' opts r) . (`at` origin)) . op Path -- | Expand a 'Path' with the given radius and default options. See 'expandPath''. expandPath :: RealFloat n => n -> Path V2 n -> Path V2 n expandPath = expandPath' def -- > import Diagrams.TwoD.Offset -- > import Data.Default.Class -- > -- > expandTrailExample :: Diagram SVG -- > 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 veryThick -- > <> stroke (expandTrail' -- > (def & expandJoin .~ LineJoinRound -- > & expandCap .~ c -- > ) 2 corner) -- > # lw none # fc green) -- > === (strutY 3 <> text s # font "Helvetica" # bold) -- > -- > expandLoopExample :: Diagram SVG -- > expandLoopExample = pad 1.1 . centerXY $ ((strokeLocT t # lw veryThick # lc white) -- > <> (stroke t' # lw none # fc green)) -- > where -- > t = mapLoc glueTrail $ fromVertices (map p2 [(0, 0), (5, 0), (10, 5), (10, 10), (0, 0)]) -- > t' = expandTrail' (def & expandJoin .~ LineJoinRound) 1 t -- | 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 :: RealFloat n => (n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n) -> n -> Point V2 n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Located (Trail V2 n) caps cap r s e fs bs = mapLoc glueTrail $ mconcat [ cap r s (atStart bs) (atStart fs) , unLoc fs , cap r e (atEnd fs) (atEnd bs) , reverseDomain (unLoc bs) ] `at` atStart bs -- | Take a LineCap style and give a function for building the cap from fromLineCap :: RealFloat n => LineCap -> n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n fromLineCap c = case c of LineCapButt -> capCut LineCapRound -> capArc LineCapSquare -> capSquare -- | Builds a cap that directly connects the ends. capCut :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capCut _r _c a b = fromSegments [straight (b .-. a)] -- | Builds a cap with a square centered on the end. capSquare :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capSquare _r c a b = unLoc $ fromVertices [ a, a .+^ v, b .+^ v, b ] where v = perp (a .-. c) -- | Builds an arc to fit with a given radius, center, start, and end points. -- A Negative r means a counter-clockwise arc capArc :: RealFloat n => n -> Point V2 n -> Point V2 n -> Point V2 n -> Trail V2 n capArc r c a b = trailLike . moveTo c $ fs where fs | r < 0 = scale (-r) $ arcCW (dirBetween a c) (dirBetween b c) | otherwise = scale r $ arcCCW (dirBetween a c) (dirBetween b c) -- | 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 :: RealFloat n => n -> (n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n) -> Bool -> n -> n -> [Point V2 n] -> [Located (Trail V2 n)] -> Located (Trail V2 n) joinSegments _ _ _ _ _ _ [] = mempty `at` origin joinSegments _ _ _ _ _ [] _ = mempty `at` origin joinSegments epsilon j isLoop ml r es ts@(t:_) = t' where t' | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t | otherwise = mapLoc (<> f (ss es ts)) t ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] test a b tj | atStart b `distance` atEnd a > epsilon = Just tj | otherwise = Nothing f = mconcat . catMaybes -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin :: RealFloat n => LineJoin -> n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n fromLineJoin 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 :: (OrderedField n) => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n 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 :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentClip _ _ _ a b = fromSegments [straight $ atStart b .-. atEnd a] -- | Join with a radius arc. On an inside corner this will loop around the interior -- of the offset trail. With a winding fill this will not be visible. joinSegmentArc :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentArc _ r e a b = capArc r e (atEnd a) (atStart b) -- | Join to the intersection of the incoming trails projected tangent to their ends. -- If the intersection is beyond the miter limit times the radius, stop at the limit. joinSegmentIntersect :: RealFloat n => n -> n -> Point V2 n -> Located (Trail V2 n) -> Located (Trail V2 n) -> Trail V2 n joinSegmentIntersect miterLimit r e a b = if cross < 0.000001 then clip else case traceP pa va t of -- clip join when we excede the miter limit. We could instead -- Join at exactly the miter limit, but standard behavior seems -- to be clipping. Nothing -> clip Just p -- If trace gave us garbage... | p `distance` pb > abs (miterLimit * r) -> clip | otherwise -> unLoc $ fromVertices [ pa, p, pb ] where t = straight (miter vb) `at` pb va = unitPerp (pa .-. e) vb = negated $ unitPerp (pb .-. e) pa = atEnd a pb = atStart b miter v = abs (miterLimit * r) *^ v clip = joinSegmentClip miterLimit r e a b cross = let (xa,ya) = unr2 va; (xb,yb) = unr2 vb in abs (xa * yb - xb * ya) diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Segment/0000755000000000000000000000000012754644012017201 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/TwoD/Segment/Bernstein.hs0000644000000000000000000001251112754644012021466 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Segment.Bernstein -- Copyright : (c) 2014-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Bernstein polynomials, used internally by code to find -- intersections of paths. This module is probably not of any -- relevance to most users of diagrams. ----------------------------------------------------------------------------- module Diagrams.TwoD.Segment.Bernstein ( BernsteinPoly (..) , listToBernstein , evaluateBernstein , degreeElevate , bernsteinDeriv , evaluateBernsteinDerivs ) where import Data.List (tails) import Diagrams.Core.V import Diagrams.Parametric import Linear.V1 -- | Compute the binomial coefficients of degree n. binomials :: Num n => Int -> [n] binomials n = map fromIntegral $ scanl (\x m -> x * (n - m+1) `quot` m) 1 [1..n] data BernsteinPoly n = BernsteinPoly { bernsteinDegree :: Int , bernsteinCoeffs :: [n] } deriving (Show, Functor) type instance V (BernsteinPoly n) = V1 type instance N (BernsteinPoly n) = n type instance Codomain (BernsteinPoly n) = V1 -- | Create a bernstein polynomial from a list of coëfficients. listToBernstein :: Fractional n => [n] -> BernsteinPoly n listToBernstein [] = 0 listToBernstein l = BernsteinPoly (length l - 1) l -- | Degree elevate a bernstein polynomial a number of times. degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n degreeElevate b 0 = b degreeElevate (BernsteinPoly lp p) times = degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1) where n = fromIntegral lp inner [] _ = [0] inner [a] _ = [a] inner (a:b:rest) i = (i*a/(n+1) + b*(1 - i/(n+1))) : inner (b:rest) (i+1) -- | Evaluate the bernstein polynomial. evaluateBernstein :: Fractional n => BernsteinPoly n -> n -> n evaluateBernstein (BernsteinPoly _ []) _ = 0 evaluateBernstein (BernsteinPoly _ [b]) _ = b evaluateBernstein (BernsteinPoly lp (b':bs)) t = go t n (b'*u) 2 bs where u = 1-t n = fromIntegral lp go tn bc tmp _ [b] = tmp + tn*bc*b go tn bc tmp i (b:rest) = go (tn*t) -- tn (bc*(n - i+1)/i) -- bc ((tmp + tn*bc*b)*u) -- tmp (i+1) -- i rest go _ _ _ _ [] = error "evaluateBernstein: impossible" -- | Evaluate the bernstein polynomial and its derivatives. evaluateBernsteinDerivs :: Fractional n => BernsteinPoly n -> n -> [n] evaluateBernsteinDerivs b t | bernsteinDegree b == 0 = [evaluateBernstein b t] | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t -- | Find the derivative of a bernstein polynomial. bernsteinDeriv :: Fractional n => BernsteinPoly n -> BernsteinPoly n bernsteinDeriv (BernsteinPoly 0 _) = 0 bernsteinDeriv (BernsteinPoly lp p) = -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (tail p) p BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p instance Fractional n => Parametric (BernsteinPoly n) where atParam b = V1 . evaluateBernstein b instance Num n => DomainBounds (BernsteinPoly n) instance Fractional n => EndValues (BernsteinPoly n) instance Fractional n => Sectionable (BernsteinPoly n) where splitAtParam = bernsteinSplit reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) -- | Split a bernstein polynomial. bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) bernsteinSplit (BernsteinPoly lp p) t = (BernsteinPoly lp $ map head controls, BernsteinPoly lp $ reverse $ map last controls) where interp a b = (1-t)*a + t*b terp [_] = [] terp l = let ctrs = zipWith interp l (tail l) in ctrs : terp ctrs controls = p : terp p instance Fractional n => Num (BernsteinPoly n) where ba@(BernsteinPoly la a) + bb@(BernsteinPoly lb b) | la < lb = BernsteinPoly lb $ zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b | la > lb = BernsteinPoly la $ zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb) | otherwise = BernsteinPoly la $ zipWith (+) a b ba@(BernsteinPoly la a) - bb@(BernsteinPoly lb b) | la < lb = BernsteinPoly lb $ zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b | la > lb = BernsteinPoly la $ zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) | otherwise = BernsteinPoly la $ zipWith (-) a b (BernsteinPoly la a) * (BernsteinPoly lb b) = BernsteinPoly (la+lb) $ zipWith (flip (/)) (binomials (la + lb)) $ init $ map sum $ map (zipWith (*) a') (down b') ++ map (zipWith (*) (reverse b')) (tail $ tails a') -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b') where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ... a' = zipWith (*) a (binomials la) b' = zipWith (*) b (binomials lb) fromInteger a = BernsteinPoly 0 [fromInteger a] signum (BernsteinPoly _ []) = 0 signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a] abs = fmap abs diagrams-lib-1.3.1.4/src/Diagrams/Animation/0000755000000000000000000000000012754644012016641 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Animation/Active.hs0000644000000000000000000000754712754644012020425 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Animation.Active -- Copyright : (c) 2011 Brent Yorgey -- License : BSD-style (see LICENSE) -- Maintainer : byorgey@cis.upenn.edu -- -- A few utilities and class instances for 'Active' (from the @active@ -- package). In particular, this module defines -- -- * An instance of 'V' for 'Active': @'V' ('Active' a) = 'V' a@ -- -- * 'HasOrigin', 'Transformable', and 'HasStyle' instances for -- 'Active' which all work pointwise. -- -- * A 'TrailLike' instance for @'Active' p@ where @p@ is also -- 'TrailLike', which simply lifts a pathlike thing to a constant -- active value. -- -- * A 'Juxtaposable' instance for @'Active' a@ where @a@ is also -- 'Juxtaposable'. An active value can be juxtaposed against -- another by doing the juxtaposition pointwise over time. The -- era of @juxtapose v a1 a2@ will be the same as the era of @a2@, -- unless @a2@ is constant, in which case it will be the era of -- @a1@. (Note that @juxtapose v a1 a2@ and @liftA2 (juxtapose v) -- a1 a2@ therefore have different semantics: the second is an -- active value whose era is the /combination/ of the eras of @a1@ -- and @a2@). -- -- * An 'Alignable' instance for @'Active' a@ where @a@ is also -- 'Alignable'; the active value is aligned pointwise over time. ----------------------------------------------------------------------------- module Diagrams.Animation.Active where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (pure, (<$>)) #endif import Diagrams.Core import Diagrams.TrailLike import Data.Active type instance V (Active a) = V a type instance N (Active a) = N a -- Yes, these are all orphan instances. Get over it. We don't want to -- put them in the 'active' package because 'active' is supposed to be -- generally useful and shouldn't depend on diagrams. We'd also -- rather not put them in diagrams-core so that diagrams-core doesn't -- have to depend on active. instance HasOrigin a => HasOrigin (Active a) where moveOriginTo = fmap . moveOriginTo instance Transformable a => Transformable (Active a) where transform = fmap . transform instance HasStyle a => HasStyle (Active a) where applyStyle = fmap . applyStyle instance TrailLike t => TrailLike (Active t) where trailLike = pure . trailLike -- | An active value can be juxtaposed against another by doing the -- juxtaposition pointwise over time. The era of @juxtapose v a1 -- a2@ will be the same as the era of @a2@, unless @a2@ is constant, -- in which case it will be the era of @a1@. (Note that @juxtapose -- v a1 a2@ and @liftA2 (juxtapose v) a1 a2@ therefore have -- different semantics: the second is an active value whose era is -- the /combination/ of the eras of @a1@ and @a2@). instance Juxtaposable a => Juxtaposable (Active a) where juxtapose v a1 a2 = onActive -- a1 (\c1 -> -- if a1 is constant, just juxtapose a2 pointwise with its value juxtapose v c1 <$> a2 ) -- if a1 is dynamic... (onDynamic $ \s1 e1 d1 -> onActive -- a2 (\c2 -> -- if a2 is constant, juxtapose pointwise with a1. Since -- the result will no longer be constant, the result -- needs an era: we use a1's. mkActive s1 e1 (\t -> juxtapose v (d1 t) c2) ) -- otherwise, juxtapose pointwise, without changing a2's era (onDynamic $ \s2 e2 d2 -> mkActive s2 e2 (\t -> juxtapose v (d1 t) (d2 t)) ) a2 ) a1 -- instance Alignable a => Alignable (Active a) where -- alignBy v d a = alignBy v d <$> a diagrams-lib-1.3.1.4/src/Diagrams/Transform/0000755000000000000000000000000012754644012016675 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Transform/ScaleInv.hs0000644000000000000000000001627312754644012020746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- 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.Transform.ScaleInv ( ScaleInv(..) , scaleInvObj, scaleInvDir, scaleInvLoc , scaleInv, scaleInvPrim) where import Control.Lens (makeLenses, view, (^.)) #if __GLASGOW_HASKELL__ < 710 import Data.Semigroup #endif import Data.Typeable import Diagrams.Angle import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Linear.Affine import Linear.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 :: Vn t , _scaleInvLoc :: Point (V t) (N t) } deriving Typeable deriving instance (Show t, Show (Vn t)) => Show (ScaleInv t) makeLenses ''ScaleInv -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. scaleInv :: (V t ~ v, N t ~ n, Additive v, Num n) => t -> v n -> ScaleInv t scaleInv t d = ScaleInv t d origin type instance V (ScaleInv t) = V t type instance N (ScaleInv t) = N t instance (V t ~ v, N t ~ n, Additive v, Num n, HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) instance (V t ~ V2, N t ~ n, RealFloat n, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where angle = transform tr v ^. _theta rot :: (V k ~ V t, N k ~ N t, Transformable k) => k -> k rot = rotateAround 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 = rotateAround l angle = rotateAround l (direction (transform mempty v) - direction v) = rotateAround l (direction v - direction v) = rotateAround 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 = rotateAround 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 = rotateAround l angle l' = transform t2 l trans = translate (l' .-. l) angle2 = direction (transform t1 (rot v)) - direction (rot v) rot2 = rotateAround 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 = rotateAround 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 = rotateAround l' angle2 = ??? } -} instance (V t ~ V2, N t ~ n, RealFloat n, Renderable t b) => 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 :: (V t ~ V2, N t ~ n, RealFloat n, Typeable t, Renderable t b, Monoid m) => t -> V2 n -> QDiagram b (V t) (N t) m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty diagrams-lib-1.3.1.4/src/Diagrams/Transform/Matrix.hs0000644000000000000000000000526612754644012020506 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform.Matrix -- Copyright : (c) 2014 diagrams team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Functions for converting between 'Transformation's and matricies. -- ----------------------------------------------------------------------------- module Diagrams.Transform.Matrix where import Control.Arrow ((&&&)) import Control.Lens import Data.Distributive import qualified Data.Foldable as F import Data.Functor.Rep import Diagrams.Core.Transform as D import Diagrams.ThreeD.Types import Diagrams.TwoD.Types import Linear.Matrix import Linear.Vector -- | Build a matrix from a 'Transformation', ignoring the translation. mkMat :: (HasBasis v, Num n) => Transformation v n -> v (v n) mkMat t = distribute . tabulate $ apply t . unit . el -- | Build a 3D transformation matrix in homogeneous coordinates from -- a 'Transformation V3'. mkMatHomo :: Num n => Transformation V3 n -> M44 n mkMatHomo t = mkTransformationMat (mkMat t) (transl t) -- | Make a 2D transformation from a 2x2 transform matrix and a -- translation vector. Does not check if the matrix is not invertible -- (in which case the 'T2' will be invalid). fromMat22 :: Floating n => M22 n -> V2 n -> T2 n fromMat22 m v = flip (fromMatWithInv m) v $ inv22 m -- | Make a 3D transformation from a 3x3 transform matrix and a -- translation vector. Does not check if the matrix is not invertible -- (in which case the 'T3' will be invalid). fromMat33 :: Floating n => M33 n -> V3 n -> T3 n fromMat33 m v = flip (fromMatWithInv m) v $ inv33 m -- | Build a transform with a maxtrix along with its inverse. fromMatWithInv :: (Additive v, Distributive v, F.Foldable v, Num n) => v (v n) -- ^ matrix -> v (v n) -- ^ inverse -> v n -- ^ translation -> Transformation v n fromMatWithInv m m_ v = Transformation ((*! m) <-> (*! m_)) ((*! distribute m) <-> (*! distribute m_)) v -- | Prism onto a 2D transformation from a 2x2 transform matrix and -- translation vector. Does not check if the matrix is invertible (in -- which case the 'T2' will be invalid). mat22 :: Floating n => Iso' (M22 n, V2 n) (T2 n) mat22 = iso (uncurry fromMat22) (mkMat &&& transl) -- | Prism onto a 2D transformation from a 2x2 transform matrix and -- translation vector (in which case the 'T3' will be invalid). mat33 :: Floating n => Iso' (M33 n, V3 n) (T3 n) mat33 = iso (uncurry fromMat33) (mkMat &&& transl) diagrams-lib-1.3.1.4/src/Diagrams/Attributes/0000755000000000000000000000000012754644012017050 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Attributes/Compile.hs0000644000000000000000000001223512754644012020777 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes.Compile -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- XXX -- ----------------------------------------------------------------------------- module Diagrams.Attributes.Compile ( SplitAttribute(..), splitAttr ) where import Data.Typeable import Control.Arrow (second) import Control.Lens ((%~), (&), _Wrapping') import qualified Data.HashMap.Strict as HM import Data.Semigroup ((<>)) import Data.Tree (Tree (..)) import Diagrams.Core import Diagrams.Core.Style (Style (..), attributeToStyle) import Diagrams.Core.Types (RNode (..), RTree) ------------------------------------------------------------ -- This is a sort of roundabout, overly-general way to define -- splitFills; it's done this way to facilitate testing. class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where type AttrType code :: * type PrimType code :: * primOK :: code -> PrimType code -> Bool -- | Push certain attributes down until they are at the roots of trees -- containing only "safe" nodes. In particular this is used to push -- fill attributes down until they are over only loops; see -- 'splitFills'. splitAttr :: forall code b v n a. SplitAttribute code => code -> RTree b v n a -> RTree b v n a splitAttr code = fst . splitAttr' Nothing where -- splitAttr' is where the most interesting logic happens. -- Mutually recursive with splitAttr'Forest. rebuildNode and -- applyMfc are helper functions. -- -- Input: attribute to apply to "safe" subtrees. -- -- Output: tree with attributes pushed down appropriately, and -- a Bool indicating whether the tree contains only "safe" prims (True) or -- contains some unsafe ones (False). splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool) -- RStyle node: Check for the special attribute, and split it out of -- the style, combining it with the incoming attribute. Recurse and -- rebuild. The tricky bit is that we use some knot-tying to -- determine the right attribute to pass down to the subtrees based -- on this computed Bool: if all subtrees are safe, then we will -- apply the attribute at the root of this tree, and pass Nothing to -- all the subtrees. Otherwise, we pass the given attribute along. -- This works out because the attribute does not need to be -- pattern-matched until actually applying it at some root, so the -- recursion can proceed and the Bool values be computed with the -- actual value of the attributes nodes filled in lazily. splitAttr' mattr (Node (RStyle sty) cs) = (t', ok) where mattr' = mattr <> getAttr sty sty' = sty & _Wrapping' Style %~ HM.delete ty ty = typeOf (undefined :: AttrType code) (cs', ok) = splitAttr'Forest mattr' cs t' | ok = rebuildNode Nothing ok (RStyle sty) cs' | otherwise = rebuildNode mattr ok (RStyle sty') cs' -- RPrim node: check whether it -- * is some sort of prim not under consideration: don't apply the attribute; return True -- * is unsafe: don't apply the attribute; return False -- * is safe : do apply the attribute; return True splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) = case cast prm :: Maybe (PrimType code) of Nothing -> (Node rp [], True) Just p -> if primOK code p then (rebuildNode mattr True rp [], True) else (Node rp [], False) -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note -- we assume that transformations do not affect the attributes. splitAttr' mattr (Node nd cs) = (t', ok) where (cs', ok) = splitAttr'Forest mattr cs t' = rebuildNode mattr ok nd cs' -- Recursively call splitAttr' on all subtrees, returning the -- logical AND of the Bool results returned (the whole forest is -- safe iff all subtrees are). splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v n a] -> ([RTree b v n a], Bool) splitAttr'Forest mattr cs = (cs', ok) where (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs -- Given a fill attribute, a Bool indicating whether the given -- subforest contains only loops, a node, and a subforest, rebuild a -- tree, applying the fill attribute as appropriate (only if the -- Bool is true and the attribute is not Nothing). rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v n a -> [RTree b v n a] -> RTree b v n a rebuildNode mattr ok nd cs | ok = applyMattr mattr (Node nd cs) | otherwise = Node nd cs -- Prepend a new fill color node if Just; the identity function if -- Nothing. applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a applyMattr Nothing t = t applyMattr (Just a) t = Node (RStyle $ attributeToStyle (Attribute a)) [t] diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/0000755000000000000000000000000012754644012016075 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Light.hs0000644000000000000000000000461612754644012017507 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- 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 Data.Typeable import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Types -- | A @PointLight@ radiates uniformly in all directions from a given -- point. data PointLight n = PointLight (Point V3 n) (Colour Double) deriving Typeable type instance V (PointLight n) = V3 type instance N (PointLight n) = n -- | A @ParallelLight@ casts parallel rays in the specified direction, -- from some distant location outside the scene. data ParallelLight n = ParallelLight (V3 n) (Colour Double) deriving Typeable type instance V (ParallelLight n) = V3 type instance N (ParallelLight n) = n instance Fractional n => Transformable (PointLight n) where transform t (PointLight p c) = PointLight (transform t p) c instance Transformable (ParallelLight n) where transform t (ParallelLight v c) = ParallelLight (transform t v) c -- | Construct a Diagram with a single PointLight at the origin, which -- takes up no space. pointLight :: (Typeable n, Num n, Ord n, Renderable (PointLight n) b) => Colour Double -- ^ The color of the light -> QDiagram b V3 n Any 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 :: (Typeable n, OrderedField n, Renderable (ParallelLight n) b) => Direction V3 n -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> QDiagram b V3 n Any parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) mempty mempty mempty (Query . const . Any $ False) diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Deform.hs0000644000000000000000000000145112754644012017646 0ustar0000000000000000module Diagrams.ThreeD.Deform ( parallelX0, perspectiveX1, facingX , parallelY0, perspectiveY1, facingY , parallelZ0, perspectiveZ1, facingZ ) where import Control.Lens import Diagrams.Deform import Diagrams.TwoD.Deform import Linear.V3 import Linear.Vector -- | The parallel projection onto the plane z=0 parallelZ0 :: (R3 v, Num n) => Deformation v v n parallelZ0 = Deformation (_z .~ 0) -- | The perspective division onto the plane z=1 along lines going -- through the origin. perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v v n perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _x) facingZ :: (R3 v, Functor v, Fractional n) => Deformation v v n facingZ = Deformation $ \p -> let z = p ^. _z in p ^/ z & _z .~ z diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Size.hs0000644000000000000000000000307612754644012017351 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Size -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Utilities for working with sizes of three-dimensional objects. -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Size ( -- ** Computing sizes extentX, extentY, extentZ -- ** Specifying sizes , mkSizeSpec3D , dims3D ) where import Diagrams.Core import Diagrams.Core.Envelope import Diagrams.Size import Diagrams.TwoD.Size import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the absolute z-coordinate range of an enveloped object in -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty -- envelope. extentZ :: (InSpace v n a, R3 v, Enveloped a) => a -> Maybe (n, n) extentZ = extent unitZ -- | Make a 'SizeSpec' from possibly-specified width and height. mkSizeSpec3D :: Num n => Maybe n -> Maybe n -> Maybe n -> SizeSpec V3 n mkSizeSpec3D x y z = mkSizeSpec (V3 x y z) -- | Make a 'SizeSpec' from a width and height. dims3D :: n -> n -> n -> SizeSpec V3 n dims3D x y z = dims (V3 x y z) diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Vector.hs0000644000000000000000000000211412754644012017671 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 3D vectors unitX, unitY, unitZ, unit_X, unit_Y, unit_Z , xDir, yDir, zDir ) where import Control.Lens ((&), (.~)) import Diagrams.ThreeD.Types import Diagrams.TwoD.Vector import Diagrams.Direction import Linear.Vector -- | The unit vector in the positive Y direction. unitZ :: (R3 v, Additive v, Num n) => v n unitZ = zero & _z .~ 1 -- | The unit vector in the negative X direction. unit_Z :: (R3 v, Additive v, Num n) => v n unit_Z = zero & _z .~ (-1) -- | A 'Direction' pointing in the Z direction. zDir :: (R3 v, Additive v, Num n) => Direction v n zDir = dir unitZ diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Attributes.hs0000644000000000000000000001205712754644012020564 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Attributes -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Diagrams may have /attributes/ which affect the way they are -- rendered. This module defines some common attributes relevant in -- 3D; particular backends may also define more backend-specific -- attributes. -- -- Every attribute type must have a /semigroup/ structure, that is, an -- associative binary operation for combining two attributes into one. -- Unless otherwise noted, all the attributes defined here use the -- 'Last' structure, that is, combining two attributes simply keeps -- the second one and throws away the first. This means that child -- attributes always override parent attributes. -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Attributes where import Control.Lens import Data.Semigroup import Data.Typeable import Data.Colour import Diagrams.Core -- | @SurfaceColor@ is the inherent pigment of an object, assumed to -- be opaque. newtype SurfaceColor = SurfaceColor (Last (Colour Double)) deriving (Typeable, Semigroup) instance AttributeClass SurfaceColor _SurfaceColor :: Iso' SurfaceColor (Colour Double) _SurfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) -- | Set the surface color. sc :: HasStyle d => Colour Double -> d -> d sc = applyAttr . review _SurfaceColor -- | Lens onto the surface colour of a style. _sc :: Lens' (Style v n) (Maybe (Colour Double)) _sc = atAttr . mapping _SurfaceColor -- | @Diffuse@ is the fraction of incident light reflected diffusely, -- that is, in all directions. The actual light reflected is the -- product of this value, the incident light, and the @SurfaceColor@ -- Attribute. For physical reasonableness, @Diffuse@ should have a -- value between 0 and 1; this is not checked. newtype Diffuse = Diffuse (Last Double) deriving (Typeable, Semigroup) instance AttributeClass Diffuse -- | Isomorphism between 'Diffuse' and 'Double' _Diffuse :: Iso' Diffuse Double _Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) -- | Set the diffuse reflectance. diffuse :: HasStyle d => Double -> d -> d diffuse = applyAttr . review _Diffuse -- | Lens onto the possible diffuse reflectance in a style. _diffuse :: Lens' (Style v n) (Maybe Double) _diffuse = atAttr . mapping _Diffuse -- | @Ambient@ is an ad-hoc representation of indirect lighting. The -- product of @Ambient@ and @SurfaceColor@ is added to the light -- leaving an object due to diffuse and specular terms. @Ambient@ can -- be set per-object, and can be loosely thought of as the product of -- indirect lighting incident on that object and the diffuse -- reflectance. newtype Ambient = Ambient (Last Double) deriving (Typeable, Semigroup) instance AttributeClass Ambient _Ambient :: Iso' Ambient Double _Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) -- | Set the emittance due to ambient light. ambient :: HasStyle d => Double -> d -> d ambient = applyAttr . review _Ambient -- | Lens onto the possible ambience in a style. _ambient :: Lens' (Style v n) (Maybe Double) _ambient = atAttr . mapping _Ambient -- | A specular highlight has two terms, the intensity, between 0 and -- 1, and the size. The highlight size is assumed to be the exponent -- in a Phong shading model (though Backends are free to use a -- different shading model). In this model, reasonable values are -- between 1 and 50 or so, with higher values for shinier objects. -- Physically, the intensity and the value of @Diffuse@ must add up to -- less than 1; this is not enforced. data Specular = Specular { _specularIntensity :: Double , _specularSize :: Double } makeLenses ''Specular newtype Highlight = Highlight (Last Specular) deriving (Typeable, Semigroup) instance AttributeClass Highlight _Highlight :: Iso' Highlight Specular _Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) -- | Set the specular highlight. highlight :: HasStyle d => Specular -> d -> d highlight = applyAttr . review _Highlight -- | Lens onto the possible specular highlight in a style _highlight :: Lens' (Style v n) (Maybe Specular) _highlight = atAttr . mapping _Highlight -- | Traversal over the highlight intensity of a style. If the style has -- no 'Specular', setting this will do nothing. highlightIntensity :: Traversal' (Style v n) Double highlightIntensity = _highlight . _Just . specularSize -- | Traversal over the highlight size in a style. If the style has no -- 'Specular', setting this will do nothing. highlightSize :: Traversal' (Style v n) Double highlightSize = _highlight . _Just . specularSize diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Transform.hs0000644000000000000000000002057512754644012020415 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# 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 ( T3 -- * Rotation , aboutX, aboutY, aboutZ , rotationAbout, rotateAbout , pointAt, pointAt' -- * Scaling , scalingX, scalingY, scalingZ , scaleX, scaleY, scaleZ , scaling, scale -- * Translation , translationX, translateX , translationY, translateY , translationZ, translateZ , translation, translate -- * Reflection , reflectionX, reflectX , reflectionY, reflectY , reflectionZ, reflectZ , reflectionAcross, reflectAcross ) where import Diagrams.Core import Diagrams.Core.Transform import Diagrams.Angle import Diagrams.Direction import Diagrams.ThreeD.Types import Diagrams.Transform import Diagrams.Points import Control.Lens (view, (&), (*~), (.~), (//~)) import Data.Semigroup import Diagrams.TwoD.Transform import Linear.Affine import Linear.Metric import Linear.V3 (cross) import Linear.Vector -- | 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 :: Floating n => Angle n -> Transformation V3 n aboutZ (view rad -> a) = fromOrthogonal r where r = rot a <-> rot (-a) rot θ (V3 x y z) = V3 (cos θ * x - sin θ * y) (sin θ * x + cos θ * y) z -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis. aboutX :: Floating n => Angle n -> Transformation V3 n aboutX (view rad -> a) = fromOrthogonal r where r = rot a <-> rot (-a) rot θ (V3 x y z) = V3 x (cos θ * y - sin θ * z) (sin θ * y + cos θ * z) -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis. aboutY :: Floating n => Angle n -> Transformation V3 n aboutY (view rad -> a) = fromOrthogonal r where r = rot a <-> rot (-a) rot θ (V3 x y z) = V3 (cos θ * x + sin θ * z) y (-sin θ * x + cos θ * z) -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. rotationAbout :: Floating n => Point V3 n -- ^ origin of rotation -> Direction V3 n -- ^ direction of rotation axis -> Angle n -- ^ angle of rotation -> Transformation V3 n rotationAbout (P t) d (view rad -> a) = mconcat [translation (negated t), fromOrthogonal r, translation t] where r = rot a <-> rot (-a) w = fromDirection d rot θ v = v ^* cos θ ^+^ cross w v ^* sin θ ^+^ w ^* ((w `dot` v) * (1 - cos θ)) -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. rotateAbout :: (InSpace V3 n t, Floating n, Transformable t) => Point V3 n -- ^ origin of rotation -> Direction V3 n -- ^ direction of rotation axis -> Angle n -- ^ angle of rotation -> t -> t rotateAbout p d theta = transform (rotationAbout p d theta) -- | @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 @about@ 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 :: Floating n => Direction V3 n -> Direction V3 n -> Direction V3 n -> Transformation V3 n pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. pointAt' :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAt' about initial final = pointAtUnit (signorm about) (signorm initial) (signorm final) -- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. pointAtUnit :: Floating n => V3 n -> V3 n -> V3 n -> Transformation V3 n pointAtUnit about initial final = tilt <> pan where -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v signedAngle rel u v = signum (cross u v `dot` rel) *^ angleBetween u v inPanPlaneF = final ^-^ project about final inPanPlaneI = initial ^-^ project about initial panAngle = signedAngle about inPanPlaneI inPanPlaneF pan = rotationAbout origin (direction about) panAngle tiltAngle = signedAngle tiltAxis (transform pan initial) final tiltAxis = cross final about tilt = rotationAbout origin (direction tiltAxis) tiltAngle -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the z direction. scalingZ :: (Additive v, R3 v, Fractional n) => n -> Transformation v n scalingZ c = fromSymmetric $ (_z *~ c) <-> (_z //~ c) -- | Scale a diagram by the given factor in the z direction. To scale -- uniformly, use 'scale'. scaleZ :: (InSpace v n t, R3 v, Fractional n, Transformable t) => n -> t -> t scaleZ = transform . scalingZ -- Translation ---------------------------------------- -- | Construct a transformation which translates by the given distance -- in the z direction. translationZ :: (Additive v, R3 v, Num n) => n -> Transformation v n translationZ z = translation (zero & _z .~ z) -- | Translate a diagram by the given distance in the y -- direction. translateZ :: (InSpace v n t, R3 v, Transformable t) => n -> t -> t translateZ = transform . translationZ -- Reflection ---------------------------------------------- -- | Construct a transformation which flips a diagram across z=0, -- i.e. sends the point (x,y,z) to (x,y,-z). reflectionZ :: (Additive v, R3 v, Num n) => Transformation v n reflectionZ = fromSymmetric $ (_z *~ (-1)) <-> (_z *~ (-1)) -- | Flip a diagram across z=0, i.e. send the point (x,y,z) to -- (x,y,-z). reflectZ :: (InSpace v n t, R3 v, Transformable t) => t -> t reflectZ = transform reflectionZ -- | @reflectionAcross p v@ is a reflection across the plane through -- the point @p@ and normal to vector @v@. This also works as a 2D -- transform where @v@ is the normal to the line passing through point -- @p@. reflectionAcross :: (Metric v, Fractional n) => Point v n -> v n -> Transformation v n reflectionAcross p v = conjugate (translation (origin .-. p)) reflect where reflect = fromLinear t (linv t) t = f v <-> f (negated v) f u w = w ^-^ 2 *^ project u w -- | @reflectAcross p v@ reflects a diagram across the plane though -- the point @p@ and the vector @v@. This also works as a 2D transform -- where @v@ is the normal to the line passing through point @p@. reflectAcross :: (InSpace v n t, Metric v, Fractional n, Transformable t) => Point v n -> v n -> t -> t reflectAcross p v = transform (reflectionAcross p v) diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Types.hs0000644000000000000000000000477512754644012017552 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Types -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Basic types for three-dimensional Euclidean space. -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Types ( -- * 3D Euclidean space r3, unr3, mkR3 , p3, unp3, mkP3 , r3Iso, p3Iso, project , r3SphericalIso, r3CylindricalIso , V3 (..), P3, T3 , R1 (..), R2 (..), R3 (..) ) where import Control.Lens (Iso', iso, _1, _2, _3) import Diagrams.Angle import Diagrams.Core import Diagrams.Points import Diagrams.TwoD.Types import Linear.Metric import Linear.V3 as V ------------------------------------------------------------ -- 3D Euclidean space -- Basic R3 types type P3 = Point V3 type T3 = Transformation V3 r3Iso :: Iso' (V3 n) (n, n, n) r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. r3 :: (n, n, n) -> V3 n r3 (x,y,z) = V3 x y z -- | Curried version of `r3`. mkR3 :: n -> n -> n -> V3 n mkR3 = V3 -- | Convert a 3D vector back into a triple of components. unr3 :: V3 n -> (n, n, n) unr3 (V3 x y z) = (x,y,z) -- | Construct a 3D point from a triple of coordinates. p3 :: (n, n, n) -> P3 n p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. unp3 :: P3 n -> (n, n, n) unp3 (P (V3 x y z)) = (x,y,z) p3Iso :: Iso' (P3 n) (n, n, n) p3Iso = iso unp3 p3 -- | Curried version of `r3`. mkP3 :: n -> n -> n -> P3 n mkP3 x y z = p3 (x, y, z) type instance V (V3 n) = V3 type instance N (V3 n) = n instance Transformable (V3 n) where transform = apply r3SphericalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, Angle n) r3SphericalIso = iso (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) r3CylindricalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, n) r3CylindricalIso = iso (\(V3 x y z) -> (sqrt $ x*x + y*y, atan2A y x, z)) (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) instance HasR V3 where _r = r3SphericalIso . _1 instance HasTheta V3 where _theta = r3CylindricalIso . _2 instance HasPhi V3 where _phi = r3SphericalIso . _3 diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Align.hs0000644000000000000000000001220212754644012017460 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Align -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Alignment combinators specialized for three dimensions. See -- "Diagrams.Align" for more general alignment combinators. -- -- The basic idea is that alignment is achieved by moving diagrams' -- 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 'alignZMax'@), and then put them -- together with their local origins along a line (using e.g. 'cat' -- from "Diagrams.Combinators"). -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Align ( -- * Absolute alignment -- ** Align by envelope alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax -- ** Align by trace , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax -- * Relative alignment , alignX, snugX, alignY, snugY, alignZ, snugZ -- * Centering , centerX, centerY, centerZ , centerXY, centerXZ, centerYZ, centerXYZ , snugCenterX, snugCenterY, snugCenterZ , snugCenterXY, snugCenterXZ, snugCenterYZ, snugCenterXYZ ) where import Diagrams.Core import Diagrams.Align import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector import Diagrams.TwoD.Align -- | Translate the diagram along unitX so that all points have -- positive x-values. alignXMin :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignXMin = align unit_X snugXMin :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugXMin = snug unit_X -- | Translate the diagram along unitX so that all points have -- negative x-values. alignXMax :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignXMax = align unitX snugXMax :: (InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugXMax = snug unitX -- | Translate the diagram along unitY so that all points have -- positive y-values. alignYMin :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignYMin = align unit_Y snugYMin :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugYMin = snug unit_Y -- | Translate the diagram along unitY so that all points have -- negative y-values. alignYMax :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignYMax = align unitY snugYMax :: (InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugYMax = snug unitY -- | Translate the diagram along unitZ so that all points have -- positive z-values. alignZMin :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignZMin = align unit_Z snugZMin :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugZMin = snug unit_Z -- | Translate the diagram along unitZ so that all points have -- negative z-values. alignZMax :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a alignZMax = align unitZ snugZMax :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugZMax = snug unitZ -- | Like 'alignX', but moving the local origin in the Z direction, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. alignZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => n -> a -> a alignZ = alignBy unitZ -- | See the documentation for 'alignZ'. snugZ :: (V a ~ v, N a ~ n, Alignable a, Traced a, HasOrigin a, R3 v, Fractional n) => n -> a -> a snugZ = snugBy unitZ -- | Center the local origin along the Z-axis. centerZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerZ = alignBy unitZ 0 snugCenterZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugCenterZ = snugBy unitZ 0 -- | Center along both the X- and Z-axes. centerXZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerXZ = centerX . centerZ snugCenterXZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugCenterXZ = snugCenterX . snugCenterZ -- | Center along both the Y- and Z-axes. centerYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerYZ = centerZ . centerY snugCenterYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugCenterYZ = snugCenterZ . snugCenterY -- | Center an object in three dimensions. centerXYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a) => a -> a centerXYZ = centerX . centerY . centerZ snugCenterXYZ :: (InSpace v n a, R3 v, Fractional n, Alignable a, HasOrigin a, Traced a) => a -> a snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Projection.hs0000644000000000000000000001245312754644012020552 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Projection -- Copyright : (c) 2014 diagrams team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- 3D projections are a way of viewing a three-dimensional objects on a -- two-dimensional plane. -- -- This module can be used with the functions in "Linear.Projection". -- -- Disclaimer: This module should be considered experimental and is -- likely to change. -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Projection ( -- * Orthographic projections -- $orthographic -- ** Parallel projections facingXY , facingXZ , facingYZ -- ** axonometric -- $axonometric -- *** Isometric projections -- $isometric , isometricApply , isometric , lookingAt -- ** Affine maps , m44AffineApply , m44AffineMap , m33AffineApply , m33AffineMap -- * Perspective projections -- $perspective -- ** Perspective deformations , m44Deformation , module Linear.Projection ) where import Control.Lens hiding (transform) import Data.Functor.Rep import Diagrams.Core import Diagrams.Deform import Diagrams.Direction import Diagrams.LinearMap import Diagrams.ThreeD.Types (P3) import Diagrams.ThreeD.Vector import Linear as L import Linear.Affine import Linear.Projection ------------------------------------------------------------------------ -- Orthographic projections ------------------------------------------------------------------------ -- $orthographic -- Orthographic projections are a form of parallel projections where are -- projection lines are orthogonal to the projection plane. -- Parallel projections -- | Look at the xy-plane with y as the up direction. facingXY :: (Epsilon n, Floating n) => AffineMap V3 V2 n facingXY = lookingAt unitZ origin yDir -- | Look at the xz-plane with z as the up direction. facingXZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n facingXZ = lookingAt unitY origin zDir -- | Look at the yz-plane with z as the up direction. facingYZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n facingYZ = lookingAt unitX origin zDir -- $axonometric -- Axonometric projections are a type of orthographic projection where -- the object is rotated along one or more of its axes relative to the -- plane of projection. -- $isometric -- Isometric projections are when the scale along each axis of the -- projection is the same and the angle between any axis is 120 -- degrees. -- | Apply an isometric projection given the up direction isometricApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b, Floating n, Epsilon n) => Direction V3 n -> a -> b isometricApply up = amap (isometric up) -- | Make an isometric affine map with the given up direction. isometric :: (Floating n, Epsilon n) => Direction V3 n -> AffineMap V3 V2 n isometric up = m44AffineMap m where m = lookAt (V3 1 1 1) zero (fromDirection up) lookingAt :: (Epsilon n, Floating n) => P3 n -- ^ Eye -> P3 n -- ^ Center -> Direction V3 n -- ^ Up -> AffineMap V3 V2 n lookingAt (P cam) (P center) d = m44AffineMap m where m = lookAt cam center (d^._Dir) -- | Apply the affine part of a homogeneous matrix. m44AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b) => M44 n -> a -> b m44AffineApply = amap . m44AffineMap -- | Create an 'AffineMap' from a 4x4 homogeneous matrix, ignoring any -- perspective transforms. m44AffineMap :: Num n => M44 n -> AffineMap V3 V2 n m44AffineMap m = AffineMap (LinearMap f) (f v) where f = view _xy . (m' !*) m' = m ^. linearTransform v = m ^. L.translation -- | Apply a transformation matrix and translation. m33AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b) => M33 n -> V2 n -> a -> b m33AffineApply m = amap . m33AffineMap m -- | Create an 'AffineMap' from a 3x3 transformation matrix and a -- translation vector. m33AffineMap :: Num n => M33 n -> V2 n -> AffineMap V3 V2 n m33AffineMap m = AffineMap (LinearMap f) where f = view _xy . (m !*) -- | Extract the linear transform part of a homogeneous matrix. linearTransform :: (Representable u, R3 v, R3 u) => Lens' (u (v n)) (M33 n) linearTransform = column _xyz . _xyz ------------------------------------------------------------------------ -- Perspective transforms ------------------------------------------------------------------------ -- For the time being projective transforms use the deformable class. -- Eventually we would like to replace this with a more specialised -- method. -- $perspective -- Perspective projections are when closer objects appear bigger. -- | Make a deformation from a 4x4 homogeneous matrix. m44Deformation :: Fractional n => M44 n -> Deformation V3 V2 n m44Deformation m = Deformation (P . view _xy . normalizePoint . (m !*) . point . view _Point) diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Shapes.hs0000644000000000000000000001411712754644012017660 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Various three-dimensional shapes. -- ----------------------------------------------------------------------------- module Diagrams.ThreeD.Shapes ( Ellipsoid(..), sphere , Box(..), cube , Frustum(..) , frustum, cone, cylinder ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Lens (review, (^.), _1) import Data.Typeable import Data.Semigroup import Diagrams.Angle import Diagrams.Core import Diagrams.Points import Diagrams.Solve.Polynomial import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector import Linear.Affine import Linear.Metric import Linear.Vector data Ellipsoid n = Ellipsoid (Transformation V3 n) deriving Typeable type instance V (Ellipsoid n) = V3 type instance N (Ellipsoid n) = n instance Fractional n => Transformable (Ellipsoid n) where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) instance Fractional n => Renderable (Ellipsoid n) NullBackend where render _ _ = mempty -- | A sphere of radius 1 with its center at the origin. sphere :: (Typeable n, OrderedField n, Renderable (Ellipsoid n) b) => QDiagram b V3 n Any sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) (mkTrace sphereTrace) mempty (Query sphereQuery) where sphereEnv v = 1 / norm v sphereTrace (P p) v = mkSortedList $ quadForm a b c where a = v `dot` v b = 2 * (p `dot` v) c = p `dot` (p - 1) sphereQuery v = Any $ quadrance (v .-. origin) <= 1 data Box n = Box (Transformation V3 n) deriving Typeable type instance V (Box n) = V3 type instance N (Box n) = n instance Fractional n => Transformable (Box n) where transform t1 (Box t2) = Box (t1 <> t2) instance Fractional n => Renderable (Box n) NullBackend where render _ _ = mempty -- | A cube with side length 1, in the positive octant, with one -- vertex at the origin. cube :: (Typeable n, OrderedField n, Renderable (Box n) b) => QDiagram b V3 n Any cube = mkQD (Prim $ Box mempty) (mkEnvelope boxEnv) (mkTrace boxTrace) mempty (Query boxQuery) where corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] boxEnv v = maximum (map (v `dot`) corners) / quadrance v -- ts gives all intersections with the planes forming the box -- filter keeps only those actually on the box surface boxTrace p v = mkSortedList . filter (range . atT) $ ts where (x0, y0, z0) = unp3 p (vx, vy, vz) = unr3 v intersections f d = case d of 0 -> [] _ -> [-f/d, (1-f)/d] ts = concat $ zipWith intersections [x0,y0,z0] [vx,vy,vz] atT t = p .+^ (t*^v) range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where (x, y, z) = unp3 u boxQuery = Any . range data Frustum n = Frustum n n (Transformation V3 n) deriving Typeable type instance V (Frustum n) = V3 type instance N (Frustum n) = n instance Fractional n => Transformable (Frustum n) where transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) instance Fractional n => Renderable (Frustum n) NullBackend where render _ _ = mempty -- | A frustum of a right circular cone. It has height 1 oriented -- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. -- 'cone' and 'cylinder' are special cases. frustum :: (TypeableFloat n, Renderable (Frustum n) b) => n -> n -> QDiagram b V3 n Any frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) (mkEnvelope frEnv) (mkTrace frTrace) mempty (Query frQuery) where projectXY u = u ^-^ project unitZ u frQuery p = Any $ x >= 0 && x <= 1 && a <= r where (x, _, z) = unp3 p r = r0 + (r1 - r0)*z v = p .-. origin a = norm $ projectXY v -- The plane containing v and the z axis intersects the frustum in a trapezoid -- Test the four corners of this trapezoid; one must determine the Envelope frEnv v = maximum . map (norm . project v . review r3CylindricalIso) $ corners where θ = v ^. _theta corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] -- The trace can intersect the sides of the cone or one of the end -- caps The sides are described by a quadric equation; substitute -- in the parametric form of the ray but disregard any -- intersections outside z = [0,1] Similarly, find intersections -- with the planes z=0, z=1, but disregard any r>r0, r>r1 frTrace p v = mkSortedList $ filter zbounds (quadForm a b c) ++ ends where (px, py, pz) = unp3 p (vx, vy, vz) = unr3 v ray t = p .+^ t *^ v dr = r1 - r0 a = vx**2 + vy**2 - vz**2 * dr**2 b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr * vz) c = px**2 + py**2 - (r0 + dr*pz)**2 zbounds t = ray t ^. _z >= 0 && ray t ^. _z <= 1 ends = concatMap cap [0,1] cap z = [ t | ray t ^. lensP . r3CylindricalIso . _1 < r0 + z * dr ] where t = (z - pz) / vz -- | A cone with its base centered on the origin, with radius 1 at the -- base, height 1, and it's apex on the positive Z axis. cone :: (TypeableFloat n, Renderable (Frustum n) b) => QDiagram b V3 n Any cone = frustum 1 0 -- | A circular cylinder of radius 1 with one end cap centered on the -- origin, and extending to Z=1. cylinder :: (TypeableFloat n, Renderable (Frustum n) b) => QDiagram b V3 n Any cylinder = frustum 1 1 diagrams-lib-1.3.1.4/src/Diagrams/ThreeD/Camera.hs0000644000000000000000000001205112754644012017620 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- 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.Typeable import Diagrams.Angle import Diagrams.Core import Diagrams.Direction import Diagrams.ThreeD.Vector import Linear.V3 -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. data Camera l n = Camera { camLoc :: Point V3 n , forward :: V3 n , up :: V3 n , lens :: l n } #if __GLASGOW_HASKELL__ >= 707 deriving Typeable #else instance forall l. Typeable1 l => Typeable1 (Camera l) where typeOf1 _ = mkTyConApp (mkTyCon3 "diagrams-lib" "Diagrams.ThreeD.Camera" "Camera") [] `mkAppTy` typeOf1 (undefined :: l n) #endif type instance V (Camera l n) = V3 type instance N (Camera l n) = n #if __GLASGOW_HASKELL__ > 707 class Typeable l => CameraLens l where #else class Typeable1 l => CameraLens l where #endif -- | The natural aspect ratio of the projection. aspect :: Floating n => l n -> n -- | A perspective projection data PerspectiveLens n = PerspectiveLens { _horizontalFieldOfView :: Angle n -- ^ Horizontal field of view. , _verticalFieldOfView :: Angle n -- ^ Vertical field of view. } deriving Typeable makeLenses ''PerspectiveLens type instance V (PerspectiveLens n) = V3 type instance N (PerspectiveLens n) = n instance CameraLens PerspectiveLens where aspect (PerspectiveLens h v) = angleRatio h v -- | An orthographic projection data OrthoLens n = OrthoLens { _orthoWidth :: n -- ^ Width , _orthoHeight :: n -- ^ Height } deriving Typeable makeLenses ''OrthoLens type instance V (OrthoLens n) = V3 type instance N (OrthoLens n) = n instance CameraLens OrthoLens where aspect (OrthoLens h v) = h / v instance Num n => Transformable (Camera l n) where transform t (Camera p f u l) = Camera (transform t p) (transform t f) (transform t u) l instance Num n => Renderable (Camera l n) 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 :: (Typeable n, Floating n, Ord n, Renderable (Camera PerspectiveLens n) b) => QDiagram b V3 n Any 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 :: (Floating n, Ord n, Typeable n, CameraLens l, Renderable (Camera l n) b) => l n -> QDiagram b V3 n Any facing_ZCamera l = mkQD (Prim $ Camera origin unit_Z unitY l) mempty mempty mempty (Query . const . Any $ False) {-# ANN facing_ZCamera ("HLint: ignore Use camelCase" :: String) #-} mm50, mm50Wide, mm50Narrow :: Floating n => PerspectiveLens n -- | 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 @@ deg) (27 @@ deg) -- | mm50blWide 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 @@ deg) (27 @@ deg) -- | mm50Narrow has the same vertical field of view as mm50, but an -- aspect ratio of 4:3, for VGA and similar computer resolutions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) camForward :: Camera l n -> Direction V3 n camForward = direction . forward camUp :: Camera l n -> Direction V3 n camUp = direction . up camRight :: Fractional n => Camera l n -> Direction V3 n camRight c = direction right where right = cross (forward c) (up c) camLens :: Camera l n -> l n camLens = lens camAspect :: (Floating n, CameraLens l) => Camera l n -> n camAspect = aspect . camLens diagrams-lib-1.3.1.4/src/Diagrams/Backend/0000755000000000000000000000000012754644012016251 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Backend/CmdLine.hs0000644000000000000000000006143212754644012020126 0ustar0000000000000000{-# LANGUAGE ConstrainedClassMethods #-} {-# 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(..) -- ** helper functions for implementing @mainRender@ , defaultAnimMainRender , defaultMultiMainRender , defaultLoopRender ) where import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) import Diagrams.Animation import Diagrams.Attributes import Diagrams.Core hiding (output, value) import Diagrams.Util import Options.Applicative import Options.Applicative.Types (readerAsk) import Control.Monad (forM_, forever, unless, when) import Data.Active hiding (interval) import Data.Char (isDigit) import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data import Data.IORef import Data.List (delete) import Data.Maybe (fromMaybe) import Data.Monoid import Numeric import Control.Concurrent (threadDelay) import System.Directory (canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit (ExitCode (..)) import System.FilePath (addExtension, dropExtension, replaceExtension, splitExtension, takeDirectory, takeFileName, ()) import System.FSNotify (WatchConfig (..), defaultConfig, eventTime, watchDir, withManagerConf) import System.FSNotify.Devel (existsEvents) import System.Info (os) import System.IO (hFlush, stdout) import System.Process (readProcessWithExitCode) import 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 auto) ( long "width" <> short 'w' <> metavar "WIDTH" <> help "Desired WIDTH of the output image") <*> (optional . option auto) ( long "height" <> short 'h' <> metavar "HEIGHT" <> help "Desired HEIGHT of the output image") <*> strOption ( long "output" <> short 'o' <> value "" <> metavar "OUTPUT" <> help "OUTPUT file") -- | Command line parser for 'DiagramMultiOpts'. -- Selection is option @--selection@ or @-S@. -- List is @--list@ or @-L@. diagramMultiOpts :: Parser DiagramMultiOpts diagramMultiOpts = DiagramMultiOpts <$> (optional . strOption) ( long "selection" <> short 'S' <> metavar "NAME" <> help "NAME of the diagram to render") <*> switch ( long "list" <> short 'L' <> help "List all available diagrams") -- | Command line parser for 'DiagramAnimOpts' -- Frames per unit is @--fpu@ or @-f@. diagramAnimOpts :: Parser DiagramAnimOpts diagramAnimOpts = DiagramAnimOpts <$> option auto ( long "fpu" <> short 'f' <> value 30.0 <> help "Frames per unit time (for animations)") -- | CommandLine parser for 'DiagramLoopOpts' -- Loop is @--loop@ or @-l@. -- Source is @--src@ or @-s@. -- Interval is @-i@ defaulting to one second. diagramLoopOpts :: Parser DiagramLoopOpts diagramLoopOpts = DiagramLoopOpts <$> switch (long "loop" <> short 'l' <> help "Run in a self-recompiling loop") <*> (optional . strOption) ( long "src" <> short 's' <> help "Source file to watch") <*> option auto ( long "interval" <> short 'i' <> value 1 <> metavar "INTERVAL" <> help "When running in a loop, check for changes every INTERVAL seconds.") -- | 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 auto mempty -- | Parse 'Int' according to its 'Read' instance. instance Parseable Int where parser = argument auto mempty -- | Parse 'Double' according to its 'Read' instance. instance Parseable Double where parser = argument auto mempty -- | Parse a string by just accepting the given string. instance Parseable String where parser = argument str 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 (rc <|> rh) mempty where rh, rc :: ReadM (Colour Double) rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor) rc = readerAsk >>= readColourName f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha -- value be applied to the r g b values? -- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names" -- or a hexadecimal color. instance Parseable (AlphaColour Double) where parser = argument (rc <|> rh) mempty where rh = readerAsk >>= readHexColor rc = opaque <$> (readerAsk >>= readColourName) -- 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 :: (Applicative m, Monad m) => String -> m (AlphaColour Double) readHexColor cs = case cs of ('0':'x':hs) -> handle hs ('#':hs) -> handle hs hs -> handle hs where handle hs | length hs <= 8 && all isHexDigit hs = case hs of [a,b,c,d,e,f,g,h] -> withOpacity <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) <*> hex g h [a,b,c,d,e,f ] -> opaque <$> (sRGB <$> hex a b <*> hex c d <*> hex e f) [a,b,c,d ] -> withOpacity <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) <*> hex d d [a,b,c ] -> opaque <$> (sRGB <$> hex a a <*> hex b b <*> hex c c) _ -> fail $ "could not parse as a colour" ++ cs handle _ = fail $ "could not parse as a colour: " ++ cs isHexDigit c = isDigit c || c `elem` "abcdef" hex a b = (/ 255) <$> case readHex [a,b] of [(h,"")] -> return h _ -> fail $ "could not parse as a hex value" ++ [a,b] -- | This instance is needed to signal the end of a chain of -- nested tuples, it always just results in the unit value -- 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 -- | Triples of Parsebales should also be Parseable. instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) where parser = (,,) <$> parser <*> parser <*> parser instance (Parseable a, Parseable b, Parseable c, Parseable d) => Parseable (a, b, c, d) where parser = (,,,) <$> parser <*> 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 (QDiagram b v n Any) where type Args (QDiagram b v n Any) = () type ResultOf (QDiagram b v n Any) = QDiagram b v n Any toResult d _ = d -- | A list of diagrams can produce pages. instance ToResult [QDiagram b v n Any] where type Args [QDiagram b v n Any] = () type ResultOf [QDiagram b v n Any] = [QDiagram b v n Any] toResult ds _ = ds -- | A list of named diagrams can give the multi-diagram interface. instance ToResult [(String, QDiagram b v n Any)] where type Args [(String,QDiagram b v n Any)] = () type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)] toResult ds _ = ds -- | An animation is another suitable base case. instance ToResult (Animation b v n) where type Args (Animation b v n) = () type ResultOf (Animation b v n) = Animation b v n 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 (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,QDiagram b v n Any)]@ instance as -- -- @ -- instance Mainable [(String,QDiagram b v n Any)] where -- type MainOpts [(String,QDiagram b v n Any)] = (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 $ " " ++ unwords 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 (QDiagram b v n Any) ~ DiagramOpts@ -- then this lens will simply be 'output'. For a backend supporting looping -- it will most likely be @_1 . output@. This lens is required because the -- 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 :: (opts -> QDiagram b v n Any -> IO ()) -> Lens' opts FilePath -- ^ A lens into the output path. -> (opts, DiagramAnimOpts) -> Animation b v n -> IO () defaultAnimMainRender renderF out (opts,animOpts) anim = do let frames = simulate (toRational $ animOpts^.fpu) anim nDigits = length . show . length $ frames forM_ (zip [1..] frames) $ \(i,d) -> renderF (indexize out nDigits i opts) d -- | @indexize d n@ adds the integer index @n@ to the end of the -- output file name, padding with zeros if necessary so that it uses -- at least @d@ digits. indexize :: Lens' s FilePath -> Int -> Integer -> s -> s indexize out nDigits i opts = opts & out .~ output' where fmt = "%0" ++ show nDigits ++ "d" output' = addExtension (base ++ printf fmt i) ext (base, ext) = splitExtension (opts^.out) putStrF :: String -> IO () putStrF s = putStr s >> hFlush stdout defaultLoopRender :: DiagramLoopOpts -> IO () defaultLoopRender opts = when (opts ^. loop) $ do putStrLn "Looping turned on" prog <- getProgName args <- getArgs srcPath <- case opts ^. src of Just path -> return path Nothing -> fromMaybe (error nosrc) <$> findHsFile prog where nosrc = "Unable to find Haskell source file.\n" ++ "Specify source file with '-s' or '--src'" srcPath' <- canonicalizePath srcPath sandbox <- findSandbox [] sandboxArgs <- case sandbox of Nothing -> return [] Just sb -> do putStrLn ("Using sandbox " ++ takeDirectory sb) return ["-package-db", sb] let args' = delete "-l" . delete "--loop" $ args newProg = newProgName (takeFileName srcPath) prog timeOfDay = take 8 . drop 11 . show . eventTime -- Polling is only used on Windows withManagerConf defaultConfig { confPollInterval = opts ^. interval } $ \mgr -> do lock <- newIORef False _ <- watchDir mgr (takeDirectory srcPath') (existsEvents (== srcPath')) $ \ev -> do running <- atomicModifyIORef lock ((,) True) unless running $ do putStrF ("Modified " ++ timeOfDay ev ++ " ... ") exitCode <- recompile srcPath' newProg sandboxArgs -- Call the new program without the looping option run newProg args' exitCode atomicWriteIORef lock False putStrLn $ "Watching source file " ++ srcPath putStrLn $ "Compiling target: " ++ newProg putStrLn $ "Program args: " ++ unwords args' forever . threadDelay $ case os of -- https://ghc.haskell.org/trac/ghc/ticket/7325 "darwin" -> 5000000000000 _ -> maxBound recompile :: FilePath -> FilePath -> [String] -> IO ExitCode recompile srcFile outFile args = do let ghcArgs = ["--make", srcFile, "-o", outFile] ++ args putStrF "compiling ... " (exit, _, stderr) <- readProcessWithExitCode "ghc" ghcArgs "" when (exit /= ExitSuccess) $ putStrLn ('\n':stderr) return exit -- | On Windows, the next compilation must have a different output -- than the currently running program. newProgName :: FilePath -> String -> String newProgName srcFile oldName = case os of "mingw32" -> if oldName == replaceExtension srcFile "exe" then replaceExtension srcFile ".1.exe" else replaceExtension srcFile "exe" _ -> dropExtension srcFile -- | Run the given program with specified arguments, if and only if -- the previous command returned ExitSuccess. run :: String -> [String] -> ExitCode -> IO () run prog args ExitSuccess = do let path = "." prog putStrF "running ... " (exit, stdOut, stdErr) <- readProcessWithExitCode path args "" case exit of ExitSuccess -> putStrLn "done." ExitFailure r -> do putStrLn $ prog ++ " failed with exit code " ++ show r unless (null stdOut) $ putStrLn "stdout:" >> putStrLn stdOut unless (null stdErr) $ putStrLn "stderr:" >> putStrLn stdErr run _ _ _ = return () diagrams-lib-1.3.1.4/src/Diagrams/Parametric/0000755000000000000000000000000012754644012017011 5ustar0000000000000000diagrams-lib-1.3.1.4/src/Diagrams/Parametric/Adjust.hs0000644000000000000000000000717512754644012020611 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# 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 (Lens', generateSignatures, lensRules, makeLensesWith, (&), (.~), (^.)) import Data.Proxy import Data.Default.Class import Diagrams.Core.V import Diagrams.Parametric -- | What method should be used for adjusting a segment, trail, or -- path? data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value -- (use a negative parameter to shrink) | ByAbsolute n -- ^ Extend by the given arc length -- (use a negative length to shrink) | ToAbsolute n -- ^ 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 n = AO { _adjMethod :: AdjustMethod n , _adjSide :: AdjustSide , _adjEps :: n , adjOptsvProxy :: Proxy n } -- See Diagrams.Combinators for reasoning behind 'Proxy'. makeLensesWith (lensRules & generateSignatures .~ False) ''AdjustOpts -- | Which method should be used for adjusting? adjMethod :: Lens' (AdjustOpts n) (AdjustMethod n) -- | Which end(s) of the object should be adjusted? adjSide :: Lens' (AdjustOpts n) AdjustSide -- | Tolerance to use when doing adjustment. adjEps :: Lens' (AdjustOpts n) n instance Fractional n => Default (AdjustMethod n) where def = ByParam 0.2 instance Default AdjustSide where def = Both instance Fractional n => Default (AdjustOpts n) where def = AO { _adjMethod = def , _adjSide = def , _adjEps = stdTolerance , adjOptsvProxy = 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 :: (N t ~ n, Sectionable t, HasArcLength t, Fractional n) => t -> AdjustOpts n -> t 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