diagrams-lib-0.7.1.1/0000755000000000000000000000000012221314077012376 5ustar0000000000000000diagrams-lib-0.7.1.1/Setup.hs0000644000000000000000000000237412221314077014040 0ustar0000000000000000import Data.List (isSuffixOf) import Distribution.Simple import Distribution.Simple.Setup (Flag (..), HaddockFlags, haddockDistPref) import Distribution.Simple.Utils (copyFiles) import Distribution.Text (display) import Distribution.Verbosity (normal) import System.Directory (getDirectoryContents) import System.FilePath (()) -- Ugly hack, logic copied from Distribution.Simple.Haddock haddockOutputDir :: Package pkg => HaddockFlags -> pkg -> FilePath haddockOutputDir flags pkg = destDir where baseDir = case haddockDistPref flags of NoFlag -> "." Flag x -> x destDir = baseDir "doc" "html" display (packageName pkg) diagramsDir = "diagrams" main :: IO () main = defaultMainWithHooks simpleUserHooks { postHaddock = \args flags pkg lbi -> do dias <- filter ("svg" `isSuffixOf`) `fmap` getDirectoryContents diagramsDir copyFiles normal (haddockOutputDir flags pkg) (map (\d -> ("", diagramsDir d)) dias) postHaddock simpleUserHooks args flags pkg lbi } diagrams-lib-0.7.1.1/diagrams-lib.cabal0000644000000000000000000000764312221314077015727 0ustar0000000000000000Name: diagrams-lib Version: 0.7.1.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created 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 "Diagrams.Prelude". 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: Custom Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg Tested-with: GHC == 7.4.2, GHC == 7.6.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git Library Exposed-modules: Diagrams.Prelude, Diagrams.Align, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, Diagrams.Points, Diagrams.Located, Diagrams.Parametric, Diagrams.Segment, Diagrams.Trail, Diagrams.TrailLike, Diagrams.Path, Diagrams.CubicSpline, Diagrams.CubicSpline.Internal, Diagrams.Solve, Diagrams.Transform, Diagrams.BoundingBox, Diagrams.Names, Diagrams.Envelope, Diagrams.Trace, Diagrams.Query, Diagrams.TwoD, Diagrams.TwoD.Types, Diagrams.TwoD.Align, Diagrams.TwoD.Combinators, Diagrams.TwoD.Transform, Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Segment, Diagrams.TwoD.Curvature, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, Diagrams.TwoD.Shapes, Diagrams.TwoD.Vector, Diagrams.TwoD.Size, Diagrams.TwoD.Model, Diagrams.TwoD.Text, Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, Diagrams.ThreeD.Types, Diagrams.ThreeD.Shapes, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, Diagrams.Backend.Show Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, array >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.12, monoid-extras >= 0.3 && < 0.4, diagrams-core >= 0.7 && < 0.8, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, NumInstances >= 1.2 && < 1.4, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, pretty >= 1.0.1.2 && < 1.2, newtype >= 0.2 && < 0.3, fingertree >= 0.1 && < 0.2, intervals >= 0.2.2 && < 0.3 Hs-source-dirs: src default-language: Haskell2010 diagrams-lib-0.7.1.1/README.markdown0000644000000000000000000000042712221314077015102 0ustar0000000000000000[![Build Status](https://secure.travis-ci.org/diagrams/diagrams-lib.png)](http://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-0.7.1.1/LICENSE0000644000000000000000000000376012221314077013411 0ustar0000000000000000Copyright (c) 2011-2013 diagrams-lib team: Daniel Bergey Daniil Frumin Niklas Haas Peter Hall Claude Heiland-Allen Deepak Jois Ian Ross 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-0.7.1.1/CHANGES.markdown0000644000000000000000000003660212221314077015221 0ustar00000000000000000.7.1.1 (27 September 2013) --------------------------- * allow semigroups-0.11 0.7.1 (11 September 2013) ------------------------- * **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` 0.7 (9 August 2013) ------------------- * **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) 0.6.0.3 (4 May 2013) -------------------- * bump upper bound to allow `NumInstances-1.3` 0.6.0.2 (28 March 2013) ----------------------- * bump upper bound to allow `NumInstances-1.2` * Quadratic solver is now more numerically stable, getting rid of some incorrect behavior of `juxtapose` ([\#46](https://github.com/diagrams/diagrams-lib/issues/46)) 0.6.0.1: 7 January 2013 ----------------------- * allow `semigroups-0.9` 0.6: 11 December 2012 --------------------- * **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. 0.5: 9 March 2012 ----------------- * **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. 0.4.0.1: 30 October 2011 ------------------------ * bump `data-default` dependency to allow version 0.3 0.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 0.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) 0.2: 3 June 2011 ---------------- * **documentation fixes** * **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 0.1.1: 18 May 2011 ------------------ * minor documentation fixes * link to new website 0.1: 17 May 2011 ---------------- * initial preview release diagrams-lib-0.7.1.1/diagrams/0000755000000000000000000000000012221314077014165 5ustar0000000000000000diagrams-lib-0.7.1.1/diagrams/cubicOffsetExample.svg0000644000000000000000000003735312221314077020471 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/nonagonEx.svg0000644000000000000000000000170112221314077016641 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/dodecagonEx.svg0000644000000000000000000000203412221314077017125 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/vruleEx.svg0000644000000000000000000000370012221314077016340 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/diagramA.svg0000644000000000000000000000112112221314077016406 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/hexagonEx.svg0000644000000000000000000000152512221314077016637 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/closeLineEx.svg0000644000000000000000000000162212221314077017121 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/pentagonEx.svg0000644000000000000000000000146712221314077017026 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/cubicSplineEx.svg0000644000000000000000000002037512221314077017452 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/trailOffsetEx.svg0000644000000000000000000000154712221314077017474 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/octagonEx.svg0000644000000000000000000000160012221314077016632 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/rectEx.svg0000644000000000000000000000124612221314077016143 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/diagramNeg.svg0000644000000000000000000000312212221314077016742 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/glueLineEx.svg0000644000000000000000000000160512221314077016751 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/triangleEx.svg0000644000000000000000000000127212221314077017012 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/septagonEx.svg0000644000000000000000000000156112221314077017026 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/lineFromOffsetsEx.svg0000644000000000000000000000104512221314077020310 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/unitSquareEx.svg0000644000000000000000000000260412221314077017345 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/diagramPos.svg0000644000000000000000000000310012221314077016766 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/lineFromVerticesEx.svg0000644000000000000000000000113212221314077020460 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/roundedRectEx.svg0000644000000000000000000000505312221314077017464 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/hruleEx.svg0000644000000000000000000000310012221314077016314 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/hendecagonEx.svg0000644000000000000000000000206212221314077017276 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/besideEx.svg0000644000000000000000000000452712221314077016446 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/diagramZero.svg0000644000000000000000000000307212221314077017154 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/squareEx.svg0000644000000000000000000000246612221314077016513 0ustar0000000000000000 diagrams-lib-0.7.1.1/diagrams/decagonEx.svg0000644000000000000000000000175112221314077016607 0ustar0000000000000000 diagrams-lib-0.7.1.1/src/0000755000000000000000000000000012221314077013165 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/0000755000000000000000000000000012221314077014714 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/Segment.hs0000644000000000000000000004340112221314077016654 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 -- * Fixed (absolutely located) segments , FixedSegment(..) , mkFixedSeg, fromFixedSeg -- * Segment measures -- $segmeas , SegCount(..) , ArcLength(..), getArcLengthCached, getArcLengthFun, getArcLengthBounded , TotalOffset(..) , OffsetEnvelope(..) , SegMeasure ) where import Control.Applicative (liftA2) import Data.AffineSpace import Data.Default.Class import Data.FingerTree import Data.Monoid.MList import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) import Numeric.Interval (Interval (..)) import qualified Numeric.Interval as I import Diagrams.Core import Diagrams.Located import Diagrams.Parametric import Diagrams.Solve import Diagrams.Util ------------------------------------------------------------ -- 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 where OffsetOpen :: Offset Open v OffsetClosed :: v -> Offset Closed v deriving instance Show v => Show (Offset c v) deriving instance Eq v => Eq (Offset c v) deriving instance Ord v => Ord (Offset c v) instance Functor (Offset c) where fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (f v) type instance V (Offset c v) = v instance HasLinearMap v => Transformable (Offset c v) where transform = fmap . apply ------------------------------------------------------------ -- 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 = Linear (Offset c v) -- ^ A linear segment with given offset. | Cubic v v (Offset c v) -- ^ 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 (Show, Functor, Eq, Ord) -- 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) = v instance HasLinearMap v => Transformable (Segment c v) where transform = fmap . apply instance HasLinearMap v => Renderable (Segment c v) NullBackend where render _ _ = mempty -- | @'straight' v@ constructs a translationally invariant linear -- segment with direction and length given by the vector @v@. straight :: v -> Segment Closed v 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 -> v -> v -> Segment Closed v bezier3 c1 c2 x = Cubic c1 c2 (OffsetClosed x) -- | @bézier3@ is the same as @bezier3@, but with more snobbery. bézier3 :: v -> v -> v -> Segment Closed v bézier3 = bezier3 type instance Codomain (Segment Closed v) = 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 (VectorSpace v, Num (Scalar v)) => Parametric (Segment Closed v) 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 (Scalar v) => DomainBounds (Segment Closed v) instance (VectorSpace v, Num (Scalar v)) => EndValues (Segment Closed v) where atStart = const zeroV 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 -> v segOffset (Linear (OffsetClosed v)) = v segOffset (Cubic _ _ (OffsetClosed v)) = v ------------------------------------------------------------ -- 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 (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where getEnvelope (s@(Linear {})) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v -> maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1] ++ filter (liftA2 (&&) (>0) (<1)) (quadForm (3 * ((3 *^ c1 ^-^ 3 *^ c2 ^+^ x2) <.> v)) (6 * (((-2) *^ c1 ^+^ c2) <.> v)) ((3 *^ c1) <.> v)) ------------------------------------------------------------ -- Manipulating segments ------------------------------------------------------------ instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (Segment Closed v) where splitAtParam (Linear (OffsetClosed x1)) t = (left, right) where left = straight p right = straight (x1 ^-^ p) p = lerp zeroV x1 t 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 c1 c2 t a = lerp zeroV c1 t b = lerp a p t d = lerp c2 x2 t c = lerp p d t e = lerp b c t reverseDomain = reverseSegment -- | Reverse the direction of a segment. reverseSegment :: AdditiveGroup v => Segment Closed v -> Segment Closed v reverseSegment (Linear (OffsetClosed v)) = straight (negateV v) reverseSegment (Cubic c1 c2 (OffsetClosed x2)) = bezier3 (c2 ^-^ x2) (c1 ^-^ x2) (negateV x2) instance (InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup v) => HasArcLength (Segment Closed v) where arcLengthBounded _ (Linear (OffsetClosed x1)) = I.singleton $ magnitude 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 magnitude [c1, c2 ^-^ c1, x2 ^-^ c2]) lb = magnitude 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 = FLinear (Point v) (Point v) | FCubic (Point v) (Point v) (Point v) (Point v) deriving Show type instance V (FixedSegment v) = v instance HasLinearMap v => Transformable (FixedSegment v) where transform t (FLinear p1 p2) = FLinear (transform t p1) (transform t p2) transform t (FCubic p1 c1 c2 p2) = FCubic (transform t p1) (transform t c1) (transform t c2) (transform t p2) instance VectorSpace v => HasOrigin (FixedSegment v) where moveOriginTo o (FLinear p1 p2) = FLinear (moveOriginTo o p1) (moveOriginTo o p2) moveOriginTo o (FCubic p1 c1 c2 p2) = FCubic (moveOriginTo o p1) (moveOriginTo o c1) (moveOriginTo o c2) (moveOriginTo o p2) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (FixedSegment v) 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 -- | Create a 'FixedSegment' from a located 'Segment'. mkFixedSeg :: AdditiveGroup v => Located (Segment Closed v) -> FixedSegment v mkFixedSeg (viewLoc -> (p, Linear (OffsetClosed v))) = FLinear p (p .+^ v) mkFixedSeg (viewLoc -> (p, Cubic c1 c2 (OffsetClosed x2))) = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) -- | Convert a 'FixedSegment' back into a located 'Segment'. fromFixedSeg :: AdditiveGroup v => FixedSegment v -> Located (Segment Closed v) fromFixedSeg (FLinear p1 p2) = straight (p2 .-. p1) `at` p1 fromFixedSeg (FCubic x1 c1 c2 x2) = bezier3 (c1 .-. x1) (c2 .-. x1) (x2 .-. x1) `at` x1 type instance Codomain (FixedSegment v) = Point v instance VectorSpace v => Parametric (FixedSegment v) where atParam (FLinear p1 p2) t = alerp p1 p2 t atParam (FCubic x1 c1 c2 x2) t = p3 where p11 = alerp x1 c1 t p12 = alerp c1 c2 t p13 = alerp c2 x2 t p21 = alerp p11 p12 t p22 = alerp p12 p13 t p3 = alerp p21 p22 t ------------------------------------------------------------ -- 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 { getSegCount :: Sum Int } deriving (Semigroup, Monoid) -- | A type to represent the total arc length of a chain of -- segments. The first component is a \"standard\" arc length, -- computed to within a tolerance of @10e-6@. The second component is -- a generic arc length function taking the tolerance as an -- argument. newtype ArcLength v = ArcLength { getArcLength :: (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) } -- | Project out the cached arc length, stored together with error -- bounds. getArcLengthCached :: ArcLength v -> Interval (Scalar v) getArcLengthCached = getSum . fst . getArcLength -- | Project out the generic arc length function taking the tolerance as -- an argument. getArcLengthFun :: ArcLength v -> Scalar v -> Interval (Scalar v) getArcLengthFun = fmap getSum . snd . getArcLength -- | 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 (Scalar v), Ord (Scalar v)) => Scalar v -> ArcLength v -> Interval (Scalar v) getArcLengthBounded eps al | I.width cached <= eps = cached | otherwise = getArcLengthFun al eps where cached = getArcLengthCached al deriving instance (Num (Scalar v), Ord (Scalar v)) => Semigroup (ArcLength v) deriving instance (Num (Scalar v), Ord (Scalar v)) => Monoid (ArcLength v) -- | A type to represent the total cumulative offset of a chain of -- segments. newtype TotalOffset v = TotalOffset { getTotalOffset :: v } instance AdditiveGroup v => Semigroup (TotalOffset v) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) instance AdditiveGroup v => Monoid (TotalOffset v) where mempty = TotalOffset zeroV 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 the offset of the first into account. data OffsetEnvelope v = OffsetEnvelope { oeOffset :: TotalOffset v , oeEnvelope :: Envelope v } instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = OffsetEnvelope (o1 <> o2) (e1 <> moveOriginBy (negateV . getTotalOffset $ o1) e2) -- | @SegMeasure@ collects up all the measurements over a chain of -- segments. type SegMeasure v = SegCount ::: ArcLength v ::: OffsetEnvelope v ::: () -- unfortunately we can't cache Trace, since there is not a generic -- instance Traced (Segment Closed v), only Traced (Segment Closed R2). instance (InnerSpace v, OrderedField (Scalar v)) => Measured (SegMeasure v) (SegMeasure v) where measure = id instance (OrderedField (Scalar v), InnerSpace v) => Measured (SegMeasure v) (Segment Closed v) 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-0.7.1.1/src/Diagrams/Points.hs0000644000000000000000000000252412221314077016527 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- 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 "Data.AffineSpace" and "Diagrams.Coordinates". -- ----------------------------------------------------------------------------- module Diagrams.Points ( -- * Points Point, origin, (*.) -- * Point-related utilities , centroid ) where import Diagrams.Coordinates import Diagrams.Core.Points import Control.Newtype import Control.Arrow ((&&&)) import Data.VectorSpace -- | The centroid of a set of /n/ points is their sum divided by /n/. centroid :: (VectorSpace v, Fractional (Scalar v)) => [Point v] -> Point v centroid = pack . uncurry (^/) . (sumV &&& (fromIntegral . length)) . map unpack instance Coordinates v => Coordinates (Point v) where type FinalCoord (Point v) = FinalCoord v type PrevDim (Point v) = PrevDim v type Decomposition (Point v) = Decomposition v x & y = P (x & y) coords (P v) = coords v diagrams-lib-0.7.1.1/src/Diagrams/Trail.hs0000644000000000000000000010470712221314077016334 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Trail -- Copyright : (c) 2013 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(..) , wrapTrail, wrapLine, wrapLoop , onTrail, onLine , glueTrail, closeTrail, cutTrail -- * Constructing trails , emptyLine, emptyTrail , lineFromVertices, trailFromVertices , lineFromOffsets, trailFromOffsets , lineFromSegments, trailFromSegments -- * Eliminating trails , withTrail', withTrail, withLine , isLineEmpty, isTrailEmpty , isLine, isLoop , trailSegments, lineSegments, loopSegments , onLineSegments , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailVertices, lineVertices, loopVertices , fixTrail -- * Modifying trails , reverseTrail, reverseLocTrail , reverseLine, reverseLocLine , reverseLoop, reverseLocLoop -- * Internals -- $internals -- ** Type tags , Line, Loop -- ** Segment trees , SegTree(..), trailMeasure, numSegs, offset ) where import Control.Arrow ((***)) import Data.AffineSpace import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) import qualified Data.FingerTree as FT import qualified Data.Foldable as F import Data.Monoid.MList import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) import qualified Numeric.Interval as I import Diagrams.Core hiding ((|>)) import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -- $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 instance ( HasLinearMap (V a), InnerSpace (V a), OrderedField (Scalar (V a)) , FT.Measured m a, Transformable a ) => Transformable (FingerTree m a) where transform = FT.fmap' . transform ------------------------------------------------------------ -- 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 = SegTree { getSegTree :: FingerTree (SegMeasure v) (Segment Closed v) } deriving (Eq, Ord, Show) type instance V (SegTree v) = v deriving instance (OrderedField (Scalar v), InnerSpace v) => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (SegTree v) type instance Codomain (SegTree v) = v instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (SegTree v) where atParam t p = offset . fst $ splitAtParam t p instance Num (Scalar v) => DomainBounds (SegTree v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v), Num (Scalar v)) => EndValues (SegTree v) instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (SegTree v) where splitAtParam (SegTree t) p | p < 0 = case FT.viewl t of EmptyL -> emptySplit seg :< t' -> case seg `splitAtParam` (p * tSegs) of (seg1, seg2) -> ( SegTree $ FT.singleton seg1 , SegTree $ seg2 <| t' ) | p >= 1 = case FT.viewr t of EmptyR -> emptySplit t' :> seg -> case seg `splitAtParam` (1 - (1 - p)*tSegs) of (seg1, seg2) -> ( SegTree $ t' |> seg1 , SegTree $ FT.singleton seg2 ) | otherwise = case FT.viewl after of EmptyL -> emptySplit seg :< after' -> case seg `splitAtParam` (snd . properFraction $ p * tSegs) of (seg1, seg2) -> ( SegTree $ before |> seg1 , SegTree $ seg2 <| after' ) where (before, after) = FT.split ((p * tSegs <) . numSegs) t tSegs = numSegs t emptySplit = (SegTree t, SegTree t) -- XXX seems like it should be possible to collapse some of the -- above cases into one? instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (SegTree v) 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 :: ArcLength v -> I.Interval (Scalar v)) t fun = trailMeasure (const 0) (getArcLengthFun :: ArcLength v -> Scalar v -> I.Interval (Scalar v)) t arcLengthToParam eps st@(SegTree t) l | l < 0 = case FT.viewl t of EmptyL -> 0 seg :< _ -> arcLengthToParam eps seg l / tSegs | l >= totalAL = case FT.viewr t of EmptyR -> 0 t' :> 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 :< after' -> 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) (Segment Closed v) (before, after) = FT.split ((>= l) . trailMeasure 0 (I.midpoint . (getArcLengthBounded eps :: ArcLength v -> I.Interval (Scalar v)))) 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 :: ( InnerSpace v, OrderedField (Scalar v) , SegMeasure v :>: m, FT.Measured (SegMeasure v) 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 :: ( Floating (Scalar v), Num c, Ord (Scalar v), InnerSpace v, FT.Measured (SegMeasure v) a ) => a -> c numSegs = fromIntegral . trailMeasure 0 (getSum . getSegCount) -- | Compute the total offset of anything measured by 'SegMeasure'. offset :: ( Floating (Scalar v), Ord (Scalar v), InnerSpace v, FT.Measured (SegMeasure v) t ) => t -> v offset = trailMeasure zeroV (getTotalOffset . oeOffset) ------------------------------------------------------------ -- 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 where Line :: SegTree v -> Trail' Line v Loop :: SegTree v -> Segment Open v -> Trail' Loop v -- | A generic eliminator for 'Trail'', taking functions specifying -- what to do in the case of a line or a loop. withTrail' :: (Trail' Line v -> r) -> (Trail' Loop v -> r) -> Trail' l v -> r withTrail' line loop t@(Line{}) = line t withTrail' line loop t@(Loop{}) = loop t deriving instance Show v => Show (Trail' l v) deriving instance Eq v => Eq (Trail' l v) deriving instance Ord v => Ord (Trail' l v) type instance V (Trail' l v) = v type instance Codomain (Trail' l v) = v instance (OrderedField (Scalar v), InnerSpace v) => Semigroup (Trail' Line v) 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 (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail' Line v) where mempty = emptyLine mappend = (<>) instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Trail' l v) 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 (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail' l v) where getEnvelope = withTrail' ftEnv (ftEnv . cutLoop) where ftEnv :: Trail' Line v -> Envelope v ftEnv (Line t) = trailMeasure mempty oeEnvelope $ t instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Renderable (Trail' o v) NullBackend where render _ _ = mempty instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (Trail' l v) where atParam t p = withTrail' (\(Line segT) -> segT `atParam` p) (\l -> cutLoop l `atParam` p') t where pf = snd . properFraction $ p p' | p >= 0 = pf | otherwise = 1 + pf instance Num (Scalar v) => DomainBounds (Trail' l v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (Trail' l v) instance (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (Trail' Line v) where splitAtParam (Line t) p = (Line t1, Line t2) where (t1, t2) = splitAtParam t p instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail' l v) 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 -------------------------------------------------- -- 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 where Trail :: Trail' l v -> Trail v deriving instance Show v => Show (Trail v) instance Eq v => Eq (Trail v) where t1 == t2 = withTrail (\ln1 -> withTrail (\ln2 -> ln1 == ln2) (const False) t2) (\lp1 -> withTrail (const False) (\lp2 -> lp1 == lp2) t2) t1 instance Ord v => Ord (Trail v) where compare t1 t2 = withTrail (\ln1 -> withTrail (\ln2 -> compare ln1 ln2) (const LT) t2) (\lp1 -> withTrail (const GT) (\lp2 -> compare lp1 lp2) 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 (Scalar v), InnerSpace v) => Semigroup (Trail v) 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 (OrderedField (Scalar v), InnerSpace v) => Monoid (Trail v) where mempty = wrapLine emptyLine mappend = (<>) type instance V (Trail v) = v type instance Codomain (Trail v) = v instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Trail v) where transform t = onTrail (transform t) (transform t) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where getEnvelope = withTrail getEnvelope getEnvelope instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => Parametric (Trail v) where atParam t p = withTrail (`atParam` p) (`atParam` p) t instance Num (Scalar v) => DomainBounds (Trail v) instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => EndValues (Trail v) -- | 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 (InnerSpace v, RealFrac (Scalar v), Floating (Scalar v)) => Sectionable (Trail v) where splitAtParam t p = withLine ((wrapLine *** wrapLine) . (`splitAtParam` p)) t instance (InnerSpace v, OrderedField (Scalar v), RealFrac (Scalar v)) => HasArcLength (Trail v) where arcLengthBounded = withLine . arcLengthBounded arcLengthToParam eps tr al = withLine (\ln -> arcLengthToParam eps ln al) tr -------------------------------------------------- -- 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 -> r) -> (Trail' Loop v -> r) -> Trail v -> 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 -> Trail' l1 v) -> (Trail' Loop v -> Trail' l2 v) -> (Trail v -> Trail v) 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 :: (InnerSpace v, OrderedField (Scalar v)) => (Trail' Line v -> r) -> Trail v -> 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 :: (InnerSpace v, OrderedField (Scalar v)) => (Trail' Line v -> Trail' Line v) -> Trail v -> Trail v 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 -> Trail v 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 -> Trail v 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 -> Trail v wrapLoop = wrapTrail ------------------------------------------------------------ -- Constructing trails ----------------------------------- ------------------------------------------------------------ -- | The empty line, which is the identity for concatenation of lines. emptyLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v emptyLine = Line mempty -- | A wrapped variant of 'emptyLine'. emptyTrail :: (InnerSpace v, OrderedField (Scalar v)) => Trail v emptyTrail = wrapLine emptyLine -- | Construct a line from a list of closed segments. lineFromSegments :: (InnerSpace v, OrderedField (Scalar v)) => [Segment Closed v] -> Trail' Line v lineFromSegments = Line . SegTree . FT.fromList -- | @trailFromSegments === 'wrapTrail' . 'lineFromSegments'@, for -- conveniently constructing a @Trail@ instead of a @Trail'@. trailFromSegments :: (InnerSpace v, OrderedField (Scalar v)) => [Segment Closed v] -> Trail v 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 :: (InnerSpace v, OrderedField (Scalar v)) => [v] -> Trail' Line v lineFromOffsets = lineFromSegments . map straight -- | @trailFromOffsets === 'wrapTrail' . 'lineFromOffsets'@, for -- conveniently constructing a @Trail@ instead of a @Trail' Line@. trailFromOffsets :: (InnerSpace v, OrderedField (Scalar v)) => [v] -> Trail v 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 :: (InnerSpace v, OrderedField (Scalar v)) => [Point v] -> Trail' Line v 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 :: (InnerSpace v, OrderedField (Scalar v)) => [Point v] -> Trail v 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. -- -- <> -- -- > import Diagrams.Coordinates -- > glueLineEx = pad 1.1 . hcat' with {sep = 1} -- > $ [almostClosed # strokeLine, almostClosed # glueLine # strokeLoop] -- > -- > almostClosed :: Trail' Line R2 -- > almostClosed = fromOffsets [2 & (-1), (-3) & (-0.5), (-2) & 1, 1 & 0.5] -- -- @glueLine@ is left inverse to 'cutLoop', that is, -- -- @ -- glueLine . cutLoop === id -- @ glueLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Loop v glueLine (Line (SegTree t)) = case FT.viewr t of FT.EmptyR -> Loop mempty (Linear OffsetOpen) t' :> (Linear _) -> Loop (SegTree t') (Linear OffsetOpen) t' :> (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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v 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 -> Trail' Loop v 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 -> Trail v 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. (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> Trail' Line v 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 offV = negateV . trailMeasure zeroV (getTotalOffset . 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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v cutTrail = onTrail id cutLoop ------------------------------------------------------------ -- Eliminating trails ------------------------------------ ------------------------------------------------------------ -- | Test whether a line is empty. isLineEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Bool isLineEmpty (Line (SegTree t)) = FT.null t -- | Test whether a trail is empty. Note that loops are never empty. isTrailEmpty :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Bool isTrailEmpty = withTrail isLineEmpty (const False) -- | Determine whether a trail is a line. isLine :: Trail v -> Bool isLine = not . isLoop -- | Determine whether a trail is a loop. isLoop :: Trail v -> Bool isLoop = withTrail (const False) (const True) -- | Extract the segments comprising a line. lineSegments :: Trail' Line v -> [Segment Closed v] lineSegments (Line (SegTree t)) = F.toList t -- | Modify a line by applying a function to its list of segments. onLineSegments :: (InnerSpace v, OrderedField (Scalar v)) => ([Segment Closed v] -> [Segment Closed v]) -> Trail' Line v -> Trail' Line v 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 -> ([Segment Closed v], Segment Open v) 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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [Segment Closed v] trailSegments = withLine lineSegments -- | Extract the offsets of the segments of a trail. trailOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> [v] 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)] -- > # stroke # lc red # lw 0.05 trailOffset :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> v trailOffset = withLine lineOffset -- | Extract the offsets of the segments of a line. lineOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> [v] lineOffsets = map segOffset . lineSegments -- | Extract the offsets of the segments of a loop. loopOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> [v] 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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> v lineOffset (Line t) = trailMeasure zeroV (getTotalOffset . oeOffset) t -- | Extract the vertices of a concretely located trail. 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@. -- -- Note that it does not make sense to ask for the vertices of a -- 'Trail' by itself; if you want the vertices of a trail -- with the first vertex at, say, the origin, you can use -- @trailVertices . (`at` origin)@. trailVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [Point v] trailVertices (viewLoc -> (p,t)) = withTrail (lineVertices . (`at` p)) (loopVertices . (`at` p)) t -- | Extract the vertices of a concretely located line. See -- 'trailVertices' for more information. lineVertices :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Line v) -> [Point v] lineVertices (viewLoc -> (p,t)) = segmentVertices p . lineSegments $ t -- | 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 :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Loop v) -> [Point v] loopVertices (viewLoc -> (p,t)) = segmentVertices p . fst . loopSegments $ t segmentVertices :: AdditiveGroup v => Point v -> [Segment Closed v] -> [Point v] segmentVertices p = scanl (.+^) p . map segOffset -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] fixTrail t = zipWith ((mkFixedSeg .) . at) (trailSegments (unLoc t)) (trailVertices t) ------------------------------------------------------------ -- 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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Trail v 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 :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Located (Trail v) reverseLocTrail (viewLoc -> (p, t)) = reverseTrail t `at` (p .+^ trailOffset t) -- | Reverse a line. See 'reverseTrail'. reverseLine :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Line v -> Trail' Line v reverseLine = onLineSegments (reverse . map reverseSegment) -- | Reverse a concretely located line. See 'reverseLocTrail'. reverseLocLine :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Line v) -> Located (Trail' Line v) reverseLocLine (viewLoc -> (p,l)) = reverseLine l `at` (p .+^ lineOffset l) -- | Reverse a loop. See 'reverseTrail'. reverseLoop :: (InnerSpace v, OrderedField (Scalar v)) => Trail' Loop v -> Trail' Loop v reverseLoop = glueLine . reverseLine . cutLoop -- | Reverse a concretely located loop. See 'reverseLocTrail'. Note -- that this is guaranteed to preserve the location. reverseLocLoop :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail' Loop v) -> Located (Trail' Loop v) reverseLocLoop = mapLoc reverseLoop diagrams-lib-0.7.1.1/src/Diagrams/Align.hs0000644000000000000000000000620312221314077016303 0ustar0000000000000000{-# 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(..) , alignByDefault -- * General alignment functions , align , center ) where import Diagrams.Core import Data.AffineSpace (alerp) import Data.VectorSpace import qualified Data.Map as M import qualified Data.Set as S -- | Class of things which can be aligned. class Alignable a where -- | @alignBy v d a@ moves the origin of @a@ along the vector -- @v@. If @d = 1@, the origin is moved to the edge of the -- envelope in the direction of @v@; if @d = -1@, it moves to the -- edge of the envelope in the direction of the negation of @v@. -- Other values of @d@ interpolate linearly (so for example, @d = -- 0@ centers the origin along the direction of @v@). alignBy :: V a -> Scalar (V a) -> a -> a -- | Default implementation of 'alignBy' for types with 'HasOrigin' -- and 'Enveloped' instances. alignByDefault :: (HasOrigin a, Enveloped a, Num (Scalar (V a))) => V a -> Scalar (V a) -> a -> a alignByDefault v d a = moveOriginTo (alerp (envelopeP (negateV v) a) (envelopeP v a) ((d + 1) / 2)) a instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Envelope v) where alignBy = alignByDefault instance (Enveloped b, HasOrigin b) => Alignable [b] where alignBy = alignByDefault instance (Enveloped b, HasOrigin b, Ord b) => Alignable (S.Set b) where alignBy = alignByDefault instance (Enveloped b, HasOrigin b) => Alignable (M.Map k b) where alignBy = alignByDefault instance ( HasLinearMap v, InnerSpace v, OrderedField (Scalar v) , Monoid' m ) => Alignable (QDiagram b v m) where alignBy = alignByDefault -- | @align v@ aligns an enveloped object along the edge in the -- direction of @v@. That is, it moves the local origin in the -- direction of @v@ until it is on the edge of the envelope. (Note -- that if the local origin is outside the envelope to begin with, -- it may have to move \"backwards\".) align :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a align v = alignBy v 1 -- | @center v@ centers an enveloped object along the direction of -- @v@. center :: (Alignable a, Num (Scalar (V a))) => V a -> a -> a center v = alignBy v 0 diagrams-lib-0.7.1.1/src/Diagrams/Parametric.hs0000644000000000000000000002345312221314077017346 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 ( -- * Parametric functions stdTolerance , Codomain, Parametric(..) , DomainBounds(..), EndValues(..), Sectionable(..), HasArcLength(..) -- * Adjusting , adjust , AdjustOpts(..), AdjustMethod(..), AdjustSide(..) ) where import Diagrams.Core import Diagrams.Util import Data.Default.Class import Data.VectorSpace import qualified Numeric.Interval 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 -> Scalar (V p) -> Codomain 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 -> Scalar (V p) default domainLower :: Num (Scalar (V p)) => p -> Scalar (V p) domainLower = const 0 -- | 'domainUpper' defaults to being constantly 1 (for vector spaces -- with numeric scalars). domainUpper :: p -> Scalar (V p) default domainUpper :: Num (Scalar (V p)) => p -> Scalar (V p) 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 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 atEnd x = x `atParam` domainUpper x -- | Return the lower and upper bounds of a parametric domain together -- as a pair. domainBounds :: DomainBounds p => p -> (Scalar (V p), Scalar (V p)) domainBounds x = (domainLower x, domainUpper x) -- | Type class for parametric objects which can be split into -- subobjects. -- -- Minimal definition: Either 'splitAtParam' or 'section'. 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 -> Scalar (V 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 -> Scalar (V p) -> Scalar (V p) -> p default section :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) -> p section x t1 t2 = snd (splitAtParam (fst (splitAtParam x t2)) (t1/t2)) -- | Flip the parameterization on the domain. This has the -- following default definition: -- -- > reverse x = section x (domainUpper x) (domainLower x) reverseDomain :: p -> p reverseDomain x = section x (domainUpper x) (domainLower x) -- | The standard tolerance used by @std...@ functions (like -- 'stdArcLength' and 'stdArcLengthToParam', currently set at -- @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 :: Scalar (V p) -> p -> I.Interval (Scalar (V p)) -- | @arcLength eps s@ approximates the arc length of @x@ up to the -- accuracy @eps@ (plus or minus). arcLength :: Scalar (V p) -> p -> Scalar (V p) default arcLength :: Fractional (Scalar (V p)) => Scalar (V p ) -> p -> Scalar (V p) arcLength eps = I.midpoint . arcLengthBounded eps -- | Approximate the arc length up to a standard accuracy of -- 'stdTolerance' (@1e-6@). stdArcLength :: p -> Scalar (V p) default stdArcLength :: Fractional (Scalar (V p)) => p -> Scalar (V 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 :: Scalar (V p) -> p -> Scalar (V p) -> Scalar (V p) -- | A simple interface to convert arc length to a parameter, -- guaranteed to be accurate within 'stdTolerance', or @1e-6@. stdArcLengthToParam :: p -> Scalar (V p) -> Scalar (V p) default stdArcLengthToParam :: Fractional (Scalar (V p)) => p -> Scalar (V p) -> Scalar (V p) stdArcLengthToParam = arcLengthToParam stdTolerance -------------------------------------------------- -- Adjusting length -------------------------------------------------- -- | What method should be used for adjusting a segment, trail, or -- path? data AdjustMethod v = ByParam (Scalar v) -- ^ Extend by the given parameter value -- (use a negative parameter to shrink) | ByAbsolute (Scalar v) -- ^ Extend by the given arc length -- (use a negative length to shrink) | ToAbsolute (Scalar v) -- ^ Extend or shrink to the given -- arc length -- | Which side of a segment, trail, or path should be adjusted? data AdjustSide = Start -- ^ Adjust only the beginning | End -- ^ Adjust only the end | Both -- ^ Adjust both sides equally deriving (Show, Read, Eq, Ord, Bounded, Enum) -- | How should a segment, trail, or path be adjusted? data AdjustOpts v = AO { adjMethod :: AdjustMethod v , adjSide :: AdjustSide , adjEps :: Scalar v , adjOptsvProxy__ :: Proxy v } instance Fractional (Scalar v) => Default (AdjustMethod v) where def = ByParam 0.2 instance Default AdjustSide where def = Both instance Fractional (Scalar v) => Default (AdjustOpts v) where def = AO def def stdTolerance Proxy -- | Adjust the length of a parametric object such as a segment or -- trail. The second parameter is an option record which controls how -- the adjustment should be performed; see 'AdjustOpts'. adjust :: (DomainBounds a, Sectionable a, HasArcLength a, Fractional (Scalar (V a))) => a -> AdjustOpts (V a) -> a adjust s opts = section s (if adjSide opts == End then domainLower s else getParam s) (if adjSide opts == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) where getParam seg = case adjMethod opts of ByParam p -> -p * bothCoef ByAbsolute len -> param (-len * bothCoef) ToAbsolute len -> param (absDelta len * bothCoef) where param = arcLengthToParam eps seg absDelta len = arcLength eps s - len bothCoef = if adjSide opts == Both then 0.5 else 1 eps = adjEps opts diagrams-lib-0.7.1.1/src/Diagrams/Trace.hs0000644000000000000000000000361012221314077016306 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 (HasLinearMap, Point, Subdiagram, location, origin, setTrace, trace) import Diagrams.Core.Trace import Data.Maybe import Data.VectorSpace (Scalar, negateV) import Diagrams.Combinators (withTrace) -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector. If there is no such -- point, the origin is returned; see also 'boundaryFromMay'. boundaryFrom :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Point v boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v -- | Compute the furthest point on the boundary of a subdiagram, -- beginning from the location (local origin) of the subdiagram and -- moving in the direction of the given vector, or @Nothing@ if -- there is no such point. boundaryFromMay :: (HasLinearMap v, Ord (Scalar v)) => Subdiagram b v m -> v -> Maybe (Point v) boundaryFromMay s v = traceP (location s) (negateV v) s diagrams-lib-0.7.1.1/src/Diagrams/BoundingBox.hs0000644000000000000000000003105212221314077017467 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , DeriveFunctor , FlexibleContexts , GeneralizedNewtypeDeriving , NoMonomorphismRestriction , ScopedTypeVariables , StandaloneDeriving , TypeFamilies , UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.BoundingBox -- Copyright : (c) 2011 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, boxTransform, boxFit , contains, contains' , inside, inside', outside, outside' -- * Operations on bounding boxes , union, intersection ) where import Control.Applicative ((<$>)) import Control.Monad (join, liftM2) import Data.Map (Map, fromList, toList, fromDistinctAscList, toAscList) import qualified Data.Foldable as F import Data.Maybe (fromMaybe) import Data.VectorSpace -- (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV, (^+^), (^-^)) import Data.Basis (HasBasis, Basis, decompose, recompose, basisValue) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..), Option(..)) import Data.Data (Data) import Data.Typeable (Typeable) import Diagrams.Core.Points (Point(..)) import Diagrams.Core.HasOrigin (HasOrigin(..)) import Diagrams.Core.Envelope (Enveloped(..), appEnvelope) import Diagrams.Core.V (V) import Diagrams.Core.Transform (Transformation(..), Transformable(..), HasLinearMap, (<->)) -- Unexported utility newtype newtype NonEmptyBoundingBox v = NonEmptyBoundingBox (Point v, Point v) deriving (Eq, Data, Typeable) fromNonEmpty :: NonEmptyBoundingBox v -> BoundingBox v fromNonEmpty = BoundingBox . Option . Just fromMaybeEmpty :: Maybe (NonEmptyBoundingBox v) -> BoundingBox v fromMaybeEmpty = maybe emptyBox fromNonEmpty nonEmptyCorners :: NonEmptyBoundingBox v -> (Point v, Point v) nonEmptyCorners (NonEmptyBoundingBox x) = x instance (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => Semigroup (NonEmptyBoundingBox v) where (NonEmptyBoundingBox (ul, uh)) <> (NonEmptyBoundingBox (vl, vh)) = NonEmptyBoundingBox $ mapT toPoint (combineP min ul vl, combineP 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 = BoundingBox (Option (NonEmptyBoundingBox v)) deriving (Eq, Data, Typeable) deriving instance ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) ) => Semigroup (BoundingBox v) deriving instance ( HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v) ) => Monoid (BoundingBox v) type instance V (BoundingBox v) = v -- Map a function on a homogenous 2-tuple. (unexported utility) mapT :: (a -> b) -> (a, a) -> (b, b) mapT f (x, y) = (f x, f y) instance ( VectorSpace v, HasBasis v, Ord (Basis v) , AdditiveGroup (Scalar v), Ord (Scalar v) ) => HasOrigin (BoundingBox v) where moveOriginTo p b = fromMaybeEmpty ( NonEmptyBoundingBox . mapT (moveOriginTo p) <$> getCorners b ) instance ( InnerSpace v, HasBasis v, Ord (Basis v) , AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v) ) => Enveloped (BoundingBox v) where getEnvelope = getEnvelope . getAllCorners instance Show v => Show (BoundingBox v) where show = maybe "emptyBox" (\(l, u) -> "fromCorners " ++ show l ++ " " ++ show u) . getCorners {- TODO instance Read v => Read (BoundingBox v) where read "emptyBox" = emptyBox -} -- | An empty bounding box. This is the same thing as @mempty@, but it doesn't -- require the same type constraints that the @Monoid@ emptyBox :: BoundingBox v 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 :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => Point v -> Point v -> BoundingBox v fromCorners l h | F.and (combineP (<=) l h) = fromNonEmpty $ NonEmptyBoundingBox (l, h) | otherwise = mempty -- | Create a degenerate bounding \"box\" containing only a single point. fromPoint :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => Point v -> BoundingBox v fromPoint p = fromNonEmpty $ NonEmptyBoundingBox (p, p) -- | Create the smallest bounding box containing all the given points. fromPoints :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => [Point v] -> BoundingBox v fromPoints = mconcat . map fromPoint -- | Create a bounding box for any enveloped object (such as a diagram or path). boundingBox :: forall a. ( Enveloped a, HasBasis (V a), AdditiveGroup (V a) , Ord (Basis (V a)) ) => a -> BoundingBox (V a) boundingBox a = fromMaybeEmpty $ do env <- appEnvelope $ getEnvelope a let h = recompose $ map (\v -> (v, env $ basisValue v)) us l = recompose $ map (\v -> (v, negate . env . negateV $ basisValue v)) us return $ NonEmptyBoundingBox (P l, P h) where -- The units. Might not work if 0-components aren't reported. --TODO: Depend on Enum Basis? us = map fst $ decompose (zeroV :: V a) -- | Queries whether the BoundingBox is empty. isEmptyBox :: BoundingBox v -> Bool isEmptyBox (BoundingBox (Option Nothing)) = True isEmptyBox _ = False -- | Gets the lower and upper corners that define the bounding box. getCorners :: BoundingBox v -> Maybe (Point v, Point v) getCorners (BoundingBox p) = nonEmptyCorners <$> getOption p -- | Computes all of the corners of the bounding box. getAllCorners :: (HasBasis v, AdditiveGroup (Scalar v), Ord (Basis v)) => BoundingBox v -> [Point v] getAllCorners (BoundingBox (Option Nothing)) = [] getAllCorners (BoundingBox (Option (Just (NonEmptyBoundingBox (l, u))))) = map (P . recompose) -- Enumerate all combinations of selections of lower / higher values. . mapM (\(b, (l', u')) -> [(b, l'), (b, u')]) -- List of [(basis, (lower, upper))] . toList $ combineP (,) l u -- | Get the size of the bounding box - the vector from the (component-wise) -- lesser point to the greater point. boxExtents :: (AdditiveGroup v) => BoundingBox v -> v boxExtents = maybe zeroV (\(P l, P h) -> h ^-^ l) . getCorners -- | Create a transformation mapping points from one bounding box to the other. boxTransform :: (AdditiveGroup v, HasLinearMap v, Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v)) => BoundingBox v -> BoundingBox v -> Maybe (Transformation v) boxTransform u v = do ((P ul), _) <- getCorners u ((P vl), _) <- getCorners v let lin_map = box_scale (v, u) <-> box_scale (u, v) box_scale = combineV' (*) . uncurry (combineV' (/)) . mapT boxExtents combineV' f x = toVector . combineV f x return $ Transformation lin_map lin_map (vl ^-^ box_scale (v, u) ul) -- | Transforms an enveloped thing to fit within a @BoundingBox@. If it's -- empty, then the result is also @mempty@. boxFit :: (Enveloped a, Transformable a, Monoid a, Ord (Basis (V a))) => BoundingBox (V a) -> 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 :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> Point v -> Bool contains b p = maybe False check $ getCorners b where check (l, h) = F.and (combineP (<=) l p) && F.and (combineP (<=) p h) -- | Check whether a point is /strictly/ contained in a bounding box. contains' :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> Point v -> Bool contains' b p = maybe False check $ getCorners b where check (l, h) = F.and (combineP (<) l p) && F.and (combineP (<) p h) -- | Test whether the first bounding box is contained inside -- the second. inside :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> Bool inside u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.and (combineP (>=) ul vl) && F.and (combineP (<=) uh vh) -- | Test whether the first bounding box is /strictly/ contained -- inside the second. inside' :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> Bool inside' u v = fromMaybe False $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.and (combineP (>) ul vl) && F.and (combineP (<) uh vh) -- | Test whether the first bounding box lies outside the second -- (although they may intersect in their boundaries). outside :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> Bool outside u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.or (combineP (<=) uh vl) || F.or (combineP (>=) ul vh) -- | Test whether the first bounding box lies /strictly/ outside the second -- (they do not intersect at all). outside' :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> Bool outside' u v = fromMaybe True $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ F.or (combineP (<) uh vl) || F.or (combineP (>) 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 :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> BoundingBox v intersection u v = maybe mempty (uncurry fromCorners) $ do (ul, uh) <- getCorners u (vl, vh) <- getCorners v return $ mapT toPoint (combineP max ul vl, combineP min uh vh) -- | Form the smallest bounding box containing the given two bound union. This -- function is just an alias for @mappend@. union :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> BoundingBox v union = mappend -- internals using Map (Basis v) (Scalar v) -- probably paranoia, but decompose might not always -- 1. contain basis elements whose component is zero -- 2. have basis elements in the same order fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v) fromVector = fromList . decompose toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v toVector = recompose . toList toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v toPoint = P . toVector combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) => (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v) combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a combineP f (P u) (P v) = combineV f u v combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c combineDefault a b f = combine g where g Nothing Nothing = f a b g Nothing (Just y) = f a y g (Just x) Nothing = f x b g (Just x) (Just y) = f x y combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm) where merge [] [] = [] merge ((x,a):xs) [] = (x, f (Just a) Nothing) : merge xs [] merge [] ((y,b):ys) = (y, f Nothing (Just b)) : merge [] ys merge xs0@((x,a):xs) ys0@((y,b):ys) = case compare x y of LT -> (x, f (Just a) Nothing ) : merge xs ys0 EQ -> (x, f (Just a) (Just b)) : merge xs ys GT -> (y, f Nothing (Just b)) : merge xs0 ysdiagrams-lib-0.7.1.1/src/Diagrams/CubicSpline.hs0000644000000000000000000000556412221314077017462 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 Diagrams.Core import Diagrams.Core.Points import Diagrams.CubicSpline.Internal import Diagrams.Located (at) import Diagrams.Located import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) -- for e.g. the Fractional (Double, Double) instance import Data.NumInstances.Tuple () import Control.Newtype import Data.Semigroup import Data.VectorSpace -- | Construct a spline path-like thing of cubic segments from a list of -- vertices, with the first vertex as the starting point. The first -- argument specifies whether the path should be closed. -- -- <> -- -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] -- > dot = circle 0.2 # fc blue # lw 0 -- > mkPath closed = position (zip pts (repeat dot)) -- > <> cubicSpline closed pts # lw 0.05 -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) -- > # centerXY # pad 1.1 -- -- For more information, see . cubicSpline :: (TrailLike t, Fractional (V t)) => Bool -> [Point (V t)] -> t cubicSpline c [] = trailLike . closeIf c $ emptyLine `at` origin cubicSpline c ps = flattenBeziers . map f . solveCubicSplineCoefficients c . map unpack $ ps where f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] flattenBeziers bs@((b:_):_) = trailLike . closeIf c $ lineFromSegments (map bez bs) `at` P b bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) closeIf :: (InnerSpace v, OrderedField (Scalar v)) => Bool -> Located (Trail' Line v) -> Located (Trail v) closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) diagrams-lib-0.7.1.1/src/Diagrams/Query.hs0000644000000000000000000000121312221314077016352 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-0.7.1.1/src/Diagrams/Animation.hs0000644000000000000000000001176012221314077017174 0ustar0000000000000000{-# 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 Diagrams.Core import Diagrams.Animation.Active () import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.TrailLike import Diagrams.TwoD.Shapes import Diagrams.TwoD.Types import Data.Active import Data.Semigroup import Control.Applicative ((<$>)) import Data.Foldable (foldMap) import Data.VectorSpace -- | 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 m = Active (QDiagram b v 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 = QAnimation b v 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 :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) => QAnimation b v m -> QAnimation b v 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' :: (Backend b v, OrderedField (Scalar v), InnerSpace v, Monoid' m) => Rational -> QAnimation b v m -> QAnimation b v 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 :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) => QAnimation b R2 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' :: (TrailLike t, Enveloped t, Transformable t, Monoid t, V t ~ R2) => Rational -> QAnimation b R2 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-0.7.1.1/src/Diagrams/Combinators.hs0000644000000000000000000003522112221314077017533 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# 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 , extrudeEnvelope, intrudeEnvelope -- * Binary operations , atop , beneath , beside -- * n-ary operations , appends , position, decorateTrail, decorateLocatedTrail, decoratePath , cat, cat', CatOpts(..), CatMethod(..) ) where import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class import Data.Semigroup import Data.VectorSpace import Diagrams.Core import Diagrams.Located import Diagrams.Path import Diagrams.Segment (Segment (..), straight) import Diagrams.Trail (Trail, trailVertices) import Diagrams.TrailLike (fromOffsets) import Diagrams.Util ------------------------------------------------------------ -- Working with envelopes ------------------------------------------------------------ -- | Use the envelope from some object as the envelope for a -- diagram, in place of the diagram's default envelope. withEnvelope :: (HasLinearMap (V a), Enveloped a, Monoid' m) => a -> QDiagram b (V a) m -> QDiagram b (V a) 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 :: (HasLinearMap (V a), Traced a, OrderedField (Scalar (V a)), InnerSpace (V a), Monoid' m) => a -> QDiagram b (V a) m -> QDiagram b (V a) m withTrace = setTrace . getTrace -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. phantom :: (Backend b (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty -- | @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 :: ( Backend b v , InnerSpace v, OrderedField (Scalar v) , Monoid' m ) => Scalar v -> QDiagram b v m -> QDiagram b v m pad s d = withEnvelope (d # scale s) d -- | @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. strut :: ( Backend b v, InnerSpace v , OrderedField (Scalar v) , Monoid' m ) => v -> QDiagram b v m strut v = mkQD nullPrim env mempty mempty mempty 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 :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => v -> QDiagram b v m -> QDiagram b v 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 :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => v -> QDiagram b v m -> QDiagram b v m intrudeEnvelope = deformEnvelope (-0.5) -- Utility for extrudeEnvelope / intrudeEnvelope deformEnvelope :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m deformEnvelope s v d = setEnvelope (inEnvelope deform $ getEnvelope d) d where deform = Option . fmap deform' . getOption deform' env v' | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v' | otherwise = env v' where dot = v' <.> 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 :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) => QDiagram b v m -> QDiagram b v m -> QDiagram b v 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) => V a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 ------------------------------------------------------------ -- 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'. appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps) -- | Position things absolutely: combine a list of objects -- (e.g. diagrams or paths) by assigning them absolute positions in -- the vector space of the combined object. position :: (HasOrigin a, Monoid' a) => [(Point (V a), a)] -> a position = mconcat . map (uncurry moveTo) -- | Combine a list of diagrams (or paths) by using them to -- \"decorate\" a trail, placing the local origin of one object at -- each successive vertex of the trail. The first vertex of the -- trail is placed at the origin. If the trail and list of objects -- have different lengths, the extra tail of the longer one is -- ignored. decorateTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) => Trail (V a) -> [a] -> a decorateTrail = decorateLocatedTrail . (`at` origin) -- | Combine a list of diagrams (or paths) by using them to -- \"decorate\" a concretely located trail, placing the local origin -- of one object at each successive vertex of the trail. If the -- trail and list of objects have different lengths, the extra tail -- of the longer one is ignored. decorateLocatedTrail :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) => Located (Trail (V a)) -> [a] -> a decorateLocatedTrail t = position . zip (trailVertices t) -- | Combine a list of diagrams (or paths) by using them to -- \"decorate\" a path, placing the local origin of one object at -- each successive vertex of the path. If the path and list of objects -- have different lengths, the extra tail of the longer one is -- ignored. decoratePath :: (InnerSpace (V a), OrderedField (Scalar (V a)), HasOrigin a, Monoid' a) => Path (V a) -> [a] -> a decoratePath p = position . zip (concat $ pathVertices p) -- | 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 v = CatOpts { catMethod :: CatMethod -- ^ Which 'CatMethod' should be used: -- normal catenation (default), or -- distribution? , sep :: Scalar v -- ^ How much separation should be used -- between successive diagrams -- (default: 0)? When @catMethod = -- Cat@, this is the distance between -- /envelopes/; when @catMethod = -- Distrib@, this is the distance -- between /origins/. , catOptsvProxy__ :: Proxy v -- ^ This field exists solely to aid type inference; -- please ignore it. } -- The reason the proxy field is necessary is that without it, -- altering the sep field could theoretically change the type of a -- CatOpts record. This causes problems when writing an expression -- like @with { sep = 10 }@, because knowing the type of the whole -- 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. instance Num (Scalar v) => Default (CatOpts v) 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 :: ( Juxtaposable a, Monoid' a, HasOrigin a , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> [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' :: ( Juxtaposable a, Monoid' a, HasOrigin a , InnerSpace (V a), OrderedField (Scalar (V a)) ) => V a -> CatOpts (V a) -> [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 *^ normalized (negateV v) cat' v (CatOpts { catMethod = Distrib, sep = s }) = position . zip (iterate (.+^ (s *^ normalized v)) origin) diagrams-lib-0.7.1.1/src/Diagrams/TrailLike.hs0000644000000000000000000001406412221314077017135 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 Data.AffineSpace ((.-.)) import Data.VectorSpace import Diagrams.Core import Diagrams.Located import Diagrams.Segment import Diagrams.Trail ------------------------------------------------------------ -- 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 (InnerSpace (V t), OrderedField (Scalar (V t))) => TrailLike t where trailLike :: Located (Trail (V 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 'trailVertices'. instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike [Point v] where trailLike = trailVertices -- | Lines are trail-like. If given a 'Trail' which contains a loop, -- the loop will be cut with 'cutLoop'. The location is ignored. instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Line v) 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 (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail' Loop v) where trailLike = withTrail glueLine id . unLoc -- | 'Trail's are trail-like; the location is simply ignored. instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Trail v) where trailLike = unLoc -- | Translationally invariant things are trail-like as long as the -- underlying type is. instance TrailLike t => TrailLike (TransInv t) where trailLike = TransInv . 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. -- -- XXX example/picture fromSegments :: TrailLike t => [Segment Closed (V 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)] -> t fromLocSegments = trailLike . mapLoc trailFromSegments -- | Construct a trail-like thing of linear segments from a list -- of offsets, with the origin as the location. -- -- XXX example/picture fromOffsets :: TrailLike t => [V t] -> t fromOffsets = trailLike . (`at` origin) . trailFromOffsets -- | Construct a trail-like thing of linear segments from a located -- list of offsets. fromLocOffsets :: (V (V t) ~ V t, TrailLike t) => Located [V t] -> 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. -- -- XXX example/picture fromVertices :: TrailLike t => [Point (V t)] -> t fromVertices [] = trailLike (emptyTrail `at` origin) fromVertices ps@(p:_) = trailLike (trailFromSegments (segmentsFromVertices ps) `at` p) segmentsFromVertices :: AdditiveGroup v => [Point v] -> [Segment Closed v] segmentsFromVertices [] = [] segmentsFromVertices vvs@(_:vs) = map straight (zipWith (flip (.-.)) vvs vs) -- | Create a linear trail between two given points. (~~) :: TrailLike t => Point (V t) -> Point (V t) -> t p1 ~~ p2 = fromVertices [p1, p2] -- | Given a concretely located trail, \"explode\" it by turning each -- segment into its own separate trail. Useful for (say) applying a -- different style to each segment. explodeTrail :: (VectorSpace (V t), TrailLike t) => Located (Trail (V t)) -> [t] explodeTrail = map (mkTrail . fromFixedSeg) . fixTrail where mkTrail = trailLike . mapLoc (trailFromSegments . (:[])) diagrams-lib-0.7.1.1/src/Diagrams/TwoD.hs0000644000000000000000000001364612221314077016137 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD -- Copyright : (c) 2011 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.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.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.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 R2, r2, unr2 , P2, p2, unp2 , T2 , unitX, unitY, unit_X, unit_Y , direction, fromDirection, e -- * Angles , tau , Angle(..) , Turn(..), CircleFrac, Rad(..), Deg(..) , fullCircle, convertAngle -- * Paths -- ** Stroking , stroke, stroke', strokeT, strokeT', strokeLine, strokeLoop , strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule , StrokeOpts(..) -- ** Clipping , clipBy -- * Shapes -- ** Rules , hrule, vrule -- ** Circle-ish things , unitCircle , circle , ellipse , ellipseXY , arc , arc' , arcCW , wedge -- ** General polygons , polygon, polyTrail , PolygonOpts(..), PolyType(..), PolyOrientation(..) -- ** Star polygons , StarOpts(..), star -- ** Regular polygons , regPoly , triangle , eqTriangle , square , pentagon , hexagon , septagon , octagon , nonagon , decagon , hendecagon , dodecagon -- ** Other special polygons , unitSquare , rect -- ** Other shapes , roundedRect, roundedRect' , RoundedRectOpts(..) -- * Text , text, topLeftText, alignedText, baselineText , font, fontSize, italic, oblique, bold -- * Images , image -- * Transformations -- ** Rotation , rotation, rotate, rotateBy , rotationAbout, rotateAbout -- ** 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 -- * Combinators -- ** Combining multiple diagrams , (===), (|||), atAngle , hcat, hcat' , vcat, vcat' -- ** Spacing and envelopes , strutX, strutY , padX, padY , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop , view -- ** Background , boundingRect, bg -- * Alignment , alignL, alignR, alignT, alignB, alignTL, alignTR, alignBL, alignBR , alignX, alignY , centerX, centerY, centerXY -- * Size -- ** Computing size , width, height, size2D, sizeSpec2D , extentX, extentY, center2D -- ** Specifying size , SizeSpec2D(..) , mkSizeSpec -- ** Adjusting size , sized, sizedAs -- * Visual aids for understanding the internal model , showOrigin , showOrigin' , OriginOpts(..) , showLabels ) where import Diagrams.TwoD.Align import Diagrams.TwoD.Arc import Diagrams.TwoD.Combinators 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-0.7.1.1/src/Diagrams/Solve.hs0000644000000000000000000001005512221314077016341 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Solve -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Exact solving of low-degree (n <= 3) polynomials. -- ----------------------------------------------------------------------------- module Diagrams.Solve ( quadForm , cubForm ) where import Data.List (maximumBy) import Data.Ord (comparing) import Diagrams.Util (tau) ------------------------------------------------------------ -- Quadratic formula ------------------------------------------------------------ -- | The quadratic formula. quadForm :: (Floating d, Ord d) => d -> d -> d -> [d] quadForm a b c -- There are infinitely many solutions in this case, -- so arbitrarily return 0 | a == 0 && b == 0 && c == 0 = [0] -- c /= 0 | a == 0 && b == 0 = [] -- linear | a == 0 = [-c/b] -- no real solutions | d < 0 = [] -- ax^2 + c = 0 | b == 0 = [sqrt (-c/a), -sqrt (-c/a)] -- multiplicity 2 solution | d == 0 = [-b/(2*a)] -- see http://www.mpi-hd.mpg.de/astrophysik/HEA/internal/Numerical_Recipes/f5-6.pdf | otherwise = [q/a, c/q] where d = b*b - 4*a*c q = -1/2*(b + signum b * sqrt d) quadForm_prop :: Double -> Double -> Double -> Bool quadForm_prop a b c = all (aboutZero . eval) (quadForm a b c) where eval x = a*x*x + b*x + c aboutZero x = abs x < tolerance tolerance = 1e-10 ------------------------------------------------------------ -- Cubic formula ------------------------------------------------------------ -- See http://en.wikipedia.org/wiki/Cubic_formula#General_formula_of_roots -- | Solve the cubic equation ax^3 + bx^2 + cx + d = 0, returning a -- list of all real roots. cubForm :: (Floating d, Ord d) => d -> d -> d -> d -> [d] cubForm a b c d | aboutZero a = quadForm b c d -- three real roots, use trig method to avoid complex numbers | delta > 0 = map trig [0,1,2] -- one real root of multiplicity 3 | delta == 0 && disc == 0 = [ -b/(3*a) ] -- two real roots, one of multiplicity 2 | delta == 0 && disc /= 0 = [ (b*c - 9*a*d)/(2*disc) , (9*a*a*d - 4*a*b*c + b*b*b)/(a * disc) ] -- one real root (and two complex) | otherwise = [-b/(3*a) - cc/(3*a) + disc/(3*a*cc)] where delta = 18*a*b*c*d - 4*b*b*b*d + b*b*c*c - 4*a*c*c*c - 27*a*a*d*d disc = 3*a*c - b*b qq = sqrt(-27*a*a*delta) qq' | aboutZero disc = maximumBy (comparing (abs . (+xx))) [qq, -qq] | otherwise = qq cc = cubert (1/2*(qq' + xx)) xx = 2*b*b*b - 9*a*b*c + 27*a*a*d p = disc/(3*a*a) q = xx/(27*a*a*a) trig k = 2 * sqrt(-p/3) * cos(1/3*acos(3*q/(2*p)*sqrt(-3/p)) - k*tau/3) - b/(3*a) cubert x | x < 0 = -((-x)**(1/3)) | otherwise = x**(1/3) aboutZero x = abs x < toler toler = 1e-10 cubForm_prop :: Double -> Double -> Double -> Double -> Bool cubForm_prop a b c d = all (aboutZero . eval) (cubForm a b c d) where eval x = a*x*x*x + b*x*x + c*x + d aboutZero x = abs x < tolerance tolerance = 1e-5 -- Basically, however large you set the tolerance it seems -- that quickcheck can always come up with examples where -- the returned solutions evaluate to something near zero -- but larger than the tolerance (but it takes it more -- tries the larger you set the tolerance). Wonder if this -- is an inherent limitation or (more likely) a problem -- with numerical stability. If this turns out to be an -- issue in practice we could, say, use the solutions -- generated here as very good guesses to a numerical -- solver which can give us a more precise answer?diagrams-lib-0.7.1.1/src/Diagrams/Attributes.hs0000644000000000000000000003123112221314077017376 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , ExistentialQuantification , GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes -- Copyright : (c) 2011 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 ( -- * Color -- $color Color(..), SomeColor(..) -- ** Line color , LineColor, getLineColor, lineColor, lineColorA, lc, lcA -- ** Fill color , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity -- ** Converting colors , toRGBAUsingSpace, colorToSRGBA, colorToRGBA -- * Lines -- ** Width , LineWidth, getLineWidth, lineWidth, lineWidthA, lw -- ** Cap style , LineCap(..), LineCapA, getLineCap, lineCap -- ** Join style , LineJoin(..), LineJoinA, getLineJoin, lineJoin -- ** Miter limit , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA -- ** Dashing , Dashing(..), DashingA, getDashing, dashing ) where import Diagrams.Core import Data.Default.Class import Data.Colour import Data.Colour.RGBSpace import Data.Colour.SRGB (sRGBSpace) import Data.Typeable import Data.Monoid.Recommend import Data.Semigroup ------------------------------------------------------------ -- 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 -- | An existential wrapper for instances of the 'Color' class. data SomeColor = forall c. Color c => SomeColor c deriving Typeable -- | The color with which lines (strokes) are drawn. Note that child -- colors always override parent colors; that is, @'lineColor' c1 -- . 'lineColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. -- More precisely, the semigroup structure on line color attributes -- is that of 'Last'. newtype LineColor = LineColor (Last SomeColor) deriving (Typeable, Semigroup) instance AttributeClass LineColor instance Default LineColor where def = LineColor (Last (SomeColor black)) getLineColor :: LineColor -> SomeColor getLineColor (LineColor (Last c)) = c -- | Set the line (stroke) color. This function is polymorphic in the -- color type (so it can be used with either 'Colour' or -- 'AlphaColour'), but this can sometimes create problems for type -- inference, so the 'lc' and 'lcA' variants are provided with more -- concrete types. lineColor :: (Color c, HasStyle a) => c -> a -> a lineColor = applyAttr . LineColor . Last . SomeColor -- | Apply a 'lineColor' attribute. lineColorA :: HasStyle a => LineColor -> a -> a lineColorA = applyAttr -- | A synonym for 'lineColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). lc :: HasStyle a => Colour Double -> a -> a lc = lineColor -- | A synonym for 'lineColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). lcA :: HasStyle a => AlphaColour Double -> a -> a lcA = lineColor -- | The color with which shapes are filled. Note that child -- colors always override parent colors; that is, @'fillColor' c1 -- . 'fillColor' c2 $ d@ is equivalent to @'lineColor' c2 $ d@. -- More precisely, the semigroup structure on fill color attributes -- is that of 'Last'. newtype FillColor = FillColor (Recommend (Last SomeColor)) deriving (Typeable, Semigroup) instance AttributeClass FillColor -- | Set the fill color. This function is polymorphic in the color -- type (so it can be used with either 'Colour' or 'AlphaColour'), -- but this can sometimes create problems for type inference, so the -- 'fc' and 'fcA' variants are provided with more concrete types. fillColor :: (Color c, HasStyle a) => c -> a -> a fillColor = applyAttr . FillColor . Commit . Last . SomeColor -- | Set a \"recommended\" fill color, to be used only if no explicit -- calls to 'fillColor' (or 'fc', or 'fcA') are used. recommendFillColor :: (Color c, HasStyle a) => c -> a -> a recommendFillColor = applyAttr . FillColor . Recommend . Last . SomeColor getFillColor :: FillColor -> SomeColor getFillColor (FillColor c) = getLast . getRecommend $ c -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). fc :: HasStyle a => Colour Double -> a -> a fc = fillColor -- | A synonym for 'fillColor', specialized to @'AlphaColour' Double@ -- (i.e. colors with transparency). fcA :: HasStyle a => AlphaColour Double -> a -> a fcA = fillColor instance (Floating a, Real a) => Color (Colour a) where toAlphaColour = opaque . colourConvert instance (Floating a, Real a) => Color (AlphaColour a) where toAlphaColour = alphaColourConvert instance Color SomeColor where toAlphaColour (SomeColor c) = toAlphaColour c instance Color LineColor where toAlphaColour (LineColor (Last c)) = toAlphaColour c instance Color FillColor where toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c -- | Convert to an RGB space while preserving the alpha channel. toRGBAUsingSpace :: Color c => RGBSpace Double -> c -> (Double, Double, Double, Double) toRGBAUsingSpace s col = (r,g,b,a) where c' = toAlphaColour col c = toRGBUsingSpace s (alphaToColour c') a = alphaChannel c' r = channelRed c g = channelGreen c b = channelBlue c -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) colorToSRGBA = toRGBAUsingSpace sRGBSpace colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} alphaToColour :: (Floating a, Ord a, Fractional 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 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 ------------------------------------------------------------ -- Lines and stuff ------------------------------------- ------------------------------------------------------------ -- | The width of lines. By default, the line width is measured with -- respect to the /final/ coordinate system of a rendered diagram, -- as opposed to the local coordinate systems in effect at the time -- the line width was set for various subdiagrams. This is so that -- it is easy to combine a variety of shapes (some created by -- scaling) and have them all drawn using a consistent line width. -- However, sometimes it is desirable for scaling to affect line -- width; the 'freeze' operation is provided for this purpose. The -- line width of frozen diagrams is affected by transformations. -- -- Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth = LineWidth (Last Double) deriving (Typeable, Semigroup) instance AttributeClass LineWidth instance Default LineWidth where def = LineWidth (Last 0.01) getLineWidth :: LineWidth -> Double getLineWidth (LineWidth (Last w)) = w -- | Set the line (stroke) width. lineWidth :: HasStyle a => Double -> a -> a lineWidth = applyAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. lineWidthA :: HasStyle a => LineWidth -> a -> a lineWidthA = applyAttr -- | A convenient synonym for 'lineWidth'. lw :: HasStyle a => Double -> a -> a lw = lineWidth -- | What sort of shape should be placed at the endpoints of lines? data LineCap = LineCapButt -- ^ Lines end precisely at their endpoints. | LineCapRound -- ^ Lines are capped with semicircles -- centered on endpoints. | LineCapSquare -- ^ Lines are capped with a squares -- centered on endpoints. deriving (Eq,Show,Typeable) newtype LineCapA = LineCapA (Last LineCap) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineCapA instance Default LineCap where def = LineCapButt getLineCap :: LineCapA -> LineCap getLineCap (LineCapA (Last c)) = c -- | Set the line end cap attribute. lineCap :: HasStyle a => LineCap -> a -> a lineCap = applyAttr . LineCapA . Last -- | 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,Show,Typeable) newtype LineJoinA = LineJoinA (Last LineJoin) deriving (Typeable, Semigroup, Eq) instance AttributeClass LineJoinA instance Default LineJoin where def = LineJoinMiter getLineJoin :: LineJoinA -> LineJoin getLineJoin (LineJoinA (Last j)) = j -- | Set the segment join style. lineJoin :: HasStyle a => LineJoin -> a -> a lineJoin = applyAttr . LineJoinA . Last -- | Miter limit attribute affecting the 'LineJoinMiter' joins. -- For some backends this value may have additional effects. newtype LineMiterLimit = LineMiterLimit (Last Double) deriving (Typeable, Semigroup) instance AttributeClass LineMiterLimit 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 -- | Create lines that are dashing... er, dashed. data Dashing = Dashing [Double] Double deriving (Typeable, Eq) newtype DashingA = DashingA (Last Dashing) deriving (Typeable, Semigroup, Eq) instance AttributeClass DashingA getDashing :: DashingA -> Dashing getDashing (DashingA (Last d)) = d -- | Set the line dashing style. dashing :: HasStyle a => [Double] -- ^ A list specifying alternate lengths of on -- and off portions of the stroke. The empty -- list indicates no dashing. -> Double -- ^ An offset into the dash pattern at which the -- stroke should start. -> a -> a dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) diagrams-lib-0.7.1.1/src/Diagrams/Names.hs0000644000000000000000000000346512221314077016323 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 , withName, withNameAll, withNames ) where import Data.Semigroup import Data.VectorSpace import Diagrams.Core (HasLinearMap, OrderedField, Point) import Diagrams.Core.Names import Diagrams.Core.Types -- | Attach an atomic name to a diagram. named :: ( IsName n , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => n -> QDiagram b v m -> QDiagram b v 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 n , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Semigroup m) => (QDiagram b v m -> Point v) -> n -> QDiagram b v m -> QDiagram b v m namePoint p = nameSub (subPoint . p) diagrams-lib-0.7.1.1/src/Diagrams/Util.hs0000644000000000000000000000735012221314077016172 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Util -- Copyright : (c) 2011 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 -- * Internal utilities , Proxy(..) , foldB ) where import Data.Default.Class import Data.Monoid -- | 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 ($) -- | @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 -- | A value of @Proxy a@ carries no information; it's used only to -- fix the type @a@. data Proxy a = Proxy -- | Given an associative binary operation and a default value to use -- in the case of an empty list, perform a /balanced/ fold over a -- 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 diagrams-lib-0.7.1.1/src/Diagrams/Prelude.hs0000644000000000000000000001102712221314077016651 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Prelude -- Copyright : (c) 2011 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 ( -- * 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 -- | 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 -- | 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 -- | Convenient definitions and utilities for working with -- good old-fashioned, axis-aligned bounding boxes. , module Diagrams.BoundingBox -- | Giving names to subdiagrams and later retrieving -- subdiagrams by name. , module Diagrams.Names -- | 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 -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional -- diagrams. , module Diagrams.TwoD -- | Tools for making animations. , module Diagrams.Animation -- | Various utility definitions. , module Diagrams.Util -- * Convenience re-exports -- | For representing and operating on colors. , module Data.Colour -- | A large list of color names. , module Data.Colour.Names -- | 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 Data.VectorSpace -- | For computing with points and vectors. , module Data.AffineSpace -- | For working with 'Active' (i.e. animated) things. , module Data.Active , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where import Diagrams.Core import Diagrams.Align import Diagrams.Animation import Diagrams.Attributes import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline import Diagrams.Envelope import Diagrams.Located import Diagrams.Names import Diagrams.Parametric import Diagrams.Path import Diagrams.Points import Diagrams.Query import Diagrams.Segment import Diagrams.Trace import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform import Diagrams.TwoD import Diagrams.Util import Control.Applicative import Data.Active import Data.AffineSpace import Data.Colour hiding (AffineSpace (..), atop) import Data.Colour.Names import Data.Semigroup import Data.VectorSpace hiding (Sum (..)) diagrams-lib-0.7.1.1/src/Diagrams/Path.hs0000644000000000000000000001705312221314077016152 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# 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(..) -- * Constructing paths -- $construct , pathFromTrail , pathFromTrailAt , pathFromLocTrail -- * Eliminating paths , pathVertices , pathOffsets , pathCentroid , fixPath -- * Modifying paths , scalePath , reversePath -- * Miscellaneous , explodePath , partitionPath ) where import Diagrams.Align import Diagrams.Core import Diagrams.Core.Points import Diagrams.Located import Diagrams.Points import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.Transform import Control.Arrow (first, second, (***)) import Control.Newtype hiding (under) import Data.AffineSpace import qualified Data.Foldable as F import Data.List (mapAccumL, partition) import Data.Semigroup import Data.VectorSpace ------------------------------------------------------------ -- 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 = Path { pathTrails :: [Located (Trail v)] } deriving (Semigroup, Monoid) deriving instance Show v => Show (Path v) deriving instance Eq v => Eq (Path v) deriving instance Ord v => Ord (Path v) type instance V (Path v) = v instance Newtype (Path v) [Located (Trail v)] where pack = Path unpack = pathTrails instance VectorSpace v => HasOrigin (Path v) where moveOriginTo = over Path . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a -- singleton path. instance (InnerSpace v, OrderedField (Scalar v)) => TrailLike (Path v) where trailLike = Path . (:[]) -- See Note [Transforming paths] instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Path v) where transform = over Path . map . transform {- ~~~~ Note [Transforming paths] Careful! It's tempting to just define > transform = fmap . transform but that doesn't take into account the fact that some of the v's are inside Points and hence ought to be translated. -} instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => IsPrim (Path v) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where getEnvelope = F.foldMap trailEnvelope . pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 where trailEnvelope :: Located (Trail v) -> Envelope v trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Path v) where juxtapose = juxtaposeDefault instance (InnerSpace v, OrderedField (Scalar v)) => Alignable (Path v) where alignBy = alignByDefault instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Renderable (Path v) NullBackend where render _ _ = mempty ------------------------------------------------------------ -- Constructing paths ------------------------------------ ------------------------------------------------------------ -- $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 :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Path v pathFromTrail = trailLike . (`at` origin) -- | Convert a trail to a path with a particular starting point. pathFromTrailAt :: (InnerSpace v, OrderedField (Scalar v)) => Trail v -> Point v -> Path v 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 :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> Path v pathFromLocTrail = trailLike ------------------------------------------------------------ -- Eliminating paths ------------------------------------- ------------------------------------------------------------ -- | Extract the vertices of a path, resulting in a separate list of -- vertices for each component trail (see 'trailVertices'). pathVertices :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[Point v]] pathVertices = map trailVertices . pathTrails -- | Compute the total offset of each trail comprising a path (see 'trailOffset'). pathOffsets :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [v] pathOffsets = map (trailOffset . unLoc) . pathTrails -- | Compute the /centroid/ of a path (/i.e./ the average location of -- its vertices). pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v pathCentroid = centroid . concat . pathVertices -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] fixPath = map fixTrail . unpack -- | \"Explode\" a path by exploding every component trail (see -- 'explodeTrail'). explodePath :: (VectorSpace (V t), TrailLike t) => Path (V t) -> [[t]] explodePath = map explodeTrail . pathTrails -- | Partition a path into two paths based on a predicate on trails: -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) partitionPath p = (pack *** pack) . partition p . unpack ------------------------------------------------------------ -- Modifying paths --------------------------------------- ------------------------------------------------------------ -- | Scale a path using its centroid (see 'pathCentroid') as the base -- point for the scale. scalePath :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Scalar v -> Path v -> Path v scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v reversePath = (over Path . map) reverseLocTrail diagrams-lib-0.7.1.1/src/Diagrams/Transform.hs0000644000000000000000000000350012221314077017221 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Diagrams.Transform -- Copyright : (c) 2011-13 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, under -- * The HasOrigin class , HasOrigin(..), moveOriginBy ) where import Data.Semigroup import Diagrams.Core -- | Conjugate one transformation by another. @conjugate t1 t2@ is the -- transformation which performs first @t1@, then @t2@, then the -- inverse of @t1@. conjugate :: HasLinearMap v => Transformation v -> Transformation v -> Transformation v conjugate t1 t2 = inv t1 <> t2 <> t1 -- | Carry out some transformation \"under\" another one: @f ``under`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For -- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- -- Note that -- -- @ -- (transform t2) `under` t1 == transform (conjugate t1 t2) -- @ -- -- for all transformations @t1@ and @t2@. under :: Transformable a => (a -> a) -> Transformation (V a) -> a -> a f `under` t = transform (inv t) . f . transform t diagrams-lib-0.7.1.1/src/Diagrams/Coordinates.hs0000644000000000000000000000564112221314077017530 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- 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. -- -- NOTE: to avoid clashing with the '(&)' operator from the @lens@ -- package, this module is not re-exported by "Diagrams.Prelude". To -- make use of the contents of this module, you must explicitly import -- it. -- ----------------------------------------------------------------------------- module Diagrams.Coordinates ( (:&)(..), Coordinates(..) ) where -- | A pair of values, with a convenient infix (left-associative) -- data constructor. data a :& b = a :& b deriving (Eq, Ord, Show) infixl 7 :& -- | 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 :: R3 -- @ -- -- Note that @&@ is left-associative. (&) :: PrevDim c -> FinalCoord c -> c -- | Decompose a value of type @c@ into its constituent coordinates, -- stored in a nested @(:&)@ structure. coords :: c -> Decomposition c infixl 7 & -- 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 diagrams-lib-0.7.1.1/src/Diagrams/Envelope.hs0000644000000000000000000000165112221314077017030 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-0.7.1.1/src/Diagrams/Located.hs0000644000000000000000000001350112221314077016623 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Located -- Copyright : (c) 2013 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, unLoc, loc, mapLoc ) where import Data.AffineSpace import Data.VectorSpace import Diagrams.Core import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Parametric -- for GHC 7.4 type family bug -- | \"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) -- ^ 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) -> 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), 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 :: (V a ~ V b) => (a -> b) -> Located a -> Located b mapLoc f (Loc p a) = Loc p (f a) deriving instance (Eq (V a), Eq a ) => Eq (Located a) deriving instance (Ord (V a), Ord a ) => Ord (Located a) deriving instance (Show (V a), Show a) => Show (Located a) type instance V (Located a) = V 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 VectorSpace (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 Transformable a => Transformable (Located a) where transform t@(Transformation t1 t2 _) (Loc p a) = Loc (transform t p) (transform (Transformation t1 t2 zeroV) 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 => 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) = Located (Codomain a) instance (V a ~ V (Codomain a), Parametric a) => Parametric (Located a) where (Loc x a) `atParam` p = Loc x (a `atParam` p) instance DomainBounds a => DomainBounds (Located a) where domainLower (Loc _ a) = domainLower a domainUpper (Loc _ a) = domainUpper a instance (V a ~ V (Codomain a), EndValues a) => EndValues (Located a) instance ( Codomain a ~ V a, Fractional (Scalar (V a)), AdditiveGroup (V a) , Sectionable a, Parametric a ) => Sectionable (Located a) where splitAtParam (Loc x a) p = (Loc x a1, Loc (x .+^ (a `atParam` p)) a2) where (a1,a2) = splitAtParam a p instance (HasArcLength a, Fractional (Scalar (V a)), V a ~ V (Codomain a)) => HasArcLength (Located a) where arcLengthBounded eps (Loc _ a) = arcLengthBounded eps a arcLengthToParam eps (Loc _ a) l = arcLengthToParam eps a l diagrams-lib-0.7.1.1/src/Diagrams/Backend/0000755000000000000000000000000012221314077016243 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/Backend/Show.hs0000644000000000000000000000464212221314077017525 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Show -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- A simple Show-based diagrams backend, for testing purposes. -- ----------------------------------------------------------------------------- module Diagrams.Backend.Show where import Diagrams.Core.Transform (onBasis) import Diagrams.Prelude import Diagrams.Trail import Data.Basis import Text.PrettyPrint (Doc, empty, hsep, parens, ($+$)) import qualified Text.PrettyPrint as PP import Data.List (transpose) -- | Token for identifying this backend. data ShowBackend = ShowBackend instance HasLinearMap v => Backend ShowBackend v where data Render ShowBackend v = SR Doc type Result ShowBackend v = String data Options ShowBackend v = SBOpt withStyle _ _ _ r = r -- XXX FIXME doRender _ _ (SR r) = PP.render r instance Monoid (Render ShowBackend v) where mempty = SR empty (SR d1) `mappend` (SR d2) = SR (d1 $+$ d2) renderTransf :: forall v. (Num (Scalar v), HasLinearMap v, Show (Scalar v)) => Transformation v -> Doc renderTransf t = renderMat mat where vmat :: [v] (vmat, _) = onBasis t mat :: [[Scalar v]] mat = map decompV vmat -- mat' :: [[Scalar v]] -- mat' = map (++[0]) mat ++ [decompV tr ++ [1]] decompV = map snd . decompose renderMat :: Show a => [[a]] -> Doc renderMat = PP.vcat . map renderRow . transpose where renderRow = parens . hsep . map (PP.text . show) instance (Show v, HasLinearMap v) => Renderable (Segment o v) ShowBackend where render _ s = SR $ PP.text (show s) instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Trail v) ShowBackend where render _ t = SR $ PP.text (show t) instance (Show v, OrderedField (Scalar v), InnerSpace v, HasLinearMap v) => Renderable (Path v) ShowBackend where render _ p = SR $ PP.text (show p) diagrams-lib-0.7.1.1/src/Diagrams/ThreeD/0000755000000000000000000000000012221314077016067 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/ThreeD/Types.hs0000644000000000000000000000474612221314077017542 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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, r3, unr3 , P3, p3, unp3 , T3 ) where import Diagrams.Coordinates import Diagrams.TwoD.Types import Diagrams.Core import Control.Newtype import Data.Basis import Data.VectorSpace ------------------------------------------------------------ -- 3D Euclidean space -- | The three-dimensional Euclidean vector space R^3. newtype R3 = R3 { unR3 :: (Double, Double, Double) } deriving (AdditiveGroup, Eq, Ord, Show, Read) instance Newtype R3 (Double, Double, Double) where pack = R3 unpack = unR3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 r3 = pack -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) unr3 = unpack type instance V R3 = R3 instance VectorSpace R3 where type Scalar R3 = Double (*^) = over R3 . (*^) instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) basisValue = R3 . basisValue decompose = decompose . unR3 decompose' = decompose' . unR3 instance InnerSpace R3 where (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 instance Coordinates R3 where type FinalCoord R3 = Double type PrevDim R3 = R2 type Decomposition R3 = Double :& Double :& Double (coords -> x :& y) & z = r3 (x,y,z) coords (unR3 -> (x,y,z)) = x :& y :& z -- | Points in R^3. type P3 = Point R3 -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 p3 = pack . pack -- | Convert a 2D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) unp3 = unpack . unpack -- | Transformations in R^3. type T3 = Transformation R3 instance Transformable R3 where transform = apply diagrams-lib-0.7.1.1/src/Diagrams/ThreeD/Shapes.hs0000644000000000000000000000307312221314077017651 0ustar0000000000000000{-# LANGUAGE TypeFamilies , FlexibleContexts , MultiParamTypeClasses , ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 ) where import Prelude hiding (minimum) import Data.Semigroup import Data.AffineSpace import Data.Monoid.Inf (minimum) import Data.VectorSpace import Diagrams.Core import Diagrams.ThreeD.Types import Diagrams.Solve data Ellipsoid = Ellipsoid T3 type instance V Ellipsoid = R3 instance Transformable Ellipsoid where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) instance IsPrim Ellipsoid instance Renderable Ellipsoid NullBackend where render _ _ = mempty sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) (mkTrace sphereTrace) mempty (Query sphereQuery) where sphereEnv v = 1 / magnitude v sphereTrace p v = minimum (quadForm a b c) where a = v <.> v b = 2 *^ p' <.> v c = p' <.> p' - 1 p' = p .-. origin sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 diagrams-lib-0.7.1.1/src/Diagrams/TwoD/0000755000000000000000000000000012221314077015571 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Segment.hs0000644000000000000000000000613512221314077017534 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- 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 where import Control.Applicative (liftA2) import Data.AffineSpace import Data.Monoid.Inf hiding (minimum) import Data.VectorSpace import Diagrams.Core import Diagrams.Core.Trace import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment import Diagrams.Solve import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Util instance Traced (Segment Closed R2) where getTrace = getTrace . mkFixedSeg . (`at` origin) instance Traced (FixedSegment R2) where {- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of intersection in 2D is given by t_i = (v_(1-i)^ . (p1 - p0)) / (v1^ . v0) where v^ denotes the perpendicular to v, i.e. v rotated by -tau/4. This can be derived by starting with the parametric equation p0 + v0 t0 = p1 + v1 t1 and rearranging to get the matrix equation [v0 -v1] [ t0 ] = (p1 - p0) [ t1 ] Working out the product of the inverse of [v0 -v1] with (p1 - p0) results in the above formulas for t_i. -} getTrace (FLinear p0 p0') = mkTrace $ \p1 v1 -> let v0 = p0' .-. p0 det = perp v1 <.> v0 perp v = rotateBy (-1/4) v p = p1 .-. p0 t0 = (perp v1 <.> p) / det t1 = (perp v0 <.> p) / det in if det == 0 || t0 < 0 || t0 > 1 then Infinity else Finite t1 {- To do intersection of a line with a cubic Bezier, we first rotate and scale everything so that the line has parameters (origin, unitX); then we find the intersection(s) of the Bezier with the x-axis. XXX could we speed this up by first checking whether all the control point y-coordinates lie on the same side of the x-axis (if so, there can't possibly be any intersections)? Need to set up some benchmarks. -} getTrace bez@(FCubic {}) = mkTrace $ \p1 v1 -> let bez'@(FCubic x1 c1 c2 x2) = bez # moveOriginTo p1 # rotateBy (negate (direction v1)) # scale (1/magnitude v1) [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] a = -y0 + 3*y1 - 3*y2 + y3 b = 3*y0 - 6*y1 + 3*y2 c = -3*y0 + 3*y1 d = y0 ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d) xs = map (fst . unp2 . atParam bez') ts in case xs of [] -> Infinity _ -> Finite (minimum xs) diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Curvature.hs0000644000000000000000000001440412221314077020110 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 Data.AffineSpace import Data.Monoid.Inf import Data.VectorSpace import Control.Arrow (first, second) import Control.Monad (join) import Diagrams.Core import Diagrams.Segment import Diagrams.TwoD.Types import Diagrams.TwoD.Vector -- | Curvature measures how curved the segment is at a point. One intuition -- for the concept is how much you would turn the wheel when driving a car -- 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 = Cubic (12 & 0) (8 & 10) (OffsetClosed (20 & 8)) -- > -- > curveA = lw 0.1 . stroke . fromSegments $ [segmentA] -- > -- > diagramA = pad 1.1 . centerXY $ curveA -- > -- > diagramPos = diagramWithRadius 0.2 -- > -- > diagramZero = diagramWithRadius 0.5 -- > -- > diagramNeg = diagramWithRadius 0.8 -- > -- > diagramWithRadius t = pad 1.1 . centerXY -- > $ curveA -- > <> showCurvature segmentA t -- > # withEnvelope (curveA :: D R2) -- > # lw 0.05 # lc red -- > -- > showCurvature bez@(Cubic b c (OffsetClosed d)) t -- > | v == 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 -- > <> stroke (origin ~~ (origin .+^ vpr))) -- > # moveTo (origin .+^ atParam bez t) -- > where -- > vpr = r2 (normalized vp ^* r) -- > -- curvature :: Segment Closed R2 -- ^ Segment to measure on. -> Double -- ^ Parameter to measure at. -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents -- infinite curvature or zero radius of curvature. curvature s = toPosInf . second sqrt . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | 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 :: Segment Closed R2 -> Double -> PosInf Double squaredCurvature s = toPosInf . first (join (*)) . curvaturePair (fmap unr2 s) -- TODO: Use the generalized unr2 -- | Reciprocal of @curvature@. radiusOfCurvature :: Segment Closed R2 -- ^ Segment to measure on. -> Double -- ^ Parameter to measure at. -> PosInf Double -- ^ Result is a @PosInf@ value where @PosInfty@ represents -- infinite radius of curvature or zero curvature. radiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . second sqrt . curvaturePair (fmap unr2 s) -- | Reciprocal of @squaredCurvature@ squaredRadiusOfCurvature :: Segment Closed R2 -> Double -> PosInf Double squaredRadiusOfCurvature s = toPosInf . (\(p,q) -> (q,p)) . first (join (*)) . curvaturePair (fmap unr2 s) -- Package up problematic values with the appropriate infinity. toPosInf :: RealFloat a => (a,a) -> PosInf a toPosInf (_,0) = Infinity toPosInf (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 t, Num (Scalar t), VectorSpace t) => Segment Closed (t, t) -> Scalar t -> (t, t) curvaturePair (Linear _) t = (0,1) -- Linear segments always have zero curvature (infinite radius). curvaturePair (Cubic b c (OffsetClosed d)) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) where (x' ,y' ) = firstDerivative b c d t -- TODO: Use the generalized unr2 (x'',y'') = secondDerivative b c d t firstDerivative b c d t = (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d where tt = t * t secondDerivative b c d t = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d -- 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. diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Text.hs0000644000000000000000000002122112221314077017047 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable , GeneralizedNewtypeDeriving , FlexibleContexts , TypeFamilies , MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Text -- Copyright : (c) 2011 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 -- * Text attributes -- ** Font family , Font(..), getFont, font -- ** Font size , FontSize(..), getFontSize, fontSize, fontSizeA -- ** Font slant , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique -- ** Font weight , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold ) where import Diagrams.Attributes import Diagrams.Core import Diagrams.TwoD.Types import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Colour import Data.Default.Class import Data.Typeable ------------------------------------------------------------ -- Text diagrams ------------------------------------------------------------ -- | A text primitive consists of the string contents and alignment -- specification, along with a transformation mapping from the local -- vector space of the text to the vector space in which it is -- embedded. data Text = Text T2 TextAlignment String type instance V Text = R2 instance Transformable Text where transform t (Text tt a s) = Text (t <> tt) a s instance IsPrim Text instance HasOrigin Text where moveOriginTo p = translate (origin .-. p) instance Renderable Text NullBackend where render _ _ = mempty -- | @TextAlignment@ specifies the alignment of the text's origin. data TextAlignment = BaselineText | BoxAlignedText Double Double mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 mkText a t = recommendFillColor black -- See Note [recommendFillColor] $ mkQD (Prim (Text mempty a t)) mempty 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. -- | 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 :: Renderable Text b => String -> Diagram b R2 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 :: Renderable Text b => String -> Diagram b R2 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). -- -- 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 :: Renderable Text b => Double -> Double -> String -> Diagram b R2 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 :: Renderable Text b => String -> Diagram b R2 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) 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 -------------------------------------------------- -- Font size -- | The @FontSize@ attribute specifies the size of a font's -- em-square, measured with respect to the current local vector space. -- Inner @FontSize@ attributes override outer ones. newtype FontSize = FontSize (Last Double) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSize instance Default FontSize where def = FontSize (Last 1) -- | Extract the size from a @FontSize@ attribute. getFontSize :: FontSize -> Double getFontSize (FontSize (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 :: HasStyle a => Double -> a -> a fontSize = applyAttr . FontSize . Last -- | Apply a 'FontSize' attribute. fontSizeA :: HasStyle a => FontSize -> a -> a fontSizeA = applyAttr -------------------------------------------------- -- Font slant data FontSlant = FontSlantNormal | FontSlantItalic | FontSlantOblique deriving (Eq) -- | 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. newtype FontSlantA = FontSlantA (Last FontSlant) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSlantA -- | Extract the font slant from a 'FontSlantA' attribute. getFontSlant :: FontSlantA -> FontSlant getFontSlant (FontSlantA (Last s)) = s -- | 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 . FontSlantA . Last -- | 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 data FontWeight = FontWeightNormal | FontWeightBold deriving (Eq) -- | 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. newtype FontWeightA = FontWeightA (Last FontWeight) deriving (Typeable, Semigroup, Eq) instance AttributeClass FontWeightA -- | Extract the font weight from a 'FontWeightA' attribute. getFontWeight :: FontWeightA -> FontWeight getFontWeight (FontWeightA (Last w)) = w -- | 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 . FontWeightA . Last -- | Set all text using a bold font weight. bold :: HasStyle a => a -> a bold = fontWeight FontWeightBold diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Size.hs0000644000000000000000000001341612221314077017044 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 ( -- * Size and extent of diagrams in R2 -- ** Computing sizes width, height, size2D, sizeSpec2D , extentX, extentY, center2D -- ** Specifying sizes , SizeSpec2D(..) , mkSizeSpec , requiredScaleT, requiredScale -- ** Changing the size of things , sized, sizedAs ) where import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Control.Applicative (liftA2, (<$>)) import Control.Arrow ((&&&), (***)) ------------------------------------------------------------ -- Computing diagram sizes ------------------------------------------------------------ -- | Compute the width of an enveloped object. width :: (Enveloped a, V a ~ R2) => a -> Double width = maybe 0 (negate . uncurry (-)) . extentX -- | Compute the height of an enveloped object. height :: (Enveloped a, V a ~ R2) => a -> Double height = maybe 0 (negate . uncurry (-)) . extentY -- | Compute the width and height of an enveloped object. size2D :: (Enveloped a, V a ~ R2) => a -> (Double, Double) size2D = width &&& height -- | Compute the size of an enveloped object as a 'SizeSpec2D' value. sizeSpec2D :: (Enveloped a, V a ~ R2) => a -> SizeSpec2D sizeSpec2D = uncurry Dims . size2D -- | Compute the absolute x-coordinate range of an enveloped object in -- R2, in the form (lo,hi). Return @Nothing@ for objects with an -- empty envelope. extentX :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) extentX d = (\f -> (-f unit_X, f unitX)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the absolute y-coordinate range of an enveloped object in -- R2, in the form (lo,hi). extentY :: (Enveloped a, V a ~ R2) => a -> Maybe (Double, Double) extentY d = (\f -> (-f unit_Y, f unitY)) <$> (appEnvelope . getEnvelope $ d) -- | Compute the point at the center (in the x- and y-directions) of a -- enveloped object. Return the origin for objects with an empty -- envelope. center2D :: (Enveloped a, V a ~ R2) => a -> P2 center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY) where mm = uncurry (liftA2 (,)) mid = (/2) . uncurry (+) ------------------------------------------------------------ -- Size specifications ------------------------------------------------------------ -- | A specification of a (requested) rectangular size. data SizeSpec2D = Width Double -- ^ Specify an explicit -- width. The height should be -- determined automatically (so -- as to preserve aspect ratio). | Height Double -- ^ Specify an explicit -- height. The width should be -- determined automatically (so -- as to preserve aspect ratio). | Dims Double Double -- ^ An explicit specification -- of a width and height. | Absolute -- ^ Absolute size: use whatever -- size an object already has; -- do not rescale. deriving (Eq, Ord, Show) -- | Create a size specification from a possibly-specified width and -- height. mkSizeSpec :: Maybe Double -> Maybe Double -> SizeSpec2D mkSizeSpec Nothing Nothing = Absolute mkSizeSpec (Just w) Nothing = Width w mkSizeSpec Nothing (Just h) = Height h mkSizeSpec (Just w) (Just h) = Dims w h -- | @requiredScaleT spec sz@ returns a transformation (a uniform scale) -- which can be applied to something of size @sz@ to make it fit the -- requested size @spec@, without changing the aspect ratio. requiredScaleT :: SizeSpec2D -> (Double, Double) -> Transformation R2 requiredScaleT spec size = scaling (requiredScale spec size) -- | @requiredScale spec sz@ returns a scaling factor necessary to -- make something of size @sz@ fit the requested size @spec@, -- without changing the aspect ratio. Hence an explicit -- specification of both dimensions may not be honored if the aspect -- ratios do not match; in that case the scaling will be as large as -- possible so that the object still fits within the requested size. requiredScale :: SizeSpec2D -> (Double, Double) -> Double requiredScale Absolute _ = 1 requiredScale (Width wSpec) (w,_) | wSpec == 0 || w == 0 = 1 | otherwise = wSpec / w requiredScale (Height hSpec) (_,h) | hSpec == 0 || h == 0 = 1 | otherwise = hSpec / h requiredScale (Dims wSpec hSpec) (w,h) = s where xscale = wSpec / w yscale = hSpec / h s' = min xscale yscale s | isInfinite s' = 1 | otherwise = s' -- | Uniformly scale any enveloped object so that it fits within the -- given size. sized :: (Transformable a, Enveloped a, V a ~ R2) => SizeSpec2D -> a -> a sized spec a = transform (requiredScaleT spec (size2D 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 :: ( Transformable a, Enveloped a, V a ~ R2 , Enveloped b, V b ~ R2) => b -> a -> a sizedAs other = sized (sizeSpec2D other) diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Align.hs0000644000000000000000000000611712221314077017164 0ustar0000000000000000{-# LANGUAGE FlexibleContexts , 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. For example, to align -- several diagrams along their tops, we first move their local -- origins to the upper edge of their envelopes (using e.g. @map -- 'alignTop'@), and then put them together with their local origins -- along a horizontal line (using e.g. 'hcat' from -- "Diagrams.TwoD.Combinators"). -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Align ( -- * Absolute alignment alignL, alignR, alignT, alignB , alignTL, alignTR, alignBL, alignBR -- * Relative alignment , alignX, alignY -- * Centering , centerX, centerY, centerXY ) where import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector import Diagrams.Align import Data.VectorSpace -- | Align along the left edge, i.e. translate the diagram in a -- horizontal direction so that the local origin is on the left edge -- of the envelope. alignL :: (Alignable a, V a ~ R2) => a -> a alignL = align (negateV unitX) -- | Align along the right edge. alignR :: (Alignable a, V a ~ R2) => a -> a alignR = align unitX -- | Align along the top edge. alignT :: (Alignable a, V a ~ R2) => a -> a alignT = align unitY -- | Align along the bottom edge. alignB :: (Alignable a, V a ~ R2) => a -> a alignB = align (negateV unitY) alignTL, alignTR, alignBL, alignBR :: (Alignable a, V a ~ R2) => a -> a alignTL = alignT . alignL alignTR = alignT . alignR alignBL = alignB . alignL alignBR = alignB . alignR -- | @alignX@ moves the local origin horizontally as follows: -- -- * @alignX (-1)@ moves the local origin to the left edge of the envelope; -- -- * @align 1@ moves the local origin to the right edge; -- -- * any other argument interpolates linearly between these. For -- example, @alignX 0@ centers, @alignX 2@ moves the origin one -- \"radius\" to the right of the right edge, and so on. alignX :: (Alignable a, V a ~ R2) => Double -> a -> a alignX = alignBy unitX -- | Like 'alignX', but moving the local origin vertically, with an -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding -- to the bottom edge. alignY :: (Alignable a, V a ~ R2) => Double -> a -> a alignY = alignBy unitY -- | Center the local origin along the X-axis. centerX :: (Alignable a, V a ~ R2) => a -> a centerX = alignBy unitX 0 -- | Center the local origin along the Y-axis. centerY :: (Alignable a, V a ~ R2) => a -> a centerY = alignBy unitY 0 -- | Center along both the X- and Y-axes. centerXY :: (Alignable a, V a ~ R2) => a -> a centerXY = centerX . centerY diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Ellipse.hs0000644000000000000000000000376712221314077017537 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.Located (at) import Diagrams.Path import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.Util -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t unitCircle = trailLike $ arcT 0 (tau::Rad) `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 ~ R2, Transformable t) => Double -> 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 ~ R2, Transformable t) => Double -> 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 ~ R2, Transformable t) => Double -> Double -> t ellipseXY x y = unitCircle # scaleX x # scaleY y diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Vector.hs0000644000000000000000000000426312221314077017374 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 -- * Converting between vectors and angles , direction, fromDirection, e -- * 2D vector utilities , perp, leftTurn ) where import Data.VectorSpace ((<.>)) import Diagrams.Coordinates import Diagrams.TwoD.Types import Diagrams.Util (( # )) -- | The unit vector in the positive X direction. unitX :: R2 unitX = 1 & 0 -- | The unit vector in the positive Y direction. unitY :: R2 unitY = 0 & 1 -- | The unit vector in the negative X direction. unit_X :: R2 unit_X = (-1) & 0 -- | The unit vector in the negative Y direction. unit_Y :: R2 unit_Y = 0 & (-1) -- | Compute the direction of a vector, measured counterclockwise from -- the positive x-axis as a fraction of a full turn. The zero -- vector is arbitrarily assigned the direction 0. direction :: Angle a => R2 -> a direction (coords -> x :& y) = convertAngle . Rad $ atan2 y x -- | Convert an angle into a unit vector pointing in that direction. fromDirection :: Angle a => a -> R2 fromDirection a = cos a' & sin a' where Rad a' = convertAngle a -- | A convenient synonym for 'fromDirection'. e :: Angle a => a -> R2 e = fromDirection -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. perp :: R2 -> R2 perp (coords -> x :& y) = (-y) & x -- | @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 :: R2 -> R2 -> Bool leftTurn v1 v2 = (v1 <.> perp v2) < 0 diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Types.hs0000644000000000000000000001510012221314077017226 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} {-# 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 R2, r2, unr2 , P2, p2, unp2 , T2 -- * Angles , Angle(..) , Turn(..), CircleFrac, Rad(..), Deg(..) , fullCircle, convertAngle ) where import Diagrams.Coordinates import Diagrams.Core import Diagrams.Util (tau) import Control.Newtype import Data.Basis import Data.NumInstances.Tuple () import Data.VectorSpace import Data.Typeable ------------------------------------------------------------ -- 2D Euclidean space -- | The two-dimensional Euclidean vector space R^2. This type is -- intentionally abstract. -- -- * To construct a vector, use 'r2', or '&' (from "Diagrams.Coordinates"): -- -- @ -- r2 (3,4) :: R2 -- 3 & 4 :: R2 -- @ -- -- Note that "Diagrams.Coordinates" is not re-exported by -- "Diagrams.Prelude" and must be explicitly imported. -- -- * To construct the vector from the origin to a point @p@, use -- @p 'Data.AffineSpace..-.' 'origin'@. -- -- * To convert a vector @v@ into the point obtained by following -- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. -- -- * To convert a vector back into a pair of components, use 'unv2' -- or 'coords' (from "Diagrams.Coordinates"). These are typically -- used in conjunction with the @ViewPatterns@ extension: -- -- @ -- foo (unr2 -> (x,y)) = ... -- foo (coords -> x :& y) = ... -- @ newtype R2 = R2 { unR2 :: (Double, Double) } deriving (AdditiveGroup, Eq, Ord, Typeable, Num, Fractional) instance Show R2 where showsPrec p (R2 (x,y)) = showParen (p >= 7) $ showCoord x . showString " & " . showCoord y where showCoord x | x < 0 = showParen True (shows x) | otherwise = shows x instance Read R2 where readsPrec d r = readParen (d > app_prec) (\r -> [ (R2 (x,y), r''') | (x,r') <- readsPrec (amp_prec + 1) r , ("&",r'') <- lex r' , (y,r''') <- readsPrec (amp_prec + 1) r'' ]) r where app_prec = 10 amp_prec = 7 instance Newtype R2 (Double, Double) where pack = R2 unpack = unR2 -- | Construct a 2D vector from a pair of components. See also '&'. r2 :: (Double, Double) -> R2 r2 = pack -- | Convert a 2D vector back into a pair of components. See also 'coords'. unr2 :: R2 -> (Double, Double) unr2 = unpack type instance V R2 = R2 instance VectorSpace R2 where type Scalar R2 = Double (*^) = over R2 . (*^) instance HasBasis R2 where type Basis R2 = Either () () -- = Basis (Double, Double) basisValue = R2 . basisValue decompose = decompose . unR2 decompose' = decompose' . unR2 instance InnerSpace R2 where (unR2 -> vec1) <.> (unR2 -> vec2) = vec1 <.> vec2 instance Coordinates R2 where type FinalCoord R2 = Double type PrevDim R2 = Double type Decomposition R2 = Double :& Double x & y = r2 (x,y) coords (unR2 -> (x,y)) = x :& y -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '&' (see -- "Diagrams.Coordinates"): -- -- @ -- p2 (3,4) :: P2 -- 3 & 4 :: P2 -- @ -- -- * To construct a point from a vector @v@, use @'origin' 'Data.AffineSpace..+^' v@. -- -- * To convert a point @p@ into the vector from the origin to @p@, -- use @p 'Data.AffineSpace..-.' 'origin'@. -- -- * To convert a point back into a pair of coordinates, use 'unp2', -- or 'coords' (from "Diagrams.Coordinates"). It's common to use -- these in conjunction with the @ViewPatterns@ extension: -- -- @ -- foo (unp2 -> (x,y)) = ... -- foo (coords -> x :& y) = ... -- @ type P2 = Point R2 -- | Construct a 2D point from a pair of coordinates. See also '&'. p2 :: (Double, Double) -> P2 p2 = pack . pack -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. unp2 :: P2 -> (Double, Double) unp2 = unpack . unpack -- | Transformations in R^2. type T2 = Transformation R2 instance Transformable R2 where transform = apply ------------------------------------------------------------ -- Angles -- | Newtype wrapper used to represent angles as fractions of a -- circle. For example, 1\/3 turn = tau\/3 radians = 120 degrees. newtype Turn = Turn { getTurn :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) -- | Deprecated synonym for 'Turn', retained for backwards compatibility. type CircleFrac = Turn -- | Newtype wrapper for representing angles in radians. newtype Rad = Rad { getRad :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) -- | Newtype wrapper for representing angles in degrees. newtype Deg = Deg { getDeg :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) -- | Type class for types that measure angles. class Num a => Angle a where -- | Convert to a turn, /i.e./ a fraction of a circle. toTurn :: a -> Turn -- | Convert from a turn, /i.e./ a fraction of a circle. fromTurn :: Turn -> a instance Angle Turn where toTurn = id fromTurn = id -- | tau radians = 1 full turn. instance Angle Rad where toTurn = Turn . (/tau) . getRad fromTurn = Rad . (*tau) . getTurn -- | 360 degrees = 1 full turn. instance Angle Deg where toTurn = Turn . (/360) . getDeg fromTurn = Deg . (*360) . getTurn -- | An angle representing one full turn. fullTurn :: Angle a => a fullTurn = fromTurn 1 -- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. fullCircle :: Angle a => a fullCircle = fullTurn -- | Convert between two angle representations. convertAngle :: (Angle a, Angle b) => a -> b convertAngle = fromTurn . toTurn diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Arc.hs0000644000000000000000000001330312221314077016632 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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' , arcCW , arcT , bezierFromSweep , wedge ) where import Diagrams.Coordinates import Diagrams.Core import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (e, unitX) import Diagrams.Util (tau, ( # )) import Data.Semigroup ((<>)) import Data.VectorSpace (negateV, (*^), (^-^)) -- 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 @s@ -- radians. The approximation is only valid for angles in the first -- quadrant. bezierFromSweepQ1 :: Rad -> Segment Closed R2 bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s/2) v c1 = ((4-x)/3) & ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 v = unitX -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise -- through @s@ radians. 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 tau -- then it is truncated to tau. bezierFromSweep :: Rad -> [Segment Closed R2] bezierFromSweep s | s > tau = bezierFromSweep tau | s < 0 = fmap reflectY . bezierFromSweep $ (-s) | s < 0.0001 = [] | s < tau/4 = [bezierFromSweepQ1 s] | otherwise = bezierFromSweepQ1 (tau/4) : map (rotateBy (1/4)) (bezierFromSweep (max (s - tau/4) 0)) {- ~~~~ 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 angle @s@ and an end angle @e@, @'arcT' s e@ is the -- 'Trail' of a radius one arc counterclockwise between the two angles. arcT :: Angle a => a -> a -> Trail R2 arcT start end | e < s = arcT s (e + fromIntegral d) | otherwise = (if sweep >= tau then glueTrail else id) $ trailFromSegments bs where sweep = convertAngle $ end - start bs = map (rotate start) . bezierFromSweep $ sweep -- We want to compare the start and the end and in case -- there isn't some law about 'Angle' ordering, we use a -- known 'Angle' for that. s = convertAngle start :: Turn e = convertAngle end d = ceiling (s - e) :: Integer -- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the -- path of a radius one arc counterclockwise between the two angles. -- The origin of the arc is its center. arc :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0)) -- | Like 'arc' but clockwise. arcCW :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t arcCW start end = trailLike $ -- flipped arguments to get the path we want -- then reverse the trail to get the cw direction. (reverseTrail $ arcT end start) `at` (rotate start $ p2 (1,0)) -- We could just have `arcCW = reversePath . flip arc` -- but that wouldn't be `TrailLike`. -- | Given a radus @r@, a start angle @s@ and an end angle @e@, -- @'arc'' r s e@ is the path of a radius @(abs r)@ arc between -- the two angles. If a negative radius is given, the arc will -- be clockwise, otherwise it will be counterclockwise. The origin -- of the arc is its center. arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) where ts | r < 0 = reverseTrail $ arcT end start | otherwise = arcT start end -- | Create a circular wedge of the given radius, beginning at the -- first angle and extending counterclockwise to the second. wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p wedge r a1 a2 = trailLike . (`at` origin) . wrapLine $ fromOffsets [r *^ e a1] <> arc a1 a2 # scale r <> fromOffsets [r *^ negateV (e a2)] diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Image.hs0000644000000000000000000000507612221314077017157 0ustar0000000000000000{-# LANGUAGE TypeFamilies , FlexibleContexts , MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- 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. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Image ( Image(..) , image ) where import Diagrams.Core import Diagrams.Path import Diagrams.TwoD.Types import Diagrams.TwoD.Path import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size (SizeSpec2D(..)) import Data.AffineSpace ((.-.)) import Data.Semigroup -- | An external image primitive, representing an image the backend -- should import from another file when rendering. data Image = Image { imgFile :: FilePath , imgSize :: SizeSpec2D , imgTransf :: T2 } type instance V Image = R2 instance Transformable Image where transform t1 (Image file sz t2) = Image file sz (t1 <> t2) instance IsPrim Image instance HasOrigin Image where moveOriginTo p = translate (origin .-. p) instance Renderable Image NullBackend where render _ _ = mempty -- See Note [Image size specification] -- | Take an external image from the specified file and turn it into a -- diagram with the specified width and height, centered at the -- origin. Note that the image's aspect ratio will be preserved; if -- the specified width and height have a different ratio than the -- image's aspect ratio, there will be extra space in one dimension. image :: (Renderable Image b) => FilePath -> Double -> Double -> Diagram b R2 image file w h = mkQD (Prim (Image file (Dims w h) mempty)) (getEnvelope r) (getTrace r) mempty (Query $ \p -> Any (isInsideEvenOdd p r)) where r :: Path R2 r = rect w h {- ~~~~ Note [Image size specification] It's tempting to make 'image' take a SizeSpec2D instead of two Doubles. For example, if I know I want the image to be x units wide but I don't know the original aspect ratio of the image, I'd like to be able to just say "make it x units wide". The problem is that diagrams would then not know how tall the image is until rendering time (at least, not without unsafePerformIO yuckiness). A more general solution will have to wait until we can specify constraints and solve them later. -}diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Combinators.hs0000644000000000000000000002313612221314077020412 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 (===), (|||), atAngle -- * n-ary combinators , hcat, hcat' , vcat, vcat' -- * Spacing/envelopes , strutR2 , strutX, strutY , padX, padY , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop , view , boundingRect, bg ) where import Data.AffineSpace import Data.Colour import Data.Default.Class import Data.Semigroup import Data.VectorSpace import Diagrams.Core import Diagrams.Attributes (fc, lw) import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike import Diagrams.TwoD.Align import Diagrams.TwoD.Path () import Diagrams.TwoD.Segment import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) import Diagrams.Util (( # )) 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. (===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) -- | 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. (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (|||) = beside unitX -- | Place two diagrams (or other juxtaposable objects) adjacent to one -- another, with the second diagram placed along a line at angle -- 'th' 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. atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a, Angle b) => b -> a -> a -> a atAngle th = beside (fromDirection th) -- | 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 :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [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. hcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => CatOpts R2 -> [a] -> a hcat' = cat' unitX -- | 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 :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => [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. vcat' :: (Juxtaposable a, HasOrigin a, Monoid' a, V a ~ R2) => CatOpts R2 -> [a] -> a vcat' = cat' (negateV unitY) -- | @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 :: (Backend b R2, Monoid' m) => R2 -> QDiagram b R2 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 :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m strutX d = strut (d & 0) -- | @strutY h@ is an empty diagram with height @h@, width 0, and a -- centered local origin. Note that @strutY (-h)@ behaves the same as -- @strutY h@. strutY :: (Backend b R2, Monoid' m) => Double -> QDiagram b R2 m strutY d = strut (0 & d) -- | @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 :: ( Backend b R2, Monoid' m ) => Double -> QDiagram b R2 m -> QDiagram b R2 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 :: ( Backend b R2, Monoid' m ) => Double -> QDiagram b R2 m -> QDiagram b R2 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 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 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 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 s | s >= 0 = extrudeEnvelope $ unitY ^* s | otherwise = intrudeEnvelope $ unitY ^* s -- | @view 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. view :: ( Backend b R2, Monoid' m ) => P2 -> R2 -> QDiagram b R2 m -> QDiagram b R2 m view p (coords -> w :& h) = withEnvelope (rect w h # alignBL # moveTo p :: D R2) -- | Construct a bounding rectangle for an enveloped object, that is, -- the smallest axis-aligned rectangle which encloses the object. boundingRect :: ( Enveloped t, Transformable t, TrailLike t, Monoid t, V t ~ R2 , Enveloped a, V a ~ R2 ) => 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 :: (Renderable (Path R2) b) => Colour Double -> Diagram b R2 -> Diagram b R2 bg c d = d <> boundingRect d # lw 0 # fc c diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Adjust.hs0000644000000000000000000000774112221314077017370 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 , adjustDiaSize2D , adjustDia2D , adjustSize -- for backwards compatibility , requiredScale -- re-exported for backwards compatibility ) where import Diagrams.Core import Diagrams.Attributes (lineWidthA, lineColorA, lineCap , lineJoin, lineMiterLimitA ) import Diagrams.Util ((#)) import Diagrams.TwoD.Types (R2, p2) import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) , requiredScaleT, requiredScale ) import Diagrams.TwoD.Text (fontSizeA) import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Default.Class import Data.Colour.Names (black) -- | Set default attributes of a 2D diagram (in case they have not -- been set): -- -- * Line width 0.01 -- -- * Line color black -- -- * Font size 1 -- -- * Line cap LineCapButt -- -- * line join miter -- -- * Miter limit 10 setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m setDefault2DAttributes d = d # lineWidthA def # lineColorA def # fontSizeA def # lineCap def # lineJoin def # lineMiterLimitA def -- | Adjust the size and position of a 2D diagram to fit within the -- requested size. The first two arguments specify a method for -- extracting the requested output size from the rendering options, -- and a way of updating the rendering options with a new (more -- specific) size. adjustDiaSize2D :: Monoid' m => (Options b R2 -> SizeSpec2D) -> (SizeSpec2D -> Options b R2 -> Options b R2) -> b -> Options b R2 -> QDiagram b R2 m -> (Options b R2, QDiagram b R2 m) adjustDiaSize2D getSize setSize _ opts d = ( case spec of Dims _ _ -> opts _ -> setSize (uncurry Dims . scale s $ size) opts , d # scale s # translate tr ) where spec = getSize opts size = size2D d s = requiredScale spec size finalSz = case spec of Dims w h -> (w,h) _ -> scale s size tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) -- | @adjustDia2D@ provides a useful default implementation of -- the 'adjustDia' method from the 'Backend' type class. -- -- As its first two arguments it requires a method for extracting -- the requested output size from the rendering options, and a way -- of updating the rendering options with a new (more specific) size. -- -- It then performs the following adjustments: -- -- * Set default attributes (see 'setDefault2DAttributes') -- -- * Freeze the diagram in its final form -- -- * Scale and translate the diagram to fit within the requested -- size (see 'adjustDiaSize2D') -- -- * Also return the actual adjusted size of the diagram. adjustDia2D :: Monoid' m => (Options b R2 -> SizeSpec2D) -> (SizeSpec2D -> Options b R2 -> Options b R2) -> b -> Options b R2 -> QDiagram b R2 m -> (Options b R2, QDiagram b R2 m) adjustDia2D getSize setSize b opts d = adjustDiaSize2D getSize setSize b opts (d # setDefault2DAttributes # freeze) {-# DEPRECATED adjustSize "Use Diagrams.TwoD.Size.requiredScaleT instead." #-} -- | Re-export 'requiredScaleT' with the name 'adjustSize' for -- backwards compatibility. adjustSize :: SizeSpec2D -> (Double, Double) -> Transformation R2 adjustSize = requiredScaleT diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Shapes.hs0000644000000000000000000002661212221314077017357 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# 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 , septagon , octagon , nonagon , decagon , hendecagon , dodecagon -- * Other special polygons , unitSquare , rect -- * Other shapes , roundedRect , RoundedRectOpts(..) , roundedRect' ) where import Diagrams.Core import Diagrams.Coordinates 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.Util import Data.Default.Class import Data.Semigroup -- | Create a centered horizontal (L-R) line of the given length. -- -- <> -- -- > hruleEx = vcat' with {sep = 0.2} (map hrule [1..5]) -- > # centerXY # pad 1.1 hrule :: (TrailLike t, V t ~ R2) => Double -> t hrule d = trailLike $ trailFromSegments [straight (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 :: (TrailLike t, V t ~ R2) => Double -> t vrule d = trailLike $ trailFromSegments [straight (0 & (-d))] `at` (p2 (0,d/2)) -- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. -- -- <> unitSquare :: (TrailLike t, V t ~ R2) => t unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) , polyOrient = OrientH } -- > unitSquareEx = unitSquare # pad 1.1 # showOrigin -- | A square with its center at the origin and sides of the given -- length, oriented parallel to the axes. -- -- <> square :: (TrailLike t, Transformable t, V t ~ R2) => Double -> t square d = rect d d -- > squareEx = hcat' with {sep = 0.5} [square 1, square 2, square 3] -- > # centerXY # pad 1.1 # lw 0.03 -- | @rect w h@ is an axis-aligned rectangle of width @w@ and height -- @h@, centered at the origin. -- -- <> rect :: (TrailLike t, Transformable t, V t ~ R2) => Double -> Double -> t rect w h = trailLike . head . pathTrails $ unitSquare # scaleX w # scaleY h -- > 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 :: (TrailLike t, V t ~ R2) => Int -> Double -> t regPoly n l = polygon with { 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 -- > septagonEx = shapeEx septagon -- > octagonEx = shapeEx octagon -- > nonagonEx = shapeEx nonagon -- > decagonEx = shapeEx decagon -- > hendecagonEx = shapeEx hendecagon -- > dodecagonEx = shapeEx dodecagon -- | A synonym for 'triangle', provided for backwards compatibility. eqTriangle :: (TrailLike t, V t ~ R2) => Double -> t eqTriangle = triangle -- | An equilateral triangle, with sides of the given length and base -- parallel to the x-axis. -- -- <> triangle :: (TrailLike t, V t ~ R2) => Double -> t triangle = regPoly 3 -- | A regular pentagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> pentagon :: (TrailLike t, V t ~ R2) => Double -> t pentagon = regPoly 5 -- | A regular hexagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> hexagon :: (TrailLike t, V t ~ R2) => Double -> t hexagon = regPoly 6 -- | A regular septagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> septagon :: (TrailLike t, V t ~ R2) => Double -> t septagon = regPoly 7 -- | A regular octagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> octagon :: (TrailLike t, V t ~ R2) => Double -> t octagon = regPoly 8 -- | A regular nonagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> nonagon :: (TrailLike t, V t ~ R2) => Double -> t nonagon = regPoly 9 -- | A regular decagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> decagon :: (TrailLike t, V t ~ R2) => Double -> t decagon = regPoly 10 -- | A regular hendecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> hendecagon :: (TrailLike t, V t ~ R2) => Double -> t hendecagon = regPoly 11 -- | A regular dodecagon, with sides of the given length and base -- parallel to the x-axis. -- -- <> dodecagon :: (TrailLike t, V t ~ R2) => Double -> t dodecagon = regPoly 12 ------------------------------------------------------------ -- Other shapes ------------------------------------------ ------------------------------------------------------------ -- | @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 :: (TrailLike t, V t ~ R2) => Double -> Double -> Double -> t roundedRect w h r = roundedRect' w h (with { radiusTL = r, radiusBR = r, radiusTR = r, radiusBL = r}) -- | @roundedRect'@ 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' :: (TrailLike t, V t ~ R2) => Double -> Double -> RoundedRectOpts -> 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') = (rx opts, ry opts, ro opts, r opts) 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 2 | otherwise = doArc 0 1 where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn) data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double , radiusTR :: Double , radiusBL :: Double , radiusBR :: Double } instance Default RoundedRectOpts where def = RoundedRectOpts 0 0 0 0 diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Path.hs0000644000000000000000000003272012221314077017025 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# 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', strokeT, strokeT', strokeLine, strokeLoop , strokeLocT, strokeLocLine, strokeLocLoop -- ** Stroke options , FillRule(..) , FillRuleA(..), getFillRule, fillRule , StrokeOpts(..) -- ** Inside/outside testing , isInsideWinding, isInsideEvenOdd -- * Clipping , Clip(..), clipBy ) where import Control.Applicative (liftA2) import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable import Data.AffineSpace import Data.Default.Class import Data.VectorSpace import Diagrams.Coordinates import Diagrams.Core import Diagrams.Located (Located, mapLoc, unLoc) import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Solve import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Segment import Diagrams.TwoD.Types import Diagrams.Util (tau) ------------------------------------------------------------ -- 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 Traced (Trail R2) where getTrace = withLine $ foldr (\seg bds -> moveOriginBy (negateV . atEnd $ seg) bds <> getTrace seg) mempty . lineSegments instance Traced (Path R2) where getTrace = F.foldMap getTrace . pathTrails ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- ------------------------------------------------------------ -- | Convert a path 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 behavior to be customized. -- -- Note that a bug in GHC 7.0.1 causes a context stack overflow when -- inferring the type of @stroke@. The solution is to give a type -- signature to expressions involving @stroke@, or (recommended) -- upgrade GHC (the bug is fixed in 7.0.2 onwards). stroke :: Renderable (Path R2) b => Path R2 -> Diagram b R2 stroke = stroke' (def :: StrokeOpts ()) instance Renderable (Path R2) b => TrailLike (QDiagram b R2 Any) where trailLike = stroke . trailLike -- | A variant of 'stroke' that takes an extra record of options to -- customize its behavior. 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' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts path | null (pathTrails p1) = mkP p2 | null (pathTrails p2) = mkP p1 | otherwise = mkP p1 <> mkP p2 where (p1,p2) = partitionPath (isLine . unLoc) path mkP p = mkQD (Prim p) (getEnvelope p) (getTrace p) (fromNames . concat $ zipWith zip (vertexNames opts) ((map . map) subPoint (pathVertices p)) ) (Query $ Any . flip (runFillRule (queryFillRule opts)) p) -- | A record of options that control how a path is stroked. -- @StrokeOpts@ is an instance of 'Default', so a @StrokeOpts@ -- records can be created using @'with' { ... }@ notation. data StrokeOpts a = StrokeOpts { vertexNames :: [[a]] -- ^ Atomic names that should be assigned -- to the vertices of the path so that -- they can be referenced later. If -- there are not enough names, the extra -- vertices are not assigned names; if -- there are too many, the extra names -- are ignored. Note that this is a -- /list of lists/ of names, since paths -- can consist of multiple trails. The -- first list of names are assigned to -- the vertices of the first trail, the -- second list to the second trail, and -- so on. -- -- The default value is the empty list. , queryFillRule :: FillRule -- ^ The fill rule used for determining -- which points are inside the path. -- The default is 'Winding'. NOTE: for -- now, this only affects the resulting -- diagram's 'Query', /not/ how it will -- be drawn! To set the fill rule -- determining how it is to be drawn, -- use the 'fillRule' function. } instance Default (StrokeOpts a) where def = StrokeOpts { vertexNames = [] , queryFillRule = Winding } -- | A composition of 'stroke' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. -- -- Note that a bug in GHC 7.0.1 causes a context stack overflow when -- inferring the type of 'stroke' and hence of @strokeT@ as well. -- The solution is to give a type signature to expressions involving -- @strokeT@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 -- onwards). strokeT :: (Renderable (Path R2) b) => Trail R2 -> Diagram b R2 strokeT = stroke . pathFromTrail -- | A composition of 'stroke'' and 'pathFromTrail' for conveniently -- converting a trail directly into a diagram. strokeT' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Trail R2 -> Diagram b R2 strokeT' opts = stroke' opts . pathFromTrail -- | A composition of 'strokeT' and 'wrapLine' for conveniently -- converting a line directly into a diagram. strokeLine :: (Renderable (Path R2) b) => Trail' Line R2 -> Diagram b R2 strokeLine = strokeT . wrapLine -- | A composition of 'strokeT' and 'wrapLoop' for conveniently -- converting a loop directly into a diagram. strokeLoop :: (Renderable (Path R2) b) => Trail' Loop R2 -> Diagram b R2 strokeLoop = strokeT . wrapLoop -- | A convenience function for converting a @Located Trail@ directly -- into a diagram; @strokeLocT = stroke . trailLike@. strokeLocT :: (Renderable (Path R2) b) => Located (Trail R2) -> Diagram b R2 strokeLocT = stroke . trailLike -- | A convenience function for converting a @Located@ line directly -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. strokeLocLine :: (Renderable (Path R2) b) => Located (Trail' Line R2) -> Diagram b R2 strokeLocLine = stroke . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. strokeLocLoop :: (Renderable (Path R2) b) => Located (Trail' Loop R2) -> Diagram b R2 strokeLocLoop = stroke . trailLike . mapLoc wrapLoop ------------------------------------------------------------ -- Inside/outside testing ------------------------------------------------------------ -- | Enumeration of algorithms or \"rules\" for determining which -- points lie in the interior of a (possibly self-intersecting) -- closed path. data FillRule = Winding -- ^ Interior points are those with a nonzero -- /winding/ /number/. See -- . | EvenOdd -- ^ Interior points are those where a ray -- extended infinitely in a particular -- direction crosses the path an odd number -- of times. See -- . deriving (Eq) runFillRule :: FillRule -> P2 -> Path R2 -> Bool runFillRule Winding = isInsideWinding runFillRule EvenOdd = isInsideEvenOdd newtype FillRuleA = FillRuleA (Last FillRule) deriving (Typeable, Semigroup) instance AttributeClass FillRuleA -- | Extract the fill rule from a 'FillRuleA' attribute. getFillRule :: FillRuleA -> FillRule getFillRule (FillRuleA (Last r)) = r -- | Specify the fill rule that should be used for determining which -- points are inside a path. fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr . FillRuleA . Last cross :: R2 -> R2 -> Double cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' -- XXX link to more info on this -- | Test whether the given point is inside the given (closed) path, -- by testing whether the point's /winding number/ is nonzero. Note -- that @False@ is /always/ returned for /open/ paths, regardless of -- the winding number. isInsideWinding :: P2 -> Path R2 -> Bool isInsideWinding p = (/= 0) . crossings p -- | Test whether the given point is inside the given (closed) 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 -- /open/ paths, regardless of the number of crossings. isInsideEvenOdd :: P2 -> Path R2 -> 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 :: P2 -> Path R2 -> Int crossings p = F.sum . map (trailCrossings p) . pathTrails -- | Compute the sum of signed crossings of a trail starting from the -- given point in the positive x direction. trailCrossings :: P2 -> Located (Trail R2) -> 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 (unp2 -> x1@(_,x1y)) (unp2 -> c1@(_,c1y)) (unp2 -> c2@(_,c2y)) (unp2 -> x2@(_,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 (dx,dy) = (3*t*t) *^ ((-1)*^x1 ^+^ 3*^c1 ^-^ 3*^c2 ^+^ x2) ^+^ (2*t) *^ (3*^x1 ^-^ 6*^c1 ^+^ 3*^c2) ^+^ ((-3)*^x1 ^+^ 3*^c1) ang = atan2 dy dx in case () of _ | 0 < ang && ang < tau/2 && t < 1 -> 1 | -tau/2 < ang && ang < 0 && t > 0 -> -1 | otherwise -> 0 isLeft a b = cross (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 = Clip { getClip :: [Path R2] } deriving (Typeable, Semigroup) instance AttributeClass Clip type instance V Clip = R2 instance Transformable Clip where transform t (Clip ps) = Clip (transform t ps) -- | 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 ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) -- XXX Should include a 'clipTo' function which clips a diagram AND -- restricts its envelope. It will have to take a *pointwise minimum* -- of the diagram's current envelope and the path's envelope. Not -- sure of the best way to do this at the moment. diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Transform.hs0000644000000000000000000003337112221314077020107 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform -- Copyright : (c) 2011 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 ( -- * Rotation rotation, rotate, rotateBy , rotationAbout, rotateAbout -- * 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 -- * Scale invariance , ScaleInv(..), scaleInv, scaleInvPrim -- * component-wise , onBasis ) where import Diagrams.Core import qualified Diagrams.Core.Transform as T import Control.Newtype (over) import Diagrams.Coordinates import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction) import Data.Semigroup import Data.AffineSpace import Control.Arrow (first, second) -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. rotation :: Angle a => a -> T2 rotation ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) Rad theta = convertAngle ang rot th (coords -> x :& y) = (cos th * x - sin th * y) & (sin th * x + cos th * y) -- | 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 type which is an -- instance of '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 type annotation, 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 is specialized to take a 'Turn' argument. rotate :: (Transformable t, V t ~ R2, Angle a) => a -> t -> t rotate = transform . rotation -- | A synonym for 'rotate', specialized to only work with -- @Turn@ arguments; it can be more convenient to write -- @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'Turn')@. rotateBy :: (Transformable t, V t ~ R2) => Turn -> t -> t rotateBy = transform . rotation -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). rotationAbout :: Angle a => P2 -> a -> T2 rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. rotateAbout :: (Transformable t, V t ~ R2, Angle a) => P2 -> a -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- -- | Construct a transformation which scales by the given factor in -- the x (horizontal) direction. scalingX :: Double -> T2 scalingX c = fromLinear s s where s = (over r2 . first) (*c) <-> (over r2 . first) (/c) -- | Scale a diagram by the given factor in the x (horizontal) -- direction. To scale uniformly, use 'scale'. scaleX :: (Transformable t, V t ~ R2) => Double -> t -> t scaleX = transform . scalingX -- | Construct a transformation which scales by the given factor in -- the y (vertical) direction. scalingY :: Double -> T2 scalingY c = fromLinear s s where s = (over r2 . second) (*c) <-> (over r2 . second) (/c) -- | Scale a diagram by the given factor in the y (vertical) -- direction. To scale uniformly, use 'scale'. scaleY :: (Transformable t, V t ~ R2) => Double -> 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleToX w d = scaleX (w / width 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleToY h d = scaleY (h / height 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleUToX w d = scale (w / width 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 :: (Enveloped t, Transformable t, V t ~ R2) => Double -> t -> t scaleUToY h d = scale (h / height d) d -- Translation --------------------------------------------- -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. translationX :: Double -> T2 translationX x = translation (x & 0) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. translateX :: (Transformable t, V t ~ R2) => Double -> t -> t translateX = transform . translationX -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. translationY :: Double -> T2 translationY y = translation (0 & y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. translateY :: (Transformable t, V t ~ R2) => Double -> 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 :: T2 reflectionX = scalingX (-1) -- | Flip a diagram from left to right, i.e. send the point (x,y) to -- (-x,y). reflectX :: (Transformable t, V t ~ R2) => 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 :: T2 reflectionY = scalingY (-1) -- | Flip a diagram from top to bottom, i.e. send the point (x,y) to -- (x,-y). reflectY :: (Transformable t, V t ~ R2) => t -> t reflectY = transform reflectionY -- | @reflectionAbout p v@ is a reflection in the line determined by -- the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 reflectionAbout p v = conjugate (rotation (-direction v :: Rad) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by -- the point @p@ and the vector @v@. reflectAbout :: (Transformable t, V t ~ R2) => P2 -> R2 -> t -> t reflectAbout p v = transform (reflectionAbout p v) -- Shears -------------------------------------------------- -- | @shearingX d@ is the linear transformation which is the identity on -- y coordinates and sends @(0,1)@ to @(d,1)@. shearingX :: Double -> T2 shearingX d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) (over r2 (sh' d) <-> over r2 (sh' (-d))) where sh k (x, y) = (x+k*y, y) sh' k = swap . sh k . swap swap (x,y) = (y,x) -- | @shearX d@ performs a shear in the x-direction which sends -- @(0,1)@ to @(d,1)@. shearX :: (Transformable t, V t ~ R2) => Double -> 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 :: Double -> T2 shearingY d = fromLinear (over r2 (sh d) <-> over r2 (sh (-d))) (over r2 (sh' d) <-> over r2 (sh' (-d))) where sh k (x,y) = (x, y+k*x) sh' k = swap . sh k . swap swap (x,y) = (y,x) -- | @shearY d@ performs a shear in the y-direction which sends -- @(1,0)@ to @(1,d)@. shearY :: (Transformable t, V t ~ R2) => Double -> t -> t shearY = transform . shearingY -- Scale invariance ---------------------------------------- -- | 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 { unScaleInv :: t , scaleInvDir :: R2 , scaleInvLoc :: P2 } deriving (Show) -- | Create a scale-invariant object pointing in the given direction, -- located at the origin. scaleInv :: t -> R2 -> ScaleInv t scaleInv t d = ScaleInv t d origin type instance V (ScaleInv t) = R2 instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where moveOriginTo p (ScaleInv t v l) = ScaleInv (moveOriginTo p t) v (moveOriginTo p l) instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where angle :: Rad angle = direction (transform tr v) - direction v rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l trans = translate (l' .-. l) -- This is how we handle freezing properly with ScaleInv wrappers. -- Normal transformations are applied ignoring scaling; "frozen" -- transformations (i.e. transformations applied after a freeze) are -- applied directly to the underlying object, scales and all. We must -- take care to transform the reference point and direction vector -- appropriately. instance (V t ~ R2, Transformable t) => IsPrim (ScaleInv t) where transformWithFreeze t1 t2 s = ScaleInv t'' d'' origin'' where -- first, apply t2 normally, i.e. ignoring scaling s'@(ScaleInv t' _ _) = transform t2 s -- now apply t1 to get the new direction and origin (ScaleInv _ d'' origin'') = transform t1 s' -- but apply t1 directly to the underlying thing, scales and all. t'' = transform t1 t' instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where render b = render b . unScaleInv -- | Create a diagram from a single scale-invariant primitive. The -- vector argument specifies the direction in which the primitive is -- \"pointing\" (for the purpose of keeping it rotated correctly -- under non-uniform scaling). The primitive is assumed to be -- \"located\" at the origin (for the purpose of translating it -- correctly under scaling). -- -- Note that the resulting diagram will have an /empty/ envelope, -- trace, and query. The reason is that the envelope, trace, and -- query cannot be cached---applying a transformation would cause -- the cached envelope, etc. to get \"out of sync\" with the -- scale-invariant object. The intention, at any rate, is that -- scale-invariant things will be used only as \"decorations\" (/e.g./ -- arrowheads) which should not affect the envelope, trace, and -- query. scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) => t -> R2 -> QDiagram b R2 m scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty -- | Get the matrix equivalent of the linear transform, -- (as a pair of columns) and the translation vector. This -- is mostly useful for implementing backends. onBasis :: Transformation R2 -> ((R2, R2), R2) onBasis t = ((x, y), v) where ((x:y:[]), v) = T.onBasis t diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Offset.hs0000644000000000000000000001232212221314077017353 0ustar0000000000000000{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Offset -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- Compute offsets to segments in two dimensions. -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Offset ( offsetSegment ) where import Data.AffineSpace import Data.Monoid.Inf import Data.VectorSpace import Diagrams.Core import Diagrams.Parametric import Diagrams.Path import Diagrams.Segment import Diagrams.Trail import Diagrams.TwoD.Curvature import Diagrams.TwoD.Transform import Diagrams.TwoD.Types perp :: R2 -> R2 perp v = rotateBy (-1/4) v unitPerp :: R2 -> R2 unitPerp = normalized . perp perpAtParam :: Segment Closed R2 -> Double -> R2 perpAtParam (Linear (OffsetClosed a)) t = unitPerp a perpAtParam s@(Cubic _ _ _) t = unitPerp a where (Cubic a _ _) = snd $ splitAtParam s 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 tolerance. -- 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. -- offsetSegment :: Double -- ^ Epsilon value that represents the maximum -- allowed deviation from the true offset. In -- the current implementation each result segment -- should be bounded by arcs that are plus or -- minus epsilon from the radius of curvature of -- the offset. -> Double -- ^ Offset from the original segment, positive is -- on the right of the curve, negative is on the -- left. -> Segment Closed R2 -- ^ Original segment -> (Point R2, Trail R2) -- ^ Resulting offset point and trail. offsetSegment _ r s@(Linear (OffsetClosed a)) = (origin .+^ va, trailFromSegments [s]) where va = r *^ unitPerp a offsetSegment epsilon r s@(Cubic a b (OffsetClosed c)) = (origin .+^ va, t) where t = trailFromSegments (go (radiusOfCurvature s 0.5)) -- Perpendiculars to handles. va = r *^ unitPerp a vc = r *^ unitPerp (c - b) -- Split segments. ss = (\(a,b) -> [a,b]) $ splitAtParam s 0.5 subdivided = concatMap (trailSegments . snd . offsetSegment epsilon r) ss -- 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 > (magnitude (p o + va - p s - pp s)) | t <- [0.25, 0.5, 0.75] , let p = (`atParam` t) , let pp = (r *^) . (`perpAtParam` t) ] -- > import Diagrams.TwoD.Offset -- > -- > showExample :: Segment R2 -> Diagram SVG R2 -- > showExample s = pad 1.1 . centerXY $ d # lc blue # lw 0.1 <> d' # lw 0.1 -- > where -- > d = stroke $ Path [(origin, Trail [s] False)] -- > d' = mconcat . zipWith lc colors . map stroke . uncurry explodeTrail -- > $ offsetSegment 0.1 (-1) s -- > -- > colors = cycle [green, red] -- > -- > cubicOffsetExample :: Diagram SVG R2 -- > cubicOffsetExample = hcat . map showExample $ -- > [ Cubic (10 & 0) ( 5 & 18) (10 & 20) -- > , Cubic ( 0 & 20) ( 10 & 10) ( 5 & 10) -- > , Cubic (10 & 20) ( 0 & 10) (10 & 0) -- > , Cubic (10 & 20) ((-5) & 10) (10 & 0) -- > ] diagrams-lib-0.7.1.1/src/Diagrams/TwoD/Polygons.hs0000644000000000000000000003226712221314077017751 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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(..) , polygon , polyTrail -- ** Generating polygon vertices , polyPolarTrail , polySidesTrail , polyRegularTrail , orient -- * Star polygons , StarOpts(..) , star -- ** Function graphs -- $graphs , GraphPart(..) , orbits, mkGraph ) where import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, writeArray) import qualified Data.Foldable as F import Data.List (maximumBy, minimumBy) import qualified Data.List.NonEmpty as NEL import Data.Maybe (catMaybes) import Data.Monoid (mconcat, mempty) import Data.Ord (comparing) import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) import Diagrams.Core import Diagrams.Located import Diagrams.Path import Diagrams.Points (centroid) import Diagrams.Segment 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, ( # )) -- | Method used to determine the vertices of a polygon. data PolyType = forall a. Angle a => PolyPolar [a] [Double] -- ^ 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)@. | forall a. Angle a => PolySides [a] [Double] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other -- words, a polygon specified by \"turtle -- graphics\": go straight ahead x1 units; turn by -- angle a1; go straght ahead x2 units; turn by -- 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 angle at each vertex -- from the previous vertex to the next. The -- first angle in the list is the 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 Double -- ^ 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 = 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 R2 -- ^ 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 = PolygonOpts { polyType :: PolyType -- ^ Specification for the polygon's vertices. , polyOrient :: PolyOrientation -- ^ Should a rotation be applied to the -- polygon in order to orient it in a -- particular way? , polyCenter :: P2 -- ^ Should a translation be applied to the -- polygon in order to place the center at a -- particular location? } -- | The default polygon is a regular pentagon of radius 1, centered -- at the origin, aligned to the x-axis. instance Default PolygonOpts where def = PolygonOpts (PolyRegular 5 1) OrientH origin -- | Generate a polygon. See 'PolygonOpts' for more information. polyTrail :: PolygonOpts -> Located (Trail R2) polyTrail po = transform ori tr where tr = case polyType po of PolyPolar ans szs -> polyPolarTrail ans szs PolySides ans szs -> polySidesTrail ans szs PolyRegular n r -> polyRegularTrail n r ori = case polyOrient po 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 :: (TrailLike t, V t ~ R2) => PolygonOpts -> t polygon = trailLike . polyTrail -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) 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 (+) 0 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 :: Angle a => [a] -> [Double] -> Located (Trail R2) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where ans' = scanl (+) 0 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 :: Int -> Double -> Located (Trail R2) polyRegularTrail n r = polyPolarTrail (take (n-1) . repeat $ (tau::Rad) / 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 :: R2 -> Located (Trail R2) -> T2 orient v = orientPoints v . trailVertices orientPoints :: R2 -> [P2] -> T2 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 <.> p) * magnitude (project w p) sndOf3 (_,x,_) = x a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v angleFromNormal o | leftTurn o' v' = phi | otherwise = negate phi where o' = normalized o theta = acos (v' <.> o') phi | theta <= tau/4 = Rad $ tau/4 - theta | otherwise = Rad $ theta - tau/4 ------------------------------------------------------------ -- 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 case isMarked of True -> return [] False -> 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 -- @[P2]@ 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' 'R2'@ 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 :: StarOpts -> [P2] -> Path R2 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-0.7.1.1/src/Diagrams/TwoD/Model.hs0000644000000000000000000000576012221314077017175 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- 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, /etc./ -- ----------------------------------------------------------------------------- module Diagrams.TwoD.Model ( -- * Showing the local origin showOrigin , showOrigin' , OriginOpts(..) , showLabels ) where import Diagrams.Core import Diagrams.Core.Names import Diagrams.Path import Diagrams.Attributes import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Path import Diagrams.TwoD.Size (size2D) import Diagrams.TwoD.Text import Diagrams.TwoD.Types import Diagrams.Util import Control.Arrow (second) import Data.AffineSpace ((.-.)) import Data.Default.Class import Data.Semigroup import Data.VectorSpace ((^*)) import qualified Data.Map as M import Data.Colour (Colour) import Data.Colour.Names ------------------------------------------------------------ -- Marking the origin ------------------------------------------------------------ -- | Mark the origin of a diagram by placing a red dot 1/50th its size. showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m) => QDiagram b R2 m -> QDiagram b R2 m showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. showOrigin' :: (Renderable (Path R2) b, Backend b R2, Monoid' m) => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m showOrigin' oo d = o <> d where o = stroke (circle sz) # fc (oColor oo) # lw 0 # fmap (const mempty) (w,h) = size2D d ^* oScale oo sz = maximum [w, h, oMinSize oo] data OriginOpts = OriginOpts { oColor :: Colour Double , oScale :: Double , oMinSize :: Double } instance Default OriginOpts where def = OriginOpts red (1/50) 0.001 ------------------------------------------------------------ -- Labeling named points ------------------------------------------------------------ showLabels :: (Renderable Text b, Backend b R2) => QDiagram b R2 m -> QDiagram b R2 Any showLabels d = ( mconcat . map (\(n,p) -> text (show 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 = subMap d diagrams-lib-0.7.1.1/src/Diagrams/CubicSpline/0000755000000000000000000000000012221314077017114 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/CubicSpline/Internal.hs0000644000000000000000000001127112221314077021226 0ustar0000000000000000{-# LANGUAGE TypeFamilies , FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | -- 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 solveTriDiagonal , solveCyclicTriDiagonal , solveCubicSplineDerivatives , solveCubicSplineDerivativesClosed , solveCubicSplineCoefficients ) where import Data.List -- | Solves a system of the form 'A*X=D' for 'x' where 'A' is an -- 'n' by 'n' matrix with 'bs' as the main diagonal and -- 'as' the diagonal below and 'cs' the diagonal above. -- See: solveTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> [a] solveTriDiagonal as (b0:bs) (c0:cs) (d0:ds) = h cs' ds' where cs' = c0 / b0 : f cs' as bs cs f _ [_] _ _ = [] f (c':cs') (a:as) (b:bs) (c:cs) = c / (b - c' * a) : f cs' as bs cs f _ _ _ _ = error "solveTriDiagonal.f: impossible!" ds' = d0 / b0 : g ds' as bs cs' ds g _ [] _ _ _ = [] g (d':ds') (a:as) (b:bs) (c':cs') (d:ds) = (d - d' * a)/(b - c' * a) : g ds' as bs cs' ds g _ _ _ _ _ = error "solveTriDiagonal.g: impossible!" h _ [d] = [d] h (c:cs) (d:ds) = let xs@(x:_) = h cs ds in d - c * x : xs h _ _ = error "solveTriDiagonal.h: impossible!" solveTriDiagonal _ _ _ _ = error "arguments 2,3,4 to solveTriDiagonal must be nonempty" -- Helper that applies the passed function only to the last element of a list modifyLast :: (a -> a) -> [a] -> [a] modifyLast _ [] = [] modifyLast f [a] = [f a] modifyLast f (a:as) = a : modifyLast f as -- Helper that builds a list of length n of the form: '[s,m,m,...,m,m,e]' sparseVector :: Int -> a -> a -> a -> [a] sparseVector n s m e | n < 1 = [] | otherwise = s : h (n - 1) where h 1 = [e] h n = m : h (n - 1) -- | Solves a system similar to the tri-diagonal system using a special case -- of the Sherman-Morrison formula . -- This code is based on /Numerical Recpies in C/'s @cyclic@ function in section 2.7. solveCyclicTriDiagonal :: Fractional a => [a] -> [a] -> [a] -> [a] -> a -> a -> [a] solveCyclicTriDiagonal as (b0:bs) cs ds alpha beta = zipWith ((+) . (fact *)) zs xs where l = length ds gamma = -b0 us = sparseVector l gamma 0 alpha bs' = (b0 - gamma) : modifyLast (subtract (alpha*beta/gamma)) bs xs@(x:_) = solveTriDiagonal as bs' cs ds zs@(z:_) = solveTriDiagonal as bs' cs us fact = -(x + beta * last xs / gamma) / (1.0 + z + beta * last zs / gamma) solveCyclicTriDiagonal _ _ _ _ _ _ = error "second argument to solveCyclicTriDiagonal must be nonempty" -- | 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-0.7.1.1/src/Diagrams/Animation/0000755000000000000000000000000012221314077016633 5ustar0000000000000000diagrams-lib-0.7.1.1/src/Diagrams/Animation/Active.hs0000644000000000000000000000747412221314077020416 0ustar0000000000000000{-# 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 import Control.Applicative (pure, (<$>)) import Diagrams.Align import Diagrams.Core import Diagrams.Path import Diagrams.TrailLike import Data.Active type instance V (Active a) = V 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