diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,211 +0,0 @@ -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: 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: 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 - - - #61: terminology change from "bounds" to "envelope" - + boundary -> envelopeP - + "bounding region" -> "envelope" - + Bounds -> Envelope - + Boundable -> Enveloped - + getBounds -> getEnvelope - + etc. - - - rename AnnDiagram to QDiagram - - - 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 - Doubles, 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 http://patch-tag.com/r/byorgey/diagrams-povray. - - * 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 - diff --git a/CHANGES.markdown b/CHANGES.markdown new file mode 100644 --- /dev/null +++ b/CHANGES.markdown @@ -0,0 +1,279 @@ +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 + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -2,8 +2,10 @@ Peter Hall Claude Heiland-Allen + Deepak Jois Ian Ross Michael Sloan + Jim Snavely Kanchalai Suveepattananont Scott Walck Ryan Yates diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,9 +0,0 @@ -The standard library for diagrams, a Haskell embedded domain-specific -language for compositional, declarative drawing. See - - http://projects.haskell.org/diagrams/ - -for more information about the project, including installation -instructions, tutorials, a user manual, a gallery of example images, -and links to the mailing list, IRC channel, developer wiki and bug -tracker. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,5 @@ +[![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. diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 0.5.0.1 +Version: 0.6 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 @@ -13,19 +13,21 @@ License-file: LICENSE Author: Brent Yorgey Maintainer: diagrams-discuss@googlegroups.com +Bug-reports: http://github.com/diagrams/diagrams-lib/issues Category: Graphics Build-type: Simple Cabal-version: >=1.6 -Extra-source-files: CHANGES, README -Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 +Extra-source-files: CHANGES.markdown, README.markdown +Tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.2, GHC == 7.6.1 Source-repository head - type: darcs - location: http://patch-tag.com/r/byorgey/diagrams-lib + 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.Segment, @@ -42,6 +44,7 @@ Diagrams.TwoD.Transform, Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, + Diagrams.TwoD.Segment, Diagrams.TwoD.Path, Diagrams.TwoD.Polygons, Diagrams.TwoD.Shapes, @@ -57,11 +60,12 @@ Diagrams.Animation.Active, Diagrams.Util, Diagrams.Backend.Show - Build-depends: base >= 4.2 && < 4.6, - containers >= 0.3 && < 0.5, + Build-depends: base >= 4.2 && < 4.7, + containers >= 0.3 && < 0.6, array >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.9, - diagrams-core >= 0.5 && < 0.6, + monoid-extras >= 0.2.2 && < 0.3, + diagrams-core >= 0.6 && < 0.7, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, NumInstances >= 1.0 && < 1.1, diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -31,7 +31,7 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Data.VectorSpace import Data.AffineSpace (alerp) diff --git a/src/Diagrams/Animation.hs b/src/Diagrams/Animation.hs --- a/src/Diagrams/Animation.hs +++ b/src/Diagrams/Animation.hs @@ -29,7 +29,7 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.Combinators import Diagrams.Animation.Active () @@ -41,9 +41,9 @@ import Data.Active import Data.Semigroup -import Data.VectorSpace - 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 @@ -119,7 +119,8 @@ -- accurate but slower. animRect' :: (PathLike p, Enveloped p, Transformable p, V p ~ R2) => Rational -> QAnimation b R2 m -> p -animRect' r = maybe (rect 1 1) (`boxFit` rect 1 1) - . unions - . map boundingBox - . simulate r +animRect' r anim + | null results = rect 1 1 + | otherwise = boxFit (foldMap boundingBox results) (rect 1 1) + where + results = simulate r anim diff --git a/src/Diagrams/Animation/Active.hs b/src/Diagrams/Animation/Active.hs --- a/src/Diagrams/Animation/Active.hs +++ b/src/Diagrams/Animation/Active.hs @@ -38,7 +38,7 @@ module Diagrams.Animation.Active where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Control.Applicative ((<$>), pure) import Diagrams.Align diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -32,7 +32,7 @@ , LineColor, getLineColor, lineColor, lc, lcA -- ** Fill color - , FillColor, getFillColor, fillColor, fc, fcA + , FillColor, getFillColor, recommendFillColor, fillColor, fc, fcA -- ** Opacity , Opacity, getOpacity, opacity @@ -52,14 +52,15 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core -import Data.Colour +import Data.Colour import qualified Data.Colour.SRGB as RGB -import Data.Typeable +import Data.Typeable -import Data.Semigroup +import Data.Monoid.Recommend +import Data.Semigroup ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -121,7 +122,7 @@ -- . '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 (Last SomeColor) +newtype FillColor = FillColor (Recommend (Last SomeColor)) deriving (Typeable, Semigroup) instance AttributeClass FillColor @@ -130,10 +131,15 @@ -- 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 . Last . SomeColor +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 (Last c)) = c +getFillColor (FillColor c) = getLast . getRecommend $ c -- | A synonym for 'fillColor', specialized to @'Colour' Double@ -- (i.e. opaque colors). @@ -168,7 +174,7 @@ colorToRGBA (LineColor (Last c)) = colorToRGBA c instance Color FillColor where - colorToRGBA (FillColor (Last c)) = colorToRGBA c + colorToRGBA (FillColor c) = colorToRGBA . getLast . getRecommend $ c alphaToColour :: (Floating a, Ord a, Fractional a) => AlphaColour a -> Colour a alphaToColour ac | alphaChannel ac == 0 = ac `over` black @@ -238,7 +244,7 @@ deriving (Eq,Show,Typeable) newtype LineCapA = LineCapA (Last LineCap) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq) instance AttributeClass LineCapA getLineCap :: LineCapA -> LineCap @@ -258,7 +264,7 @@ deriving (Eq,Show,Typeable) newtype LineJoinA = LineJoinA (Last LineJoin) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq) instance AttributeClass LineJoinA getLineJoin :: LineJoinA -> LineJoin @@ -270,10 +276,10 @@ -- | Create lines that are dashing... er, dashed. data Dashing = Dashing [Double] Double - deriving Typeable + deriving (Typeable, Eq) newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq) instance AttributeClass DashingA getDashing :: DashingA -> Dashing diff --git a/src/Diagrams/BoundingBox.hs b/src/Diagrams/BoundingBox.hs --- a/src/Diagrams/BoundingBox.hs +++ b/src/Diagrams/BoundingBox.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DeriveDataTypeable , DeriveFunctor , FlexibleContexts + , GeneralizedNewtypeDeriving , NoMonomorphismRestriction , ScopedTypeVariables + , StandaloneDeriving , TypeFamilies , UndecidableInstances #-} @@ -13,7 +15,11 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Definitions and functions for working with bounding boxes. +-- 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. -- ----------------------------------------------------------------------------- @@ -22,201 +28,267 @@ BoundingBox() -- * Constructing bounding boxes - , fromCorners, fromPoint, fromPoints + , 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, unions, intersections + , union, intersection ) where -import Control.Applicative ((<*>)) +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 (fromJust) +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 Graphics.Rendering.Diagrams.Points (Point(..)) -import Graphics.Rendering.Diagrams.HasOrigin (HasOrigin(..)) -import Graphics.Rendering.Diagrams.Envelope (Enveloped(..), envelopeP) -import Graphics.Rendering.Diagrams.V (V) -import Graphics.Rendering.Diagrams.Transform +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, (<->)) --- | A bounding box is an axis-aligned region determined --- by two points indicating its \"lower\" and \"upper\" corners. -data BoundingBox v = BoundingBox (Point v) (Point v) - deriving (Show, Read, Eq, Data, Typeable, Functor) +-- 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 -instance VectorSpace v => HasOrigin (BoundingBox v) where - moveOriginTo p (BoundingBox p1 p2) = BoundingBox (moveOriginTo p p1) - (moveOriginTo p p2) +-- 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 ( InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup (Scalar v) - , HasBasis v, Ord (Basis v) +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 --- | Create a bounding box from any two opposite corners. +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 u v = BoundingBox (toPoint (combineP min u v)) - (toPoint (combineP max u 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 = BoundingBox p p +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] -> Maybe (BoundingBox v) -fromPoints = unions . map fromPoint + => [Point v] -> BoundingBox v +fromPoints = mconcat . map fromPoint --- | Create a bounding box for any boundable object (such as a diagram or path). -boundingBox :: forall a. (Enveloped a, HasBasis (V a), Ord (Basis (V a))) - => a -> BoundingBox (V a) -boundingBox a = fromJust . fromPoints . map (`envelopeP` a) $ [id, negateV] <*> units - where units = map (basisValue . fst) (decompose (zeroV :: V a)) +-- | 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) --- | Gets the lower and upper corners that define the bounding box. -getCorners :: BoundingBox v -> (Point v, Point v) -getCorners (BoundingBox l u) = (l, u) +-- | Queries whether the BoundingBox is empty. +isEmptyBox :: BoundingBox v -> Bool +isEmptyBox (BoundingBox (Option Nothing)) = True +isEmptyBox _ = False -{- -Ord (Data.Basis.Basis b), - Data.AdditiveGroup.AdditiveGroup (Data.VectorSpace.Scalar b), - Data.Basis.HasBasis b, - Data.Basis.HasBasis v, - Data.Basis.Basis v ~ Data.Basis.Basis b, - Data.VectorSpace.Scalar v ~ Data.VectorSpace.Scalar b) => --} +-- | 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 l u) +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, (x, y)) -> [(b, x), (b, y)]) - . toList $ combineP (,) l u + . 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 lesser to the greater --- point. +-- | 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 (BoundingBox (P l) (P h)) = h ^-^ l +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 -> Transformation v -boxTransform a@(BoundingBox (P l1) _) b@(BoundingBox (P l2) _) - = Transformation s s (l2 ^-^ boxTrans a b l1) - where - s = boxTrans a b <-> boxTrans b a - boxTrans b1 b2 = vcombineV (*) (vcombineV (/) (boxExtents b2) (boxExtents b1)) - vcombineV f x = toVector . combineV f x + => 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 a boundable thing to fit within a @BoundingBox@. -boxFit :: (Enveloped a, Transformable a, Ord (Basis (V a))) +-- | 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 = transform (boxTransform (boundingBox x) b) x +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 (BoundingBox l h) p = F.and (combineP (<=) l p) - && F.and (combineP (<=) p h) +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' (BoundingBox l h) p = F.and (combineP (< ) l p) - && F.and (combineP (< ) p h) - --- | Compute the smallest bounding box containing all the given --- bounding boxes (or @Nothing@ if the list is empty). -unions - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => [BoundingBox v] -> Maybe (BoundingBox v) -unions [] = Nothing -unions ps = Just . foldr1 union $ ps - --- | Compute the largest bounding box contained in all the given --- bounding boxes (or @Nothing@ is the list is empty). -intersections - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) - => [BoundingBox v] -> Maybe (BoundingBox v) -intersections [] = Nothing -intersections ps = foldr1 ((join .) . liftM2 intersection) (map Just ps) +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 (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (<=) uh vh) - && F.and (combineP (>=) ul vl) +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' (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (< ) uh vh) - && F.and (combineP (> ) ul vl) +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 (BoundingBox ul uh) (BoundingBox vl vh) = F.or (combineP (<=) uh vl) - || F.or (combineP (>=) ul vh) +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' (BoundingBox ul uh) (BoundingBox vl vh) = F.or (combineP (< ) uh vl) - || F.or (combineP (> ) ul vh) +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 -> Maybe (BoundingBox v) -intersection u@(BoundingBox ul uh) v@(BoundingBox vl vh) - | u `outside'` v = Nothing - | otherwise = Just (fromCorners (toPoint (combineP max ul vl)) (toPoint (combineP min uh vh))) - --- | Form the smallest bounding box containing the given two bounding boxes. -union - :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v)) => BoundingBox v -> BoundingBox v -> BoundingBox v -union (BoundingBox ul uh) (BoundingBox vl vh) = BoundingBox (toPoint (combineP min ul vl)) (toPoint (combineP max uh vh)) +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 diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -16,10 +16,10 @@ module Diagrams.Combinators ( -- * Unary operations - withEnvelope + withEnvelope, withTrace , phantom, strut - , pad + , extrudeEnvelope, intrudeEnvelope -- * Binary operations , beneath @@ -32,7 +32,7 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.Segment (Segment(..)) import Diagrams.Path @@ -51,14 +51,20 @@ -- | Use the envelope from some object as the envelope for a -- diagram, in place of the diagram's default envelope. -withEnvelope :: (Backend b (V a), Enveloped a, Monoid' m) +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 as @x@ but produces no output. -phantom :: (Backend b (V a), Enveloped a, Monoid' m) => a -> QDiagram b (V a) m -phantom a = mkQD nullPrim (getEnvelope a) mempty mempty +-- 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). @@ -74,15 +80,68 @@ -- | @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. --- Useful for manually creating separation between two diagrams. +-- 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 = phantom . translate ((-0.5) *^ v) . getEnvelope $ Linear v +strut v = mkQD nullPrim env mempty mempty mempty + where env = translate ((-0.5) *^ v) . getEnvelope $ Linear 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 ------------------------------------------------------------ @@ -94,6 +153,8 @@ => 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 @@ -244,8 +305,8 @@ => 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 = withLength s (negateV v) + vs = s *^ normalized (negateV v) cat' v (CatOpts { catMethod = Distrib, sep = s }) = - decorateTrail . fromOffsets . repeat $ withLength s v + decorateTrail . fromOffsets . repeat $ s *^ normalized v -- infinite trail, no problem for Haskell =D diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Coordinates.hs @@ -0,0 +1,87 @@ +{-# 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. +-- +----------------------------------------------------------------------------- + +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 diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -25,8 +25,8 @@ import Diagrams.CubicSpline.Internal -import Graphics.Rendering.Diagrams -import Graphics.Rendering.Diagrams.Points +import Diagrams.Core +import Diagrams.Core.Points import Diagrams.Segment import Diagrams.Path diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -59,7 +59,7 @@ , pathVertices , pathOffsets , pathCentroid - , expandPath + , scalePath , reversePath , fixPath @@ -71,8 +71,8 @@ ) where -import Graphics.Rendering.Diagrams -import Graphics.Rendering.Diagrams.Points +import Diagrams.Core +import Diagrams.Core.Points import Diagrams.Align import Diagrams.Segment @@ -193,10 +193,23 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Trail v) where getEnvelope (Trail segs _) = - foldr (\seg bds -> moveOriginTo (P . negateV . segOffset $ seg) bds <> getEnvelope seg) + foldr (\seg bds -> moveOriginBy (negateV . segOffset $ seg) bds <> getEnvelope seg) mempty segs + -- XXX can we improve the efficiency of the above? E.g. note the + -- last segment in each trail ends up getting translated O(n) times, + -- so overall we do O(n^2) work! (to find the max over the bounds + -- for O(n) segments, where the ith segment requires working through + -- a stack of i translations...) + -- + -- The idea would be to first convert to a list of FixedSegments (to + -- cache the translation work) then take the bounds of those. + -- + -- Also, use a balanced fold! + -- + -- Need to make some benchmarks I guess. + instance HasLinearMap v => Renderable (Trail v) NullBackend where render _ _ = mempty @@ -248,7 +261,7 @@ addClosingSegment :: AdditiveGroup v => Trail v -> Trail v addClosingSegment t | isClosed t = Trail (trailSegments t ++ [closeSeg]) False | otherwise = t - where closeSeg = Linear . negateV $ trailOffset t + where closeSeg = Linear . negateV $ trailOffset t -- | Convert a starting point and a trail into a list of fixed segments. fixTrail :: AdditiveGroup v => Point v -> Trail v -> [FixedSegment v] @@ -340,9 +353,9 @@ -- | Scale a path using its centroid (see 'pathCentroid') as the base -- point for the scale. -expandPath :: (HasLinearMap v, VectorSpace v, Fractional (Scalar v), Eq (Scalar v)) - => Scalar v -> Path v -> Path v -expandPath d p = (scale d `under` translation (origin .-. pathCentroid p)) p +scalePath :: (HasLinearMap v, VectorSpace v, Fractional (Scalar v), Eq (Scalar v)) + => Scalar v -> Path v -> Path v +scalePath d p = (scale d `under` translation (origin .-. pathCentroid p)) p -- | Reverse the direction of all the component trails of a path. reversePath :: AdditiveGroup v => Path v -> Path v diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts - #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -17,7 +17,8 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Coordinates +import Diagrams.Core.Points import Control.Newtype @@ -28,3 +29,11 @@ -- | 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 diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -16,9 +16,14 @@ -- * Core library -- | The core definitions of transformations, diagrams, -- backends, and so on. - module Graphics.Rendering.Diagrams + module Diagrams.Core -- * Standard library + + -- | Nice syntax for constructing and pattern-matching + -- literal points and vectors. + , module Diagrams.Coordinates + -- | Attributes (color, line style, etc.) and styles. , module Diagrams.Attributes @@ -57,6 +62,8 @@ , 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 @@ -73,24 +80,25 @@ , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core -import Diagrams.Attributes import Diagrams.Align +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.BoundingBox import Diagrams.Combinators -import Diagrams.Segment -import Diagrams.Path +import Diagrams.Coordinates import Diagrams.CubicSpline +import Diagrams.Path +import Diagrams.Segment import Diagrams.Transform -import Diagrams.BoundingBox import Diagrams.TwoD -import Diagrams.Animation import Diagrams.Util +import Data.Colour hiding (atop, AffineSpace(..)) import Data.Colour.Names import Data.Semigroup import Data.VectorSpace hiding (Sum(..)) import Data.AffineSpace import Data.Active import Control.Applicative - diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -47,12 +47,12 @@ -- * Fixed (absolutely located) segments , FixedSegment(..) - , mkFixedSeg + , mkFixedSeg, fromFixedSeg , fAtParam ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.Solve import Diagrams.Util @@ -285,8 +285,8 @@ -- performed; see 'AdjustOpts'. adjustSegment :: (InnerSpace v, OrderedField (Scalar v)) => Segment v -> AdjustOpts v -> Segment v -adjustSegment s opts = adjustSegmentToParams s - (if adjSide opts == End then 0 else getParam s) +adjustSegment s opts = adjustSegmentToParams s + (if adjSide opts == End then 0 else getParam s) (if adjSide opts == Start then 0 else 1 - getParam (reverseSegment s)) where getParam seg = case adjMethod opts of @@ -319,27 +319,49 @@ 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) + 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) + moveOriginTo o (FLinear p1 p2) + = FLinear + (moveOriginTo o p1) + (moveOriginTo o p2) --- instance Enveloped (FixedSegment v) where - -- XXX write me + 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) = 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 starting point and a 'Segment'. mkFixedSeg :: AdditiveGroup v => Point v -> Segment v -> FixedSegment v mkFixedSeg p (Linear v) = FLinear p (p .+^ v) mkFixedSeg p (Cubic c1 c2 x2) = FCubic p (p .+^ c1) (p .+^ c2) (p .+^ x2) + +-- | Decompose a 'FixedSegment' into a starting point and a 'Segment'. +fromFixedSeg :: AdditiveGroup v => FixedSegment v -> (Point v, Segment v) +fromFixedSeg (FLinear p1 p2) = (p1, Linear (p2 .-. p1)) +fromFixedSeg (FCubic x1 c1 c2 x2) = (x1, Cubic (c1 .-. x1) (c2 .-. x1) (x2 .-. x1)) -- | Compute the point on a fixed segment at a given parameter. A -- parameter of 0 corresponds to the starting point and 1 corresponds diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies , FlexibleContexts + , MultiParamTypeClasses , ViewPatterns #-} ----------------------------------------------------------------------------- @@ -19,12 +20,18 @@ , sphere ) where -import Graphics.Rendering.Diagrams +import Prelude hiding (minimum) +import Data.Semigroup -import Diagrams.ThreeD.Types +import Data.AffineSpace +import Data.Monoid.PosInf (minimum) +import Data.VectorSpace -import Data.Semigroup +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.Solve + data Ellipsoid = Ellipsoid T3 type instance V Ellipsoid = R3 @@ -32,10 +39,19 @@ instance Transformable Ellipsoid where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) +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 (unr3 -> (x,y,z)) = 1 / sqrt(x*x + y*y + z*z) - sphereQuery (unp3 -> (x,y,z)) = Any $ x*x + y*y + z*z <= 1 + 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 diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE TypeSynonymInstances - , FlexibleInstances - , TypeFamilies - , ViewPatterns - , MultiParamTypeClasses - , GeneralizedNewtypeDeriving - #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -26,7 +27,9 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Coordinates +import Diagrams.TwoD.Types +import Diagrams.Core import Control.Newtype @@ -66,6 +69,14 @@ 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 diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -14,7 +14,7 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Data.Semigroup -- | Conjugate one transformation by another. @conjugate t1 t2@ is the diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -87,6 +87,8 @@ , ellipse , ellipseXY , arc + , arc' + , arcCW , wedge -- ** General polygons @@ -147,14 +149,23 @@ , 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 @@ -162,12 +173,15 @@ -- * Size -- ** Computing size - , width, height, size2D + , width, height, size2D, sizeSpec2D , extentX, extentY, center2D -- ** Specifying size , SizeSpec2D(..) , mkSizeSpec + + -- ** Adjusting size + , sized, sizedAs -- * Visual aids for understanding the internal model , showOrigin diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -13,61 +13,58 @@ -- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Adjust ( - adjustDia2D - , adjustSize - , requiredScale - ) where +module Diagrams.TwoD.Adjust + ( + setDefault2DAttributes + , adjustDiaSize2D + , adjustDia2D + , adjustSize -- for backwards compatibility + , requiredScale -- re-exported for backwards compatibility + ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.Attributes (lw, lc) import Diagrams.Util ((#)) import Diagrams.TwoD.Types (R2, p2) -import Diagrams.TwoD.Size (size2D, center2D, SizeSpec2D(..)) +import Diagrams.TwoD.Size ( size2D, center2D, SizeSpec2D(..) + , requiredScaleT, requiredScale + ) import Diagrams.TwoD.Text (fontSize) import Data.AffineSpace ((.-.)) +import Data.Semigroup import Data.Colour.Names (black) --- | @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 some default attributes (in case they have not been set): +-- | Set default attributes of a 2D diagram (in case they have not +-- been set): -- -- * Line width 0.01 -- -- * Line color black -- -- * Font size 1 --- --- * Freeze the diagram in its final form --- --- * Scale and translate the diagram to fit within the requested size --- --- * Also return the actual adjusted size of the diagram. +setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m +setDefault2DAttributes d = d # lw 0.01 # lc black # fontSize 1 --- XXX should split out the attribute-setting into a separate function. -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 _ opts d = +-- | 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 # lw 0.01 # lc black # fontSize 1 # freeze - # scale s + , d # scale s # translate tr ) where spec = getSize opts @@ -78,29 +75,33 @@ _ -> scale s size tr = (0.5 *. p2 finalSz) .-. (s *. center2D d) --- | @adjustSize spec sz@ returns a transformation (a uniform scale) --- which can be applied to something of size @sz@ to make it the --- requested size @spec@. -adjustSize :: SizeSpec2D -> (Double, Double) -> Transformation R2 -adjustSize spec size = scaling (requiredScale spec size) +-- | @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) --- | @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' +{-# DEPRECATED adjustSize "Use Diagrams.TwoD.Size.requiredScaleT instead." #-} +-- | Re-export 'requiredScaleT' with the name 'adjustSize' for +-- backwards compatibility. +adjustSize :: SizeSpec2D -> (Double, Double) -> Transformation R2 +adjustSize = requiredScaleT diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -34,7 +34,7 @@ ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -14,20 +14,22 @@ module Diagrams.TwoD.Arc ( arc + , arc' + , arcCW , arcT , bezierFromSweep , wedge ) where -import Graphics.Rendering.Diagrams - -import Diagrams.TwoD.Types -import Diagrams.TwoD.Transform -import Diagrams.TwoD.Vector (unitX, e) +import Diagrams.Core +import Diagrams.Coordinates import Diagrams.Path import Diagrams.Segment +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (unitX, e) import Diagrams.Util ((#), tau) import Data.Semigroup ((<>)) @@ -42,10 +44,10 @@ -- quadrant. bezierFromSweepQ1 :: Rad -> Segment R2 bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ Cubic c2 c1 p0 - where p0@(unr2 -> (x,y)) = rotate (s/2) v - c1 = r2 ((4-x)/3, (1-x)*(3-x)/(3*y)) - c2 = reflectY c1 - v = unitX + 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 @@ -82,17 +84,51 @@ 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 = Trail bs (sweep >= tau) +arcT start end + | e < s = arcT s (e + fromIntegral d) + | otherwise = Trail bs (sweep >= tau) 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 :: CircleFrac + 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, PathLike p, V p ~ R2) => a -> a -> p arc start end = pathLike (rotate start $ p2 (1,0)) False (trailSegments $ arcT start end) + +-- | Like 'arc' but clockwise. +arcCW :: (Angle a, PathLike p, V p ~ R2) => a -> a -> p +arcCW start end = pathLike (rotate start $ p2 (1,0)) + False + -- flipped arguments to get the path we want + -- then reverse the trail to get the cw direction. + (trailSegments . reverseTrail $ arcT end start) + -- We could just have `arcCW = reversePath . flip arc` + -- but that wouldn't be `PathLike`. + +-- | 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, PathLike p, V p ~ R2) => Double -> a -> a -> p +arc' r start end = pathLike (rotate start $ p2 (abs r,0)) + False + (trailSegments . scale (abs r) $ ts) + 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. diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -25,30 +25,42 @@ , vcat, vcat' -- * Spacing/envelopes + , strutR2 , strutX, strutY , padX, padY + , extrudeLeft, extrudeRight, extrudeBottom, extrudeTop + , view + , boundingRect, bg + ) where -import Graphics.Rendering.Diagrams +import Data.AffineSpace +import Data.Colour +import Data.Default +import Data.Semigroup +import Data.VectorSpace +import Diagrams.Core + +import Diagrams.Attributes (lw, fc) +import Diagrams.BoundingBox +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.Path +import Diagrams.Segment +import Diagrams.TwoD.Align +import Diagrams.TwoD.Path () -- for PathLike (D R2) instance +import Diagrams.TwoD.Segment +import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unitY, fromDirection) -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Align -import Diagrams.TwoD.Path () -- for PathLike (D R2) instance - import Diagrams.Util ((#)) -import Diagrams.Combinators -import Data.VectorSpace -import Data.Semigroup -import Data.Default - infixl 6 === infixl 6 ||| @@ -128,17 +140,28 @@ => 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 d@ is an empty diagram with width @d@, 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 (r2 (d,0)) +strutX d = strut (d & 0) -- | @strutY d@ is an empty diagram with height @d@, width 0, and a --- centered local origin. Note that @strutY (-w)@ behaves the same as --- @strutY w@. +-- 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 (r2 (0,d)) +strutY d = strut (0 & d) -- | @padX s@ \"pads\" a diagram in the x-direction, expanding its -- envelope horizontally by a factor of @s@ (factors between 0 and 1 @@ -162,6 +185,42 @@ => 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 @@ -169,4 +228,17 @@ -- 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 (unr2 -> (w,h)) = withEnvelope (rect w h # alignBL # moveTo p :: D R2) +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 p, Transformable p, PathLike p, V p ~ R2 + , Enveloped a, V a ~ R2 + ) + => a -> p +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 diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -23,7 +23,7 @@ , ellipseXY ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Transform diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -19,7 +19,7 @@ , image ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.Path import Diagrams.TwoD.Types @@ -59,6 +59,7 @@ 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 diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -19,8 +19,8 @@ , showLabels ) where -import Graphics.Rendering.Diagrams -import Graphics.Rendering.Diagrams.Names +import Diagrams.Core +import Diagrams.Core.Names import Diagrams.Path @@ -50,7 +50,7 @@ -- | 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 +showOrigin = showOrigin' def -- | Mark the origin of a diagram, with control over colour and scale -- of marker dot. @@ -79,7 +79,7 @@ showLabels :: (Renderable Text b, Backend b R2) => QDiagram b R2 m -> QDiagram b R2 Any -showLabels d = +showLabels d = ( mconcat . map (\(n,p) -> text (show n) # translate (p .-. origin)) . concatMap (\(n,ps) -> zip (repeat n) ps) @@ -89,15 +89,4 @@ ) <> fmap (const (Any False)) d where - NameMap m = names d - --- XXX finish: - --- Draw the separating lines between diagrams composed with 'beside' --- (or any combinators implemented in terms of 'beside', like '(|||)' --- or '(===)'). - --- showSep :: QDiagram b R2 m -> QDiagram b R2 m --- showSep d = s <> d --- where ... = case d of --- QDiagram (Branch u ds children) -> ... + SubMap m = subMap d diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -15,7 +15,8 @@ -- -- 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. +-- intersection and union. They also have a trace, whereas paths in +-- higher dimensions do not. -- ----------------------------------------------------------------------------- @@ -39,25 +40,44 @@ , Clip(..), clipBy ) where -import Graphics.Rendering.Diagrams +import Control.Applicative (liftA2) +import qualified Data.Foldable as F +import Data.Semigroup +import Data.Typeable -import Diagrams.Util (tau) +import Data.AffineSpace +import Data.Default +import Data.VectorSpace -import Diagrams.Segment -import Diagrams.Path -import Diagrams.TwoD.Types -import Diagrams.Solve +import Diagrams.Core -import Data.AffineSpace -import Data.VectorSpace +import Diagrams.Coordinates +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.TwoD.Segment +import Diagrams.TwoD.Types +import Diagrams.Util (tau) -import Data.Semigroup hiding ((<>)) -import Control.Applicative (liftA2) -import qualified Data.Foldable as F -import Data.Default +------------------------------------------------------------ +-- Trail and path traces --------------------------------- +------------------------------------------------------------ -import Data.Typeable +-- 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 t = case addClosingSegment t of + (Trail segs _) -> + foldr (\seg bds -> moveOriginBy (negateV . segOffset $ seg) bds <> getTrace seg) + mempty + segs + +instance Traced (Path R2) where + getTrace = F.foldMap trailTrace . pathTrails + where trailTrace (p, t) = moveOriginTo ((-1) *. p) (getTrace t) + ------------------------------------------------------------ -- Constructing path-based diagrams ---------------------- ------------------------------------------------------------ @@ -90,8 +110,10 @@ stroke' opts p = mkQD (Prim p) (getEnvelope p) + (getTrace p) (fromNames . concat $ - zipWith zip (vertexNames opts) (pathVertices p)) + 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. @@ -165,6 +187,7 @@ -- direction crosses the path an odd number -- of times. See -- . + deriving (Eq) runFillRule :: FillRule -> P2 -> Path R2 -> Bool runFillRule Winding = isInsideWinding @@ -184,7 +207,7 @@ fillRule = applyAttr . FillRuleA . Last cross :: R2 -> R2 -> Double -cross (unr2 -> (x,y)) (unr2 -> (x',y')) = x * y' - y * x' +cross (coords -> x :& y) (coords -> x' :& y') = x * y' - y * x' -- XXX link to more info on this diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | --- Module : Diagrams.TwoD.Polygon +-- Module : Diagrams.TwoD.Polygons -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com @@ -39,6 +39,7 @@ , star -- ** Function graphs + -- $graphs , GraphPart(..) , orbits, mkGraph @@ -58,7 +59,7 @@ import Data.VectorSpace (magnitude, normalized, project, (<.>), (^*)) import Data.Default -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Transform @@ -224,11 +225,16 @@ -- Function graphs ------------------------------------------------------------ --- | Pieces of a function graph can either be cycles or "hairs". +-- $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 diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Segment.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleContexts + , FlexibleInstances + , 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.PosInf hiding (minimum) +import Data.VectorSpace + +import Diagrams.Core +import Diagrams.Core.Trace + +import Diagrams.Segment +import Diagrams.Solve +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector +import Diagrams.Util + +instance Traced (Segment R2) where + getTrace = getTrace . mkFixedSeg 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 PosInfty + 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 . fAtParam bez') ts + in + case xs of + [] -> PosInfty + _ -> Finite (minimum xs) + diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -44,14 +44,15 @@ , roundedRect' ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core -import Diagrams.Segment +import Diagrams.Coordinates import Diagrams.Path +import Diagrams.Segment import Diagrams.TwoD.Arc -import Diagrams.TwoD.Types -import Diagrams.TwoD.Transform import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Transform +import Diagrams.TwoD.Types import Diagrams.Util @@ -60,19 +61,19 @@ -- | Create a centered horizontal (L-R) line of the given length. hrule :: (PathLike p, V p ~ R2) => Double -> p -hrule d = pathLike (p2 (-d/2,0)) False [Linear (r2 (d,0))] +hrule d = pathLike (p2 (-d/2,0)) False [Linear (d & 0)] -- | Create a centered vertical (T-B) line of the given length. vrule :: (PathLike p, V p ~ R2) => Double -> p -vrule d = pathLike (p2 (0,d/2)) False [Linear (r2 (0,-d))] +vrule d = pathLike (p2 (0,d/2)) False [Linear (0 & (-d))] --- | A sqaure with its center at the origin and sides of length 1, +-- | A square with its center at the origin and sides of length 1, -- oriented parallel to the axes. unitSquare :: (PathLike p, V p ~ R2) => p unitSquare = polygon with { polyType = PolyRegular 4 (sqrt 2 / 2) , polyOrient = OrientH } --- | A sqaure with its center at the origin and sides of the given +-- | A square with its center at the origin and sides of the given -- length, oriented parallel to the axes. square :: (PathLike p, Transformable p, V p ~ R2) => Double -> p square d = unitSquare # scale d @@ -204,7 +205,7 @@ mkCorner k r | r == 0 = mempty | r < 0 = doArc 3 2 | otherwise = doArc 0 1 - where doArc d d' = arc ((k+d)/4) ((k+d')/4:: CircleFrac) # scale (abs r) + where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: CircleFrac) data RoundedRectOpts = RoundedRectOpts { radiusTL :: Double , radiusTR :: Double diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -15,15 +15,20 @@ ( -- * Size and extent of diagrams in R2 -- ** Computing sizes - width, height, size2D + width, height, size2D, sizeSpec2D , extentX, extentY, center2D -- ** Specifying sizes , SizeSpec2D(..) , mkSizeSpec + + , requiredScaleT, requiredScale + + -- ** Changing the size of things + , sized, sizedAs ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Diagrams.TwoD.Types import Diagrams.TwoD.Vector @@ -46,6 +51,10 @@ 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. @@ -91,3 +100,44 @@ 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) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -31,14 +31,16 @@ , FontWeight(..), FontWeightA, getFontWeight, fontWeight, bold ) where -import Graphics.Rendering.Diagrams - +import Diagrams.Attributes +import Diagrams.Core import Diagrams.TwoD.Types import Data.AffineSpace ((.-.)) import Data.Semigroup +import Data.Colour + import Data.Typeable ------------------------------------------------------------ @@ -66,23 +68,25 @@ data TextAlignment = BaselineText | BoxAlignedText Double Double mkText :: Renderable Text b => TextAlignment -> String -> Diagram b R2 -mkText a t = mkQD (Prim (Text mempty a t)) +mkText a t = recommendFillColor black + $ mkQD (Prim (Text mempty a t)) mempty mempty mempty + mempty -- | Create a primitive text diagram from the given string, with center --- alignment, equivalent to @alignedText 0.5 0.5@. --- +-- 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.5 0.5@. --- +-- 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 @@ -91,7 +95,7 @@ -- 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. -- @@ -103,7 +107,7 @@ -- 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 @@ -118,7 +122,7 @@ -- | The @Font@ attribute specifies the name of a font family. Inner -- @Font@ attributes override outer ones. newtype Font = Font (Last String) - deriving (Typeable, Semigroup) + deriving (Typeable, Semigroup, Eq) instance AttributeClass Font -- | Extract the font family name from a @Font@ attribute. @@ -136,7 +140,7 @@ -- 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) + deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSize -- | Extract the size from a @FontSize@ attribute. @@ -155,12 +159,13 @@ 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) + deriving (Typeable, Semigroup, Eq) instance AttributeClass FontSlantA -- | Extract the font slant from a 'FontSlantA' attribute. @@ -186,12 +191,13 @@ 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) + deriving (Typeable, Semigroup, Eq) instance AttributeClass FontWeightA -- | Extract the font weight from a 'FontWeightA' attribute. diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts + , FlexibleInstances , TypeFamilies , ViewPatterns #-} @@ -44,16 +45,20 @@ , shearingX, shearX , shearingY, shearY + -- * Scale invariance + , ScaleInv(..), scaleInv + ) where -import Graphics.Rendering.Diagrams +import Diagrams.Core import Control.Newtype (over) -import Diagrams.TwoD.Types +import Diagrams.Coordinates +import Diagrams.Transform import Diagrams.TwoD.Size (width, height) +import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction) -import Diagrams.Transform import Data.Semigroup @@ -63,21 +68,23 @@ -- Rotation ------------------------------------------------ --- | Create a transformation which performs a rotation by the given --- angle. See also 'rotate'. +-- | 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 (unr2 -> (x,y)) = r2 (cos th * x - sin th * y, sin th * x + cos th * y) + rot th (coords -> x :& y) = (cos th * x - sin th * y) & (sin th * x + cos th * y) --- | Rotate 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 :: 'CircleFrac')@, @rotate (tau\/4 :: 'Rad')@, and --- @rotate (90 :: 'Deg')@ all represent the same transformation, namely, --- a counterclockwise rotation by a right angle. +-- | 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 :: +-- 'CircleFrac')@, @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 @@ -157,7 +164,7 @@ -- | Construct a transformation which translates by the given distance -- in the x (horizontal) direction. translationX :: Double -> T2 -translationX x = translation (r2 (x,0)) +translationX x = translation (x & 0) -- | Translate a diagram by the given distance in the x (horizontal) -- direction. @@ -167,7 +174,7 @@ -- | Construct a transformation which translates by the given distance -- in the y (vertical) direction. translationY :: Double -> T2 -translationY y = translation (r2 (0,y)) +translationY y = translation (0 & y) -- | Translate a diagram by the given distance in the y (vertical) -- direction. @@ -238,3 +245,66 @@ shearY :: (Transformable t, V t ~ R2) => Double -> t -> t shearY = transform . shearingY + +-- Scale invariance ---------------------------------------- + +-- XXX what about freezing? Doesn't interact with ScaleInv the way it +-- ought. + +-- | 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. +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) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TypeFamilies - , TypeSynonymInstances - , FlexibleInstances - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , ViewPatterns - , DeriveDataTypeable - #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -30,8 +31,9 @@ , fullCircle, convertAngle ) where -import Graphics.Rendering.Diagrams +import Diagrams.Coordinates import Diagrams.Util (tau) +import Diagrams.Core import Control.Newtype @@ -47,27 +49,55 @@ -- | The two-dimensional Euclidean vector space R^2. This type is -- intentionally abstract. -- --- * To construct a vector, use 'r2'. +-- * To construct a vector, use 'r2', or '&' (from "Diagrams.Coordinates"): -- +-- > r2 (3,4) :: R2 +-- > 3 & 4 :: R2 +-- -- * To construct the vector from the origin to a point @p@, use --- @p .-. origin@. +-- @p 'Data.AffineSpace..-.' 'origin'@. -- -- * To convert a vector @v@ into the point obtained by following --- @v@ from the origin, use @'origin' '.+^' v@. +-- @v@ from the origin, use @'origin' 'Data.AffineSpace..+^' v@. -- --- * To convert a vector back into a pair of components, use 'unv2'. +-- * 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, Show, Read, Typeable, Num, Fractional) + 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. +-- | 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. +-- | Convert a 2D vector back into a pair of components. See also 'coords'. unr2 :: R2 -> (Double, Double) unr2 = unpack @@ -86,23 +116,40 @@ 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'. +-- * To construct a point, use 'p2', or '&' (see +-- "Diagrams.Coordinates"): -- --- * To construct a point from a vector @v@, use @origin .+^ v@. +-- > 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 '.-.' 'origin'@. +-- use @p 'Data.AffineSpace..-.' 'origin'@. -- --- * To convert a point back into a pair of coordinates, use 'unp2'. +-- * 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. +-- | 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. +-- | Convert a 2D point back into a pair of coordinates. See also 'coords'. unp2 :: P2 -> (Double, Double) unp2 = unpack . unpack @@ -116,7 +163,7 @@ -- Angles -- | Newtype wrapper used to represent angles as fractions of a --- circle. For example, 1/3 = tau/3 radians = 120 degrees. +-- circle. For example, 1\/3 = tau\/3 radians = 120 degrees. newtype CircleFrac = CircleFrac { getCircleFrac :: Double } deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac) diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -20,33 +20,34 @@ , direction, fromDirection, e ) where +import Diagrams.Coordinates import Diagrams.TwoD.Types -- | The unit vector in the positive X direction. unitX :: R2 -unitX = r2 (1,0) +unitX = 1 & 0 -- | The unit vector in the positive Y direction. unitY :: R2 -unitY = r2 (0,1) +unitY = 0 & 1 -- | The unit vector in the negative X direction. unit_X :: R2 -unit_X = r2 (-1,0) +unit_X = (-1) & 0 -- | The unit vector in the negative Y direction. unit_Y :: R2 -unit_Y = r2 (0,-1) +unit_Y = 0 & (-1) -- | Compute the direction of a vector, measured counterclockwise from -- the positive x-axis as a fraction of a full turn. The zero -- vector is arbitrarily assigned the direction 0. direction :: Angle a => R2 -> a -direction (unr2 -> (x,y)) = convertAngle . Rad $ atan2 y x +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 = r2 (cos a', sin a') +fromDirection a = cos a' & sin a' where Rad a' = convertAngle a -- | A convenient synonym for 'fromDirection'.